System: perl version 3.0 Patch #: 18 Priority: MED-HIGH Subject: patch #16, continued Description: See patch #16. Fix: From rn, say "| patch -p -N -d DIR", where DIR is your perl source directory. Outside of rn, say "cd DIR; patch -p -N #define PATCHLEVEL 18 Index: t/op.dbm Prereq: 3.0 *** t/op.dbm.old Tue Mar 27 16:43:24 1990 --- t/op.dbm Tue Mar 27 16:43:25 1990 *************** *** 1,6 **** #!./perl ! # $Header: op.dbm,v 3.0 89/10/18 15:28:31 lwall Locked $ if (!-r '/usr/include/dbm.h' && !-r '/usr/include/ndbm.h') { print "1..0\n"; --- 1,6 ---- #!./perl ! # $Header: op.dbm,v 3.0.1.1 90/03/27 16:25:57 lwall Locked $ if (!-r '/usr/include/dbm.h' && !-r '/usr/include/ndbm.h') { print "1..0\n"; *************** *** 7,13 **** exit; } ! print "1..9\n"; unlink 'Op.dbmx.dir', 'Op.dbmx.pag'; umask(0); --- 7,13 ---- exit; } ! print "1..10\n"; unlink 'Op.dbmx.dir', 'Op.dbmx.pag'; umask(0); *************** *** 91,95 **** --- 91,99 ---- ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat('Op.dbmx.pag'); print ($size > 0 ? "ok 9\n" : "not ok 9\n"); + + @h{0..200} = 200..400; + @foo = @h{0..200}; + print join(':',200..400) eq join(':',@foo) ? "ok 10\n" : "no ok 10\n"; unlink 'Op.dbmx.dir', 'Op.dbmx.pag'; Index: t/op.range Prereq: 3.0 *** t/op.range.old Tue Mar 27 16:43:29 1990 --- t/op.range Tue Mar 27 16:43:30 1990 *************** *** 1,8 **** #!./perl ! # $Header: op.range,v 3.0 89/10/18 15:30:53 lwall Locked $ ! print "1..6\n"; print join(':',1..5) eq '1:2:3:4:5' ? "ok 1\n" : "not ok 1\n"; --- 1,8 ---- #!./perl ! # $Header: op.range,v 3.0.1.1 90/03/27 16:27:58 lwall Locked $ ! print "1..8\n"; print join(':',1..5) eq '1:2:3:4:5' ? "ok 1\n" : "not ok 1\n"; *************** *** 28,30 **** --- 28,36 ---- $x += $_; } print $x == 5050 ? "ok 6\n" : "not ok 6 $x\n"; + + $x = join('','a'..'z'); + print $x eq 'abcdefghijklmnopqrstuvwxyz' ? "ok 7\n" : "not ok 7 $x\n"; + + @x = 'A'..'ZZ'; + print @x == 27 * 26 ? "ok 8\n" : "not ok 8\n"; Index: t/op.write Prereq: 3.0 *** t/op.write.old Tue Mar 27 16:43:35 1990 --- t/op.write Tue Mar 27 16:43:36 1990 *************** *** 1,8 **** #!./perl ! # $Header: op.write,v 3.0 89/10/18 15:32:16 lwall Locked $ ! print "1..2\n"; format OUT = the quick brown @<< --- 1,8 ---- #!./perl ! # $Header: op.write,v 3.0.1.1 90/03/27 16:29:00 lwall Locked $ ! print "1..3\n"; format OUT = the quick brown @<< *************** *** 84,87 **** --- 84,129 ---- { print "ok 2\n"; unlink 'Op.write.tmp'; } else { print "not ok 2\n"; } + + eval <<'EOFORMAT'; + format OUT2 = + the brown quick @<< + $fox + jumped + @* + $multiline + ^<<<<<<<<< ~~ + $foo + now @<>>> for all@|||||men to come @<<<< + 'i' . 's', "time\n", $good, 'to' + . + EOFORMAT + + open(OUT2, '>Op.write.tmp') || die "Can't create Op.write.tmp"; + + $fox = 'foxiness'; + $good = 'good'; + $multiline = "forescore\nand\nseven years\n"; + $foo = 'when in the course of human events it becomes necessary'; + write(OUT2); + close OUT2; + + $right = + "the brown quick fox + jumped + forescore + and + seven years + when in + the course + of human + events it + becomes + necessary + now is the time for all good men to come to\n"; + + if (`cat Op.write.tmp` eq $right) + { print "ok 3\n"; unlink 'Op.write.tmp'; } + else + { print "not ok 3\n"; } Index: perl.h Prereq: 3.0.1.6 *** perl.h.old Tue Mar 27 16:41:03 1990 --- perl.h Tue Mar 27 16:41:05 1990 *************** *** 1,4 **** ! /* $Header: perl.h,v 3.0.1.6 90/03/12 16:40:43 lwall Locked $ * * Copyright (c) 1989, Larry Wall * --- 1,4 ---- ! /* $Header: perl.h,v 3.0.1.7 90/03/27 16:12:52 lwall Locked $ * * Copyright (c) 1989, Larry Wall * *************** *** 6,11 **** --- 6,15 ---- * as specified in the README file that comes with the perl 3.0 kit. * * $Log: perl.h,v $ + * Revision 3.0.1.7 90/03/27 16:12:52 lwall + * patch16: MSDOS support + * patch16: support for machines that can't cast negative floats to unsigned ints + * * Revision 3.0.1.6 90/03/12 16:40:43 lwall * patch13: did some ndir straightening up for Xenix * *************** *** 49,54 **** --- 53,103 ---- #define VOIDUSED 1 #include "config.h" + #ifdef MSDOS + /* + * BUGGY_MSC: + * This symbol is defined if you are the unfortunate owner of a buggy + * Microsoft C compiler and want to use intrinsic functions. Versions + * up to 5.1 are known conform to this definition. This is not needed + * under Unix. + */ + #define BUGGY_MSC /**/ + /* + * BINARY: + * This symbol is defined if you run under an operating system that + * distinguishes between binary and text files. If so the function + * setmode will be used to set the file into binary mode. Unix + * doesn't distinguish. + */ + #define BINARY /**/ + + #else /* !MSDOS */ + + /* + * The following symbols are defined if your operating system supports + * functions by that name. All Unixes I know of support them, thus they + * are not checked by the configuration script, but are directly defined + * here. + */ + #define CHOWN + #define CHROOT + #define FORK + #define GETLOGIN + #define GETPPID + #define KILL + #define LINK + #define PIPE + #define WAIT + #define UMASK + /* + * The following symbols are defined if your operating system supports + * password and group functions in general. All Unix systems do. + */ + #define GROUP + #define PASSWD + + #endif /* !MSDOS */ + #if defined(HASVOLATILE) || defined(__STDC__) #define VOLATILE volatile #else *************** *** 244,250 **** #include "array.h" #include "hash.h" ! #if defined(iAPX286) || defined(M_I286) || defined(I80286) # define I286 #endif --- 293,299 ---- #include "array.h" #include "hash.h" ! #if defined(iAPX286) || defined(M_I286) || defined(I80286) || defined(M_I86) # define I286 #endif *************** *** 349,354 **** --- 398,414 ---- #undef NTOHS #undef NTOHL #endif + #endif + + #ifdef CASTNEGFLOAT + #define U_S(what) ((unsigned short)(what)) + #define U_I(what) ((unsigned int)(what)) + #define U_L(what) ((unsigned long)(what)) + #else + unsigned long castulong(); + #define U_S(what) ((unsigned int)castulong(what)) + #define U_I(what) ((unsigned int)castulong(what)) + #define U_L(what) (castulong(what)) #endif CMD *add_label(); Index: perl.y Prereq: 3.0.1.5 *** perl.y.old Tue Mar 27 16:41:15 1990 --- perl.y Tue Mar 27 16:41:19 1990 *************** *** 1,4 **** ! /* $Header: perl.y,v 3.0.1.5 90/03/12 16:55:56 lwall Locked $ * * Copyright (c) 1989, Larry Wall * --- 1,4 ---- ! /* $Header: perl.y,v 3.0.1.6 90/03/27 16:13:45 lwall Locked $ * * Copyright (c) 1989, Larry Wall * *************** *** 6,11 **** --- 6,14 ---- * as specified in the README file that comes with the perl 3.0 kit. * * $Log: perl.y,v $ + * Revision 3.0.1.6 90/03/27 16:13:45 lwall + * patch16: formats didn't work inside eval + * * Revision 3.0.1.5 90/03/12 16:55:56 lwall * patch13: added list slice operator (LIST)[LIST] * patch13: (LIST,) now legal *************** *** 67,73 **** %token RSTRING TRANS %type prog decl format remember - %type %type block lineseq line loop cond sideff nexpr else %type expr sexpr cexpr csexpr term handle aryword hshword %type texpr listop --- 70,75 ---- *************** *** 307,320 **** format : FORMAT WORD '=' FORMLIST { if (strEQ($2,"stdout")) ! stab_form(stabent("STDOUT",TRUE)) = $4; else if (strEQ($2,"stderr")) ! stab_form(stabent("STDERR",TRUE)) = $4; else ! stab_form(stabent($2,TRUE)) = $4; Safefree($2);} | FORMAT '=' FORMLIST ! { stab_form(stabent("STDOUT",TRUE)) = $3; } ; subrout : SUB WORD block --- 309,322 ---- format : FORMAT WORD '=' FORMLIST { if (strEQ($2,"stdout")) ! make_form(stabent("STDOUT",TRUE),$4); else if (strEQ($2,"stderr")) ! make_form(stabent("STDERR",TRUE),$4); else ! make_form(stabent($2,TRUE),$4); Safefree($2);} | FORMAT '=' FORMLIST ! { make_form(stabent("STDOUT",TRUE),$3); } ; subrout : SUB WORD block Index: perl_man.1 Prereq: 3.0.1.4 *** perl.man.1 Tue Mar 27 16:41:29 1990 --- perl_man.1 Tue Mar 27 16:41:34 1990 *************** *** 1,7 **** .rn '' }` ! ''' $Header: perl.man.1,v 3.0.1.4 90/03/12 16:44:33 lwall Locked $ ''' ''' $Log: perl.man.1,v $ ''' Revision 3.0.1.4 90/03/12 16:44:33 lwall ''' patch13: (LIST,) now legal ''' patch13: improved LIST documentation --- 1,10 ---- .rn '' }` ! ''' $Header: perl_man.1,v 3.0.1.5 90/03/27 16:14:37 lwall Locked $ ''' ''' $Log: perl_man.1,v $ + ''' Revision 3.0.1.5 90/03/27 16:14:37 lwall + ''' patch16: .. now works using magical string increment + ''' ''' Revision 3.0.1.4 90/03/12 16:44:33 lwall ''' patch13: (LIST,) now legal ''' patch13: improved LIST documentation *************** *** 1450,1452 **** --- 1453,1474 ---- .fi The autodecrement is not magical. + .PP + The range operator (in an array context) makes use of the magical + autoincrement algorithm if the minimum and maximum are strings. + You can say + + @alphabet = (\'A\' .. \'Z\'); + + to get all the letters of the alphabet, or + + $hexdigit = (0 .. 9, \'a\' .. \'f\')[$num & 15]; + + to get a hexadecimal digit, or + + @z2 = (\'01\' .. \'31\'); print @z2[$mday]; + + to get dates with leading zeros. + (If the final value specified is not in the sequence that the magical increment + would produce, the sequence goes until the next value would be longer than + the final value specified.) Index: perl_man.2 Prereq: 3.0.1.4 *** perl.man.2 Tue Mar 27 16:41:48 1990 --- perl_man.2 Tue Mar 27 16:41:53 1990 *************** *** 1,7 **** ''' Beginning of part 2 ! ''' $Header: perl.man.2,v 3.0.1.4 90/03/12 16:46:02 lwall Locked $ ''' ''' $Log: perl.man.2,v $ ''' Revision 3.0.1.4 90/03/12 16:46:02 lwall ''' patch13: documented behavior of @array = /noparens/ ''' --- 1,10 ---- ''' Beginning of part 2 ! ''' $Header: perl_man.2,v 3.0.1.5 90/03/27 16:15:17 lwall Locked $ ''' ''' $Log: perl_man.2,v $ + ''' Revision 3.0.1.5 90/03/27 16:15:17 lwall + ''' patch16: MSDOS support + ''' ''' Revision 3.0.1.4 90/03/12 16:46:02 lwall ''' patch13: documented behavior of @array = /noparens/ ''' *************** *** 62,67 **** --- 65,79 ---- Returns the arctangent of X/Y in the range .if t \-\(*p to \(*p. .if n \-PI to PI. + .Ip "binmode(FILEHANDLE)" 8 4 + .Ip "binmode FILEHANDLE" 8 4 + Arranges for the file to be read in \*(L"binary\*(R" mode in operating systems + that distinguish between binary and text files. + Files that are not read in binary mode have CR LF sequences translated + to LF on input and LF translated to CR LF on output. + Binmode has no effect under Unix. + If FILEHANDLE is an expression, the value is taken as the name of + the filehandle. .Ip "bind(SOCKET,NAME)" 8 2 Does the same thing that the bind system call does. Returns true if it succeeded, false otherwise. Index: perl_man.3 Prereq: 3.0.1.5 *** perl.man.3 Tue Mar 27 16:42:12 1990 --- perl_man.3 Tue Mar 27 16:42:18 1990 *************** *** 1,7 **** ''' Beginning of part 3 ! ''' $Header: perl.man.3,v 3.0.1.5 90/03/12 16:52:21 lwall Locked $ ''' ''' $Log: perl.man.3,v $ ''' Revision 3.0.1.5 90/03/12 16:52:21 lwall ''' patch13: documented that print $filehandle &foo is ambiguous ''' patch13: added splice operator: @oldelems = splice(@array,$offset,$len,LIST) --- 1,10 ---- ''' Beginning of part 3 ! ''' $Header: perl_man.3,v 3.0.1.6 90/03/27 16:17:56 lwall Locked $ ''' ''' $Log: perl_man.3,v $ + ''' Revision 3.0.1.6 90/03/27 16:17:56 lwall + ''' patch16: MSDOS support + ''' ''' Revision 3.0.1.5 90/03/12 16:52:21 lwall ''' patch13: documented that print $filehandle &foo is ambiguous ''' patch13: added splice operator: @oldelems = splice(@array,$offset,$len,LIST) *************** *** 235,241 **** DIRHANDLEs have their own namespace separate from FILEHANDLEs. .Ip "ord(EXPR)" 8 4 .Ip "ord EXPR" 8 ! Returns the ascii value of the first character of EXPR. If EXPR is omitted, uses $_. .Ip "pack(TEMPLATE,LIST)" 8 4 Takes an array or list of values and packs it into a binary structure, --- 238,244 ---- DIRHANDLEs have their own namespace separate from FILEHANDLEs. .Ip "ord(EXPR)" 8 4 .Ip "ord EXPR" 8 ! Returns the numeric ascii value of the first character of EXPR. If EXPR is omitted, uses $_. .Ip "pack(TEMPLATE,LIST)" 8 4 Takes an array or list of values and packs it into a binary structure, Index: perl_man.4 Prereq: 3.0.1.7 *** perl.man.4 Tue Mar 27 16:42:34 1990 --- perl_man.4 Tue Mar 27 16:42:39 1990 *************** *** 1,7 **** ''' Beginning of part 4 ! ''' $Header: perl.man.4,v 3.0.1.7 90/03/14 12:29:50 lwall Locked $ ''' ''' $Log: perl.man.4,v $ ''' Revision 3.0.1.7 90/03/14 12:29:50 lwall ''' patch15: man page falsely states that you can't subscript array values ''' --- 1,10 ---- ''' Beginning of part 4 ! ''' $Header: perl_man.4,v 3.0.1.8 90/03/27 16:19:31 lwall Locked $ ''' ''' $Log: perl_man.4,v $ + ''' Revision 3.0.1.8 90/03/27 16:19:31 lwall + ''' patch16: MSDOS support + ''' ''' Revision 3.0.1.7 90/03/14 12:29:50 lwall ''' patch15: man page falsely states that you can't subscript array values ''' *************** *** 504,510 **** ($name, $aliases, $proto) = getprotobyname('tcp'); ($name, $aliases, $port) = getservbyname($port, 'tcp') ! unless $port =~ /^\ed+$/;; .ie t \{\ ($name, $aliases, $type, $len, $thisaddr) = gethostbyname($hostname); 'br\} --- 507,513 ---- ($name, $aliases, $proto) = getprotobyname('tcp'); ($name, $aliases, $port) = getservbyname($port, 'tcp') ! unless $port =~ /^\ed+$/; .ie t \{\ ($name, $aliases, $type, $len, $thisaddr) = gethostbyname($hostname); 'br\} *************** *** 549,555 **** ($name, $aliases, $proto) = getprotobyname('tcp'); ($name, $aliases, $port) = getservbyname($port, 'tcp') ! unless $port =~ /^\ed+$/;; $this = pack($sockaddr, &AF_INET, $port, "\e0\e0\e0\e0"); --- 552,558 ---- ($name, $aliases, $proto) = getprotobyname('tcp'); ($name, $aliases, $port) = getservbyname($port, 'tcp') ! unless $port =~ /^\ed+$/; $this = pack($sockaddr, &AF_INET, $port, "\e0\e0\e0\e0"); *************** *** 1318,1323 **** --- 1321,1328 ---- .fi .SH AUTHOR Larry Wall + .br + MS-DOS port by Diomidis Spinellis .SH FILES /tmp/perl\-eXXXXXX temporary file for .B \-e Index: perly.c Prereq: 3.0.1.4 *** perly.c.old Tue Mar 27 16:42:48 1990 --- perly.c Tue Mar 27 16:42:52 1990 *************** *** 1,4 **** ! char rcsid[] = "$Header: perly.c,v 3.0.1.4 90/02/28 18:06:41 lwall Locked $\nPatch level: ###\n"; /* * Copyright (c) 1989, Larry Wall * --- 1,4 ---- ! char rcsid[] = "$Header: perly.c,v 3.0.1.5 90/03/27 16:20:57 lwall Locked $\nPatch level: ###\n"; /* * Copyright (c) 1989, Larry Wall * *************** *** 6,11 **** --- 6,15 ---- * as specified in the README file that comes with the perl 3.0 kit. * * $Log: perly.c,v $ + * Revision 3.0.1.5 90/03/27 16:20:57 lwall + * patch16: MSDOS support + * patch16: do FILE inside eval blows up + * * Revision 3.0.1.4 90/02/28 18:06:41 lwall * patch9: perl can now start up other interpreters scripts * patch9: nested evals clobbered their longjmp environment *************** *** 71,76 **** --- 75,89 ---- euid = (int)geteuid(); gid = (int)getgid(); egid = (int)getegid(); + #ifdef MSDOS + /* + * There is no way we can refer to them from Perl so close them to save + * space. The other alternative would be to provide STDAUX and STDPRN + * filehandles. + */ + (void)fclose(stdaux); + (void)fclose(stdprn); + #endif if (do_undump) { do_undump = 0; loop_ptr = -1; /* start label stack again */ *************** *** 195,201 **** goto reswitch; case 'v': fputs(rcsid,stdout); ! fputs("\nCopyright (c) 1989, Larry Wall\n\n\ Perl may be copied only under the terms of the GNU General Public License,\n\ a copy of which can be found with the Perl 3.0 distribution kit.\n",stdout); exit(0); --- 208,219 ---- goto reswitch; case 'v': fputs(rcsid,stdout); ! fputs("\nCopyright (c) 1989, 1990, Larry Wall\n",stdout); ! #ifdef MSDOS ! fputs("MS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n", ! stdout); ! #endif ! fputs("\n\ Perl may be copied only under the terms of the GNU General Public License,\n\ a copy of which can be found with the Perl 3.0 distribution kit.\n",stdout); exit(0); *************** *** 748,754 **** str_cat(linestr,";"); /* be kind to them */ } else { ! if (last_root) { Safefree(last_eval); cmd_free(last_root); last_root = Nullcmd; --- 766,772 ---- str_cat(linestr,";"); /* be kind to them */ } else { ! if (last_root && !in_eval) { Safefree(last_eval); cmd_free(last_root); last_root = Nullcmd; Index: msdos/popen.c *** msdos/popen.c.old Tue Mar 27 16:40:55 1990 --- msdos/popen.c Tue Mar 27 16:40:56 1990 *************** *** 0 **** --- 1,175 ---- + /* $Header: popen.c,v 3.0.1.1 90/03/27 16:11:57 lwall Locked $ + * + * (C) Copyright 1988, 1990 Diomidis Spinellis. + * + * You may distribute under the terms of the GNU General Public License + * as specified in the README file that comes with the perl 3.0 kit. + * + * $Log: popen.c,v $ + * Revision 3.0.1.1 90/03/27 16:11:57 lwall + * patch16: MSDOS support + * + * Revision 1.1 90/03/18 20:32:20 dds + * Initial revision + * + */ + + /* + * Popen and pclose for MS-DOS + */ + + #include + #include + #include + + /* + * Possible actions on an popened file + */ + enum action { + delete, /* Used for "r". Delete the tmp file */ + execute /* Used for "w". Execute the command. */ + }; + + /* + * Linked list of things to do at the end of the program execution. + */ + static struct todo { + FILE *f; /* File we are working on (to fclose) */ + const char *name; /* Name of the file (to unlink) */ + const char *command; /* Command to execute */ + enum action what; /* What to do (execute or delete) */ + struct todo *next; /* Next structure */ + } *todolist; + + + /* Clean up function */ + static int close_pipes(void); + + /* + * Add a file f running the command command on file name to the list + * of actions to be done at the end. The action is specified in what. + * Return -1 on failure, 0 if ok. + */ + static int + add(FILE *f, const char *command, const char *name, enum action what) + { + struct todo *p; + + if ((p = (struct todo *) malloc(sizeof(struct todo))) == NULL) + return -1; + p->f = f; + p->command = command; + p->name = name; + p->what = what; + p->next = todolist; + todolist = p; + return 0; + } + + FILE * + mypopen(const char *command, const char *t) + { + char buff[256]; + char *name; + FILE *f; + static init = 0; + + if (!init) + if (onexit(close_pipes) == NULL) + return NULL; + else + init++; + + if ((name = tempnam(getenv("TMP"), "pp")) == NULL) + return NULL; + + switch (*t) { + case 'r': + sprintf(buff, "%s >%s", command, name); + if (system(buff) || (f = fopen(name, "r")) == NULL) { + free(name); + return NULL; + } + if (add(f, command, name, delete)) { + (void)fclose(f); + (void)unlink(name); + free(name); + return NULL; + } + return f; + case 'w': + if ((f = fopen(name, "w")) == NULL) { + free(name); + return NULL; + } + if (add(f, command, name, execute)) { + (void)fclose(f); + (void)unlink(name); + free(name); + return NULL; + } + return f; + default: + free(name); + return NULL; + } + } + + int + mypclose(FILE *f) + { + struct todo *p, **prev; + char buff[256]; + const char *name; + int status; + + for (p = todolist, prev = &todolist; p; prev = &(p->next), p = p->next) + if (p->f == f) { + *prev = p->next; + name = p->name; + switch (p->what) { + case delete: + free(p); + if (fclose(f) == EOF) { + (void)unlink(name); + status = EOF; + } else if (unlink(name) < 0) + status = EOF; + else + status = 0; + free(name); + return status; + case execute: + (void)sprintf(buff, "%s <%s", p->command, p->name); + free(p); + if (system(buff)) { + (void)unlink(name); + status = EOF; + } else if (fclose(f) == EOF) { + (void)unlink(name); + status = EOF; + } else if (unlink(name) < 0) + status = EOF; + else + status = 0; + free(name); + return status; + default: + return EOF; + } + } + return EOF; + } + + /* + * Clean up at the end. Called by the onexit handler. + */ + static int + close_pipes(void) + { + struct todo *p; + + for (p = todolist; p; p = p->next) + (void)mypclose(p->f); + return 0; + } Index: stab.c Prereq: 3.0.1.5 *** stab.c.old Tue Mar 27 16:43:01 1990 --- stab.c Tue Mar 27 16:43:03 1990 *************** *** 1,4 **** ! /* $Header: stab.c,v 3.0.1.5 90/03/12 17:00:11 lwall Locked $ * * Copyright (c) 1989, Larry Wall * --- 1,4 ---- ! /* $Header: stab.c,v 3.0.1.6 90/03/27 16:22:11 lwall Locked $ * * Copyright (c) 1989, Larry Wall * *************** *** 6,11 **** --- 6,14 ---- * as specified in the README file that comes with the perl 3.0 kit. * * $Log: stab.c,v $ + * Revision 3.0.1.6 90/03/27 16:22:11 lwall + * patch16: support for machines that can't cast negative floats to unsigned ints + * * Revision 3.0.1.5 90/03/12 17:00:11 lwall * patch13: undef $/ didn't work as advertised * *************** *** 342,348 **** arybase = (int)str_gnum(str); break; case '?': ! statusvalue = (unsigned short)str_gnum(str); break; case '!': errno = (int)str_gnum(str); /* will anyone ever use this? */ --- 345,351 ---- arybase = (int)str_gnum(str); break; case '?': ! statusvalue = U_S(str_gnum(str)); break; case '!': errno = (int)str_gnum(str); /* will anyone ever use this? */ Index: str.c Prereq: 3.0.1.6 *** str.c.old Tue Mar 27 16:43:13 1990 --- str.c Tue Mar 27 16:43:18 1990 *************** *** 1,4 **** ! /* $Header: str.c,v 3.0.1.6 90/03/12 17:02:14 lwall Locked $ * * Copyright (c) 1989, Larry Wall * --- 1,4 ---- ! /* $Header: str.c,v 3.0.1.7 90/03/27 16:24:11 lwall Locked $ * * Copyright (c) 1989, Larry Wall * *************** *** 6,11 **** --- 6,15 ---- * as specified in the README file that comes with the perl 3.0 kit. * * $Log: str.c,v $ + * Revision 3.0.1.7 90/03/27 16:24:11 lwall + * patch16: strings with prefix chopped off sometimes freed wrong + * patch16: taint check blows up on undefined array element + * * Revision 3.0.1.6 90/03/12 17:02:14 lwall * patch13: substr as lvalue didn't invalidate old numeric value * *************** *** 122,130 **** register STR *str; double num; { str->str_u.str_nval = num; str->str_state = SS_NORM; - str->str_pok = 0; /* invalidate pointer */ str->str_nok = 1; /* validate number */ #ifdef TAINT str->str_tainted = tainted; --- 126,138 ---- register STR *str; double num; { + if (str->str_pok) { + str->str_pok = 0; /* invalidate pointer */ + if (str->str_state == SS_INCR) + str_grow(str,0); + } str->str_u.str_nval = num; str->str_state = SS_NORM; str->str_nok = 1; /* validate number */ #ifdef TAINT str->str_tainted = tainted; *************** *** 197,202 **** --- 205,212 ---- { if (!str) return 0.0; + if (str->str_state == SS_INCR) + str_grow(str,0); /* just force copy down */ str->str_state = SS_NORM; if (str->str_len && str->str_pok) str->str_u.str_nval = atof(str->str_ptr); *************** *** 220,226 **** register STR *sstr; { #ifdef TAINT ! tainted |= sstr->str_tainted; #endif if (sstr == dstr) return; --- 230,237 ---- register STR *sstr; { #ifdef TAINT ! if (sstr) ! tainted |= sstr->str_tainted; #endif if (sstr == dstr) return; *************** *** 245,250 **** --- 256,264 ---- else if (sstr->str_nok) str_numset(dstr,sstr->str_u.str_nval); else { + if (dstr->str_state == SS_INCR) + str_grow(dstr,0); /* just force copy down */ + #ifdef STRUCTCOPY dstr->str_u = sstr->str_u; #else *************** *** 260,266 **** register int len; { STR_GROW(str, len + 1); ! (void)bcopy(ptr,str->str_ptr,len); str->str_cur = len; *(str->str_ptr+str->str_cur) = '\0'; str->str_nok = 0; /* invalidate number */ --- 274,281 ---- register int len; { STR_GROW(str, len + 1); ! if (ptr) ! (void)bcopy(ptr,str->str_ptr,len); str->str_cur = len; *(str->str_ptr+str->str_cur) = '\0'; str->str_nok = 0; /* invalidate number */ Index: lib/syslog.pl *** lib/syslog.pl.old Tue Mar 27 16:40:05 1990 --- lib/syslog.pl Tue Mar 27 16:40:07 1990 *************** *** 0 **** --- 1,148 ---- + # + # syslog.pl + # + # tom christiansen + # modified to use sockets by Larry Wall + # NOTE: openlog now takes three arguments, just like openlog(3) + # + # call syslog() with a string priority and a list of printf() args + # like syslog(3) + # + # usage: do 'syslog.pl' || die "syslog.pl: $@"; + # + # then (put these all in a script to test function) + # + # + # do openlog($program,'cons,pid','user'); + # do syslog('info','this is another test'); + # do syslog('warn','this is a better test: %d', time); + # do closelog(); + # + # do syslog('debug','this is the last test'); + # do openlog("$program $$",'ndelay','user'); + # do syslog('notice','fooprogram: this is really done'); + # + # $! = 55; + # do syslog('info','problem was %m'); # %m == $! in syslog(3) + + package syslog; + + $host = 'localhost' unless $host; # set $syslog'host to change + + do '/usr/local/lib/perl/syslog.h' + || die "syslog: Can't do syslog.h: ",($@||$!),"\n"; + + sub main'openlog { + ($ident, $logopt, $facility) = @_; # package vars + $lo_pid = $logopt =~ /\bpid\b/; + $lo_ndelay = $logopt =~ /\bndelay\b/; + $lo_cons = $logopt =~ /\bncons\b/; + $lo_nowait = $logopt =~ /\bnowait\b/; + &connect if $lo_ndelay; + } + + sub main'closelog { + $facility = $ident = ''; + &disconnect; + } + + sub main'syslog { + local($priority) = shift; + local($mask) = shift; + local($message, $whoami); + + &connect unless $connected; + + $whoami = $ident; + + die "syslog: expected both priority and mask" unless $mask && $priority; + + $facility = "user" unless $facility; + + if (!$ident && $mask =~ /^(\S.*):\s?(.*)/) { + $whoami = $1; + $mask = $2; + } + $whoami .= " [$$]" if $lo_pid; + + $mask =~ s/%m/$!/g; + $mask .= "\n" unless $mask =~ /\n$/; + $message = sprintf ($mask, @_); + + $whoami = sprintf ("%s %d",$ENV{'USER'}||$ENV{'LOGNAME'},$$) unless $whoami; + + $sum = &xlate($priority) + &xlate($facility); + unless (send(SYSLOG,"<$sum>$whoami: $message",0)) { + if ($lo_cons) { + if ($pid = fork) { + unless ($lo_nowait) { + do {$died = wait;} until $died == $pid || $died < 0; + } + } + else { + open(CONS,">/dev/console"); + print CONS "$$whoami: $message\n"; + exit if defined $pid; # if fork failed, we're parent + close CONS; + } + } + } + } + + sub xlate { + local($name) = @_; + $name =~ y/a-z/A-Z/; + $name = "LOG_$name" unless $name =~ /^LOG_/; + $name = "syslog'$name"; + &$name; + } + + sub connect { + $pat = 'S n C4 x8'; + + $af_unix = 1; + $af_inet = 2; + + $stream = 1; + $datagram = 2; + + ($name,$aliases,$proto) = getprotobyname('udp'); + $udp = $proto; + + ($name,$aliase,$port,$proto) = getservbyname('syslog','udp'); + $syslog = $port; + + if (chop($myname = `hostname`)) { + ($name,$aliases,$addrtype,$length,@addrs) = gethostbyname($myname); + die "Can't lookup $myname\n" unless $name; + @bytes = unpack("C4",$addrs[0]); + } + else { + @bytes = (0,0,0,0); + } + $this = pack($pat, $af_inet, 0, @bytes); + + if ($host =~ /^\d+\./) { + @bytes = split(/\./,$host); + } + else { + ($name,$aliases,$addrtype,$length,@addrs) = gethostbyname($host); + die "Can't lookup $host\n" unless $name; + @bytes = unpack("C4",$addrs[0]); + } + $that = pack($pat,$af_inet,$syslog,@bytes); + + socket(SYSLOG,$af_inet,$datagram,$udp) || die "socket: $!\n"; + bind(SYSLOG,$this) || die "bind: $!\n"; + connect(SYSLOG,$that) || die "connect: $!\n"; + + local($old) = select(SYSLOG); $| = 1; select($old); + $connected = 1; + } + + sub disconnect { + close SYSLOG; + $connected = 0; + } + + 1; Index: toke.c Prereq: 3.0.1.6 *** toke.c.old Tue Mar 27 16:43:52 1990 --- toke.c Tue Mar 27 16:43:59 1990 *************** *** 1,4 **** ! /* $Header: toke.c,v 3.0.1.6 90/03/12 17:06:36 lwall Locked $ * * Copyright (c) 1989, Larry Wall * --- 1,4 ---- ! /* $Header: toke.c,v 3.0.1.7 90/03/27 16:32:37 lwall Locked $ * * Copyright (c) 1989, Larry Wall * *************** *** 6,11 **** --- 6,16 ---- * as specified in the README file that comes with the perl 3.0 kit. * * $Log: toke.c,v $ + * Revision 3.0.1.7 90/03/27 16:32:37 lwall + * patch16: MSDOS support + * patch16: formats didn't work inside eval + * patch16: final semicolon in program wasn't optional with -p or -n + * * Revision 3.0.1.6 90/03/12 17:06:36 lwall * patch13: last semicolon of program is now optional, just for Randal * patch13: added splice operator: @oldelems = splice(@array,$offset,$len,LIST) *************** *** 197,202 **** --- 202,208 ---- } } if (in_format) { + bufptr = bufend; yylval.formval = load_format(); in_format = FALSE; oldoldbufptr = oldbufptr = s = str_get(linestr) + 1; *************** *** 211,218 **** (void)fclose(rsfp); rsfp = Nullfp; if (minus_n || minus_p) { ! str_set(linestr,minus_p ? "}continue{print;" : ""); ! str_cat(linestr,"}"); oldoldbufptr = oldbufptr = s = str_get(linestr); bufend = linestr->str_ptr + linestr->str_cur; minus_n = minus_p = 0; --- 217,224 ---- (void)fclose(rsfp); rsfp = Nullfp; if (minus_n || minus_p) { ! str_set(linestr,minus_p ? ";}continue{print" : ""); ! str_cat(linestr,";}"); oldoldbufptr = oldbufptr = s = str_get(linestr); bufend = linestr->str_ptr + linestr->str_cur; minus_n = minus_p = 0; *************** *** 302,311 **** d = bufend; while (s < d && *s != '\n') s++; ! if (s < d) { s++; ! line++; } } else { *s = '\0'; --- 308,323 ---- d = bufend; while (s < d && *s != '\n') s++; ! if (s < d) s++; ! if (in_format) { ! bufptr = s; ! yylval.formval = load_format(); ! in_format = FALSE; ! oldoldbufptr = oldbufptr = s = bufptr + 1; ! TERM(FORMLIST); } + line++; } else { *s = '\0'; *************** *** 556,561 **** --- 568,575 ---- SNARFWORD; if (strEQ(d,"bind")) FOP2(O_BIND); + if (strEQ(d,"binmode")) + FOP(O_BINMODE); break; case 'c': case 'C': SNARFWORD; *************** *** 2074,2079 **** --- 2088,2094 ---- { FCMD froot; FCMD *flinebeg; + char *eol; register FCMD *fprev = &froot; register FCMD *fcmd; register char *s; *************** *** 2083,2089 **** bool repeater; Zero(&froot, 1, FCMD); ! while ((s = str_gets(linestr,rsfp, 0)) != Nullch) { line++; if (perldb) { STR *tmpstr = Str_new(89,0); --- 2098,2105 ---- bool repeater; Zero(&froot, 1, FCMD); ! s = bufptr; ! while (s < bufend || (s = str_gets(linestr,rsfp, 0)) != Nullch) { line++; if (perldb) { STR *tmpstr = Str_new(89,0); *************** *** 2091,2111 **** str_sset(tmpstr,linestr); astore(lineary,(int)line,tmpstr); } ! bufend = linestr->str_ptr + linestr->str_cur; ! if (strEQ(s,".\n")) { bufptr = s; return froot.f_next; } ! if (*s == '#') continue; flinebeg = Nullfcmd; noblank = FALSE; repeater = FALSE; ! while (s < bufend) { Newz(804,fcmd,1,FCMD); fprev->f_next = fcmd; fprev = fcmd; ! for (t=s; t < bufend && *t != '@' && *t != '^'; t++) { if (*t == '~') { noblank = TRUE; *t = ' '; --- 2107,2135 ---- str_sset(tmpstr,linestr); astore(lineary,(int)line,tmpstr); } ! if (in_eval && !rsfp) { ! eol = index(s,'\n'); ! if (!eol++) ! eol = bufend; ! } ! else ! eol = bufend = linestr->str_ptr + linestr->str_cur; ! if (strnEQ(s,".\n",2)) { bufptr = s; return froot.f_next; } ! if (*s == '#') { ! s = eol; continue; + } flinebeg = Nullfcmd; noblank = FALSE; repeater = FALSE; ! while (s < eol) { Newz(804,fcmd,1,FCMD); fprev->f_next = fcmd; fprev = fcmd; ! for (t=s; t < eol && *t != '@' && *t != '^'; t++) { if (*t == '~') { noblank = TRUE; *t = ' '; *************** *** 2118,2124 **** fcmd->f_pre = nsavestr(s, t-s); fcmd->f_presize = t-s; s = t; ! if (s >= bufend) { if (noblank) fcmd->f_flags |= FC_NOBLANK; if (repeater) --- 2142,2148 ---- fcmd->f_pre = nsavestr(s, t-s); fcmd->f_presize = t-s; s = t; ! if (s >= eol) { if (noblank) fcmd->f_flags |= FC_NOBLANK; if (repeater) *************** *** 2162,2168 **** } if (flinebeg) { again: ! if ((s = str_gets(linestr, rsfp, 0)) == Nullch) goto badform; line++; if (perldb) { --- 2186,2192 ---- } if (flinebeg) { again: ! if (s >= bufend && (s = str_gets(linestr, rsfp, 0)) == Nullch) goto badform; line++; if (perldb) { *************** *** 2171,2202 **** str_sset(tmpstr,linestr); astore(lineary,(int)line,tmpstr); } ! if (strEQ(s,".\n")) { bufptr = s; yyerror("Missing values line"); return froot.f_next; } ! if (*s == '#') goto again; ! bufend = linestr->str_ptr + linestr->str_cur; ! str = flinebeg->f_unparsed = Str_new(91,bufend - bufptr); str->str_u.str_hash = curstash; str_nset(str,"(",1); flinebeg->f_line = line; ! if (!flinebeg->f_next->f_type || index(linestr->str_ptr, ',')) { ! str_scat(str,linestr); str_ncat(str,",$$);",5); } else { ! while (s < bufend && isspace(*s)) s++; t = s; ! while (s < bufend) { switch (*s) { case ' ': case '\t': case '\n': case ';': str_ncat(str, t, s - t); str_ncat(str, "," ,1); ! while (s < bufend && (isspace(*s) || *s == ';')) s++; t = s; break; --- 2195,2238 ---- str_sset(tmpstr,linestr); astore(lineary,(int)line,tmpstr); } ! if (in_eval && !rsfp) { ! eol = index(s,'\n'); ! if (!eol++) ! eol = bufend; ! } ! else ! eol = bufend = linestr->str_ptr + linestr->str_cur; ! if (strnEQ(s,".\n",2)) { bufptr = s; yyerror("Missing values line"); return froot.f_next; } ! if (*s == '#') { ! s = eol; goto again; ! } ! str = flinebeg->f_unparsed = Str_new(91,eol - s); str->str_u.str_hash = curstash; str_nset(str,"(",1); flinebeg->f_line = line; ! eol[-1] = '\0'; ! if (!flinebeg->f_next->f_type || index(s, ',')) { ! eol[-1] = '\n'; ! str_ncat(str, s, eol - s - 1); str_ncat(str,",$$);",5); + s = eol; } else { ! eol[-1] = '\n'; ! while (s < eol && isspace(*s)) s++; t = s; ! while (s < eol) { switch (*s) { case ' ': case '\t': case '\n': case ';': str_ncat(str, t, s - t); str_ncat(str, "," ,1); ! while (s < eol && (isspace(*s) || *s == ';')) s++; t = s; break; *************** *** 2203,2212 **** case '$': str_ncat(str, t, s - t); t = s; ! s = scanreg(s,bufend,tokenbuf); str_ncat(str, t, s - t); t = s; ! if (s < bufend && *s && index("$'\"",*s)) str_ncat(str, ",", 1); break; case '"': case '\'': --- 2239,2248 ---- case '$': str_ncat(str, t, s - t); t = s; ! s = scanreg(s,eol,tokenbuf); str_ncat(str, t, s - t); t = s; ! if (s < eol && *s && index("$'\"",*s)) str_ncat(str, ",", 1); break; case '"': case '\'': *************** *** 2213,2225 **** str_ncat(str, t, s - t); t = s; s++; ! while (s < bufend && (*s != *t || s[-1] == '\\')) s++; ! if (s < bufend) s++; str_ncat(str, t, s - t); t = s; ! if (s < bufend && *s && index("$'\"",*s)) str_ncat(str, ",", 1); break; default: --- 2249,2261 ---- str_ncat(str, t, s - t); t = s; s++; ! while (s < eol && (*s != *t || s[-1] == '\\')) s++; ! if (s < eol) s++; str_ncat(str, t, s - t); t = s; ! if (s < eol && *s && index("$'\"",*s)) str_ncat(str, ",", 1); break; default: Index: util.c Prereq: 3.0.1.4 *** util.c.old Tue Mar 27 16:44:20 1990 --- util.c Tue Mar 27 16:44:24 1990 *************** *** 1,4 **** ! /* $Header: util.c,v 3.0.1.4 90/03/01 10:26:48 lwall Locked $ * * Copyright (c) 1989, Larry Wall * --- 1,4 ---- ! /* $Header: util.c,v 3.0.1.5 90/03/27 16:35:13 lwall Locked $ * * Copyright (c) 1989, Larry Wall * *************** *** 6,11 **** --- 6,16 ---- * as specified in the README file that comes with the perl 3.0 kit. * * $Log: util.c,v $ + * Revision 3.0.1.5 90/03/27 16:35:13 lwall + * patch16: MSDOS support + * patch16: support for machines that can't cast negative floats to unsigned ints + * patch16: tail anchored pattern could dump if string to search was shorter + * * Revision 3.0.1.4 90/03/01 10:26:48 lwall * patch9: fbminstr() called instr() rather than ninstr() * patch9: nested evals clobbered their longjmp environment *************** *** 492,497 **** --- 497,504 ---- littlelen = littlestr->str_cur; #ifndef lint if (littlestr->str_pok & SP_TAIL && !multiline) { /* tail anchored? */ + if (littlelen > bigend - big) + return Nullch; little = (unsigned char*)littlestr->str_ptr; if (littlestr->str_pok & SP_CASEFOLD) { /* oops, fake it */ big = bigend - littlelen; /* just start near end */ *************** *** 1116,1121 **** --- 1123,1129 ---- #endif /* BYTEORDER != 0x4321 */ #endif /* HTONS */ + #ifndef MSDOS FILE * mypopen(cmd,mode) char *cmd; *************** *** 1175,1180 **** --- 1183,1189 ---- forkprocess = pid; return fdopen(p[this], mode); } + #endif /* !MSDOS */ #ifdef NOTDEF dumpfds(s) *************** *** 1209,1214 **** --- 1218,1224 ---- } #endif + #ifndef MSDOS int mypclose(ptr) FILE *ptr; *************** *** 1250,1255 **** --- 1260,1266 ---- str_numset(str,0.0); return(status); } + #endif /* !MSDOS */ pidgone(pid,status) int pid; *************** *** 1311,1313 **** --- 1322,1338 ---- from = frombase; } } + + #ifndef CASTNEGFLOAT + unsigned long + castulong(f) + double f; + { + long along; + + if (f >= 0.0) + return (unsigned long)f; + along = (long)f; + return (unsigned long)along; + } + #endif Index: t/op.s *** t/op.subst Tue Mar 27 17:20:03 1990 --- t/op.s Wed Feb 28 18:37:33 1990 *************** *** 1,6 **** #!./perl ! # $Header: op.subst,v 3.0.1.1 90/02/28 18:37:30 lwall Locked $ print "1..42\n"; --- 1,6 ---- #!./perl ! # $Header: op.s,v 3.0.1.1 90/02/28 18:37:30 lwall Locked $ print "1..42\n"; *** End of Patch 18 *** Index: arg.h Prereq: 3.0.1.4 *** arg.h.old Tue Mar 27 16:36:41 1990 --- arg.h Tue Mar 27 16:36:44 1990 *************** *** 1,4 **** ! /* $Header: arg.h,v 3.0.1.4 90/03/12 16:18:21 lwall Locked $ * * Copyright (c) 1989, Larry Wall * --- 1,4 ---- ! /* $Header: arg.h,v 3.0.1.5 90/03/27 15:29:41 lwall Locked $ * * Copyright (c) 1989, Larry Wall * *************** *** 6,11 **** --- 6,14 ---- * as specified in the README file that comes with the perl 3.0 kit. * * $Log: arg.h,v $ + * Revision 3.0.1.5 90/03/27 15:29:41 lwall + * patch16: MSDOS support + * * Revision 3.0.1.4 90/03/12 16:18:21 lwall * patch13: added list slice operator (LIST)[LIST] * patch13: added splice operator: @oldelems = splice(@array,$offset,$len,LIST) *************** *** 267,273 **** #define O_GETPEERNAME 240 #define O_LSLICE 241 #define O_SPLICE 242 ! #define MAXO 243 #ifndef DOINIT extern char *opname[]; --- 270,277 ---- #define O_GETPEERNAME 240 #define O_LSLICE 241 #define O_SPLICE 242 ! #define O_BINMODE 243 ! #define MAXO 244 #ifndef DOINIT extern char *opname[]; *************** *** 516,522 **** "GETPEERNAME", "LSLICE", "SPLICE", ! "243" }; #endif --- 520,527 ---- "GETPEERNAME", "LSLICE", "SPLICE", ! "BINMODE", ! "244" }; #endif *************** *** 892,897 **** --- 897,903 ---- A(1,0,0), /* GETPEERNAME */ A(0,3,3), /* LSLICE */ A(0,3,1), /* SPLICE */ + A(1,0,0), /* BINMODE */ 0 }; #undef A Index: msdos/README.msdos *** msdos/README.msdos.old Tue Mar 27 16:40:20 1990 --- msdos/README.msdos Tue Mar 27 16:40:21 1990 *************** *** 0 **** --- 1,100 ---- + Notes on the MS-DOS Perl port + + Diomidis Spinellis + (dds@cc.ic.ac.uk) + + [0. First copy the files in the msdos directory into the parent + directory--law] + + 1. Compiling. + + Perl has been compiled under MS-DOS using the Microsoft + C compiler version 5.1. Before compiling install dir.h as + . You will need a Unix-like make program (e.g. + pdmake) and something like yacc (e.g. bison). You could get + away by running yacc and dry running make on a Unix host, + but I haven't tried it. Compilation takes 12 minutes on a + 20MHz 386 machine (together with formating the manual), so + you will probably need something to do in the meantime. The + executable is 272k and the top level directory needs 1M for + sources and about the same ammount for the object code and + the executables. + + The makefile will compile glob for you which you will + need to place somewhere in your path so that perl globbing + will work correctly. I have not tried all the tests or the + examples, nor the awk and sed to Perl translators. You are + on your own with them. In the eg directory I have included + an example program that uses ioctl to display the charac- + teristics of the storage devices of the system. + + 2. Using MS-DOS Perl + + The MS-DOS version of perl has most of the functional- + ity of the Unix version. Functions that can not be provided + under MS-DOS like sockets, password and host database + access, fork and wait have been ommited and will terminate + with a fatal error. Care has been taken to implement the + rest. In particular directory access, redirection (includ- + ing pipes, but excluding the pipe function), system, ioctl + and sleep have been provided. + + 2.1. Interface to the MS-DOS ioctl system call. + + The function code of the ioctl function (the second + argument) is encoded as follows: + + - The lowest nibble of the function code goes to AL. + - The two middle nibbles go to CL. + - The high nibble goes to CH. + + The return code is -1 in the case of an error and if + successful: + + - for functions AL = 00, 09, 0a the value of the register DX + - for functions AL = 02 - 08, 0e the value of the register AX + - for functions AL = 01, 0b - 0f the number 0. + + See the perl manual for instruction on how to distin- + guish between the return value and the success of ioctl. + + Some ioctl functions need a number as the first argu- + ment. Provided that no other files have been opened the + number can be obtained if ioctl is called with + @fdnum[number] as the first argument after executing the + following code: + + @fdnum = ("STDIN", "STDOUT", "STDERR"); + $maxdrives = 15; + for ($i = 3; $i < $maxdrives; $i++) { + open("FD$i", "nul"); + @fdnum[$i - 1] = "FD$i"; + } + + 2.2. Binary file access + + Files are opened in text mode by default. This means + that CR LF pairs are translated to LF. If binary access is + needed the `binary' function should be used. There is + currently no way to reverse the effect of the binary func- + tion. If that is needed close and reopen the file. + + 2.3. Interpreter startup. + + The effect of the Unix #!/bin/perl interpreter startup + can be obtained under MS-DOS by giving the script a .bat + extension and using the following lines on its begining: + + @REM=(" + @perl %0.bat %1 %2 %3 %4 %5 %6 %7 %8 %9 + @end ") if 0 ; + + (Note that you will probably want an absolute path name in + front of %0.bat). + + March 1990 + + Diomidis Spinellis + Myrsinis 1 + GR-145 62 Kifissia + Greece Index: cons.c Prereq: 3.0.1.5 *** cons.c.old Tue Mar 27 16:37:44 1990 --- cons.c Tue Mar 27 16:37:48 1990 *************** *** 1,4 **** ! /* $Header: cons.c,v 3.0.1.5 90/03/12 16:23:10 lwall Locked $ * * Copyright (c) 1989, Larry Wall * --- 1,4 ---- ! /* $Header: cons.c,v 3.0.1.6 90/03/27 15:35:21 lwall Locked $ * * Copyright (c) 1989, Larry Wall * *************** *** 6,11 **** --- 6,15 ---- * as specified in the README file that comes with the perl 3.0 kit. * * $Log: cons.c,v $ + * Revision 3.0.1.6 90/03/27 15:35:21 lwall + * patch16: formats didn't work inside eval + * patch16: $foo++ now optimized to ++$foo where value not required + * * Revision 3.0.1.5 90/03/12 16:23:10 lwall * patch13: perl -d coredumped on scripts with subs that did explicit return * *************** *** 95,100 **** --- 99,126 ---- return sub; } + make_form(stab,fcmd) + STAB *stab; + FCMD *fcmd; + { + if (stab_form(stab)) { + FCMD *tmpfcmd; + FCMD *nextfcmd; + + for (tmpfcmd = stab_form(stab); tmpfcmd; tmpfcmd = nextfcmd) { + nextfcmd = tmpfcmd->f_next; + if (tmpfcmd->f_expr) + arg_free(tmpfcmd->f_expr); + if (tmpfcmd->f_unparsed) + str_free(tmpfcmd->f_unparsed); + if (tmpfcmd->f_pre) + Safefree(tmpfcmd->f_pre); + Safefree(tmpfcmd); + } + } + stab_form(stab) = fcmd; + } + CMD * block_head(tail) register CMD *tail; *************** *** 594,599 **** --- 620,629 ---- if (arg[flp].arg_flags & (AF_PRE|AF_POST)) { cmd->c_flags |= opt; + if (acmd && !cmd->ucmd.acmd.ac_expr && !(cmd->c_flags & CF_TERM)) { + arg[flp].arg_flags &= ~AF_POST; /* prefer ++$foo to $foo++ */ + arg[flp].arg_flags |= AF_PRE; /* if value not wanted */ + } return; /* side effect, can't optimize */ } Index: msdos/eg/drives.bat *** msdos/eg/drives.bat.old Tue Mar 27 17:46:22 1990 --- msdos/eg/drives.bat Tue Mar 27 17:46:23 1990 *************** *** 0 **** --- 1,41 ---- + @REM=(" + @perl %0.bat %1 %2 %3 %4 %5 %6 %7 %8 %9 + @end ") if 0 ; + + # + # Test the ioctl function for MS-DOS. Provide a list of drives and their + # characteristics. + # + # By Diomidis Spinellis. + # + + @fdnum = ("STDIN", "STDOUT", "STDERR"); + $maxdrives = 15; + for ($i = 3; $i < $maxdrives; $i++) { + open("FD$i", "nul"); + @fdnum[$i - 1] = "FD$i"; + } + @mediatype = ( + "320/360 k floppy drive", + "1.2M floppy", + "720K floppy", + "8'' single density floppy", + "8'' double density floppy", + "fixed disk", + "tape drive", + "1.44M floppy", + "other" + ); + print "The system has the following drives:\n"; + for ($i = 1; $i < $maxdrives; $i++) { + if ($ret = ioctl(@fdnum[$i], 8, 0)) { + $type = ($ret == 0) ? "removable" : "fixed"; + $ret = ioctl(@fdnum[$i], 9, 0); + $location = ($ret & 0x800) ? "local" : "remote"; + ioctl(@fdnum[$i], 0x860d, $param); + @par = unpack("CCSSSC31S", $param); + $lock = (@par[2] & 2) ? "supporting door lock" : "not supporting door lock"; + printf "%c:$type $location @mediatype[@par[1]] @par[3] cylinders @par[6] + sectors/track $lock\n", ord('A') + $i - 1; + } + }