diff options
| -rwxr-xr-x | Configure | 17 | ||||
| -rw-r--r-- | lib/perldb.pl | 19 | ||||
| -rw-r--r-- | lib/pwd.pl | 6 | ||||
| -rw-r--r-- | patchlevel.h | 2 | ||||
| -rw-r--r-- | perl.man.1 | 21 | ||||
| -rw-r--r-- | perl.man.2 | 12 | ||||
| -rw-r--r-- | perl.man.3 | 26 | ||||
| -rw-r--r-- | perl.man.4 | 18 | ||||
| -rw-r--r-- | perl.y | 7 | ||||
| -rw-r--r-- | perly.c | 62 | ||||
| -rw-r--r-- | stab.c | 9 | ||||
| -rw-r--r-- | str.c | 24 | ||||
| -rw-r--r-- | toke.c | 20 | ||||
| -rw-r--r-- | util.c | 12 | ||||
| -rw-r--r-- | x2p/s2p.SH | 6 |
15 files changed, 192 insertions, 69 deletions
@@ -8,7 +8,7 @@ # 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 $ +# $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,15 +1321,16 @@ main() exit(result); } EOCP -if $cc -o try $ccflags try.c >/dev/null 2>&1 && ./try; then - d_castneg="$define" - castflags=0 +$cc -o try $ccflags try.c >/dev/null 2>&1 && ./try +castflags=$? +case "$castflags" in +0) d_castneg="$define" echo "Yup, it does." -else - d_castneg="$undef" - castflags=$? + ;; +*) d_castneg="$undef" echo "Nope, it doesn't." -fi + ;; +esac $rm -f try.* : see how we invoke the C preprocessor diff --git a/lib/perldb.pl b/lib/perldb.pl index c86fb16506..4c2f54d499 100644 --- a/lib/perldb.pl +++ b/lib/perldb.pl @@ -1,6 +1,6 @@ package DB; -$header = '$Header: perldb.pl,v 3.0.1.5 90/11/10 01:40:26 lwall Locked $'; +$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,6 +10,9 @@ $header = '$Header: perldb.pl,v 3.0.1.5 90/11/10 01:40:26 lwall Locked $'; # 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,7 +65,7 @@ sub DB { $signal |= 1; } else { - &eval("\$DB'signal |= do {$stop;}"); + $evalarg = "\$DB'signal |= do {$stop;}"; &eval; $dbline{$line} =~ s/;9($|\0)/$1/; } } @@ -74,9 +77,9 @@ sub DB { print OUT "$sub($filename:$i):\t",$dbline[$i]; } } - &eval($action) if $action; + $evalarg = $action, &eval if $action; if ($single || $signal) { - &eval($pre) if $pre; + $evalarg = $pre, &eval if $pre; print OUT $#stack . " levels deep in subroutine calls!\n" if $single & 4; $start = $line; @@ -452,11 +455,11 @@ command Execute as a perl statement in current package. }; }; next; }; - &eval($cmd); + $evalarg = $cmd; &eval; print OUT "\n"; } if ($post) { - &eval($post); + $evalarg = $post; &eval; } } ($@, $!, $[, $,, $/, $\) = @saved; @@ -467,8 +470,10 @@ sub save { $[ = 0; $, = ""; $/ = "\n"; $\ = ""; } +# The following takes its argument via $evalarg to preserve current @_ + sub eval { - eval "$usercontext $_[0]; &DB'save"; + eval "$usercontext $evalarg; &DB'save"; print OUT $@; } diff --git a/lib/pwd.pl b/lib/pwd.pl index c141e9888e..7abcc1f97d 100644 --- a/lib/pwd.pl +++ b/lib/pwd.pl @@ -1,8 +1,11 @@ ;# 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 $ +;# $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,3 +49,4 @@ sub main'chdir { } } +1; diff --git a/patchlevel.h b/patchlevel.h index 64b1306a8b..760709b84a 100644 --- a/patchlevel.h +++ b/patchlevel.h @@ -1 +1 @@ -#define PATCHLEVEL 43 +#define PATCHLEVEL 44 diff --git a/perl.man.1 b/perl.man.1 index 9a24089704..fdc606c215 100644 --- a/perl.man.1 +++ b/perl.man.1 @@ -1,7 +1,10 @@ .rn '' }` -''' $Header: perl_man.1,v 3.0.1.10 90/11/10 01:45:16 lwall Locked $ +''' $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 ''' @@ -180,6 +183,22 @@ only allows one argument. Example: .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 .B \-n diff --git a/perl.man.2 b/perl.man.2 index b9c37ef313..a6ab6a1a86 100644 --- a/perl.man.2 +++ b/perl.man.2 @@ -1,7 +1,10 @@ ''' Beginning of part 2 -''' $Header: perl_man.2,v 3.0.1.10 90/11/10 01:46:29 lwall Locked $ +''' $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,8 +91,8 @@ Only one timer may be counting at once. Each call disables the previous 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 +.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,6 +656,7 @@ the filehandle. .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,7 +961,7 @@ Here is yet another way to print your environment: @keys = keys %ENV; @values = values %ENV; while ($#keys >= 0) { - print pop(keys), \'=\', pop(values), "\en"; + print pop(@keys), \'=\', pop(@values), "\en"; } or how about sorted by key: diff --git a/perl.man.3 b/perl.man.3 index be1cc72e2b..d4574ebd69 100644 --- a/perl.man.3 +++ b/perl.man.3 @@ -1,7 +1,10 @@ ''' Beginning of part 3 -''' $Header: perl_man.3,v 3.0.1.11 90/11/10 01:48:21 lwall Locked $ +''' $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,17 +294,24 @@ of values, as follows: 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" and "A" the pack function will gobble up that many values +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 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,6 +352,9 @@ Examples: $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,6 +1371,15 @@ which will assume a bit vector operation is desired when both operands are 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. diff --git a/perl.man.4 b/perl.man.4 index 7100e80a22..54ddff5248 100644 --- a/perl.man.4 +++ b/perl.man.4 @@ -1,7 +1,10 @@ ''' Beginning of part 4 -''' $Header: perl_man.4,v 3.0.1.13 90/11/10 01:51:00 lwall Locked $ +''' $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,6 +410,7 @@ with multiple <, >, or | characters to specify, respectively, left justification 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,6 +1560,18 @@ compiles the whole program before executing it. 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 @@ -1,4 +1,4 @@ -/* $Header: perl.y,v 3.0.1.10 91/01/11 18:14:28 lwall Locked $ +/* $Header: perl.y,v 3.0.1.11 91/01/11 21:57:40 lwall Locked $ * * Copyright (c) 1989, Larry Wall * @@ -6,6 +6,9 @@ * 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,7 +675,7 @@ term : '-' term %prec UMINUS | SPLIT %prec '(' { static char p[]="/\\s+/"; char *oldend = bufend; - int oldarg = yylval.arg; + ARG *oldarg = yylval.arg; bufend=p+5; (void)scanpat(p); @@ -1,4 +1,4 @@ -char rcsid[] = "$Header: perly.c,v 3.0.1.9 90/11/10 01:53:26 lwall Locked $\nPatch level: ###\n"; +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,6 +6,11 @@ char rcsid[] = "$Header: perly.c,v 3.0.1.9 90/11/10 01:53:26 lwall Locked $\nPat * 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,6 +87,7 @@ static char* moreswitches(); static char* cddir; extern char **environ; static bool minus_c; +static char patchlevel[6]; main(argc,argv,env) register int argc; @@ -110,6 +116,7 @@ setuid perl scripts securely.\n"); 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,6 +154,7 @@ setuid perl scripts securely.\n"); s = argv[0]+1; reswitch: switch (*s) { + case '0': case 'a': case 'c': case 'd': @@ -287,8 +295,8 @@ setuid perl scripts securely.\n"); #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)) { + if (S_ISREG(statbuf.st_mode) + && cando(S_IRUSR,TRUE,&statbuf) && cando(S_IXUSR,TRUE,&statbuf)) { xfound = tokenbuf; /* bingo! */ break; } @@ -303,7 +311,7 @@ setuid perl scripts securely.\n"); } fdpid = anew(Nullstab); /* for remembering popen pids by fd */ - pidstatus = hnew(Nullstab); /* for remembering status of dead pids */ + pidstatus = hnew(COEFFSIZE);/* for remembering status of dead pids */ origfilename = savestr(argv[0]); curcmd->c_filestab = fstab(origfilename); @@ -360,7 +368,7 @@ setuid perl scripts securely.\n"); #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"); + (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel); execv(buf, origargv); /* try again */ fatal("Can't do setuid\n"); } @@ -378,12 +386,13 @@ setuid perl scripts securely.\n"); * 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. + * 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,7 +403,7 @@ setuid perl scripts securely.\n"); * 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. + * version called taintperl or tperlN.NNN that just does the TAINT checks. */ #ifdef DOSUID @@ -445,15 +454,15 @@ setuid perl scripts securely.\n"); } 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? */ + if (!cando(S_IXUSR,FALSE,&statbuf)) /* can real uid exec? */ fatal("Permission denied\n"); } #endif /* SETREUID */ #endif /* IAMSUID */ - if ((statbuf.st_mode & S_IFMT) != S_IFREG) + if (!S_ISREG(statbuf.st_mode)) fatal("Permission denied"); - if ((statbuf.st_mode >> 6) & S_IWRITE) + 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,7 +472,7 @@ setuid perl scripts securely.\n"); s = tokenbuf+2; if (*s == ' ') s++; while (!isspace(*s)) s++; - if (strnNE(s-4,"perl",4)) /* sanity check */ + if (strnNE(s-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */ fatal("Not a perl script"); while (*s == ' ' || *s == '\t') s++; /* @@ -487,7 +496,7 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n"); if (euid) { /* oops, we're not the setuid root perl */ (void)fclose(rsfp); #ifndef IAMSUID - (void)sprintf(buf, "%s/%s", BIN, "suidperl"); + (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel); execv(buf, origargv); /* try again */ #endif fatal("Can't do setuid\n"); @@ -529,7 +538,7 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n"); euid = (int)geteuid(); gid = (int)getgid(); egid = (int)getegid(); - if (!cando(S_IEXEC,TRUE,&statbuf)) + if (!cando(S_IXUSR,TRUE,&statbuf)) fatal("Permission denied\n"); /* they can't do this */ } #ifdef IAMSUID @@ -542,7 +551,7 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n"); /* 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"); + (void)sprintf(buf, "%s/tperl%s", BIN, patchlevel); execv(buf, origargv); /* try again */ fatal("Can't run setuid script with taint checks"); } @@ -563,7 +572,7 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n"); #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */ /* not set-id, must be wrapped */ (void)fclose(rsfp); - (void)sprintf(buf, "%s/%s", BIN, "taintperl"); + (void)sprintf(buf, "%s/tperl%s", BIN, patchlevel); execv(buf, origargv); /* try again */ fatal("Can't run setuid script with taint checks"); } @@ -677,9 +686,7 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n"); 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_u.str_nval = atof(patchlevel); str->str_nok = 1; } str_nset(stab_val(stabent("\"", TRUE)), " ", 1); @@ -1024,6 +1031,15 @@ char *s; { 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++; @@ -1,4 +1,4 @@ -/* $Header: stab.c,v 3.0.1.10 90/11/10 02:02:05 lwall Locked $ +/* $Header: stab.c,v 3.0.1.11 91/01/11 18:23:44 lwall Locked $ * * Copyright (c) 1989, Larry Wall * @@ -6,6 +6,9 @@ * 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,7 +173,7 @@ STR *str; break; #endif case '/': - if (record_separator != 12345) { + if (record_separator != 0777) { *tokenbuf = record_separator; tokenbuf[1] = '\0'; str_nset(stab_val(stab),tokenbuf,rslen); @@ -401,7 +404,7 @@ STR *str; rslen = str->str_cur; } else { - record_separator = 12345; /* fake a non-existent char */ + record_separator = 0777; /* fake a non-existent char */ rslen = 1; } break; @@ -1,4 +1,4 @@ -/* $Header: str.c,v 3.0.1.11 90/11/13 15:27:14 lwall Locked $ +/* $Header: str.c,v 3.0.1.12 91/01/11 18:26:54 lwall Locked $ * * Copyright (c) 1989, Larry Wall * @@ -6,6 +6,11 @@ * 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,8 +290,14 @@ register STR *sstr; sstr->str_pok = 0; /* wipe out any weird flags */ sstr->str_state = 0; /* so sstr frees uneventfully */ } - else /* have to copy actual string */ + 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,12 +749,12 @@ register STR *str2; if (str1->str_cur < str2->str_cur) { if (retval = memcmp(str1->str_ptr, str2->str_ptr, str1->str_cur)) - return retval; + return retval < 0 ? -1 : 1; else return -1; } else if (retval = memcmp(str1->str_ptr, str2->str_ptr, str2->str_cur)) - return retval; + return retval < 0 ? -1 : 1; else if (str1->str_cur == str2->str_cur) return 0; else @@ -804,6 +815,7 @@ int append; 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,8 +1385,10 @@ register STR *old; if (new->str_ptr) Safefree(new->str_ptr); Copy(old,new,1,STR); - if (old->str_ptr) + if (old->str_ptr) { new->str_ptr = nsavestr(old->str_ptr,old->str_len); + new->str_pok &= ~SP_TEMP; + } return new; } @@ -1,4 +1,4 @@ -/* $Header: toke.c,v 3.0.1.11 90/11/10 02:13:44 lwall Locked $ +/* $Header: toke.c,v 3.0.1.12 91/01/11 18:31:45 lwall Locked $ * * Copyright (c) 1989, Larry Wall * @@ -6,6 +6,10 @@ * 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,7 +2345,7 @@ load_format() Zero(&froot, 1, FCMD); s = bufptr; - while (s < bufend || (s = str_gets(linestr,rsfp, 0)) != Nullch) { + while (s < bufend || (rsfp && (s = str_gets(linestr,rsfp, 0)) != Nullch)) { curcmd->c_line++; if (in_eval && !rsfp) { eol = index(s,'\n'); @@ -2356,9 +2360,12 @@ load_format() 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 == '.') { + for (t = s+1; *t == ' ' || *t == '\t'; t++) ; + if (*t == '\n') { + bufptr = s; + return froot.f_next; + } } if (*s == '#') { s = eol; @@ -2456,7 +2463,8 @@ load_format() } if (flinebeg) { again: - if (s >= bufend && (s = str_gets(linestr, rsfp, 0)) == Nullch) + if (s >= bufend && + (!rsfp || (s = str_gets(linestr, rsfp, 0)) == Nullch) ) goto badform; curcmd->c_line++; if (in_eval && !rsfp) { @@ -1,4 +1,4 @@ -/* $Header: util.c,v 3.0.1.10 90/11/10 02:19:28 lwall Locked $ +/* $Header: util.c,v 3.0.1.11 91/01/11 18:33:10 lwall Locked $ * * Copyright (c) 1989, Larry Wall * @@ -6,6 +6,10 @@ * 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,7 +859,7 @@ long a1, a2, a3, a4; if (e_fp) (void)UNLINK(e_tmpname); statusvalue >>= 8; - exit(errno?errno:(statusvalue?statusvalue:255)); + exit((int)((errno&255)?errno:((statusvalue&255)?statusvalue:255))); } /*VARARGS1*/ @@ -959,7 +963,7 @@ va_dcl if (e_fp) (void)UNLINK(e_tmpname); statusvalue >>= 8; - exit((int)(errno?errno:(statusvalue?statusvalue:255))); + exit((int)((errno&255)?errno:((statusvalue&255)?statusvalue:255))); } /*VARARGS0*/ @@ -1458,7 +1462,7 @@ double f; { long along; -#ifdef mips +#if CASTFLAGS & 2 # define BIGDOUBLE 2147483648.0 if (f >= BIGDOUBLE) return (unsigned long)(f-(long)(f/BIGDOUBLE)*BIGDOUBLE)|0x80000000; diff --git a/x2p/s2p.SH b/x2p/s2p.SH index 9898dcf6a0..36eab5e11e 100644 --- a/x2p/s2p.SH +++ b/x2p/s2p.SH @@ -7,6 +7,7 @@ case $CONFIG in '') 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,9 +29,12 @@ $spitshell >s2p <<!GROK!THIS! : 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 $ +# $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" # |