perl 4.0 patch 6: patch #4, continued
authorLarry Wall <lwall@netlabs.com>
Thu, 6 Jun 1991 23:28:02 +0000 (23:28 +0000)
committerLarry Wall <lwall@netlabs.com>
Thu, 6 Jun 1991 23:28:02 +0000 (23:28 +0000)
See patch #4.

19 files changed:
doSH [new file with mode: 0644]
doarg.c
doio.c
dolist.c
dump.c
eval.c
form.c
form.h
h2pl/getioctlsizes
handy.h
hash.c
lib/find.pl [new file with mode: 0644]
lib/finddepth.pl [new file with mode: 0644]
msdos/dir.h
msdos/directory.c
patchlevel.h
t/op/groups.t
x2p/find2perl.SH
x2p/handy.h

diff --git a/doSH b/doSH
new file mode 100644 (file)
index 0000000..4b02784
--- /dev/null
+++ b/doSH
@@ -0,0 +1,36 @@
+#!/bin/sh
+
+: if this fails, just run all the .SH files by hand
+. ./config.sh
+
+echo " "
+echo "Doing variable substitutions on .SH files..."
+set x `awk '{print $1}' <MANIFEST | grep '\.SH'`
+shift
+case $# in
+0) set x *.SH; shift;;
+esac
+if test ! -f $1; then
+    shift
+fi
+for file in $*; do
+    set X
+    shift
+    chmod +x $file
+    case "$file" in
+    */*)
+       dir=`expr X$file : 'X\(.*\)/'`
+       file=`expr X$file : 'X.*/\(.*\)'`
+       (cd $dir && . $file)
+       ;;
+    *)
+       . $file
+       ;;
+    esac
+done
+if test -f config.h.SH; then
+    if test ! -f config.h; then
+       : oops, they left it out of MANIFEST, probably, so do it anyway.
+       . config.h.SH
+    fi
+fi
diff --git a/doarg.c b/doarg.c
index 045b597..2a1d5eb 100644 (file)
--- a/doarg.c
+++ b/doarg.c
@@ -1,11 +1,21 @@
-/* $RCSfile: doarg.c,v $$Revision: 4.0.1.1 $$Date: 91/04/11 17:40:14 $
+/* $RCSfile: doarg.c,v $$Revision: 4.0.1.2 $$Date: 91/06/07 10:42:17 $
  *
- *    Copyright (c) 1989, Larry Wall
+ *    Copyright (c) 1991, Larry Wall
  *
- *    You may distribute under the terms of the GNU General Public License
- *    as specified in the README file that comes with the perl 3.0 kit.
+ *    You may distribute under the terms of either the GNU General Public
+ *    License or the Artistic License, as specified in the README file.
  *
  * $Log:       doarg.c,v $
+ * Revision 4.0.1.2  91/06/07  10:42:17  lwall
+ * patch4: new copyright notice
+ * patch4: // wouldn't use previous pattern if it started with a null character
+ * patch4: //o and s///o now optimize themselves fully at runtime
+ * patch4: added global modifier for pattern matches
+ * patch4: undef @array disabled "@array" interpolation
+ * patch4: chop("") was returning "\0" rather than ""
+ * patch4: vector logical operations &, | and ^ sometimes returned null string
+ * patch4: syscall couldn't pass numbers with most significant bit set on sparcs
+ * 
  * Revision 4.0.1.1  91/04/11  17:40:14  lwall
  * patch1: fixed undefined environ problem
  * patch1: fixed debugger coredump on subroutines
@@ -67,6 +77,12 @@ int sp;
        if (spat->spat_flags & SPAT_KEEP) {
            arg_free(spat->spat_runtime);       /* it won't change, so */
            spat->spat_runtime = Nullarg;       /* no point compiling again */
+           scanconst(spat, m, dstr->str_cur);
+           hoistmust(spat);
+            if (curcmd->c_expr && (curcmd->c_flags & CF_OPTIMIZE) == CFT_EVAL) {
+                curcmd->c_flags &= ~CF_OPTIMIZE;
+                opt_arg(curcmd, 1, curcmd->c_type == C_EXPR);
+            }
        }
     }
 #ifdef DEBUGGING
@@ -76,7 +92,7 @@ int sp;
 #endif
     safebase = ((!spat->spat_regexp || !spat->spat_regexp->nparens) &&
       !sawampersand);
-    if (!*spat->spat_regexp->precomp && lastspat)
+    if (!spat->spat_regexp->prelen && lastspat)
        spat = lastspat;
     orig = m = s;
     if (hint) {
@@ -122,7 +138,7 @@ int sp;
            spat->spat_short = Nullstr; /* opt is being useless */
        }
     }
-    once = ((rspat->spat_flags & SPAT_ONCE) != 0);
+    once = !(rspat->spat_flags & SPAT_GLOBAL);
     if (rspat->spat_flags & SPAT_CONST) {      /* known replacement string? */
        if ((rspat->spat_repl[1].arg_type & A_MASK) == A_SINGLE)
            dstr = rspat->spat_repl[1].arg_ptr.arg_str;
@@ -1287,7 +1303,7 @@ int *arglast;
     if (type == O_ARRAY || type == O_LARRAY) {
        stab = arg[1].arg_ptr.arg_stab;
        afree(stab_xarray(stab));
-       stab_xarray(stab) = Null(ARRAY*);
+       stab_xarray(stab) = anew(stab);         /* so "@array" still works */
     }
     else if (type == O_HASH || type == O_LHASH) {
        stab = arg[1].arg_ptr.arg_stab;
@@ -1442,14 +1458,16 @@ register STR *str;
        return;
     }
     tmps = str_get(str);
-    if (!tmps)
-       return;
-    tmps += str->str_cur - (str->str_cur != 0);
-    str_nset(astr,tmps,1);     /* remember last char */
-    *tmps = '\0';                              /* wipe it out */
-    str->str_cur = tmps - str->str_ptr;
-    str->str_nok = 0;
-    STABSET(str);
+    if (tmps && str->str_cur) {
+       tmps += str->str_cur - 1;
+       str_nset(astr,tmps,1);  /* remember last char */
+       *tmps = '\0';                           /* wipe it out */
+       str->str_cur = tmps - str->str_ptr;
+       str->str_nok = 0;
+       STABSET(str);
+    }
+    else
+       str_nset(astr,"",0);
 }
 
 do_vop(optype,str,left,right)
@@ -1472,6 +1490,8 @@ STR *right;
        (void)bzero(str->str_ptr + str->str_cur, len - str->str_cur);
        str->str_cur = len;
     }
+    str->str_pok = 1;
+    str->str_nok = 0;
     s = str->str_ptr;
     if (!s) {
        str_nset(str,"",0);
@@ -1506,7 +1526,7 @@ int *arglast;
     register STR **st = stack->ary_array;
     register int sp = arglast[1];
     register int items = arglast[2] - sp;
-    long arg[8];
+    unsigned long arg[8];
     register int i = 0;
     int retval = -1;
 
@@ -1527,10 +1547,10 @@ int *arglast;
      */
     while (items--) {
        if (st[++sp]->str_nok || !i)
-           arg[i++] = (long)str_gnum(st[sp]);
+           arg[i++] = (unsigned long)str_gnum(st[sp]);
 #ifndef lint
        else
-           arg[i++] = (long)st[sp]->str_ptr;
+           arg[i++] = (unsigned long)st[sp]->str_ptr;
 #endif /* lint */
     }
     sp = arglast[1];
diff --git a/doio.c b/doio.c
index 0477b0b..e93c305 100644 (file)
--- a/doio.c
+++ b/doio.c
@@ -1,11 +1,19 @@
-/* $RCSfile: doio.c,v $$Revision: 4.0.1.1 $$Date: 91/04/11 17:41:06 $
+/* $RCSfile: doio.c,v $$Revision: 4.0.1.2 $$Date: 91/06/07 10:53:39 $
  *
- *    Copyright (c) 1989, Larry Wall
+ *    Copyright (c) 1991, Larry Wall
  *
- *    You may distribute under the terms of the GNU General Public License
- *    as specified in the README file that comes with the perl 3.0 kit.
+ *    You may distribute under the terms of either the GNU General Public
+ *    License or the Artistic License, as specified in the README file.
  *
  * $Log:       doio.c,v $
+ * Revision 4.0.1.2  91/06/07  10:53:39  lwall
+ * patch4: new copyright notice
+ * patch4: system fd's are now treated specially
+ * patch4: added $^F variable to specify maximum system fd, default 2
+ * patch4: character special files now opened with bidirectional stdio buffers
+ * patch4: taintchecks could improperly modify parent in vfork()
+ * patch4: many, many itty-bitty portability fixes
+ * 
  * Revision 4.0.1.1  91/04/11  17:41:06  lwall
  * patch1: hopefully straightened out some of the Xenix mess
  * 
@@ -75,6 +83,9 @@ int len;
     int fd;
     int writing = 0;
     char mode[3];              /* stdio file mode ("r\0" or "r+\0") */
+    FILE *saveifp = Nullfp;
+    FILE *saveofp = Nullfp;
+    char savetype = ' ';
 
     name = myname;
     forkprocess = 1;           /* assume true if no fork */
@@ -84,10 +95,16 @@ int len;
        stio = stab_io(stab) = stio_new();
     else if (stio->ifp) {
        fd = fileno(stio->ifp);
-       if (stio->type == '|')
-           result = mypclose(stio->ifp);
-       else if (stio->type == '-')
+       if (stio->type == '-')
            result = 0;
+       else if (fd <= maxsysfd) {
+           saveifp = stio->ifp;
+           saveofp = stio->ofp;
+           savetype = stio->type;
+           result = 0;
+       }
+       else if (stio->type == '|')
+           result = mypclose(stio->ifp);
        else if (stio->ifp != stio->ofp) {
            if (stio->ofp) {
                result = fclose(stio->ofp);
@@ -98,7 +115,7 @@ int len;
        }
        else
            result = fclose(stio->ifp);
-       if (result == EOF && fd > 2)
+       if (result == EOF && fd > maxsysfd)
            fprintf(stderr,"Warning: unable to close filehandle %s properly.\n",
              stab_name(stab));
        stio->ofp = stio->ifp = Nullfp;
@@ -143,8 +160,12 @@ int len;
                fd = atoi(name);
            else {
                stab = stabent(name,FALSE);
-               if (!stab || !stab_io(stab))
-                   return FALSE;
+               if (!stab || !stab_io(stab)) {
+#ifdef EINVAL
+                   errno = EINVAL;
+#endif
+                   goto say_false;
+               }
                if (stab_io(stab) && stab_io(stab)->ifp) {
                    fd = fileno(stab_io(stab)->ifp);
                    if (stab_io(stab)->type == 's')
@@ -209,14 +230,14 @@ int len;
     }
     Safefree(myname);
     if (!fp)
-       return FALSE;
+       goto say_false;
     if (stio->type &&
       stio->type != '|' && stio->type != '-') {
        if (fstat(fileno(fp),&statbuf) < 0) {
            (void)fclose(fp);
-           return FALSE;
+           goto say_false;
        }
-       if (S_ISSOCK(statbuf.st_mode))
+       if (S_ISSOCK(statbuf.st_mode) || (S_ISCHR(statbuf.st_mode) && writing))
            stio->type = 's';   /* in case a socket was passed in to us */
 #ifdef S_IFMT
        else if (!(statbuf.st_mode & S_IFMT))
@@ -225,8 +246,23 @@ int len;
     }
 #if defined(HAS_FCNTL) && defined(F_SETFD)
     fd = fileno(fp);
-    fcntl(fd,F_SETFD,fd >= 3);
-#endif
+    fcntl(fd,F_SETFD,fd > maxsysfd);
+#endif
+    if (saveifp) {             /* must use old fp? */
+       fd = fileno(saveifp);
+       if (saveofp) {
+           fflush(saveofp);            /* emulate fclose() */
+           if (saveofp != saveifp) {   /* was a socket? */
+               fclose(saveofp);
+               Safefree(saveofp);
+           }
+       }
+       if (fd != fileno(fp)) {
+           dup2(fileno(fp), fd);
+           fclose(fp);
+       }
+       fp = saveifp;
+    }
     stio->ifp = fp;
     if (writing) {
        if (stio->type != 's')
@@ -235,9 +271,16 @@ int len;
            if (!(stio->ofp = fdopen(fileno(fp),"w"))) {
                fclose(fp);
                stio->ifp = Nullfp;
+               goto say_false;
            }
     }
     return TRUE;
+
+say_false:
+    stio->ifp = saveifp;
+    stio->ofp = saveofp;
+    stio->type = savetype;
+    return FALSE;
 }
 
 FILE *
@@ -1173,11 +1216,6 @@ char *cmd;
     register char *s;
     char flags[10];
 
-#ifdef TAINT
-    taintenv();
-    taintproper("Insecure dependency in exec");
-#endif
-
     /* save an extra exec if possible */
 
 #ifdef CSH
@@ -1400,7 +1438,7 @@ STAB *gstab;
     else if (nstio->ifp)
        do_close(nstab,FALSE);
 
-    fd = accept(fileno(gstio->ifp),buf,&len);
+    fd = accept(fileno(gstio->ifp),(struct sockaddr *)buf,&len);
     if (fd < 0)
        goto badexit;
     nstio->ifp = fdopen(fd, "r");
@@ -2142,18 +2180,20 @@ int *arglast;
 #ifndef telldir
     long telldir();
 #endif
+#ifndef apollo
     struct DIRENT *readdir();
+#endif
     register struct DIRENT *dp;
 
     if (!stab)
        goto nope;
     if (!(stio = stab_io(stab)))
        stio = stab_io(stab) = stio_new();
-    if (!stio->dirp && optype != O_OPENDIR)
+    if (!stio->dirp && optype != O_OPEN_DIR)
        goto nope;
     st[sp] = &str_yes;
     switch (optype) {
-    case O_OPENDIR:
+    case O_OPEN_DIR:
        if (stio->dirp)
            closedir(stio->dirp);
        if (!(stio->dirp = opendir(str_get(st[sp+1]))))
@@ -2522,11 +2562,9 @@ int *arglast;
            if (semctl(id, 0, IPC_STAT, &semds) == -1)
                return -1;
            getinfo = (cmd == GETALL);
-#ifdef _POSIX_SOURCE
-           infosize = semds.sem_nsems * sizeof(ushort_t);
-#else
-           infosize = semds.sem_nsems * sizeof(ushort);
-#endif
+           infosize = semds.sem_nsems * sizeof(short);
+               /* "short" is technically wrong but much more portable
+                  than guessing about u_?short(_t)? */
        }
        break;
 #endif
@@ -2665,7 +2703,7 @@ int *arglast;
        return -1;
     }
     errno = 0;
-    return semop(id, opbuf, opsize/sizeof(struct sembuf));
+    return semop(id, (struct sembuf *)opbuf, opsize/sizeof(struct sembuf));
 #else
     fatal("semop not implemented");
 #endif
@@ -2683,7 +2721,9 @@ int *arglast;
     char *mbuf, *shm;
     int id, mpos, msize;
     struct shmid_ds shmds;
+#ifndef VOIDSHMAT
     extern char *shmat();
+#endif
 
     id = (int)str_gnum(st[++sp]);
     mstr = st[++sp];
@@ -2696,7 +2736,7 @@ int *arglast;
        errno = EFAULT;         /* can't do as caller requested */
        return -1;
     }
-    shm = shmat(id, (char *)NULL, (optype == O_SHMREAD) ? SHM_RDONLY : 0);
+    shm = (char*)shmat(id, (char*)NULL, (optype == O_SHMREAD) ? SHM_RDONLY : 0);
     if (shm == (char *)-1)     /* I hate System V IPC, I really do */
        return -1;
     mbuf = str_get(mstr);
index 6461b7d..c1f4ed5 100644 (file)
--- a/dolist.c
+++ b/dolist.c
@@ -1,11 +1,19 @@
-/* $Header: dolist.c,v 4.0 91/03/20 01:08:03 lwall Locked $
+/* $RCSfile: dolist.c,v $$Revision: 4.0.1.1 $$Date: 91/06/07 10:58:28 $
  *
- *    Copyright (c) 1989, Larry Wall
+ *    Copyright (c) 1991, Larry Wall
  *
- *    You may distribute under the terms of the GNU General Public License
- *    as specified in the README file that comes with the perl 3.0 kit.
+ *    You may distribute under the terms of either the GNU General Public
+ *    License or the Artistic License, as specified in the README file.
  *
  * $Log:       dolist.c,v $
+ * Revision 4.0.1.1  91/06/07  10:58:28  lwall
+ * patch4: new copyright notice
+ * patch4: added global modifier for pattern matches
+ * patch4: // wouldn't use previous pattern if it started with a null character
+ * patch4: //o and s///o now optimize themselves fully at runtime
+ * patch4: $` was busted inside s///
+ * patch4: caller($arg) didn't work except under debugger
+ * 
  * Revision 4.0  91/03/20  01:08:03  lwall
  * 4.0 baseline.
  * 
@@ -35,6 +43,8 @@ int *arglast;
     char *strend = s + st[sp]->str_cur;
     STR *tmpstr;
     char *myhint = hint;
+    int global;
+    int safebase;
 
     hint = Nullch;
     if (!spat) {
@@ -45,6 +55,8 @@ int *arglast;
        st[sp] = str;
        return sp;
     }
+    global = spat->spat_flags & SPAT_GLOBAL;
+    safebase = (gimme == G_ARRAY) || global;
     if (!s)
        fatal("panic: do_match");
     if (spat->spat_flags & SPAT_USED) {
@@ -76,19 +88,30 @@ int *arglast;
        }
        spat->spat_regexp = regcomp(t,t+tmpstr->str_cur,
            spat->spat_flags & SPAT_FOLD);
-       if (!*spat->spat_regexp->precomp && lastspat)
+       if (!spat->spat_regexp->prelen && lastspat)
            spat = lastspat;
        if (spat->spat_flags & SPAT_KEEP) {
            if (spat->spat_runtime)
                arg_free(spat->spat_runtime);   /* it won't change, so */
            spat->spat_runtime = Nullarg;       /* no point compiling again */
+           scanconst(spat, t, tmpstr->str_cur);
+           hoistmust(spat);
+           if (curcmd->c_expr && (curcmd->c_flags & CF_OPTIMIZE) == CFT_EVAL) {
+               curcmd->c_flags &= ~CF_OPTIMIZE;
+               opt_arg(curcmd, 1, curcmd->c_type == C_EXPR);
+           }
+       }
+       if (global) {
+           if (spat->spat_regexp->startp[0]) {
+               s = spat->spat_regexp->endp[0];
+           }
        }
-       if (!spat->spat_regexp->nparens)
+       else if (!spat->spat_regexp->nparens)
            gimme = G_SCALAR;                   /* accidental array context? */
        if (regexec(spat->spat_regexp, s, strend, s, 0,
          srchstr->str_pok & SP_STUDIED ? srchstr : Nullstr,
-         gimme == G_ARRAY)) {
-           if (spat->spat_regexp->subbase)
+         safebase)) {
+           if (spat->spat_regexp->subbase || global)
                curspat = spat;
            lastspat = spat;
            goto gotcha;
@@ -114,9 +137,12 @@ int *arglast;
            deb("2.SPAT %c%s%c\n",ch,spat->spat_regexp->precomp,ch);
        }
 #endif
-       if (!*spat->spat_regexp->precomp && lastspat)
+       if (!spat->spat_regexp->prelen && lastspat)
            spat = lastspat;
        t = s;
+    play_it_again:
+       if (global && spat->spat_regexp->startp[0])
+           s = spat->spat_regexp->endp[0];
        if (myhint) {
            if (myhint < s || myhint > strend)
                fatal("panic: hint in do_match");
@@ -163,12 +189,12 @@ int *arglast;
                spat->spat_short = Nullstr;     /* opt is being useless */
            }
        }
-       if (!spat->spat_regexp->nparens)
+       if (!spat->spat_regexp->nparens && !global)
            gimme = G_SCALAR;                   /* accidental array context? */
        if (regexec(spat->spat_regexp, s, strend, t, 0,
          srchstr->str_pok & SP_STUDIED ? srchstr : Nullstr,
-         gimme == G_ARRAY)) {
-           if (spat->spat_regexp->subbase)
+         safebase)) {
+           if (spat->spat_regexp->subbase || global)
                curspat = spat;
            lastspat = spat;
            if (spat->spat_flags & SPAT_ONCE)
@@ -191,12 +217,16 @@ int *arglast;
        int iters, i, len;
 
        iters = spat->spat_regexp->nparens;
-       if (sp + iters >= stack->ary_max) {
-           astore(stack,sp + iters, Nullstr);
+       if (global && !iters)
+           i = 1;
+       else
+           i = 0;
+       if (sp + iters + i >= stack->ary_max) {
+           astore(stack,sp + iters + i, Nullstr);
            st = stack->ary_array;              /* possibly realloced */
        }
 
-       for (i = 1; i <= iters; i++) {
+       for (i = !i; i <= iters; i++) {
            st[++sp] = str_mortal(&str_no);
            if (s = spat->spat_regexp->startp[i]) {
                len = spat->spat_regexp->endp[i] - s;
@@ -204,6 +234,8 @@ int *arglast;
                    str_nset(st[sp],s,len);
            }
        }
+       if (global)
+           goto play_it_again;
        return sp;
     }
     else {
@@ -218,12 +250,19 @@ yup:
     lastspat = spat;
     if (spat->spat_flags & SPAT_ONCE)
        spat->spat_flags |= SPAT_USED;
+    if (global) {
+       spat->spat_regexp->startp[0] = s;
+       spat->spat_regexp->endp[0] = s + spat->spat_short->str_cur;
+       curspat = spat;
+       goto gotcha;
+    }
     if (sawampersand) {
        char *tmps;
 
        if (spat->spat_regexp->subbase)
            Safefree(spat->spat_regexp->subbase);
        tmps = spat->spat_regexp->subbase = nsavestr(t,strend-t);
+       spat->spat_regexp->subbeg = tmps;
        spat->spat_regexp->subend = tmps + (strend-t);
        tmps = spat->spat_regexp->startp[0] = tmps + (s - t);
        spat->spat_regexp->endp[0] = tmps + spat->spat_short->str_cur;
@@ -235,6 +274,7 @@ yup:
     return sp;
 
 nope:
+    spat->spat_regexp->startp[0] = Nullch;
     ++spat->spat_short->str_u.str_useful;
     if (gimme == G_ARRAY)
        return sp;
@@ -1592,7 +1632,10 @@ int *arglast;
       str_2mortal(str_nmake((double)csv->wantarray)) );
     if (csv->hasargs) {
        ARRAY *ary = csv->argarray;
+       STAB *tmpstab;
 
+       if (!dbargs)
+           dbargs = stab_xarray(aadd(stabent("DB'args", TRUE)));
        if (dbargs->ary_max < ary->ary_fill)
            astore(dbargs,ary->ary_fill,Nullstr);
        Copy(ary->ary_array, dbargs->ary_array, ary->ary_fill+1, STR*);
diff --git a/dump.c b/dump.c
index cd2048b..273e6cc 100644 (file)
--- a/dump.c
+++ b/dump.c
@@ -1,11 +1,14 @@
-/* $Header: dump.c,v 4.0 91/03/20 01:08:25 lwall Locked $
+/* $RCSfile: dump.c,v $$Revision: 4.0.1.1 $$Date: 91/06/07 10:58:44 $
  *
- *    Copyright (c) 1989, Larry Wall
+ *    Copyright (c) 1991, Larry Wall
  *
- *    You may distribute under the terms of the GNU General Public License
- *    as specified in the README file that comes with the perl 3.0 kit.
+ *    You may distribute under the terms of either the GNU General Public
+ *    License or the Artistic License, as specified in the README file.
  *
  * $Log:       dump.c,v $
+ * Revision 4.0.1.1  91/06/07  10:58:44  lwall
+ * patch4: new copyright notice
+ * 
  * Revision 4.0  91/03/20  01:08:25  lwall
  * 4.0 baseline.
  * 
diff --git a/eval.c b/eval.c
index 6185142..1b3c514 100644 (file)
--- a/eval.c
+++ b/eval.c
@@ -1,11 +1,20 @@
-/* $RCSfile: eval.c,v $$Revision: 4.0.1.1 $$Date: 91/04/11 17:43:48 $
+/* $RCSfile: eval.c,v $$Revision: 4.0.1.2 $$Date: 91/06/07 11:07:23 $
  *
- *    Copyright (c) 1989, Larry Wall
+ *    Copyright (c) 1991, Larry Wall
  *
- *    You may distribute under the terms of the GNU General Public License
- *    as specified in the README file that comes with the perl 3.0 kit.
+ *    You may distribute under the terms of either the GNU General Public
+ *    License or the Artistic License, as specified in the README file.
  *
  * $Log:       eval.c,v $
+ * Revision 4.0.1.2  91/06/07  11:07:23  lwall
+ * patch4: new copyright notice
+ * patch4: length($`), length($&), length($') now optimized to avoid string copy
+ * patch4: assignment wasn't correctly de-tainting the assigned variable.
+ * patch4: default top-of-form format is now FILEHANDLE_TOP
+ * patch4: added $^P variable to control calling of perldb routines
+ * patch4: taintchecks could improperly modify parent in vfork()
+ * patch4: many, many itty-bitty portability fixes
+ * 
  * Revision 4.0.1.1  91/04/11  17:43:48  lwall
  * patch1: fixed failed fork to return undef as documented
  * patch1: reduced maximum branch distance in eval.c
@@ -206,6 +215,16 @@ register int sp;
                (void)sprintf(buf,"STAB $%s",stab_name(argptr.arg_stab));
                tmps = buf;
            }
+#endif
+           break;
+       case A_LENSTAB:
+           str_numset(str, (double)STAB_LEN(argptr.arg_stab));
+           st[++sp] = str;
+#ifdef DEBUGGING
+           if (debug & 8) {
+               (void)sprintf(buf,"LENSTAB $%s",stab_name(argptr.arg_stab));
+               tmps = buf;
+           }
 #endif
            break;
        case A_LEXPR:
@@ -619,6 +638,10 @@ register int sp;
        goto array_return;
     case O_SASSIGN:
       sassign:
+#ifdef TAINT
+       if (tainted && !st[2]->str_tainted)
+           tainted = 0;
+#endif
        STR_SSET(str, st[2]);
        STABSET(str);
        break;
@@ -927,7 +950,7 @@ register int sp;
            break;
        }
        format(&outrec,form,sp);
-       do_write(&outrec,stab_io(stab),sp);
+       do_write(&outrec,stab,sp);
        if (stab_io(stab)->flags & IOF_FLUSH)
            (void)fflush(fp);
        str_set(str, Yes);
@@ -1087,7 +1110,7 @@ register int sp;
        else if (stab_hash(tmpstab)->tbl_dbm)
            str_magic(str, tmpstab, 'D', tmps, anum);
 #endif
-       else if (perldb && tmpstab == DBline)
+       else if (tmpstab == DBline)
            str_magic(str, tmpstab, 'L', tmps, anum);
        break;
     case O_LSLICE:
@@ -1961,6 +1984,11 @@ register int sp;
        else if (arglast[2] - arglast[1] != 1)
            value = (double)do_aexec(Nullstr,arglast);
        else {
+#ifdef TAINT
+           taintenv();
+           tainted |= st[2]->str_tainted;
+           taintproper("Insecure dependency in exec");
+#endif
            value = (double)do_exec(str_get(str_mortal(st[2])));
        }
        goto donumset;
@@ -2260,7 +2288,13 @@ donumset:
            anum = 0;
        else
            anum = (int)str_gnum(st[1]);
+#ifdef _POSIX_SOURCE
+       if (anum != 0)
+           fatal("POSIX getpgrp can't take an argument");
+       value = (double)getpgrp();
+#else
        value = (double)getpgrp(anum);
+#endif
        goto donumset;
 #else
        fatal("The getpgrp() function is unimplemented on this machine");
@@ -2852,7 +2886,7 @@ donumset:
        fatal("Unsupported function getlogin");
 #endif
        break;
-    case O_OPENDIR:
+    case O_OPEN_DIR:
     case O_READDIR:
     case O_TELLDIR:
     case O_SEEKDIR:
diff --git a/form.c b/form.c
index 652eceb..27835fe 100644 (file)
--- a/form.c
+++ b/form.c
@@ -1,11 +1,15 @@
-/* $Header: form.c,v 4.0 91/03/20 01:19:23 lwall Locked $
+/* $RCSfile: form.c,v $$Revision: 4.0.1.1 $$Date: 91/06/07 11:07:59 $
  *
- *    Copyright (c) 1989, Larry Wall
+ *    Copyright (c) 1991, Larry Wall
  *
- *    You may distribute under the terms of the GNU General Public License
- *    as specified in the README file that comes with the perl 3.0 kit.
+ *    You may distribute under the terms of either the GNU General Public
+ *    License or the Artistic License, as specified in the README file.
  *
  * $Log:       form.c,v $
+ * Revision 4.0.1.1  91/06/07  11:07:59  lwall
+ * patch4: new copyright notice
+ * patch4: default top-of-form format is now FILEHANDLE_TOP
+ * 
  * Revision 4.0  91/03/20  01:19:23  lwall
  * 4.0 baseline.
  * 
@@ -325,11 +329,12 @@ register int size;
     return count;
 }
 
-do_write(orec,stio,sp)
+do_write(orec,stab,sp)
 struct outrec *orec;
-register STIO *stio;
+STAB *stab;
 int sp;
 {
+    register STIO *stio = stab_io(stab);
     FILE *ofp = stio->ofp;
 
 #ifdef DEBUGGING
@@ -340,9 +345,18 @@ int sp;
     if (stio->lines_left < orec->o_lines) {
        if (!stio->top_stab) {
            STAB *topstab;
+           char tmpbuf[256];
 
-           if (!stio->top_name)
-               stio->top_name = savestr("top");
+           if (!stio->top_name) {
+               if (!stio->fmt_name)
+                   stio->fmt_name = savestr(stab_name(stab));
+               sprintf(tmpbuf, "%s_TOP", stio->fmt_name);
+               topstab = stabent(tmpbuf,FALSE);
+               if (topstab && stab_form(topstab))
+                   stio->top_name = savestr(tmpbuf);
+               else
+                   stio->top_name = savestr("top");
+           }
            topstab = stabent(stio->top_name,FALSE);
            if (!topstab || !stab_form(topstab)) {
                stio->lines_left = 100000000;
diff --git a/form.h b/form.h
index 202fa2e..8be33e1 100644 (file)
--- a/form.h
+++ b/form.h
@@ -1,11 +1,14 @@
-/* $Header: form.h,v 4.0 91/03/20 01:19:37 lwall Locked $
+/* $RCSfile: form.h,v $$Revision: 4.0.1.1 $$Date: 91/06/07 11:08:20 $
  *
- *    Copyright (c) 1989, Larry Wall
+ *    Copyright (c) 1991, Larry Wall
  *
- *    You may distribute under the terms of the GNU General Public License
- *    as specified in the README file that comes with the perl 3.0 kit.
+ *    You may distribute under the terms of either the GNU General Public
+ *    License or the Artistic License, as specified in the README file.
  *
  * $Log:       form.h,v $
+ * Revision 4.0.1.1  91/06/07  11:08:20  lwall
+ * patch4: new copyright notice
+ * 
  * Revision 4.0  91/03/20  01:19:37  lwall
  * 4.0 baseline.
  * 
index b7d4a0d..403fffa 100644 (file)
@@ -3,7 +3,7 @@
 open (IOCTLS,'/usr/include/sys/ioctl.h') || die "ioctl open failed";
 
 while (<IOCTLS>) {
-    if (/^\s*#\s*define\s+\w+\s+_IO(R|W|WR)\(\w+,\s*\w+,\s*([^)]+)/) {
+    if (/^\s*#\s*define\s+\w+\s+_IO(R|W|WR)\('?\w+'?,\s*\w+,\s*([^)]+)/) {
        $need{$2}++;
     } 
 }
diff --git a/handy.h b/handy.h
index 0c9edaa..da31d7a 100644 (file)
--- a/handy.h
+++ b/handy.h
@@ -1,11 +1,14 @@
-/* $Header: handy.h,v 4.0 91/03/20 01:22:15 lwall Locked $
+/* $RCSfile: handy.h,v $$Revision: 4.0.1.1 $$Date: 91/06/07 11:09:56 $
  *
- *    Copyright (c) 1989, Larry Wall
+ *    Copyright (c) 1991, Larry Wall
  *
- *    You may distribute under the terms of the GNU General Public License
- *    as specified in the README file that comes with the perl 3.0 kit.
+ *    You may distribute under the terms of either the GNU General Public
+ *    License or the Artistic License, as specified in the README file.
  *
  * $Log:       handy.h,v $
+ * Revision 4.0.1.1  91/06/07  11:09:56  lwall
+ * patch4: new copyright notice
+ * 
  * Revision 4.0  91/03/20  01:22:15  lwall
  * 4.0 baseline.
  * 
diff --git a/hash.c b/hash.c
index 887ece7..52547dd 100644 (file)
--- a/hash.c
+++ b/hash.c
@@ -1,11 +1,14 @@
-/* $Header: hash.c,v 4.0 91/03/20 01:22:26 lwall Locked $
+/* $RCSfile: hash.c,v $$Revision: 4.0.1.1 $$Date: 91/06/07 11:10:11 $
  *
- *    Copyright (c) 1989, Larry Wall
+ *    Copyright (c) 1991, Larry Wall
  *
- *    You may distribute under the terms of the GNU General Public License
- *    as specified in the README file that comes with the perl 3.0 kit.
+ *    You may distribute under the terms of either the GNU General Public
+ *    License or the Artistic License, as specified in the README file.
  *
  * $Log:       hash.c,v $
+ * Revision 4.0.1.1  91/06/07  11:10:11  lwall
+ * patch4: new copyright notice
+ * 
  * Revision 4.0  91/03/20  01:22:26  lwall
  * 4.0 baseline.
  * 
diff --git a/lib/find.pl b/lib/find.pl
new file mode 100644 (file)
index 0000000..b853d12
--- /dev/null
@@ -0,0 +1,105 @@
+# Usage:
+#      require "find.pl";
+#
+#      &find('/foo','/bar');
+#
+#      sub wanted { ... }
+#              where wanted does whatever you want.  $dir contains the
+#              current directory name, and $_ the current filename within
+#              that directory.  $name contains "$dir/$_".  You are cd'ed
+#              to $dir when the function is called.  The function may
+#              set $prune to prune the tree.
+#
+# This library is primarily for find2perl, which, when fed
+#
+#   find2perl / -name .nfs\* -mtime +7 -exec rm -f {} \; -o -fstype nfs -prune
+#
+# spits out something like this
+#
+#      sub wanted {
+#          /^\.nfs.*$/ &&
+#          (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_)) &&
+#          int(-M _) > 7 &&
+#          unlink($_)
+#          ||
+#          ($nlink || (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_))) &&
+#          $dev < 0 &&
+#          ($prune = 1);
+#      }
+
+sub find {
+    chop($cwd = `pwd`);
+    foreach $topdir (@_) {
+       (($topdev,$topino,$topmode,$topnlink) = stat($topdir))
+         || (warn("Can't stat $topdir: $!\n"), next);
+       if (-d _) {
+           if (chdir($topdir)) {
+               ($dir,$_) = ($topdir,'.');
+               $name = $topdir;
+               &wanted;
+               $topdir =~ s,/$,, ;
+               &finddir($topdir,$topnlink);
+           }
+           else {
+               warn "Can't cd to $topdir: $!\n";
+           }
+       }
+       else {
+           unless (($dir,$_) = $topdir =~ m#^(.*/)(.*)$#) {
+               ($dir,$_) = ('.', $topdir);
+           }
+           chdir $dir && &wanted;
+       }
+       chdir $cwd;
+    }
+}
+
+sub finddir {
+    local($dir,$nlink) = @_;
+    local($dev,$ino,$mode,$subcount);
+    local($name);
+
+    # Get the list of files in the current directory.
+
+    opendir(DIR,'.') || warn "Can't open $dir: $!\n";
+    local(@filenames) = readdir(DIR);
+    closedir(DIR);
+
+    if ($nlink == 2) {        # This dir has no subdirectories.
+       for (@filenames) {
+           next if $_ eq '.';
+           next if $_ eq '..';
+           $name = "$dir/$_";
+           $nlink = 0;
+           &wanted;
+       }
+    }
+    else {                    # This dir has subdirectories.
+       $subcount = $nlink - 2;
+       for (@filenames) {
+           next if $_ eq '.';
+           next if $_ eq '..';
+           $nlink = $prune = 0;
+           $name = "$dir/$_";
+           &wanted;
+           if ($subcount > 0) {    # Seen all the subdirs?
+
+               # Get link count and check for directoriness.
+
+               ($dev,$ino,$mode,$nlink) = lstat($_) unless $nlink;
+               
+               if (-d _) {
+
+                   # It really is a directory, so do it recursively.
+
+                   if (!$prune && chdir $_) {
+                       &finddir($name,$nlink);
+                       chdir '..';
+                   }
+                   --$subcount;
+               }
+           }
+       }
+    }
+}
+1;
diff --git a/lib/finddepth.pl b/lib/finddepth.pl
new file mode 100644 (file)
index 0000000..15e4daf
--- /dev/null
@@ -0,0 +1,105 @@
+# Usage:
+#      require "finddepth.pl";
+#
+#      &finddepth('/foo','/bar');
+#
+#      sub wanted { ... }
+#              where wanted does whatever you want.  $dir contains the
+#              current directory name, and $_ the current filename within
+#              that directory.  $name contains "$dir/$_".  You are cd'ed
+#              to $dir when the function is called.  The function may
+#              set $prune to prune the tree.
+#
+# This library is primarily for find2perl, which, when fed
+#
+#   find2perl / -name .nfs\* -mtime +7 -exec rm -f {} \; -o -fstype nfs -prune
+#
+# spits out something like this
+#
+#      sub wanted {
+#          /^\.nfs.*$/ &&
+#          (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_)) &&
+#          int(-M _) > 7 &&
+#          unlink($_)
+#          ||
+#          ($nlink || (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_))) &&
+#          $dev < 0 &&
+#          ($prune = 1);
+#      }
+
+sub finddepth {
+    chop($cwd = `pwd`);
+    foreach $topdir (@_) {
+       (($topdev,$topino,$topmode,$topnlink) = stat($topdir))
+         || (warn("Can't stat $topdir: $!\n"), next);
+       if (-d _) {
+           if (chdir($topdir)) {
+               $topdir =~ s,/$,, ;
+               &finddepthdir($topdir,$topnlink);
+               ($dir,$_) = ($topdir,'.');
+               $name = $topdir;
+               &wanted;
+           }
+           else {
+               warn "Can't cd to $topdir: $!\n";
+           }
+       }
+       else {
+           unless (($dir,$_) = $topdir =~ m#^(.*/)(.*)$#) {
+               ($dir,$_) = ('.', $topdir);
+           }
+           chdir $dir && &wanted;
+       }
+       chdir $cwd;
+    }
+}
+
+sub finddepthdir {
+    local($dir,$nlink) = @_;
+    local($dev,$ino,$mode,$subcount);
+    local($name);
+
+    # Get the list of files in the current directory.
+
+    opendir(DIR,'.') || warn "Can't open $dir: $!\n";
+    local(@filenames) = readdir(DIR);
+    closedir(DIR);
+
+    if ($nlink == 2) {        # This dir has no subdirectories.
+       for (@filenames) {
+           next if $_ eq '.';
+           next if $_ eq '..';
+           $name = "$dir/$_";
+           $nlink = 0;
+           &wanted;
+       }
+    }
+    else {                    # This dir has subdirectories.
+       $subcount = $nlink - 2;
+       for (@filenames) {
+           next if $_ eq '.';
+           next if $_ eq '..';
+           $nlink = $prune = 0;
+           $name = "$dir/$_";
+           if ($subcount > 0) {    # Seen all the subdirs?
+
+               # Get link count and check for directoriness.
+
+               ($dev,$ino,$mode,$nlink) = lstat($_) unless $nlink;
+               
+               if (-d _) {
+
+                   # It really is a directory, so do it recursively.
+
+                   if (!$prune && chdir $_) {
+                       &finddepthdir($name,$nlink);
+                       chdir '..';
+                   }
+                   --$subcount;
+               }
+           }
+           &wanted;
+       }
+    }
+}
+1;
index d753637..1395f81 100644 (file)
@@ -1,11 +1,14 @@
-/* $Header: dir.h,v 4.0 91/03/20 01:34:20 lwall Locked $
+/* $RCSfile: dir.h,v $$Revision: 4.0.1.1 $$Date: 91/06/07 11:22:10 $
  *
  *    (C) Copyright 1987, 1990 Diomidis Spinellis.
  *
- *    You may distribute under the terms of the GNU General Public License
- *    as specified in the README file that comes with the perl 3.0 kit.
+ *    You may distribute under the terms of either the GNU General Public
+ *    License or the Artistic License, as specified in the README file.
  *
  * $Log:       dir.h,v $
+ * Revision 4.0.1.1  91/06/07  11:22:10  lwall
+ * patch4: new copyright notice
+ * 
  * Revision 4.0  91/03/20  01:34:20  lwall
  * 4.0 baseline.
  * 
index cc469d0..802614b 100644 (file)
@@ -1,11 +1,14 @@
-/* $Header: directory.c,v 4.0 91/03/20 01:34:24 lwall Locked $
+/* $RCSfile: directory.c,v $$Revision: 4.0.1.1 $$Date: 91/06/07 11:22:24 $
  *
  *    (C) Copyright 1987, 1988, 1990 Diomidis Spinellis.
  *
- *    You may distribute under the terms of the GNU General Public License
- *    as specified in the README file that comes with the perl 3.0 kit.
+ *    You may distribute under the terms of either the GNU General Public
+ *    License or the Artistic License, as specified in the README file.
  *
  * $Log:       directory.c,v $
+ * Revision 4.0.1.1  91/06/07  11:22:24  lwall
+ * patch4: new copyright notice
+ * 
  * Revision 4.0  91/03/20  01:34:24  lwall
  * 4.0 baseline.
  * 
@@ -44,7 +47,7 @@
 #define PATHLEN 65
 
 #ifndef lint
-static char rcsid[] = "$Header: directory.c,v 4.0 91/03/20 01:34:24 lwall Locked $";
+static char rcsid[] = "$RCSfile: directory.c,v $$Revision: 4.0.1.1 $$Date: 91/06/07 11:22:24 $";
 #endif
 
 DIR *
index 51d80f3..fb8ed65 100644 (file)
@@ -1 +1 @@
-#define PATCHLEVEL 5
+#define PATCHLEVEL 6
index 73ec3a0..f8cb4ca 100644 (file)
@@ -9,10 +9,16 @@ print "1..1\n";
 
 for (split(' ', $()) {
     next if $seen{$_}++;
-    push(@gr, (getgrgid($_))[0]); 
+    ($group) = getgrgid($_);
+    if (defined $group) {
+       push(@gr, $group);
+    }
+    else {
+       push(@gr, $_);
+    }
 } 
 $gr1 = join(' ',sort @gr);
-$gr2 = join(' ', sort split(' ',`groups`));
+$gr2 = join(' ', sort split(' ',`/usr/ucb/groups`));
 #print "gr1 is <$gr1>\n";
 #print "gr2 is <$gr2>\n";
 print +($gr1 eq $gr2) ? "ok 1\n" : "not ok 1\n";
index f850247..9161f7b 100644 (file)
@@ -128,11 +128,25 @@ while (@ARGV) {
     elsif ($_ eq 'exec') {
        for (@cmd = (); @ARGV && $ARGV[0] ne ';'; push(@cmd,shift)) { }
        shift;
-       for (@cmd) { s/'/\\'/g; }
-       $" = "','";
-       $out .= &tab . "&exec(0, '@cmd')";
-       $" = ' ';
-       $initexec++;
+       $_ = "@cmd";
+       if (m#^(/bin/)?rm -f {}$#) {
+           if (!@ARGV) {
+               $out .= &tab . 'unlink($_)';
+           }
+           else {
+               $out .= &tab . '(unlink($_) || 1)';
+           }
+       }
+       elsif (m#^(/bin/)?rm {}$#) {
+           $out .= &tab . '(unlink($_) || warn "$name: $!\n")';
+       }
+       else {
+           for (@cmd) { s/'/\\'/g; }
+           $" = "','";
+           $out .= &tab . "&exec(0, '@cmd')";
+           $" = ' ';
+           $initexec++;
+       }
     }
     elsif ($_ eq 'ok') {
        for (@cmd = (); @ARGV && $ARGV[0] ne ';'; push(@cmd,shift)) { }
@@ -202,9 +216,9 @@ while (@ARGV) {
     }
     if (@ARGV) {
        if ($ARGV[0] eq '-o') {
+           { local($statdone) = 1; $out .= "\n" . &tab . "||\n"; }
            $statdone = 0 if $indent == 1 && $delayedstat;
            $saw_or++;
-           $out .= "\n" . &tab . "||\n";
            shift;
        }
        else {
@@ -246,10 +260,13 @@ print $initnewer, "\n" if $initnewer;
 
 print $initfile, "\n" if $initfile;
 
+$find = $depth ? "finddepth" : "find";
 print <<"END";
+require "$find.pl";
+
 # Traverse desired filesystems
 
-&dodirs($roots);
+&$find($roots);
 $flushall
 exit;
 
@@ -259,109 +276,6 @@ $out;
 
 END
 
-print <<'END';
-sub dodirs {
-    chop($cwd = `pwd`);
-    foreach $topdir (@_) {
-       (($topdev,$topino,$topmode,$topnlink) = stat($topdir))
-         || (warn("Can't stat $topdir: $!\n"), next);
-       if (-d _) {
-           if (chdir($topdir)) {
-END
-if ($depth) {
-    print <<'END';
-               $topdir = '' if $topdir eq '/';
-               &dodir($topdir,$topnlink);
-               ($dir,$_) = ($topdir,'.');
-               $name = $topdir;
-               &wanted;
-END
-}
-else {
-    print <<'END';
-               ($dir,$_) = ($topdir,'.');
-               $name = $topdir;
-               &wanted;
-               $topdir = '' if $topdir eq '/';
-               &dodir($topdir,$topnlink);
-END
-}
-print <<'END';
-           }
-           else {
-               warn "Can't cd to $topdir: $!\n";
-           }
-       }
-       else {
-           unless (($dir,$_) = $topdir =~ m#^(.*/)(.*)$#) {
-               ($dir,$_) = ('.', $topdir);
-           }
-           chdir $dir && &wanted;
-       }
-       chdir $cwd;
-    }
-}
-
-sub dodir {
-    local($dir,$nlink) = @_;
-    local($dev,$ino,$mode,$subcount);
-    local($name);
-
-    # Get the list of files in the current directory.
-
-    opendir(DIR,'.') || warn "Can't open $dir: $!\n";
-    local(@filenames) = readdir(DIR);
-    closedir(DIR);
-
-    if ($nlink == 2) {        # This dir has no subdirectories.
-       for (@filenames) {
-           next if $_ eq '.';
-           next if $_ eq '..';
-           $name = "$dir/$_";
-           $nlink = 0;
-           &wanted;
-       }
-    }
-    else {                    # This dir has subdirectories.
-       $subcount = $nlink - 2;
-       for (@filenames) {
-           next if $_ eq '.';
-           next if $_ eq '..';
-           $nlink = $prune = 0;
-           $name = "$dir/$_";
-END
-print <<'END' unless $depth;
-           &wanted;
-END
-print <<'END';
-           if ($subcount > 0) {    # Seen all the subdirs?
-
-               # Get link count and check for directoriness.
-
-               ($dev,$ino,$mode,$nlink) = lstat($_) unless $nlink;
-               
-               if (-d _) {
-
-                   # It really is a directory, so do it recursively.
-
-                   if (!$prune && chdir $_) {
-                       &dodir($name,$nlink);
-                       chdir '..';
-                   }
-                   --$subcount;
-               }
-           }
-END
-print <<'END' if $depth;
-           &wanted;
-END
-print <<'END';
-       }
-    }
-}
-
-END
-
 if ($initexec) {
     print <<'END';
 sub exec {
index e50cbc3..25a1bda 100644 (file)
@@ -1,11 +1,14 @@
-/* $RCSfile: handy.h,v $$Revision: 4.0.1.1 $$Date: 91/04/12 09:29:08 $
+/* $RCSfile: handy.h,v $$Revision: 4.0.1.2 $$Date: 91/06/07 12:15:43 $
  *
- *    Copyright (c) 1989, Larry Wall
+ *    Copyright (c) 1991, Larry Wall
  *
- *    You may distribute under the terms of the GNU General Public License
- *    as specified in the README file that comes with the perl 3.0 kit.
+ *    You may distribute under the terms of either the GNU General Public
+ *    License or the Artistic License, as specified in the README file.
  *
  * $Log:       handy.h,v $
+ * Revision 4.0.1.2  91/06/07  12:15:43  lwall
+ * patch4: new copyright notice
+ * 
  * Revision 4.0.1.1  91/04/12  09:29:08  lwall
  * patch1: random cleanup in cpp namespace
  *