perl 3.0 patch #44 patch #42, continued
Larry Wall [Fri, 11 Jan 1991 08:58:45 +0000 (08:58 +0000)]
See patch #42.

15 files changed:
Configure
lib/perldb.pl
lib/pwd.pl
patchlevel.h
perl.man.1
perl.man.2
perl.man.3
perl.man.4
perl.y
perly.c
stab.c
str.c
toke.c
util.c
x2p/s2p.SH

index a1bdeb4..f40c802 100755 (executable)
--- a/Configure
+++ b/Configure
@@ -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
index c86fb16..4c2f54d 100644 (file)
@@ -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 $@;
 }
 
index c141e98..7abcc1f 100644 (file)
@@ -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;
index 64b1306..760709b 100644 (file)
@@ -1 +1 @@
-#define PATCHLEVEL 43
+#define PATCHLEVEL 44
index 9a24089..fdc606c 100644 (file)
@@ -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
index b9c37ef..a6ab6a1 100644 (file)
@@ -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:
index be1cc72..d4574eb 100644 (file)
@@ -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.
index 7100e80..54ddff5 100644 (file)
@@ -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
diff --git a/perl.y b/perl.y
index 5c5b4a4..b3e7512 100644 (file)
--- a/perl.y
+++ b/perl.y
@@ -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);
diff --git a/perly.c b/perly.c
index 08aa11f..87acead 100644 (file)
--- a/perly.c
+++ b/perly.c
@@ -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++;
diff --git a/stab.c b/stab.c
index 481a504..8900e7f 100644 (file)
--- a/stab.c
+++ b/stab.c
@@ -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;
diff --git a/str.c b/str.c
index e392cee..7ec76fe 100644 (file)
--- a/str.c
+++ b/str.c
@@ -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;
 }
 
diff --git a/toke.c b/toke.c
index 5f1ccd0..e3f3c73 100644 (file)
--- a/toke.c
+++ b/toke.c
@@ -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) {
diff --git a/util.c b/util.c
index de8f122..b140694 100644 (file)
--- a/util.c
+++ b/util.c
@@ -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;
index 9898dcf..36eab5e 100644 (file)
@@ -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"
 #