Xref: utzoo comp.sources.bugs:2785 comp.lang.perl:3536 Path: utzoo!utgpu!news-server.csri.toronto.edu!cs.utexas.edu!wuarchive!zaphod.mps.ohio-state.edu!swrinde!elroy.jpl.nasa.gov!jpl-devvax!lwall From: lwall@jpl-devvax.JPL.NASA.GOV (Larry Wall) Newsgroups: comp.sources.bugs,comp.lang.perl Subject: perl 3.0 patch #44 Summary: This is an official patch for perl 3.0. Please apply it. Message-ID: <11029@jpl-devvax.JPL.NASA.GOV> Date: 12 Jan 91 08:41:02 GMT Organization: Jet Propulsion Laboratory, Pasadena, CA Lines: 1274 System: perl version 3.0 Patch #: 44 Priority: Subject: patch #42, continued Description: See patch #42. 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 44 Index: perl_man.1 Prereq: 3.0.1.10 *** perl_man.1.old Fri Jan 11 18:43:41 1991 --- perl_man.1 Fri Jan 11 18:43:48 1991 *************** *** 1,7 **** .rn '' }` ! ''' $Header: perl_man.1,v 3.0.1.10 90/11/10 01:45:16 lwall Locked $ ''' ''' $Log: perl_man.1,v $ ''' Revision 3.0.1.10 90/11/10 01:45:16 lwall ''' patch38: random cleanup ''' --- 1,10 ---- .rn '' }` ! ''' $Header: perl_man.1,v 3.0.1.11 91/01/11 18:15:46 lwall Locked $ ''' ''' $Log: perl_man.1,v $ + ''' Revision 3.0.1.11 91/01/11 18:15:46 lwall + ''' patch42: added -0 option + ''' ''' Revision 3.0.1.10 90/11/10 01:45:16 lwall ''' patch38: random cleanup ''' *************** *** 179,184 **** --- 182,203 ---- .fi Options include: + .TP 5 + .BI \-0 digits + specifies the record separator ($/) as an octal number. + If there are no digits, the null character is the separator. + Other switches may precede or follow the digits. + For example, if you have a version of + .I find + which can print filenames terminated by the null character, you can say this: + .nf + + find . \-name '*.bak' \-print0 | perl \-n0e unlink + + .fi + The special value 00 will cause Perl to slurp files in paragraph mode. + The value 0777 will cause Perl to slurp files whole since there is no + legal character with that value. .TP 5 .B \-a turns on autosplit mode when used with a Index: perl_man.2 Prereq: 3.0.1.10 *** perl_man.2.old Fri Jan 11 18:44:04 1991 --- perl_man.2 Fri Jan 11 18:44:11 1991 *************** *** 1,7 **** ''' Beginning of part 2 ! ''' $Header: perl_man.2,v 3.0.1.10 90/11/10 01:46:29 lwall Locked $ ''' ''' $Log: perl_man.2,v $ ''' Revision 3.0.1.10 90/11/10 01:46:29 lwall ''' patch38: random cleanup ''' patch38: added alarm function --- 1,10 ---- ''' Beginning of part 2 ! ''' $Header: perl_man.2,v 3.0.1.11 91/01/11 18:17:08 lwall Locked $ ''' ''' $Log: perl_man.2,v $ + ''' Revision 3.0.1.11 91/01/11 18:17:08 lwall + ''' patch42: fixed some man page entries + ''' ''' Revision 3.0.1.10 90/11/10 01:46:29 lwall ''' patch38: random cleanup ''' patch38: added alarm function *************** *** 88,95 **** timer, and an argument of 0 may be supplied to cancel the previous timer without starting a new one. The returned value is the amount of time remaining on the previous timer. ! .Ip "atan2(X,Y)" 8 2 ! Returns the arctangent of X/Y in the range .if t \-\(*p to \(*p. .if n \-PI to PI. .Ip "bind(SOCKET,NAME)" 8 2 --- 91,98 ---- timer, and an argument of 0 may be supplied to cancel the previous timer without starting a new one. The returned value is the amount of time remaining on the previous timer. ! .Ip "atan2(Y,X)" 8 2 ! Returns the arctangent of Y/X in the range .if t \-\(*p to \(*p. .if n \-PI to PI. .Ip "bind(SOCKET,NAME)" 8 2 *************** *** 653,658 **** --- 656,662 ---- .Ip "flock(FILEHANDLE,OPERATION)" 8 4 Calls flock(2) on FILEHANDLE. See manual page for flock(2) for definition of OPERATION. + Returns true for success, false on failure. Will produce a fatal error if used on a machine that doesn't implement flock(2). Here's a mailbox appender for BSD systems. *************** *** 957,963 **** @keys = keys %ENV; @values = values %ENV; while ($#keys >= 0) { ! print pop(keys), \'=\', pop(values), "\en"; } or how about sorted by key: --- 961,967 ---- @keys = keys %ENV; @values = values %ENV; while ($#keys >= 0) { ! print pop(@keys), \'=\', pop(@values), "\en"; } or how about sorted by key: Index: perl_man.3 Prereq: 3.0.1.11 *** perl_man.3.old Fri Jan 11 18:44:31 1991 --- perl_man.3 Fri Jan 11 18:44:40 1991 *************** *** 1,7 **** ''' Beginning of part 3 ! ''' $Header: perl_man.3,v 3.0.1.11 90/11/10 01:48:21 lwall Locked $ ''' ''' $Log: perl_man.3,v $ ''' Revision 3.0.1.11 90/11/10 01:48:21 lwall ''' patch38: random cleanup ''' patch38: documented tr///cds --- 1,10 ---- ''' Beginning of part 3 ! ''' $Header: perl_man.3,v 3.0.1.12 91/01/11 18:18:15 lwall Locked $ ''' ''' $Log: perl_man.3,v $ + ''' Revision 3.0.1.12 91/01/11 18:18:15 lwall + ''' patch42: added binary and hex pack/unpack options + ''' ''' Revision 3.0.1.11 90/11/10 01:48:21 lwall ''' patch38: random cleanup ''' patch38: documented tr///cds *************** *** 291,301 **** X Back up a byte. @ Null fill to absolute position. u A uuencoded string. .fi Each letter may optionally be followed by a number which gives a repeat count. ! With all types except "a" and "A" the pack function will gobble up that many values from the LIST. A * for the repeat count means to use however many items are left. The "a" and "A" types gobble just one value, but pack it as a string of length --- 294,309 ---- X Back up a byte. @ Null fill to absolute position. u A uuencoded string. + b A bit string (ascending bit order, like vec()). + B A bit string (descending bit order). + h A hex string (low nybble first). + H A hex string (high nybble first). .fi Each letter may optionally be followed by a number which gives a repeat count. ! With all types except "a", "A", "b", "B", "h" and "H", ! the pack function will gobble up that many values from the LIST. A * for the repeat count means to use however many items are left. The "a" and "A" types gobble just one value, but pack it as a string of length *************** *** 302,307 **** --- 310,317 ---- count, padding with nulls or spaces as necessary. (When unpacking, "A" strips trailing spaces and nulls, but "a" does not.) + Likewise, the "b" and "B" fields pack a string that many bits long. + The "h" and "H" fields pack a string that many nybbles long. Real numbers (floats and doubles) are in the native machine format only; due to the multiplicity of floating formats around, and the lack of a standard \*(L"network\*(R" representation, no facility for *************** *** 342,347 **** --- 352,360 ---- $foo = pack("i9pl", gmtime); # a real struct tm (on my system anyway) + sub bintodec { + unpack("N", pack("B32", substr("0" x 32 . shift, -32))); + } .fi The same template may generally also be used in the unpack function. .Ip "pipe(READHANDLE,WRITEHANDLE)" 8 3 *************** *** 1358,1363 **** --- 1371,1385 ---- strings. This interpretation is not enabled unless there is at least one vec() in your program, to protect older programs. + .Sp + To transform a bit vector into a string or array of 0's and 1's, use these: + .nf + + $bits = unpack("b*", $vector); + @bits = split(//, unpack("b*", $vector)); + + .fi + If you know the exact length in bits, it can be used in place of the *. .Ip "wait" 8 6 Waits for a child process to terminate and returns the pid of the deceased process, or -1 if there are no child processes. Index: perl_man.4 Prereq: 3.0.1.13 *** perl_man.4.old Fri Jan 11 18:45:07 1991 --- perl_man.4 Fri Jan 11 18:45:18 1991 *************** *** 1,7 **** ''' Beginning of part 4 ! ''' $Header: perl_man.4,v 3.0.1.13 90/11/10 01:51:00 lwall Locked $ ''' ''' $Log: perl_man.4,v $ ''' Revision 3.0.1.13 90/11/10 01:51:00 lwall ''' patch38: random cleanup ''' --- 1,10 ---- ''' Beginning of part 4 ! ''' $Header: perl_man.4,v 3.0.1.14 91/01/11 18:18:53 lwall Locked $ ''' ''' $Log: perl_man.4,v $ + ''' Revision 3.0.1.14 91/01/11 18:18:53 lwall + ''' patch42: started an addendum and errata section in the man page + ''' ''' Revision 3.0.1.13 90/11/10 01:51:00 lwall ''' patch38: random cleanup ''' *************** *** 407,412 **** --- 410,416 ---- right justification, or centering. As an alternate form of right justification, you may also use # characters (with an optional .) to specify a numeric field. + (Use of ^ instead of @ causes the field to be blanked if undefined.) If any of the values supplied for these fields contains a newline, only the text up to the newline is printed. The special field @* can be used for printing multi-line values. *************** *** 1556,1561 **** --- 1560,1577 ---- The arguments are available via @ARGV, not $1, $2, etc. .Ip * 4 2 The environment is not automatically made available as variables. + .SH ERRATA\0AND\0ADDENDA + The Perl book, + .I Programming\0Perl , + has the following omissions and goofs. + .PP + The + .B \-0 + switch was added to Perl after the book went to press. + .PP + The new @###.## format was omitted accidentally. + .PP + It wasn't known at press time that s///ee caused multiple evaluations. .SH BUGS .PP .I Perl Index: lib/perldb.pl Prereq: 3.0.1.5 *** lib/perldb.pl.old Fri Jan 11 18:42:32 1991 --- lib/perldb.pl Fri Jan 11 18:42:35 1991 *************** *** 1,6 **** package DB; ! $header = '$Header: perldb.pl,v 3.0.1.5 90/11/10 01:40:26 lwall Locked $'; # # This file is automatically included if you do perl -d. # It's probably not useful to include this yourself. --- 1,6 ---- package DB; ! $header = '$Header: perldb.pl,v 3.0.1.6 91/01/11 18:08:58 lwall Locked $'; # # This file is automatically included if you do perl -d. # It's probably not useful to include this yourself. *************** *** 10,15 **** --- 10,18 ---- # have a breakpoint. It also inserts a do 'perldb.pl' before the first line. # # $Log: perldb.pl,v $ + # Revision 3.0.1.6 91/01/11 18:08:58 lwall + # patch42: @_ couldn't be accessed from debugger + # # Revision 3.0.1.5 90/11/10 01:40:26 lwall # patch38: the debugger wouldn't stop correctly or do action routines # *************** *** 62,68 **** $signal |= 1; } else { ! &eval("\$DB'signal |= do {$stop;}"); $dbline{$line} =~ s/;9($|\0)/$1/; } } --- 65,71 ---- $signal |= 1; } else { ! $evalarg = "\$DB'signal |= do {$stop;}"; &eval; $dbline{$line} =~ s/;9($|\0)/$1/; } } *************** *** 74,82 **** print OUT "$sub($filename:$i):\t",$dbline[$i]; } } ! &eval($action) if $action; if ($single || $signal) { ! &eval($pre) if $pre; print OUT $#stack . " levels deep in subroutine calls!\n" if $single & 4; $start = $line; --- 77,85 ---- print OUT "$sub($filename:$i):\t",$dbline[$i]; } } ! $evalarg = $action, &eval if $action; if ($single || $signal) { ! $evalarg = $pre, &eval if $pre; print OUT $#stack . " levels deep in subroutine calls!\n" if $single & 4; $start = $line; *************** *** 452,462 **** }; }; next; }; ! &eval($cmd); print OUT "\n"; } if ($post) { ! &eval($post); } } ($@, $!, $[, $,, $/, $\) = @saved; --- 455,465 ---- }; }; next; }; ! $evalarg = $cmd; &eval; print OUT "\n"; } if ($post) { ! $evalarg = $post; &eval; } } ($@, $!, $[, $,, $/, $\) = @saved; *************** *** 467,474 **** $[ = 0; $, = ""; $/ = "\n"; $\ = ""; } sub eval { ! eval "$usercontext $_[0]; &DB'save"; print OUT $@; } --- 470,479 ---- $[ = 0; $, = ""; $/ = "\n"; $\ = ""; } + # The following takes its argument via $evalarg to preserve current @_ + sub eval { ! eval "$usercontext $evalarg; &DB'save"; print OUT $@; } Index: perly.c Prereq: 3.0.1.9 *** perly.c.old Fri Jan 11 18:45:32 1991 --- perly.c Fri Jan 11 18:45:37 1991 *************** *** 1,4 **** ! char rcsid[] = "$Header: perly.c,v 3.0.1.9 90/11/10 01:53:26 lwall Locked $\nPatch level: ###\n"; /* * Copyright (c) 1989, Larry Wall * --- 1,4 ---- ! char rcsid[] = "$Header: perly.c,v 3.0.1.10 91/01/11 18:22:48 lwall Locked $\nPatch level: ###\n"; /* * Copyright (c) 1989, Larry Wall * *************** *** 6,11 **** --- 6,16 ---- * as specified in the README file that comes with the perl 3.0 kit. * * $Log: perly.c,v $ + * Revision 3.0.1.10 91/01/11 18:22:48 lwall + * patch42: added -0 option + * patch42: ANSIfied the stat mode checking + * patch42: executables for multiple versions may now coexist + * * Revision 3.0.1.9 90/11/10 01:53:26 lwall * patch38: random cleanup * patch38: more msdos/os2 upgrades *************** *** 82,87 **** --- 87,93 ---- static char* cddir; extern char **environ; static bool minus_c; + static char patchlevel[6]; main(argc,argv,env) register int argc; *************** *** 110,115 **** --- 116,122 ---- euid = (int)geteuid(); gid = (int)getgid(); egid = (int)getegid(); + sprintf(patchlevel,"%3.3s%2.2d", rcsid+19, PATCHLEVEL); #ifdef MSDOS /* * There is no way we can refer to them from Perl so close them to save *************** *** 147,152 **** --- 154,160 ---- s = argv[0]+1; reswitch: switch (*s) { + case '0': case 'a': case 'c': case 'd': *************** *** 287,294 **** #endif if (stat(tokenbuf,&statbuf) < 0) /* not there? */ continue; ! if ((statbuf.st_mode & S_IFMT) == S_IFREG ! && cando(S_IREAD,TRUE,&statbuf) && cando(S_IEXEC,TRUE,&statbuf)) { xfound = tokenbuf; /* bingo! */ break; } --- 295,302 ---- #endif if (stat(tokenbuf,&statbuf) < 0) /* not there? */ continue; ! if (S_ISREG(statbuf.st_mode) ! && cando(S_IRUSR,TRUE,&statbuf) && cando(S_IXUSR,TRUE,&statbuf)) { xfound = tokenbuf; /* bingo! */ break; } *************** *** 303,309 **** } fdpid = anew(Nullstab); /* for remembering popen pids by fd */ ! pidstatus = hnew(Nullstab); /* for remembering status of dead pids */ origfilename = savestr(argv[0]); curcmd->c_filestab = fstab(origfilename); --- 311,317 ---- } fdpid = anew(Nullstab); /* for remembering popen pids by fd */ ! pidstatus = hnew(COEFFSIZE);/* for remembering status of dead pids */ origfilename = savestr(argv[0]); curcmd->c_filestab = fstab(origfilename); *************** *** 360,366 **** #ifndef IAMSUID /* in case script is not readable before setuid */ if (euid && stat(stab_val(curcmd->c_filestab)->str_ptr,&statbuf) >= 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) { ! (void)sprintf(buf, "%s/%s", BIN, "suidperl"); execv(buf, origargv); /* try again */ fatal("Can't do setuid\n"); } --- 368,374 ---- #ifndef IAMSUID /* in case script is not readable before setuid */ if (euid && stat(stab_val(curcmd->c_filestab)->str_ptr,&statbuf) >= 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) { ! (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel); execv(buf, origargv); /* try again */ fatal("Can't do setuid\n"); } *************** *** 378,389 **** * in perl will not fix that problem, but if you have disabled setuid * scripts in the kernel, this will attempt to emulate setuid and setgid * on scripts that have those now-otherwise-useless bits set. The setuid ! * root version must be called suidperl. If regular perl discovers that ! * it has opened a setuid script, it calls suidperl with the same argv ! * that it had. If suidperl finds that the script it has just opened ! * is NOT setuid root, it sets the effective uid back to the uid. We ! * don't just make perl setuid root because that loses the effective ! * uid we had before invoking perl, if it was different from the uid. * * DOSUID must be defined in both perl and suidperl, and IAMSUID must * be defined in suidperl only. suidperl must be setuid root. The --- 386,398 ---- * in perl will not fix that problem, but if you have disabled setuid * scripts in the kernel, this will attempt to emulate setuid and setgid * on scripts that have those now-otherwise-useless bits set. The setuid ! * root version must be called suidperl or sperlN.NNN. If regular perl ! * discovers that it has opened a setuid script, it calls suidperl with ! * the same argv that it had. If suidperl finds that the script it has ! * just opened is NOT setuid root, it sets the effective uid back to the ! * uid. We don't just make perl setuid root because that loses the ! * effective uid we had before invoking perl, if it was different from the ! * uid. * * DOSUID must be defined in both perl and suidperl, and IAMSUID must * be defined in suidperl only. suidperl must be setuid root. The *************** *** 394,400 **** * on these set-id scripts, but don't want to have the overhead of * them in normal perl, and can't use suidperl because it will lose * the effective uid info, so we have an additional non-setuid root ! * version called taintperl that just does the TAINT checks. */ #ifdef DOSUID --- 403,409 ---- * on these set-id scripts, but don't want to have the overhead of * them in normal perl, and can't use suidperl because it will lose * the effective uid info, so we have an additional non-setuid root ! * version called taintperl or tperlN.NNN that just does the TAINT checks. */ #ifdef DOSUID *************** *** 445,459 **** } if (setreuid(uid,euid) < 0 || getuid() != uid || geteuid() != euid) fatal("Can't reswap uid and euid"); ! if (!cando(S_IEXEC,FALSE,&statbuf)) /* can real uid exec? */ fatal("Permission denied\n"); } #endif /* SETREUID */ #endif /* IAMSUID */ ! if ((statbuf.st_mode & S_IFMT) != S_IFREG) fatal("Permission denied"); ! if ((statbuf.st_mode >> 6) & S_IWRITE) fatal("Setuid/gid script is writable by world"); doswitches = FALSE; /* -s is insecure in suid */ curcmd->c_line++; --- 454,468 ---- } if (setreuid(uid,euid) < 0 || getuid() != uid || geteuid() != euid) fatal("Can't reswap uid and euid"); ! if (!cando(S_IXUSR,FALSE,&statbuf)) /* can real uid exec? */ fatal("Permission denied\n"); } #endif /* SETREUID */ #endif /* IAMSUID */ ! if (!S_ISREG(statbuf.st_mode)) fatal("Permission denied"); ! if (statbuf.st_mode & S_IWOTH) fatal("Setuid/gid script is writable by world"); doswitches = FALSE; /* -s is insecure in suid */ curcmd->c_line++; *************** *** 463,469 **** s = tokenbuf+2; if (*s == ' ') s++; while (!isspace(*s)) s++; ! if (strnNE(s-4,"perl",4)) /* sanity check */ fatal("Not a perl script"); while (*s == ' ' || *s == '\t') s++; /* --- 472,478 ---- s = tokenbuf+2; if (*s == ' ') s++; while (!isspace(*s)) s++; ! if (strnNE(s-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */ fatal("Not a perl script"); while (*s == ' ' || *s == '\t') s++; /* *************** *** 487,493 **** if (euid) { /* oops, we're not the setuid root perl */ (void)fclose(rsfp); #ifndef IAMSUID ! (void)sprintf(buf, "%s/%s", BIN, "suidperl"); execv(buf, origargv); /* try again */ #endif fatal("Can't do setuid\n"); --- 496,502 ---- if (euid) { /* oops, we're not the setuid root perl */ (void)fclose(rsfp); #ifndef IAMSUID ! (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel); execv(buf, origargv); /* try again */ #endif fatal("Can't do setuid\n"); *************** *** 529,535 **** euid = (int)geteuid(); gid = (int)getgid(); egid = (int)getegid(); ! if (!cando(S_IEXEC,TRUE,&statbuf)) fatal("Permission denied\n"); /* they can't do this */ } #ifdef IAMSUID --- 538,544 ---- euid = (int)geteuid(); gid = (int)getgid(); egid = (int)getegid(); ! if (!cando(S_IXUSR,TRUE,&statbuf)) fatal("Permission denied\n"); /* they can't do this */ } #ifdef IAMSUID *************** *** 542,548 **** /* script has a wrapper--can't run suidperl or we lose euid */ else if (euid != uid || egid != gid) { (void)fclose(rsfp); ! (void)sprintf(buf, "%s/%s", BIN, "taintperl"); execv(buf, origargv); /* try again */ fatal("Can't run setuid script with taint checks"); } --- 551,557 ---- /* script has a wrapper--can't run suidperl or we lose euid */ else if (euid != uid || egid != gid) { (void)fclose(rsfp); ! (void)sprintf(buf, "%s/tperl%s", BIN, patchlevel); execv(buf, origargv); /* try again */ fatal("Can't run setuid script with taint checks"); } *************** *** 563,569 **** #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */ /* not set-id, must be wrapped */ (void)fclose(rsfp); ! (void)sprintf(buf, "%s/%s", BIN, "taintperl"); execv(buf, origargv); /* try again */ fatal("Can't run setuid script with taint checks"); } --- 572,578 ---- #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */ /* not set-id, must be wrapped */ (void)fclose(rsfp); ! (void)sprintf(buf, "%s/tperl%s", BIN, patchlevel); execv(buf, origargv); /* try again */ fatal("Can't run setuid script with taint checks"); } *************** *** 677,685 **** if (tmpstab = stabent("]",allstabs)) { str = STAB_STR(tmpstab); str_set(str,rcsid); ! strncpy(tokenbuf,rcsid+19,3); ! sprintf(tokenbuf+3,"%2.2d",PATCHLEVEL); ! str->str_u.str_nval = atof(tokenbuf); str->str_nok = 1; } str_nset(stab_val(stabent("\"", TRUE)), " ", 1); --- 686,692 ---- if (tmpstab = stabent("]",allstabs)) { str = STAB_STR(tmpstab); str_set(str,rcsid); ! str->str_u.str_nval = atof(patchlevel); str->str_nok = 1; } str_nset(stab_val(stabent("\"", TRUE)), " ", 1); *************** *** 1024,1029 **** --- 1031,1045 ---- { reswitch: switch (*s) { + case '0': + record_separator = 0; + if (s[1] == '0' && !isdigit(s[2])) + rslen = 0; + while (*s >= '0' && *s <= '7') { + record_separator <<= 3; + record_separator += *s++ & 7; + } + return s; case 'a': minus_a = TRUE; s++; Index: lib/pwd.pl Prereq: 3.0.1.1 *** lib/pwd.pl.old Fri Jan 11 18:42:46 1991 --- lib/pwd.pl Fri Jan 11 18:42:47 1991 *************** *** 1,8 **** ;# pwd.pl - keeps track of current working directory in PWD environment var ;# ! ;# $Header: pwd.pl,v 3.0.1.1 90/08/09 04:01:24 lwall Locked $ ;# ;# $Log: pwd.pl,v $ ;# Revision 3.0.1.1 90/08/09 04:01:24 lwall ;# patch19: Initial revision ;# --- 1,11 ---- ;# pwd.pl - keeps track of current working directory in PWD environment var ;# ! ;# $Header: pwd.pl,v 3.0.1.2 91/01/11 18:09:24 lwall Locked $ ;# ;# $Log: pwd.pl,v $ + ;# Revision 3.0.1.2 91/01/11 18:09:24 lwall + ;# patch42: some .pl files were missing their trailing 1; + ;# ;# Revision 3.0.1.1 90/08/09 04:01:24 lwall ;# patch19: Initial revision ;# *************** *** 46,48 **** --- 49,52 ---- } } + 1; Index: x2p/s2p.SH Prereq: 3.0.1.6 *** x2p/s2p.SH.old Fri Jan 11 18:48:13 1991 --- x2p/s2p.SH Fri Jan 11 18:48:17 1991 *************** *** 7,12 **** --- 7,13 ---- '') if test ! -f config.sh; then ln ../config.sh . || \ + ln -s ../config.sh . || \ ln ../../config.sh . || \ ln ../../../config.sh . || \ (echo "Can't find config.sh."; exit 1) *************** *** 28,36 **** : In the following dollars and backticks do not need the extra backslash. $spitshell >>s2p <<'!NO!SUBS!' ! # $Header: s2p.SH,v 3.0.1.6 90/10/20 02:21:43 lwall Locked $ # # $Log: s2p.SH,v $ # Revision 3.0.1.6 90/10/20 02:21:43 lwall # patch37: changed some ". config.sh" to ". ./config.sh" # --- 29,40 ---- : In the following dollars and backticks do not need the extra backslash. $spitshell >>s2p <<'!NO!SUBS!' ! # $Header: s2p.SH,v 3.0.1.7 91/01/11 18:36:44 lwall Locked $ # # $Log: s2p.SH,v $ + # Revision 3.0.1.7 91/01/11 18:36:44 lwall + # patch42: x2p/s2p.SH blew up on /afs misfeature + # # Revision 3.0.1.6 90/10/20 02:21:43 lwall # patch37: changed some ". config.sh" to ". ./config.sh" # Index: stab.c Prereq: 3.0.1.10 *** stab.c.old Fri Jan 11 18:45:54 1991 --- stab.c Fri Jan 11 18:45:56 1991 *************** *** 1,4 **** ! /* $Header: stab.c,v 3.0.1.10 90/11/10 02:02:05 lwall Locked $ * * Copyright (c) 1989, Larry Wall * --- 1,4 ---- ! /* $Header: stab.c,v 3.0.1.11 91/01/11 18:23:44 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.11 91/01/11 18:23:44 lwall + * patch42: added -0 option + * * Revision 3.0.1.10 90/11/10 02:02:05 lwall * patch38: random cleanup * *************** *** 170,176 **** break; #endif case '/': ! if (record_separator != 12345) { *tokenbuf = record_separator; tokenbuf[1] = '\0'; str_nset(stab_val(stab),tokenbuf,rslen); --- 173,179 ---- break; #endif case '/': ! if (record_separator != 0777) { *tokenbuf = record_separator; tokenbuf[1] = '\0'; str_nset(stab_val(stab),tokenbuf,rslen); *************** *** 401,407 **** rslen = str->str_cur; } else { ! record_separator = 12345; /* fake a non-existent char */ rslen = 1; } break; --- 404,410 ---- rslen = str->str_cur; } else { ! record_separator = 0777; /* fake a non-existent char */ rslen = 1; } break; Index: str.c Prereq: 3.0.1.11 *** str.c.old Fri Jan 11 18:46:12 1991 --- str.c Fri Jan 11 18:46:19 1991 *************** *** 1,4 **** ! /* $Header: str.c,v 3.0.1.11 90/11/13 15:27:14 lwall Locked $ * * Copyright (c) 1989, Larry Wall * --- 1,4 ---- ! /* $Header: str.c,v 3.0.1.12 91/01/11 18:26:54 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: str.c,v $ + * Revision 3.0.1.12 91/01/11 18:26:54 lwall + * patch42: s/^foo/bar/ occasionally brought on core dumps + * patch42: undid unwarranted assumptions about memcmp() return value + * patch42: ('a' .. 'z') could lose its value in a loop + * * Revision 3.0.1.11 90/11/13 15:27:14 lwall * patch41: fixed a couple of malloc/free problems * *************** *** 285,292 **** sstr->str_pok = 0; /* wipe out any weird flags */ sstr->str_state = 0; /* so sstr frees uneventfully */ } ! else /* have to copy actual string */ str_nset(dstr,sstr->str_ptr,sstr->str_cur); if (dstr->str_nok = sstr->str_nok) dstr->str_u.str_nval = sstr->str_u.str_nval; else { --- 290,303 ---- sstr->str_pok = 0; /* wipe out any weird flags */ sstr->str_state = 0; /* so sstr frees uneventfully */ } ! else { /* have to copy actual string */ ! if (dstr->str_ptr) { ! if (dstr->str_state == SS_INCR) { ! Str_Grow(dstr,0); ! } ! } str_nset(dstr,sstr->str_ptr,sstr->str_cur); + } if (dstr->str_nok = sstr->str_nok) dstr->str_u.str_nval = sstr->str_u.str_nval; else { *************** *** 738,749 **** if (str1->str_cur < str2->str_cur) { if (retval = memcmp(str1->str_ptr, str2->str_ptr, str1->str_cur)) ! return retval; else return -1; } else if (retval = memcmp(str1->str_ptr, str2->str_ptr, str2->str_cur)) ! return retval; else if (str1->str_cur == str2->str_cur) return 0; else --- 749,760 ---- if (str1->str_cur < str2->str_cur) { if (retval = memcmp(str1->str_ptr, str2->str_ptr, str1->str_cur)) ! return retval < 0 ? -1 : 1; else return -1; } else if (retval = memcmp(str1->str_ptr, str2->str_ptr, str2->str_cur)) ! return retval < 0 ? -1 : 1; else if (str1->str_cur == str2->str_cur) return 0; else *************** *** 804,809 **** --- 815,821 ---- if (get_paragraph && oldbp) obpx = oldbp - str->str_ptr; bpx = bp - str->str_ptr; /* prepare for possible relocation */ + str->str_cur = bpx; STR_GROW(str, str->str_len + append + cnt + 2); bp = str->str_ptr + bpx; /* reconstitute our pointer */ if (get_paragraph && oldbp) *************** *** 1373,1380 **** if (new->str_ptr) Safefree(new->str_ptr); Copy(old,new,1,STR); ! if (old->str_ptr) new->str_ptr = nsavestr(old->str_ptr,old->str_len); return new; } --- 1385,1394 ---- if (new->str_ptr) Safefree(new->str_ptr); Copy(old,new,1,STR); ! if (old->str_ptr) { new->str_ptr = nsavestr(old->str_ptr,old->str_len); + new->str_pok &= ~SP_TEMP; + } return new; } Index: toke.c Prereq: 3.0.1.11 *** toke.c.old Fri Jan 11 18:46:56 1991 --- toke.c Fri Jan 11 18:47:04 1991 *************** *** 1,4 **** ! /* $Header: toke.c,v 3.0.1.11 90/11/10 02:13:44 lwall Locked $ * * Copyright (c) 1989, Larry Wall * --- 1,4 ---- ! /* $Header: toke.c,v 3.0.1.12 91/01/11 18:31:45 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: toke.c,v $ + * Revision 3.0.1.12 91/01/11 18:31:45 lwall + * patch42: eval'ed formats without proper termination blew up + * patch42: whitespace now allowed after terminating . of format + * * Revision 3.0.1.11 90/11/10 02:13:44 lwall * patch38: added alarm function * patch38: tr was busted in metacharacters on signed char machines *************** *** 2341,2347 **** Zero(&froot, 1, FCMD); s = bufptr; ! while (s < bufend || (s = str_gets(linestr,rsfp, 0)) != Nullch) { curcmd->c_line++; if (in_eval && !rsfp) { eol = index(s,'\n'); --- 2345,2351 ---- Zero(&froot, 1, FCMD); s = bufptr; ! while (s < bufend || (rsfp && (s = str_gets(linestr,rsfp, 0)) != Nullch)) { curcmd->c_line++; if (in_eval && !rsfp) { eol = index(s,'\n'); *************** *** 2356,2364 **** str_nset(tmpstr, s, eol-s); astore(stab_xarray(curcmd->c_filestab), (int)curcmd->c_line,tmpstr); } ! if (strnEQ(s,".\n",2)) { ! bufptr = s; ! return froot.f_next; } if (*s == '#') { s = eol; --- 2360,2371 ---- str_nset(tmpstr, s, eol-s); astore(stab_xarray(curcmd->c_filestab), (int)curcmd->c_line,tmpstr); } ! if (*s == '.') { ! for (t = s+1; *t == ' ' || *t == '\t'; t++) ; ! if (*t == '\n') { ! bufptr = s; ! return froot.f_next; ! } } if (*s == '#') { s = eol; *************** *** 2456,2462 **** } if (flinebeg) { again: ! if (s >= bufend && (s = str_gets(linestr, rsfp, 0)) == Nullch) goto badform; curcmd->c_line++; if (in_eval && !rsfp) { --- 2463,2470 ---- } if (flinebeg) { again: ! if (s >= bufend && ! (!rsfp || (s = str_gets(linestr, rsfp, 0)) == Nullch) ) goto badform; curcmd->c_line++; if (in_eval && !rsfp) { Index: util.c Prereq: 3.0.1.10 *** util.c.old Fri Jan 11 18:47:25 1991 --- util.c Fri Jan 11 18:47:33 1991 *************** *** 1,4 **** ! /* $Header: util.c,v 3.0.1.10 90/11/10 02:19:28 lwall Locked $ * * Copyright (c) 1989, Larry Wall * --- 1,4 ---- ! /* $Header: util.c,v 3.0.1.11 91/01/11 18:33:10 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: util.c,v $ + * Revision 3.0.1.11 91/01/11 18:33:10 lwall + * patch42: die could exit with 0 value on some machines + * patch42: Configure checks typecasting behavior better + * * Revision 3.0.1.10 90/11/10 02:19:28 lwall * patch38: random cleanup * patch38: sequence of s/^x//; s/x$//; could screw up malloc *************** *** 855,861 **** if (e_fp) (void)UNLINK(e_tmpname); statusvalue >>= 8; ! exit(errno?errno:(statusvalue?statusvalue:255)); } /*VARARGS1*/ --- 859,865 ---- if (e_fp) (void)UNLINK(e_tmpname); statusvalue >>= 8; ! exit((int)((errno&255)?errno:((statusvalue&255)?statusvalue:255))); } /*VARARGS1*/ *************** *** 959,965 **** if (e_fp) (void)UNLINK(e_tmpname); statusvalue >>= 8; ! exit((int)(errno?errno:(statusvalue?statusvalue:255))); } /*VARARGS0*/ --- 963,969 ---- if (e_fp) (void)UNLINK(e_tmpname); statusvalue >>= 8; ! exit((int)((errno&255)?errno:((statusvalue&255)?statusvalue:255))); } /*VARARGS0*/ *************** *** 1458,1464 **** { long along; ! #ifdef mips # define BIGDOUBLE 2147483648.0 if (f >= BIGDOUBLE) return (unsigned long)(f-(long)(f/BIGDOUBLE)*BIGDOUBLE)|0x80000000; --- 1462,1468 ---- { long along; ! #if CASTFLAGS & 2 # define BIGDOUBLE 2147483648.0 if (f >= BIGDOUBLE) return (unsigned long)(f-(long)(f/BIGDOUBLE)*BIGDOUBLE)|0x80000000; Index: Configure Prereq: 3.0.1.13 *** Configure.old Fri Jan 11 21:58:11 1991 --- Configure Fri Jan 11 21:58:20 1991 *************** *** 8,14 **** # and edit it to reflect your system. Some packages may include samples # of config.h for certain machines, so you might look for one of those.) # ! # $Header: Configure,v 3.0.1.13 91/01/11 17:01:32 lwall Locked $ # # Yes, you may rip this off to use in other distribution packages. # (Note: this Configure script was generated automatically. Rather than --- 8,14 ---- # and edit it to reflect your system. Some packages may include samples # of config.h for certain machines, so you might look for one of those.) # ! # $Header: Configure,v 3.0.1.14 91/01/11 21:56:38 lwall Locked $ # # Yes, you may rip this off to use in other distribution packages. # (Note: this Configure script was generated automatically. Rather than *************** *** 1321,1335 **** exit(result); } EOCP ! if $cc -o try $ccflags try.c >/dev/null 2>&1 && ./try; then ! d_castneg="$define" ! castflags=0 echo "Yup, it does." ! else ! d_castneg="$undef" ! castflags=$? echo "Nope, it doesn't." ! fi $rm -f try.* : see how we invoke the C preprocessor --- 1321,1336 ---- exit(result); } EOCP ! $cc -o try $ccflags try.c >/dev/null 2>&1 && ./try ! castflags=$? ! case "$castflags" in ! 0) d_castneg="$define" echo "Yup, it does." ! ;; ! *) d_castneg="$undef" echo "Nope, it doesn't." ! ;; ! esac $rm -f try.* : see how we invoke the C preprocessor Index: perl.y Prereq: 3.0.1.10 *** perl.y.old Fri Jan 11 21:58:40 1991 --- perl.y Fri Jan 11 21:58:45 1991 *************** *** 1,4 **** ! /* $Header: perl.y,v 3.0.1.10 91/01/11 18:14:28 lwall Locked $ * * Copyright (c) 1989, Larry Wall * --- 1,4 ---- ! /* $Header: perl.y,v 3.0.1.11 91/01/11 21:57:40 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.11 91/01/11 21:57:40 lwall + * patch42: addendum + * * Revision 3.0.1.10 91/01/11 18:14:28 lwall * patch42: package didn't create symbol tables that could be reset * patch42: split with no arguments could wipe out next operator *************** *** 672,678 **** | SPLIT %prec '(' { static char p[]="/\\s+/"; char *oldend = bufend; ! int oldarg = yylval.arg; bufend=p+5; (void)scanpat(p); --- 675,681 ---- | SPLIT %prec '(' { static char p[]="/\\s+/"; char *oldend = bufend; ! ARG *oldarg = yylval.arg; bufend=p+5; (void)scanpat(p); *** End of Patch 44 ***