perl 3.0 patch #10 patch #9, continued
authorLarry Wall <lwall@jpl-devvax.jpl.nasa.gov>
Wed, 28 Feb 1990 21:54:46 +0000 (21:54 +0000)
committerLarry Wall <lwall@jpl-devvax.jpl.nasa.gov>
Wed, 28 Feb 1990 21:54:46 +0000 (21:54 +0000)
See patch #9.

12 files changed:
cmd.c
cmd.h
config.h.SH
cons.c
consarg.c
doarg.c
doio.c
dolist.c
eval.c
lib/complete.pl
patchlevel.h
t/base.term

diff --git a/cmd.c b/cmd.c
index 36c36bd..be03fe0 100644 (file)
--- a/cmd.c
+++ b/cmd.c
@@ -1,4 +1,4 @@
-/* $Header: cmd.c,v 3.0.1.4 89/12/21 19:17:41 lwall Locked $
+/* $Header: cmd.c,v 3.0.1.5 90/02/28 16:38:31 lwall Locked $
  *
  *    Copyright (c) 1989, Larry Wall
  *
@@ -6,6 +6,14 @@
  *    as specified in the README file that comes with the perl 3.0 kit.
  *
  * $Log:       cmd.c,v $
+ * Revision 3.0.1.5  90/02/28  16:38:31  lwall
+ * patch9: volatilized some more variables for super-optimizing compilers
+ * patch9: nested foreach loops didn't reset inner loop on next to outer loop
+ * patch9: returned values were read from obsolete stack
+ * patch9: added sanity check on longjmp() return value
+ * patch9: substitutions that almost always succeed can corrupt label stack
+ * patch9: subs which return by both mechanisms can clobber local return data
+ * 
  * Revision 3.0.1.4  89/12/21  19:17:41  lwall
  * patch7: arranged for certain registers to be restored after longjmp()
  * patch7: made nested or recursive foreach work right
@@ -50,11 +58,12 @@ void grow_dlevel();
 int
 cmd_exec(cmdparm,gimme,sp)
 CMD *VOLATILE cmdparm;
-int gimme;
-int sp;
+VOLATILE int gimme;
+VOLATILE int sp;
 {
     register CMD *cmd = cmdparm;
     SPAT *VOLATILE oldspat;
+    VOLATILE int firstsave = savestack->ary_fill;
     VOLATILE int oldsave;
     VOLATILE int aryoptsave;
 #ifdef DEBUGGING
@@ -178,12 +187,16 @@ tail_recursion_entry:
                cmdparm = cmd;
 #endif
                if (match = setjmp(loop_stack[loop_ptr].loop_env)) {
-#ifdef JMPCLOBBER
                    st = stack->ary_array;      /* possibly reallocated */
+#ifdef JMPCLOBBER
                    cmd = cmdparm;
                    cmdflags = cmd->c_flags|CF_ONCE;
 #endif
+                   if (savestack->ary_fill > oldsave)
+                       restorelist(oldsave);
                    switch (match) {
+                   default:
+                       fatal("longjmp returned bad value (%d)",match);
                    case O_LAST:        /* not done unless go_to found */
                        go_to = Nullch;
                        if (lastretstr) {
@@ -198,8 +211,6 @@ tail_recursion_entry:
                        olddlevel = dlevel;
 #endif
                        curspat = oldspat;
-                       if (savestack->ary_fill > oldsave)
-                           restorelist(oldsave);
                        goto next_cmd;
                    case O_NEXT:        /* not done unless go_to found */
                        go_to = Nullch;
@@ -450,7 +461,7 @@ until_loop:
                }
            }
            if (--cmd->c_short->str_u.str_useful < 0) {
-               cmdflags &= ~CF_OPTIMIZE;
+               cmdflags &= ~(CF_OPTIMIZE|CF_ONCE);
                cmdflags |= CFT_EVAL;   /* never try this optimization again */
                cmd->c_flags = cmdflags;
            }
@@ -563,8 +574,11 @@ until_loop:
                savesptr(&stab_val(cmd->c_stab));
                savelong(&cmd->c_short->str_u.str_useful);
            }
-           else
+           else {
                ar = stab_xarray(cmd->c_expr[1].arg_ptr.arg_stab);
+               if (cmd->c_type != C_WHILE && savestack->ary_fill > firstsave)
+                   restorelist(firstsave);
+           }
 
            if (match >= ar->ary_fill) {        /* we're in LAST, probably */
                retstr = &str_undef;
@@ -753,13 +767,17 @@ until_loop:
        cmdparm = cmd;
 #endif
        if (match = setjmp(loop_stack[loop_ptr].loop_env)) {
-#ifdef JMPCLOBBER
            st = stack->ary_array;      /* possibly reallocated */
+#ifdef JMPCLOBBER
            cmd = cmdparm;
            cmdflags = cmd->c_flags|CF_ONCE;
            go_to = goto_targ;
 #endif
+           if (savestack->ary_fill > oldsave)
+               restorelist(oldsave);
            switch (match) {
+           default:
+               fatal("longjmp returned bad value (%d)",match);
            case O_LAST:
                if (lastretstr) {
                    retstr = lastretstr;
@@ -770,8 +788,6 @@ until_loop:
                    retstr = st[newsp];
                }
                curspat = oldspat;
-               if (savestack->ary_fill > oldsave)
-                   restorelist(oldsave);
                goto next_cmd;
            case O_NEXT:
 #ifdef JMPCLOBBER
@@ -831,8 +847,14 @@ until_loop:
        }
       finish_while:
        curspat = oldspat;
-       if (savestack->ary_fill > oldsave)
+       if (savestack->ary_fill > oldsave) {
+           if (cmdflags & CF_TERM) {
+               for (match = sp + 1; match <= newsp; match++)
+                   st[match] = str_static(st[match]);
+               retstr = st[newsp];
+           }
            restorelist(oldsave);
+       }
 #ifdef DEBUGGING
        dlevel = olddlevel - 1;
 #endif
@@ -855,7 +877,8 @@ until_loop:
        }
 #endif
        loop_ptr--;
-       if ((cmdflags & CF_OPTIMIZE) == CFT_ARRAY)
+       if ((cmdflags & CF_OPTIMIZE) == CFT_ARRAY &&
+         savestack->ary_fill > aryoptsave)
            restorelist(aryoptsave);
     }
     cmd = cmd->c_next;
diff --git a/cmd.h b/cmd.h
index 3a1d832..0c4a0b8 100644 (file)
--- a/cmd.h
+++ b/cmd.h
@@ -1,4 +1,4 @@
-/* $Header: cmd.h,v 3.0.1.1 89/10/26 23:05:43 lwall Locked $
+/* $Header: cmd.h,v 3.0.1.2 90/02/28 16:39:36 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:       cmd.h,v $
+ * Revision 3.0.1.2  90/02/28  16:39:36  lwall
+ * patch9: volatilized some more variables for super-optimizing compilers
+ * 
  * Revision 3.0.1.1  89/10/26  23:05:43  lwall
  * patch1: unless was broken when run under the debugger
  * 
@@ -127,7 +130,7 @@ struct cmd {
        struct scmd scmd;       /* switch command */
     } ucmd;
     short      c_slen;         /* len of c_short, if not null */
-    short      c_flags;        /* optimization flags--see above */
+    VOLATILE short c_flags;    /* optimization flags--see above */
     char       *c_file;        /* file the following line # is from */
     line_t      c_line;         /* line # of this command */
     char       c_type;         /* what this command does */
@@ -135,8 +138,8 @@ struct cmd {
 
 #define Nullcmd Null(CMD*)
 
-EXT CMD *main_root INIT(Nullcmd);
-EXT CMD *eval_root INIT(Nullcmd);
+EXT CMD * VOLATILE main_root INIT(Nullcmd);
+EXT CMD * VOLATILE eval_root INIT(Nullcmd);
 
 struct compcmd {
     CMD *comp_true;
index af686c6..7215ef9 100644 (file)
@@ -422,6 +422,12 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef!/\*#undef!'
  */
 #$d_voidsig    VOIDSIG         /**/
 
+/* HASVOLATILE:
+ *     This symbol, if defined, indicates that this C compiler knows about
+ *     the volatile declaration.
+ */
+#$d_volatile   HASVOLATILE     /**/
+
 /* VPRINTF:
  *     This symbol, if defined, indicates that the vprintf routine is available
  *     to printf with a pointer to an argument list.  If unavailable, you
@@ -542,7 +548,7 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef!/\*#undef!'
 
 /* I_UTIME:
  *     This symbol, if defined, indicates to the C program that it should
- *     include utime.h (a DG/UX thingie).
+ *     include utime.h.
  */
 #$i_utime      I_UTIME         /**/
 
diff --git a/cons.c b/cons.c
index 6db876c..28b6ddf 100644 (file)
--- a/cons.c
+++ b/cons.c
@@ -1,4 +1,4 @@
-/* $Header: cons.c,v 3.0.1.3 89/12/21 19:20:25 lwall Locked $
+/* $Header: cons.c,v 3.0.1.4 90/02/28 16:44:00 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:       cons.c,v $
+ * Revision 3.0.1.4  90/02/28  16:44:00  lwall
+ * patch9: subs which return by both mechanisms can clobber local return data
+ * patch9: changed internal SUB label to _SUB_
+ * patch9: line numbers were bogus during certain portions of foreach evaluation
+ * 
  * Revision 3.0.1.3  89/12/21  19:20:25  lwall
  * patch7: made nested or recursive foreach work right
  * 
@@ -67,8 +72,12 @@ CMD *cmd;
 
        mycompblock.comp_true = cmd;
        mycompblock.comp_alt = Nullcmd;
-       cmd = add_label(savestr("SUB"),make_ccmd(C_BLOCK,Nullarg,mycompblock));
+       cmd = add_label(savestr("_SUB_"),make_ccmd(C_BLOCK,Nullarg,mycompblock));
        saw_return = FALSE;
+       if (perldb)
+           cmd->c_next->c_flags |= CF_TERM;
+       else
+           cmd->c_flags |= CF_TERM;
     }
     sub->cmd = cmd;
     stab_sub(stab) = sub;
@@ -412,7 +421,9 @@ ARG *arg;
     cmd->c_expr = cond;
     if (cond)
        cmd->c_flags |= CF_COND;
-    if (cmdline != NOLINE) {
+    if (cmdline == NOLINE)
+       cmd->c_line = line;
+    else {
        cmd->c_line = cmdline;
        cmdline = NOLINE;
     }
@@ -437,7 +448,9 @@ struct compcmd cblock;
     cmd->ucmd.ccmd.cc_alt = cblock.comp_alt;
     if (arg)
        cmd->c_flags |= CF_COND;
-    if (cmdline != NOLINE) {
+    if (cmdline == NOLINE)
+       cmd->c_line = line;
+    else {
        cmd->c_line = cmdline;
        cmdline = NOLINE;
     }
@@ -466,7 +479,9 @@ struct compcmd cblock;
     cmd->ucmd.ccmd.cc_alt = cblock.comp_alt;
     if (arg)
        cmd->c_flags |= CF_COND;
-    if (cmdline != NOLINE) {
+    if (cmdline == NOLINE)
+       cmd->c_line = line;
+    else {
        cmd->c_line = cmdline;
        cmdline = NOLINE;
     }
index 6feeb9b..4252ad5 100644 (file)
--- a/consarg.c
+++ b/consarg.c
@@ -1,4 +1,4 @@
-/* $Header: consarg.c,v 3.0.1.2 89/11/17 15:11:34 lwall Locked $
+/* $Header: consarg.c,v 3.0.1.3 90/02/28 16:47:54 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:       consarg.c,v $
+ * Revision 3.0.1.3  90/02/28  16:47:54  lwall
+ * patch9: the x operator is now up to 10 times faster
+ * patch9: @_ clobbered by ($foo,$bar) = split
+ * 
  * Revision 3.0.1.2  89/11/17  15:11:34  lwall
  * patch5: defined $foo{'bar'} should not create element
  * 
@@ -312,9 +316,12 @@ register ARG *arg;
            break;
        case O_REPEAT:
            i = (int)str_gnum(s2);
+           tmps = str_get(s1);
            str_nset(str,"",0);
-           while (i-- > 0)
-               str_scat(str,s1);
+           STR_GROW(str, i * s1->str_cur + 1);
+           repeatcpy(str->str_ptr, tmps, s1->str_cur, i);
+           str->str_cur = i * s1->str_cur;
+           str->str_ptr[str->str_cur] = '\0';
            break;
        case O_MULTIPLY:
            value = str_gnum(s1);
@@ -648,10 +655,11 @@ register ARG *arg;
                arg2 = arg[2].arg_ptr.arg_arg;
                if (arg2->arg_type == O_SPLIT) { /* use split's builtin =?*/
                    spat = arg2[2].arg_ptr.arg_spat;
-                   if (spat->spat_repl[1].arg_ptr.arg_stab == defstab &&
+                   if (!(spat->spat_flags & SPAT_ONCE) &&
                      nothing_in_common(arg1,spat->spat_repl)) {
                        spat->spat_repl[1].arg_ptr.arg_stab =
                            arg1[1].arg_ptr.arg_stab;
+                       spat->spat_flags |= SPAT_ONCE;
                        arg_free(arg1); /* recursive */
                        free_arg(arg);  /* non-recursive */
                        return arg2;    /* split has builtin assign */
diff --git a/doarg.c b/doarg.c
index 7e7bfc8..43d945f 100644 (file)
--- a/doarg.c
+++ b/doarg.c
@@ -1,4 +1,4 @@
-/* $Header: doarg.c,v 3.0.1.2 89/12/21 19:52:15 lwall Locked $
+/* $Header: doarg.c,v 3.0.1.3 90/02/28 16:56:58 lwall Locked $
  *
  *    Copyright (c) 1989, Larry Wall
  *
@@ -6,6 +6,15 @@
  *    as specified in the README file that comes with the perl 3.0 kit.
  *
  * $Log:       doarg.c,v $
+ * Revision 3.0.1.3  90/02/28  16:56:58  lwall
+ * patch9: split now can split into more than 10000 elements
+ * patch9: sped up pack and unpack
+ * patch9: pack of unsigned ints and longs blew up some places
+ * patch9: sun3 can't cast negative float to unsigned int or long
+ * patch9: local($.) didn't work
+ * patch9: grep(s/foo/bar/, @abc = @xyz) modified @xyz rather than @abc
+ * patch9: syscall returned stack size rather than value of system call
+ * 
  * Revision 3.0.1.2  89/12/21  19:52:15  lwall
  * patch7: a pattern wouldn't match a null string before the first character
  * patch7: certain patterns didn't match correctly at end of string
@@ -44,6 +53,7 @@ int sp;
     register char *d;
     int clen;
     int iters = 0;
+    int maxiters = (strend - s) + 10;
     register int i;
     bool once;
     char *orig;
@@ -192,7 +202,7 @@ int sp;
                    /* NOTREACHED */
                }
                do {
-                   if (iters++ > 10000)
+                   if (iters++ > maxiters)
                        fatal("Substitution loop");
                    m = spat->spat_regexp->startp[0];
                    if (i = m - s) {
@@ -233,7 +243,7 @@ int sp;
            curspat = spat;
        lastspat = spat;
        do {
-           if (iters++ > 10000)
+           if (iters++ > maxiters)
                fatal("Substitution loop");
            if (spat->spat_regexp->subbase
              && spat->spat_regexp->subbase != orig) {
@@ -351,7 +361,9 @@ int *arglast;
     char achar;
     short ashort;
     int aint;
+    unsigned int auint;
     long along;
+    unsigned long aulong;
     char *aptr;
 
     items = arglast[2] - sp;
@@ -361,9 +373,9 @@ int *arglast;
 #define NEXTFROM (items-- > 0 ? *st++ : &str_no)
        datumtype = *pat++;
        if (isdigit(*pat)) {
-           len = atoi(pat);
+           len = *pat++ - '0';
            while (isdigit(*pat))
-               pat++;
+               len = (len * 10) + (*pat++ - '0');
        }
        else
            len = 1;
@@ -429,6 +441,12 @@ int *arglast;
            }
            break;
        case 'I':
+           while (len-- > 0) {
+               fromstr = NEXTFROM;
+               auint = (unsigned int)str_gnum(fromstr);
+               str_ncat(str,(char*)&auint,sizeof(unsigned int));
+           }
+           break;
        case 'i':
            while (len-- > 0) {
                fromstr = NEXTFROM;
@@ -447,6 +465,12 @@ int *arglast;
            }
            break;
        case 'L':
+           while (len-- > 0) {
+               fromstr = NEXTFROM;
+               aulong = (unsigned long)str_gnum(fromstr);
+               str_ncat(str,(char*)&aulong,sizeof(unsigned long));
+           }
+           break;
        case 'l':
            while (len-- > 0) {
                fromstr = NEXTFROM;
@@ -481,6 +505,7 @@ register STR **sarg;
     register char *send;
     char *xs;
     int xlen;
+    double value;
 
     str_set(str,"");
     len--;                     /* don't count pattern string */
@@ -547,10 +572,20 @@ register STR **sarg;
            case 'x': case 'o': case 'u':
                ch = *(++t);
                *t = '\0';
+               value = str_gnum(*(sarg++));
+#if defined(sun) && !defined(sparc)
+               if (value < 0.0) {              /* sigh */
+                   if (dolong)
+                       (void)sprintf(buf,s,(long)value);
+                   else
+                       (void)sprintf(buf,s,(int)value);
+               }
+               else
+#endif
                if (dolong)
-                   (void)sprintf(buf,s,(unsigned long)str_gnum(*(sarg++)));
+                   (void)sprintf(buf,s,(unsigned long)value);
                else
-                   (void)sprintf(buf,s,(unsigned int)str_gnum(*(sarg++)));
+                   (void)sprintf(buf,s,(unsigned int)value);
                s = t;
                *(t--) = ch;
                break;
@@ -798,6 +833,7 @@ int *arglast;
     int i;
 
     makelocal = (arg->arg_flags & AF_LOCAL);
+    localizing = makelocal;
     delaymagic = DM_DELAY;             /* catch simultaneous items */
 
     /* If there's a common identifier on both sides we have to take
@@ -828,9 +864,8 @@ int *arglast;
                while (relem <= lastrelem) {    /* gobble up all the rest */
                    str = Str_new(28,0);
                    if (*relem)
-                       str_sset(str,*(relem++));
-                   else
-                       relem++;
+                       str_sset(str,*relem);
+                   *(relem++) = str;
                    (void)astore(ary,i++,str);
                }
            }
@@ -852,9 +887,8 @@ int *arglast;
                    tmps = str_get(str);
                    tmpstr = Str_new(29,0);
                    if (*relem)
-                       str_sset(tmpstr,*(relem++));    /* value */
-                   else
-                       relem++;
+                       str_sset(tmpstr,*relem);        /* value */
+                   *(relem++) = tmpstr;
                    (void)hstore(hash,tmps,str->str_cur,tmpstr,0);
                }
            }
@@ -864,10 +898,26 @@ int *arglast;
        else {
            if (makelocal)
                saveitem(str);
-           if (relem <= lastrelem)
-               str_sset(str, *(relem++));
-           else
+           if (relem <= lastrelem) {
+               str_sset(str, *relem);
+               *(relem++) = str;
+           }
+           else {
                str_nset(str, "", 0);
+               if (gimme == G_ARRAY) {
+                   i = ++lastrelem - firstrelem;
+                   relem++;            /* tacky, I suppose */
+                   astore(stack,i,str);
+                   if (st != stack->ary_array) {
+                       st = stack->ary_array;
+                       firstrelem = st + arglast[1] + 1;
+                       firstlelem = st + arglast[0] + 1;
+                       lastlelem = st + arglast[1];
+                       lastrelem = st + i;
+                       relem = lastrelem + 1;
+                   }
+               }
+           }
            STABSET(str);
        }
     }
@@ -882,6 +932,7 @@ int *arglast;
 #endif
     }
     delaymagic = 0;
+    localizing = FALSE;
     if (gimme == G_ARRAY) {
        i = lastrelem - firstrelem + 1;
        if (ary || hash)
@@ -1283,9 +1334,7 @@ int *arglast;
          arg[7]);
        break;
     }
-    st[sp] = str_static(&str_undef);
-    str_numset(st[sp], (double)retval);
-    return sp;
+    return retval;
 #else
     fatal("syscall() unimplemented");
 #endif
diff --git a/doio.c b/doio.c
index 853347a..766d120 100644 (file)
--- a/doio.c
+++ b/doio.c
@@ -1,4 +1,4 @@
-/* $Header: doio.c,v 3.0.1.4 89/12/21 19:55:10 lwall Locked $
+/* $Header: doio.c,v 3.0.1.5 90/02/28 17:01:36 lwall Locked $
  *
  *    Copyright (c) 1989, Larry Wall
  *
@@ -6,6 +6,12 @@
  *    as specified in the README file that comes with the perl 3.0 kit.
  *
  * $Log:       doio.c,v $
+ * Revision 3.0.1.5  90/02/28  17:01:36  lwall
+ * patch9: open(FOO,"$filename\0") will now protect trailing spaces in filename
+ * patch9: removed obsolete checks to avoid opening block devices
+ * patch9: removed references to acusec and modusec that some utime.h's have
+ * patch9: added pipe function
+ * 
  * Revision 3.0.1.4  89/12/21  19:55:10  lwall
  * patch7: select now works on big-endian machines
  * patch7: errno may now be a macro with an lvalue
 #endif
 
 bool
-do_open(stab,name)
+do_open(stab,name,len)
 STAB *stab;
 register char *name;
+int len;
 {
     FILE *fp;
-    int len = strlen(name);
     register STIO *stio = stab_io(stab);
     char *myname = savestr(name);
     int result;
@@ -202,21 +208,6 @@ register char *name;
            return FALSE;
        }
        result = (statbuf.st_mode & S_IFMT);
-       if (result != S_IFREG &&
-#ifdef S_IFSOCK
-           result != S_IFSOCK &&
-#endif
-#ifdef S_IFFIFO
-           result != S_IFFIFO &&
-#endif
-#ifdef S_IFIFO
-           result != S_IFIFO &&
-#endif
-           result != 0 &&              /* socket? */
-           result != S_IFCHR) {
-           (void)fclose(fp);
-           return FALSE;
-       }
 #ifdef S_IFSOCK
        if (result == S_IFSOCK || result == 0)
            stio->type = 's';   /* in case a socket was passed in to us */
@@ -250,7 +241,7 @@ register STAB *stab;
        str_sset(stab_val(stab),str);
        STABSET(stab_val(stab));
        oldname = str_get(stab_val(stab));
-       if (do_open(stab,oldname)) {
+       if (do_open(stab,oldname,stab_val(stab)->str_cur)) {
            if (inplace) {
 #ifdef TAINT
                taintproper("Insecure dependency in inplace open");
@@ -275,7 +266,7 @@ register STAB *stab;
                str_nset(str,">",1);
                str_cat(str,oldname);
                errno = 0;              /* in case sprintf set errno */
-               if (!do_open(argvoutstab,str->str_ptr))
+               if (!do_open(argvoutstab,str->str_ptr,str->str_cur))
                    fatal("Can't do inplace edit");
                defoutstab = argvoutstab;
 #ifdef FCHMOD
@@ -303,6 +294,49 @@ register STAB *stab;
     return Nullfp;
 }
 
+void
+do_pipe(str, rstab, wstab)
+STR *str;
+STAB *rstab;
+STAB *wstab;
+{
+    register STIO *rstio;
+    register STIO *wstio;
+    int fd[2];
+
+    if (!rstab)
+       goto badexit;
+    if (!wstab)
+       goto badexit;
+
+    rstio = stab_io(rstab);
+    wstio = stab_io(wstab);
+
+    if (!rstio)
+       rstio = stab_io(rstab) = stio_new();
+    else if (rstio->ifp)
+       do_close(rstab,FALSE);
+    if (!wstio)
+       wstio = stab_io(wstab) = stio_new();
+    else if (wstio->ifp)
+       do_close(wstab,FALSE);
+
+    if (pipe(fd) < 0)
+       goto badexit;
+    rstio->ifp = fdopen(fd[0], "r");
+    wstio->ofp = fdopen(fd[1], "w");
+    wstio->ifp = wstio->ofp;
+    rstio->type = '<';
+    wstio->type = '>';
+
+    str_sset(str,&str_yes);
+    return;
+
+badexit:
+    str_sset(str,&str_undef);
+    return;
+}
+
 bool
 do_close(stab,explicit)
 STAB *stab;
@@ -1991,12 +2025,9 @@ int *arglast;
            } utbuf;
 #endif
 
+           Zero(&utbuf, sizeof utbuf, char);
            utbuf.actime = (long)str_gnum(st[++sp]);    /* time accessed */
            utbuf.modtime = (long)str_gnum(st[++sp]);    /* time modified */
-#ifdef I_UTIME
-           utbuf.acusec = 0;           /* hopefully I_UTIME implies these */
-           utbuf.modusec = 0;
-#endif
            items -= 2;
 #ifndef lint
            tot = items;
index 4823231..bd7db0b 100644 (file)
--- a/dolist.c
+++ b/dolist.c
@@ -1,4 +1,4 @@
-/* $Header: dolist.c,v 3.0.1.4 89/12/21 19:58:46 lwall Locked $
+/* $Header: dolist.c,v 3.0.1.5 90/02/28 17:09:44 lwall Locked $
  *
  *    Copyright (c) 1989, Larry Wall
  *
@@ -6,6 +6,15 @@
  *    as specified in the README file that comes with the perl 3.0 kit.
  *
  * $Log:       dolist.c,v $
+ * Revision 3.0.1.5  90/02/28  17:09:44  lwall
+ * patch9: split now can split into more than 10000 elements
+ * patch9: @_ clobbered by ($foo,$bar) = split
+ * patch9: sped up pack and unpack
+ * patch9: unpack of single item now works in a scalar context
+ * patch9: slices ignored value of $[
+ * patch9: grep now returns number of items matched in scalar context
+ * patch9: grep iterations no longer in the regexp context of previous iteration
+ * 
  * Revision 3.0.1.4  89/12/21  19:58:46  lwall
  * patch7: grep(1,@array) didn't work
  * patch7: /$pat/; //; wrongly freed runtime pattern twice
@@ -264,6 +273,7 @@ int *arglast;
     register STR *dstr;
     register char *m;
     int iters = 0;
+    int maxiters = (strend - s) + 10;
     int i;
     char *orig;
     int origlimit = limit;
@@ -299,7 +309,7 @@ int *arglast;
     }
 #endif
     ary = stab_xarray(spat->spat_repl[1].arg_ptr.arg_stab);
-    if (ary && ((ary->ary_flags & ARF_REAL) || gimme != G_ARRAY)) {
+    if (ary && (gimme != G_ARRAY || (spat->spat_flags & SPAT_ONCE))) {
        realarray = 1;
        if (!(ary->ary_flags & ARF_REAL)) {
            ary->ary_flags |= ARF_REAL;
@@ -317,7 +327,7 @@ int *arglast;
            s++;
     }
     if (!limit)
-       limit = 10001;
+       limit = maxiters + 2;
     if (spat->spat_short) {
        i = spat->spat_short->str_cur;
        if (i == 1) {
@@ -353,6 +363,7 @@ int *arglast;
        }
     }
     else {
+       maxiters += (strend - s) * spat->spat_regexp->nparens;
        while (s < strend && --limit &&
            regexec(spat->spat_regexp, s, strend, orig, 1, Nullstr, TRUE) ) {
            if (spat->spat_regexp->subbase
@@ -389,7 +400,7 @@ int *arglast;
        iters = sp + 1;
     else
        iters = sp - arglast[0];
-    if (iters > 9999)
+    if (iters > maxiters)
        fatal("Split loop");
     if (s < strend || origlimit) {     /* keep field after final delim? */
        if (realarray)
@@ -468,19 +479,20 @@ int *arglast;
     unsigned long aulong;
     char *aptr;
 
-    if (gimme != G_ARRAY) {
-       str_sset(str,&str_undef);
-       STABSET(str);
-       st[sp] = str;
-       return sp;
+    if (gimme != G_ARRAY) {            /* arrange to do first one only */
+       patend = pat+1;
+       if (*pat == 'a' || *pat == 'A') {
+           while (isdigit(*patend))
+               patend++;
+       }
     }
     sp--;
     while (pat < patend) {
        datumtype = *pat++;
        if (isdigit(*pat)) {
-           len = atoi(pat);
+           len = *pat++ - '0';
            while (isdigit(*pat))
-               pat++;
+               len = (len * 10) + (*pat++ - '0');
        }
        else
            len = 1;
@@ -675,8 +687,8 @@ int *arglast;
        if (numarray) {
            while (sp < max) {
                if (st[++sp]) {
-                   st[sp-1] = afetch(stab_array(stab),(int)str_gnum(st[sp]),
-                       lval);
+                   st[sp-1] = afetch(stab_array(stab),
+                     ((int)str_gnum(st[sp])) - arybase, lval);
                }
                else
                    st[sp-1] = &str_undef;
@@ -700,7 +712,8 @@ int *arglast;
     else {
        if (numarray) {
            if (st[max])
-               st[sp] = afetch(stab_array(stab),(int)str_gnum(st[max]), lval);
+               st[sp] = afetch(stab_array(stab),
+                 ((int)str_gnum(st[max])) - arybase, lval);
            else
                st[sp] = &str_undef;
        }
@@ -732,6 +745,7 @@ int *arglast;
     register int sp = arglast[2];
     register int i = sp - arglast[1];
     int oldsave = savestack->ary_fill;
+    SPAT *oldspat = curspat;
 
     savesptr(&stab_val(defstab));
     if ((arg[1].arg_type & A_MASK) != A_EXPR) {
@@ -747,10 +761,11 @@ int *arglast;
        if (str_true(st[sp+1]))
            st[dst++] = st[src];
        src++;
+       curspat = oldspat;
     }
     restorelist(oldsave);
     if (gimme != G_ARRAY) {
-       str_sset(str,&str_undef);
+       str_numset(str,(double)(dst - arglast[1]));
        STABSET(str);
        st[arglast[0]+1] = str;
        return arglast[0]+1;
diff --git a/eval.c b/eval.c
index 95870b1..03518a8 100644 (file)
--- a/eval.c
+++ b/eval.c
@@ -1,4 +1,4 @@
-/* $Header: eval.c,v 3.0.1.3 89/12/21 20:03:05 lwall Locked $
+/* $Header: eval.c,v 3.0.1.4 90/02/28 17:36:59 lwall Locked $
  *
  *    Copyright (c) 1989, Larry Wall
  *
@@ -6,6 +6,18 @@
  *    as specified in the README file that comes with the perl 3.0 kit.
  *
  * $Log:       eval.c,v $
+ * Revision 3.0.1.4  90/02/28  17:36:59  lwall
+ * patch9: added pipe function
+ * patch9: a return in scalar context wouldn't return array
+ * patch9: !~ now always returns scalar even in array context
+ * patch9: some machines can't cast float to long with high bit set
+ * patch9: piped opens returned undef in child
+ * patch9: @array in scalar context now returns length of array
+ * patch9: chdir; coredumped
+ * patch9: wait no longer ignores signals
+ * patch9: mkdir now handles odd versions of /bin/mkdir
+ * patch9: -l FILEHANDLE now disallowed
+ * 
  * Revision 3.0.1.3  89/12/21  20:03:05  lwall
  * patch7: errno may now be a macro with an lvalue
  * patch7: ANSI strerror() is now supported
@@ -48,6 +60,7 @@ static STAB *stab2;
 static STIO *stio;
 static struct lstring *lstr;
 static char old_record_separator;
+extern int wantarray;
 
 double sin(), cos(), atan2(), pow();
 
@@ -141,10 +154,12 @@ register int sp;
        STR_SSET(str,st[1]);
        anum = (int)str_gnum(st[2]);
        if (anum >= 1) {
-           tmpstr = Str_new(50,0);
+           tmpstr = Str_new(50, 0);
            str_sset(tmpstr,str);
-           while (--anum > 0)
-               str_scat(str,tmpstr);
+           tmps = str_get(tmpstr);     /* force to be string */
+           STR_GROW(str, (anum * str->str_cur) + 1);
+           repeatcpy(str->str_ptr, tmps, tmpstr->str_cur, anum);
+           str->str_cur *= anum; str->str_ptr[str->str_cur] = '\0';
        }
        else
            str_sset(str,&str_no);
@@ -159,9 +174,7 @@ register int sp;
        break;
     case O_NMATCH:
        sp = do_match(str,arg,
-         gimme,arglast);
-       if (gimme == G_ARRAY)
-           goto array_return;
+         G_SCALAR,arglast);
        str_sset(str, str_true(str) ? &str_no : &str_yes);
        STABSET(str);
        break;
@@ -270,14 +283,14 @@ register int sp;
        value = str_gnum(st[1]);
        anum = (int)str_gnum(st[2]);
 #ifndef lint
-       value = (double)(((long)value) << anum);
+       value = (double)(((unsigned long)value) << anum);
 #endif
        goto donumset;
     case O_RIGHT_SHIFT:
        value = str_gnum(st[1]);
        anum = (int)str_gnum(st[2]);
 #ifndef lint
-       value = (double)(((long)value) >> anum);
+       value = (double)(((unsigned long)value) >> anum);
 #endif
        goto donumset;
     case O_LT:
@@ -313,7 +326,8 @@ register int sp;
        if (!sawvec || st[1]->str_nok || st[2]->str_nok) {
            value = str_gnum(st[1]);
 #ifndef lint
-           value = (double)(((long)value) & (long)str_gnum(st[2]));
+           value = (double)(((unsigned long)value) &
+                       (unsigned long)str_gnum(st[2]));
 #endif
            goto donumset;
        }
@@ -324,7 +338,8 @@ register int sp;
        if (!sawvec || st[1]->str_nok || st[2]->str_nok) {
            value = str_gnum(st[1]);
 #ifndef lint
-           value = (double)(((long)value) ^ (long)str_gnum(st[2]));
+           value = (double)(((unsigned long)value) ^
+                       (unsigned long)str_gnum(st[2]));
 #endif
            goto donumset;
        }
@@ -335,7 +350,8 @@ register int sp;
        if (!sawvec || st[1]->str_nok || st[2]->str_nok) {
            value = str_gnum(st[1]);
 #ifndef lint
-           value = (double)(((long)value) | (long)str_gnum(st[2]));
+           value = (double)(((unsigned long)value) |
+                       (unsigned long)str_gnum(st[2]));
 #endif
            goto donumset;
        }
@@ -414,7 +430,7 @@ register int sp;
        goto donumset;
     case O_COMPLEMENT:
 #ifndef lint
-       value = (double) ~(long)str_gnum(st[1]);
+       value = (double) ~(unsigned long)str_gnum(st[1]);
 #endif
        goto donumset;
     case O_SELECT:
@@ -502,11 +518,14 @@ register int sp;
            stab = arg[1].arg_ptr.arg_stab;
        else
            stab = stabent(str_get(st[1]),TRUE);
-       if (do_open(stab,str_get(st[2]))) {
+       tmps = str_get(st[2]);
+       if (do_open(stab,tmps,st[2]->str_cur)) {
            value = (double)forkprocess;
            stab_io(stab)->lines = 0;
            goto donumset;
        }
+       else if (forkprocess == 0)              /* we are a new child */
+           goto say_zero;
        else
            goto say_undef;
        break;
@@ -556,9 +575,10 @@ register int sp;
            sp += maxarg;
            goto array_return;
        }
-       else
-           str = afetch(ary,maxarg - 1,FALSE);
-       break;
+       else {
+           value = (double)maxarg;
+           goto donumset;
+       }
     case O_AELEM:
        anum = ((int)str_gnum(st[2])) - arybase;
        str = afetch(stab_array(arg[1].arg_ptr.arg_stab),anum,FALSE);
@@ -824,7 +844,7 @@ register int sp;
        goto donumset;
     case O_CHDIR:
        if (maxarg < 1)
-           tmps = str_get(stab_val(defstab));
+           tmps = Nullch;
        else
            tmps = str_get(st[1]);
        if (!tmps || !*tmps) {
@@ -993,9 +1013,9 @@ register int sp;
        STABSET(str);
        break;
     case O_RETURN:
-       tmps = "SUB";           /* just fake up a "last SUB" */
+       tmps = "_SUB_";         /* just fake up a "last _SUB_" */
        optype = O_LAST;
-       if (gimme == G_ARRAY) {
+       if (wantarray == G_ARRAY) {
            lastretstr = Nullstr;
            lastspbase = arglast[1];
            lastsize = arglast[2] - arglast[1];
@@ -1304,17 +1324,17 @@ register int sp;
        goto donumset;
     case O_WAIT:
 #ifndef lint
-       ihand = signal(SIGINT, SIG_IGN);
-       qhand = signal(SIGQUIT, SIG_IGN);
+       /* ihand = signal(SIGINT, SIG_IGN); */
+       /* qhand = signal(SIGQUIT, SIG_IGN); */
        anum = wait(&argflags);
        if (anum > 0)
            pidgone(anum,argflags);
        value = (double)anum;
 #else
-       ihand = qhand = 0;
+       /* ihand = qhand = 0; */
 #endif
-       (void)signal(SIGINT, ihand);
-       (void)signal(SIGQUIT, qhand);
+       /* (void)signal(SIGINT, ihand); */
+       /* (void)signal(SIGQUIT, qhand); */
        statusvalue = (unsigned short)argflags;
        goto donumset;
     case O_SYSTEM:
@@ -1491,6 +1511,8 @@ register int sp;
                    errno = EEXIST;
                else if (instr(buf,"non-exist"))
                    errno = ENOENT;
+               else if (instr(buf,"does not exist"))
+                   errno = ENOENT;
                else if (instr(buf,"not empty"))
                    errno = EBUSY;
                else if (instr(buf,"cannot access"))
@@ -1600,7 +1622,7 @@ register int sp;
            stab = arg[1].arg_ptr.arg_stab;
        else
            stab = stabent(str_get(st[1]),TRUE);
-       argtype = (int)str_gnum(st[2]);
+       argtype = (unsigned int)str_gnum(st[2]);
 #ifdef TAINT
        taintproper("Insecure dependency in ioctl");
 #endif
@@ -1748,6 +1770,8 @@ register int sp;
        goto say_no;
 #endif
     case O_FTLINK:
+       if (arg[1].arg_type & A_DONT)
+           fatal("You must supply explicit filename with -l");
 #ifdef LSTAT
        if (lstat(str_get(st[1]),&statcache) < 0)
            goto say_undef;
@@ -2070,6 +2094,18 @@ register int sp;
     case O_SYSCALL:
        value = (double)do_syscall(arglast);
        goto donumset;
+    case O_PIPE:
+       if ((arg[1].arg_type & A_MASK) == A_WORD)
+           stab = arg[1].arg_ptr.arg_stab;
+       else
+           stab = stabent(str_get(st[1]),TRUE);
+       if ((arg[2].arg_type & A_MASK) == A_WORD)
+           stab2 = arg[2].arg_ptr.arg_stab;
+       else
+           stab2 = stabent(str_get(st[2]),TRUE);
+       do_pipe(str,stab,stab2);
+       STABSET(str);
+       break;
     }
 
   normal_return:
@@ -2087,8 +2123,21 @@ array_return:
 #ifdef DEBUGGING
     if (debug) {
        dlevel--;
-       if (debug & 8)
-           deb("%s RETURNS ARRAY OF %d ARGS\n",opname[optype],sp - arglast[0]);
+       if (debug & 8) {
+           anum = sp - arglast[0];
+           switch (anum) {
+           case 0:
+               deb("%s RETURNS ()\n",opname[optype]);
+               break;
+           case 1:
+               deb("%s RETURNS (\"%s\")\n",opname[optype],str_get(st[1]));
+               break;
+           default:
+               deb("%s RETURNS %d ARGS (\"%s\",%s\"%s\"\n",opname[optype],anum,
+                 str_get(st[1]),anum==2?"":"...,",str_get(st[anum]));
+               break;
+           }
+       }
     }
 #endif
     return sp;
index 334d539..b59bee3 100644 (file)
@@ -25,6 +25,7 @@ sub Complete {
     local ($prompt) = shift (@_);
     local ($c, $cmp, $l, $r, $ret, $return, $test);
     @_cmp_lst = sort @_;
+    local($[) = 0;
     system 'stty raw -echo';
     loop: {
        print $prompt, $return;
index 618bca4..4e0e918 100644 (file)
@@ -1 +1 @@
-#define PATCHLEVEL 9
+#define PATCHLEVEL 10
index 945dedd..6055fe2 100644 (file)
@@ -1,6 +1,6 @@
 #!./perl
 
-# $Header: base.term,v 3.0 89/10/18 15:24:34 lwall Locked $
+# $Header: base.term,v 3.0.1.1 90/02/28 18:31:56 lwall Locked $
 
 print "1..6\n";
 
@@ -30,7 +30,13 @@ if ($x == '1') {print "ok 4\n";} else {print "not ok 4\n";}
 # check <> pseudoliteral
 
 open(try, "/dev/null") || (die "Can't open /dev/null.");
-if (<try> eq '') {print "ok 5\n";} else {print "not ok 5\n";}
+if (<try> eq '') {
+    print "ok 5\n";
+}
+else {
+    print "not ok 5\n";
+    die "/dev/null IS NOT A CHARACTER SPECIAL FILE!!!!\n" unless -c '/dev/null';
+}
 
 open(try, "../Makefile") || (die "Can't open ../Makefile.");
 if (<try> ne '') {print "ok 6\n";} else {print "not ok 6\n";}