lwall@jpl-devvax.JPL.NASA.GOV (Larry Wall) (03/29/90)
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 <thisarticle". If you don't have the patch program, apply the following by hand, or get patch (version 2.0, latest patchlevel). After patching: Configure -d make depend make make test make install If patch indicates that patchlevel is the wrong version, you may need to apply one or more previous patches, or the patch may already have been applied. See the patchlevel.h file to find out what has or has not been applied. In any event, don't continue with the patch. If you are missing previous patches they can be obtained from me: Larry Wall lwall@jpl-devvax.jpl.nasa.gov If you send a mail message of the following form it will greatly speed processing: Subject: Command @SH mailpatch PATH perl 3.0 LIST ^ note the c where PATH is a return path FROM ME TO YOU either in Internet notation, or in bang notation from some well-known host, and LIST is the number of one or more patches you need, separated by spaces, commas, and/or hyphens. Saying 35- says everything from 35 to the end. You can also get the patches via anonymous FTP from jpl-devvax.jpl.nasa.gov (128.149.1.143). Index: patchlevel.h Prereq: 17 1c1 < #define PATCHLEVEL 17 --- > #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 @<<the@>>>> 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 <arg> RSTRING TRANS %type <ival> prog decl format remember - %type <stabval> %type <cmdval> block lineseq line loop cond sideff nexpr else %type <arg> expr sexpr cexpr csexpr term handle aryword hshword %type <arg> 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 <lwall@jpl-devvax.Jpl.Nasa.Gov> + .br + MS-DOS port by Diomidis Spinellis <dds@cc.ic.ac.uk> .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 <stdlib.h> + #include <stdio.h> + #include <process.h> + + /* + * 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 <tchrist@convex.com> + # modified to use sockets by Larry Wall <lwall@jpl-devvax.jpl.nasa.gov> + # 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 "$<facility.$priority>$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 + <sys/dir.h>. 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 <dds@cc.ic.ac.uk> + 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; + } + }