This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
perl 3.0 patch #36 patch #29, continued
authorLarry Wall <lwall@jpl-devvax.jpl.nasa.gov>
Mon, 15 Oct 1990 23:07:21 +0000 (23:07 +0000)
committerLarry Wall <lwall@jpl-devvax.jpl.nasa.gov>
Mon, 15 Oct 1990 23:07:21 +0000 (23:07 +0000)
See patch #29.

doarg.c
patchlevel.h
perly.c
usersub.c
util.c
x2p/util.c
x2p/walk.c

diff --git a/doarg.c b/doarg.c
index 151bcb4..768c6c3 100644 (file)
--- a/doarg.c
+++ b/doarg.c
@@ -1,4 +1,4 @@
-/* $Header: doarg.c,v 3.0.1.7 90/08/13 22:14:15 lwall Locked $
+/* $Header: doarg.c,v 3.0.1.8 90/10/15 16:04:04 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:       doarg.c,v $
+ * Revision 3.0.1.8  90/10/15  16:04:04  lwall
+ * patch29: @ENV = () now works
+ * patch29: added caller
+ * patch29: tr/// now understands c, d and s options, and handles nulls right
+ * patch29: *foo now prints as *package'foo
+ * patch29: added caller
+ * patch29: local() without initialization now creates undefined values
+ * 
  * Revision 3.0.1.7  90/08/13  22:14:15  lwall
  * patch28: the NSIG hack didn't work on Xenix
  * patch28: defined(@array) and defined(%array) didn't work right
@@ -59,7 +67,7 @@
 
 extern unsigned char fold[];
 
-int wantarray;
+extern char **environ;
 
 #ifdef BUGGY_MSC
  #pragma function(memcmp)
@@ -320,15 +328,17 @@ nope:
 int
 do_trans(str,arg)
 STR *str;
-register ARG *arg;
+ARG *arg;
 {
-    register char *tbl;
+    register short *tbl;
     register char *s;
     register int matches = 0;
     register int ch;
     register char *send;
+    register char *d;
+    register int squash = arg[2].arg_len & 1;
 
-    tbl = arg[2].arg_ptr.arg_cval;
+    tbl = (short*) arg[2].arg_ptr.arg_cval;
     s = str_get(str);
     send = s + str->str_cur;
     if (!tbl || !s)
@@ -338,12 +348,36 @@ register ARG *arg;
        deb("2.TBL\n");
     }
 #endif
-    while (s < send) {
-       if (ch = tbl[*s & 0377]) {
-           matches++;
-           *s = ch;
+    if (!arg[2].arg_len) {
+       while (s < send) {
+           if ((ch = tbl[*s & 0377]) >= 0) {
+               matches++;
+               *s = ch;
+           }
+           s++;
+       }
+    }
+    else {
+       d = s;
+       while (s < send) {
+           if ((ch = tbl[*s & 0377]) >= 0) {
+               *d = ch;
+               if (matches++ && squash) {
+                   if (d[-1] == *d)
+                       matches--;
+                   else
+                       d++;
+               }
+               else
+                   d++;
+           }
+           else if (ch == -1)          /* -1 is unmapped character */
+               *d++ = *s;              /* -2 is delete character */
+           s++;
        }
-       s++;
+       matches += send - d;    /* account for disappeared chars */
+       *d = '\0';
+       str->str_cur = d - str->str_ptr;
     }
     STABSET(str);
     return matches;
@@ -713,10 +747,14 @@ register STR **sarg;
                xlen = (*sarg)->str_cur;
                if (*xs == 'S' && xs[1] == 't' && xs[2] == 'B'
                  && xlen == sizeof(STBP) && strlen(xs) < xlen) {
-                   xs = stab_name(((STAB*)(*sarg))); /* a stab value! */
-                   sprintf(tokenbuf,"*%s",xs); /* reformat to non-binary */
+                   STR *tmpstr = Str_new(24,0);
+
+                   stab_fullname(tmpstr, ((STAB*)(*sarg))); /* a stab value! */
+                   sprintf(tokenbuf,"*%s",tmpstr->str_ptr);
+                                       /* reformat to non-binary */
                    xs = tokenbuf;
                    xlen = strlen(tokenbuf);
+                   str_free(tmpstr);
                }
                if (strEQ(t-2,"%s")) {  /* some printfs fail on >128 chars */
                    *buf = '\0';
@@ -801,11 +839,12 @@ int *arglast;
     register int sp = arglast[1];
     register int items = arglast[2] - sp;
     register SUBR *sub;
-    ARRAY *savearray;
+    STR *str;
     STAB *stab;
-    char *oldfile = filename;
     int oldsave = savestack->ary_fill;
     int oldtmps_base = tmps_base;
+    int hasargs = ((arg[2].arg_type & A_MASK) != A_NULL);
+    register CSV *csv;
 
     if ((arg[1].arg_type & A_MASK) == A_WORD)
        stab = arg[1].arg_ptr.arg_stab;
@@ -819,115 +858,60 @@ int *arglast;
     }
     if (!stab)
        fatal("Undefined subroutine called");
-    saveint(&wantarray);
-    wantarray = gimme;
-    sub = stab_sub(stab);
-    if (!sub)
-       fatal("Undefined subroutine \"%s\" called", stab_name(stab));
-    if (sub->usersub) {
-       st[sp] = arg->arg_ptr.arg_str;
-       if ((arg[2].arg_type & A_MASK) == A_NULL)
-           items = 0;
-       return sub->usersub(sub->userindex,sp,items);
-    }
-    if ((arg[2].arg_type & A_MASK) != A_NULL) {
-       savearray = stab_xarray(defstab);
-       stab_xarray(defstab) = afake(defstab, items, &st[sp+1]);
+    if (arg->arg_type == O_DBSUBR) {
+       str = stab_val(DBsub);
+       saveitem(str);
+       stab_fullname(str,stab);
+       sub = stab_sub(DBsub);
+       if (!sub)
+           fatal("No DBsub routine");
     }
-    savelong(&sub->depth);
-    sub->depth++;
-    if (sub->depth >= 2) {     /* save temporaries on recursion? */
-       if (sub->depth == 100 && dowarn)
-           warn("Deep recursion on subroutine \"%s\"",stab_name(stab));
-       savelist(sub->tosave->ary_array,sub->tosave->ary_fill);
-    }
-    filename = sub->filename;
-    tmps_base = tmps_max;
-    sp = cmd_exec(sub->cmd,gimme,--sp);                /* so do it already */
-    st = stack->ary_array;
-
-    if ((arg[2].arg_type & A_MASK) != A_NULL) {
-       afree(stab_xarray(defstab));  /* put back old $_[] */
-       stab_xarray(defstab) = savearray;
-    }
-    filename = oldfile;
-    tmps_base = oldtmps_base;
-    if (savestack->ary_fill > oldsave) {
-       for (items = arglast[0] + 1; items <= sp; items++)
-           st[items] = str_static(st[items]);
-               /* in case restore wipes old str */
-       restorelist(oldsave);
-    }
-    return sp;
-}
-
-int
-do_dbsubr(arg,gimme,arglast)
-register ARG *arg;
-int gimme;
-int *arglast;
-{
-    register STR **st = stack->ary_array;
-    register int sp = arglast[1];
-    register int items = arglast[2] - sp;
-    register SUBR *sub;
-    ARRAY *savearray;
-    STR *str;
-    STAB *stab;
-    char *oldfile = filename;
-    int oldsave = savestack->ary_fill;
-    int oldtmps_base = tmps_base;
-
-    if ((arg[1].arg_type & A_MASK) == A_WORD)
-       stab = arg[1].arg_ptr.arg_stab;
     else {
-       STR *tmpstr = stab_val(arg[1].arg_ptr.arg_stab);
+       if (!(sub = stab_sub(stab))) {
+           STR *tmpstr = arg[0].arg_ptr.arg_str;
 
-       if (tmpstr)
-           stab = stabent(str_get(tmpstr),TRUE);
-       else
-           stab = Nullstab;
+           stab_fullname(tmpstr, stab);
+           fatal("Undefined subroutine \"%s\" called",tmpstr->str_ptr);
+       }
     }
-    if (!stab)
-       fatal("Undefined subroutine called");
-    saveint(&wantarray);
-    wantarray = gimme;
-/* begin differences */
-    str = stab_val(DBsub);
-    saveitem(str);
-    str_set(str,stab_name(stab));
-    sub = stab_sub(DBsub);
-    if (!sub)
-       fatal("No DBsub routine");
-/* end differences */
-    if ((arg[2].arg_type & A_MASK) != A_NULL) {
-       savearray = stab_xarray(defstab);
-       stab_xarray(defstab) = afake(defstab, items, &st[sp+1]);
+    str = Str_new(15, sizeof(CSV));
+    str->str_state = SS_SCSV;
+    (void)apush(savestack,str);
+    csv = (CSV*)str->str_ptr;
+    csv->sub = sub;
+    csv->stab = stab;
+    csv->curcsv = curcsv;
+    csv->curcmd = curcmd;
+    csv->depth = sub->depth;
+    csv->wantarray = gimme;
+    csv->hasargs = hasargs;
+    curcsv = csv;
+    if (sub->usersub) {
+       st[sp] = arg->arg_ptr.arg_str;
+       if (!hasargs)
+           items = 0;
+       return (*sub->usersub)(sub->userindex,sp,items);
+    }
+    if (hasargs) {
+       csv->savearray = stab_xarray(defstab);
+       csv->argarray = afake(defstab, items, &st[sp+1]);
+       stab_xarray(defstab) = csv->argarray;
     }
-    savelong(&sub->depth);
     sub->depth++;
     if (sub->depth >= 2) {     /* save temporaries on recursion? */
        if (sub->depth == 100 && dowarn)
            warn("Deep recursion on subroutine \"%s\"",stab_name(stab));
        savelist(sub->tosave->ary_array,sub->tosave->ary_fill);
     }
-    filename = sub->filename;
     tmps_base = tmps_max;
     sp = cmd_exec(sub->cmd,gimme, --sp);       /* so do it already */
     st = stack->ary_array;
 
-    if ((arg[2].arg_type & A_MASK) != A_NULL) {
-       afree(stab_xarray(defstab));  /* put back old $_[] */
-       stab_xarray(defstab) = savearray;
-    }
-    filename = oldfile;
     tmps_base = oldtmps_base;
-    if (savestack->ary_fill > oldsave) {
-       for (items = arglast[0] + 1; items <= sp; items++)
-           st[items] = str_static(st[items]);
-               /* in case restore wipes old str */
-       restorelist(oldsave);
-    }
+    for (items = arglast[0] + 1; items <= sp; items++)
+       st[items] = str_static(st[items]);
+           /* in case restore wipes old str */
+    restorelist(oldsave);
     return sp;
 }
 
@@ -992,12 +976,31 @@ int *arglast;
            else if (str->str_state == SS_HASH) {
                char *tmps;
                STR *tmpstr;
+               int magic = 0;
+               STAB *tmpstab = str->str_u.str_stab;
 
                if (makelocal)
                    hash = savehash(str->str_u.str_stab);
                else {
                    hash = stab_hash(str->str_u.str_stab);
-                   hclear(hash);
+                   if (tmpstab == envstab) {
+                       magic = 'E';
+                       environ[0] = Nullch;
+                   }
+                   else if (tmpstab == sigstab) {
+                       magic = 'S';
+#ifndef NSIG
+#define NSIG 32
+#endif
+                       for (i = 1; i < NSIG; i++)
+                           signal(i, SIG_DFL); /* crunch, crunch, crunch */
+                   }
+#ifdef SOME_DBM
+                   else if (hash->tbl_dbm)
+                       magic = 'D';
+#endif
+                   hclear(hash, magic == 'D'); /* wipe any dbm file too */
+
                }
                while (relem < lastrelem) {     /* gobble up all the rest */
                    if (*relem)
@@ -1010,6 +1013,10 @@ int *arglast;
                        str_sset(tmpstr,*relem);        /* value */
                    *(relem++) = tmpstr;
                    (void)hstore(hash,tmps,str->str_cur,tmpstr,0);
+                   if (magic) {
+                       str_magic(tmpstr, tmpstab, magic, tmps, str->str_cur);
+                       stabset(tmpstr->str_magic, tmpstr);
+                   }
                }
            }
            else
@@ -1023,7 +1030,7 @@ int *arglast;
                *(relem++) = str;
            }
            else {
-               str_nset(str, "", 0);
+               str_sset(str, &str_undef);
                if (gimme == G_ARRAY) {
                    i = ++lastrelem - firstrelem;
                    relem++;            /* tacky, I suppose */
@@ -1207,7 +1214,15 @@ int *arglast;
     }
     else if (type == O_HASH || type == O_LHASH) {
        stab = arg[1].arg_ptr.arg_stab;
-       (void)hfree(stab_xhash(stab));
+       if (stab == envstab)
+           environ[0] = Nullch;
+       else if (stab == sigstab) {
+           int i;
+
+           for (i = 1; i < NSIG; i++)
+               signal(i, SIG_DFL);     /* munch, munch, munch */
+       }
+       (void)hfree(stab_xhash(stab), TRUE);
        stab_xhash(stab) = Null(HASH*);
     }
     else if (type == O_SUBR || type == O_DBSUBR) {
index 68fcfef..d248b35 100644 (file)
@@ -1 +1 @@
-#define PATCHLEVEL 35
+#define PATCHLEVEL 36
diff --git a/perly.c b/perly.c
index 33b4a32..a914a4b 100644 (file)
--- a/perly.c
+++ b/perly.c
@@ -1,4 +1,4 @@
-char rcsid[] = "$Header: perly.c,v 3.0.1.7 90/08/13 22:22:22 lwall Locked $\nPatch level: ###\n";
+char rcsid[] = "$Header: perly.c,v 3.0.1.8 90/10/16 10:14:20 lwall Locked $\nPatch level: ###\n";
 /*
  *    Copyright (c) 1989, Larry Wall
  *
@@ -6,6 +6,15 @@ char rcsid[] = "$Header: perly.c,v 3.0.1.7 90/08/13 22:22:22 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.8  90/10/16  10:14:20  lwall
+ * patch29: *foo now prints as *package'foo
+ * patch29: added waitpid
+ * patch29: the debugger now understands packages and evals
+ * patch29: added -M, -A and -C
+ * patch29: -w sometimes printed spurious warnings about ARGV and ENV
+ * patch29: require "./foo" didn't work right
+ * patch29: require error messages referred to wrong file
+ * 
  * Revision 3.0.1.7  90/08/13  22:22:22  lwall
  * patch28: defined(@array) and defined(%array) didn't work right
  * 
@@ -45,7 +54,11 @@ char rcsid[] = "$Header: perly.c,v 3.0.1.7 90/08/13 22:22:22 lwall Locked $\nPat
 #include "EXTERN.h"
 #include "perl.h"
 #include "perly.h"
+#ifdef MSDOS
+#include "patchlev.h"
+#else
 #include "patchlevel.h"
+#endif
 
 #ifdef IAMSUID
 #ifndef DOSUID
@@ -113,6 +126,7 @@ setuid perl scripts securely.\n");
     curstash = defstash = hnew(0);
     curstname = str_make("main",4);
     stab_xhash(stabent("_main",TRUE)) = defstash;
+    defstash->tbl_name = "main";
     incstab = hadd(aadd(stabent("INC",TRUE)));
     incstab->str_pok |= SP_MULTI;
     for (argc--,argv++; argc > 0; argc--,argv++) {
@@ -274,17 +288,18 @@ setuid perl scripts securely.\n");
        argv[0] = savestr(xfound);
     }
 
-    pidstatary = anew(Nullstab);       /* for remembering popen pids, status */
+    fdpid = anew(Nullstab);    /* for remembering popen pids by fd */
+    pidstatus = hnew(Nullstab);        /* for remembering status of dead pids */
 
     origfilename = savestr(argv[0]);
-    filename = origfilename;
-    if (strEQ(filename,"-"))
+    curcmd->c_filestab = fstab(origfilename);
+    if (strEQ(origfilename,"-"))
        argv[0] = "";
     if (preprocess) {
        str_cat(str,"-I");
        str_cat(str,PRIVLIB);
        (void)sprintf(buf, "\
-/bin/sed %s -e '/^[^#]/b' \
+%ssed %s -e '/^[^#]/b' \
  -e '/^#[      ]*include[      ]/b' \
  -e '/^#[      ]*define[       ]/b' \
  -e '/^#[      ]*if[   ]/b' \
@@ -294,6 +309,11 @@ setuid perl scripts securely.\n");
  -e '/^#[      ]*endif/b' \
  -e 's/^#.*//' \
  %s | %s -C %s %s",
+#ifdef MSDOS
+         "",
+#else
+         "/bin/",
+#endif
          (doextract ? "-e '1,/^#/d\n'" : ""),
          argv[0], CPPSTDIN, str_get(str), CPPMINUS);
          doextract = FALSE;
@@ -318,7 +338,7 @@ setuid perl scripts securely.\n");
     if (rsfp == Nullfp) {
 #ifdef DOSUID
 #ifndef IAMSUID                /* in case script is not readable before setuid */
-       if (euid && stat(filename,&statbuf) >= 0 &&
+       if (euid && stat(stab_val(curcmd->c_filestab)->str_ptr,&statbuf) >= 0 &&
          statbuf.st_mode & (S_ISUID|S_ISGID)) {
            (void)sprintf(buf, "%s/%s", BIN, "suidperl");
            execv(buf, origargv);       /* try again */
@@ -327,7 +347,7 @@ setuid perl scripts securely.\n");
 #endif
 #endif
        fatal("Can't open perl script \"%s\": %s\n",
-         filename, strerror(errno));
+         stab_val(curcmd->c_filestab)->str_ptr, strerror(errno));
     }
     str_free(str);             /* free -I directories */
 
@@ -359,7 +379,7 @@ setuid perl scripts securely.\n");
 
 #ifdef DOSUID
     if (fstat(fileno(rsfp),&statbuf) < 0)      /* normal stat is insecure */
-       fatal("Can't stat script \"%s\"",filename);
+       fatal("Can't stat script \"%s\"",origfilename);
     if (statbuf.st_mode & (S_ISUID|S_ISGID)) {
        int len;
 
@@ -373,7 +393,7 @@ setuid perl scripts securely.\n");
         * But I don't think it's too important.  The manual lies when
         * it says access() is useful in setuid programs.
         */
-       if (access(filename,1))         /* as a double check */
+       if (access(stab_val(curcmd->c_filestab)->str_ptr,1))    /*double check*/
            fatal("Permission denied");
 #else
        /* If we can swap euid and uid, then we can determine access rights
@@ -386,8 +406,8 @@ setuid perl scripts securely.\n");
 
            if (setreuid(euid,uid) < 0 || getuid() != euid || geteuid() != uid)
                fatal("Can't swap uid and euid");       /* really paranoid */
-           if (stat(filename,&tmpstatbuf) < 0) /* testing full pathname here */
-               fatal("Permission denied");
+           if (stat(stab_val(curcmd->c_filestab)->str_ptr,&tmpstatbuf) < 0)
+               fatal("Permission denied");     /* testing full pathname here */
            if (tmpstatbuf.st_dev != statbuf.st_dev ||
                tmpstatbuf.st_ino != statbuf.st_ino) {
                (void)fclose(rsfp);
@@ -397,7 +417,8 @@ setuid perl scripts securely.\n");
 (Filename of set-id script was %s, uid %d gid %d.)\n\nSincerely,\nperl\n",
                        uid,tmpstatbuf.st_dev, tmpstatbuf.st_ino,
                        statbuf.st_dev, statbuf.st_ino,
-                       filename, statbuf.st_uid, statbuf.st_gid);
+                       stab_val(curcmd->c_filestab)->str_ptr,
+                       statbuf.st_uid, statbuf.st_gid);
                    (void)mypclose(rsfp);
                }
                fatal("Permission denied\n");
@@ -555,15 +576,22 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
        debstash = hnew(0);
        stab_xhash(stabent("_DB",TRUE)) = debstash;
        curstash = debstash;
-       lineary = stab_xarray(aadd((tmpstab = stabent("line",TRUE))));
+       dbargs = stab_xarray(aadd((tmpstab = stabent("args",TRUE))));
        tmpstab->str_pok |= SP_MULTI;
+       dbargs->ary_flags = 0;
        subname = str_make("main",4);
        DBstab = stabent("DB",TRUE);
        DBstab->str_pok |= SP_MULTI;
+       DBline = stabent("dbline",TRUE);
+       DBline->str_pok |= SP_MULTI;
        DBsub = hadd(tmpstab = stabent("sub",TRUE));
        tmpstab->str_pok |= SP_MULTI;
        DBsingle = stab_val((tmpstab = stabent("single",TRUE)));
        tmpstab->str_pok |= SP_MULTI;
+       DBtrace = stab_val((tmpstab = stabent("trace",TRUE)));
+       tmpstab->str_pok |= SP_MULTI;
+       DBsignal = stab_val((tmpstab = stabent("signal",TRUE)));
+       tmpstab->str_pok |= SP_MULTI;
        curstash = defstash;
     }
 
@@ -611,7 +639,7 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
        (void)hadd(sigstab);
     }
 
-    magicalize("!#?^~=-%0123456789.+&*()<>,\\/[|`':");
+    magicalize("!#?^~=-%0123456789.+&*()<>,\\/[|`':\024");
     userinit();                /* in case linked C routines want magical variables */
 
     amperstab = stabent("&",allstabs);
@@ -620,6 +648,8 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
     sawampersand = (amperstab || leftstab || rightstab);
     if (tmpstab = stabent(":",allstabs))
        str_set(STAB_STR(tmpstab),chopset);
+    if (tmpstab = stabent("\024",allstabs))
+       time(&basetime);
 
     /* these aren't necessarily magical */
     if (tmpstab = stabent(";",allstabs))
@@ -662,13 +692,6 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
 
     statname = Str_new(66,0);          /* last filename we did stat on */
 
-    perldb = FALSE;            /* don't try to instrument evals */
-
-    if (dowarn) {
-       stab_check('A','Z');
-       stab_check('a','z');
-    }
-
     if (do_undump)
        abort();
 
@@ -702,7 +725,7 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
     if (envstab = stabent("ENV",allstabs)) {
        envstab->str_pok |= SP_MULTI;
        (void)hadd(envstab);
-       hclear(stab_hash(envstab));
+       hclear(stab_hash(envstab), FALSE);
        if (env != environ)
            environ[0] = Nullch;
        for (; *env; env++) {
@@ -721,6 +744,11 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
     if (tmpstab = stabent("$",allstabs))
        str_numset(STAB_STR(tmpstab),(double)getpid());
 
+    if (dowarn) {
+       stab_check('A','Z');
+       stab_check('a','z');
+    }
+
     if (setjmp(top_env))       /* sets goto_targ on longjump */
        loop_ptr = -1;          /* start label stack again */
 
@@ -785,15 +813,16 @@ int *arglast;
     CMD *myroot;
     ARRAY *ar;
     int i;
-    char * VOLATILE oldfile = filename;
     CMD * VOLATILE oldcurcmd = curcmd;
     VOLATILE int oldtmps_base = tmps_base;
     VOLATILE int oldsave = savestack->ary_fill;
+    VOLATILE int oldperldb = perldb;
     SPAT * VOLATILE oldspat = curspat;
     static char *last_eval = Nullch;
     static CMD *last_root = Nullcmd;
     VOLATILE int sp = arglast[0];
     char *specfilename;
+    char *tmpfilename;
 
     tmps_base = tmps_max;
     if (curstash != stash) {
@@ -801,9 +830,11 @@ int *arglast;
        curstash = stash;
     }
     str_set(stab_val(stabent("@",TRUE)),"");
+    if (curcmd->c_line == 0)           /* don't debug debugger... */
+       perldb = FALSE;
     curcmd = &compiling;
     if (optype == O_EVAL) {            /* normal eval */
-       filename = "(eval)";
+       curcmd->c_filestab = fstab("(eval)");
        curcmd->c_line = 1;
        str_sset(linestr,str);
        str_cat(linestr,";");           /* be kind to them */
@@ -815,35 +846,39 @@ int *arglast;
            last_root = Nullcmd;
        }
        specfilename = str_get(str);
-       filename = savestr(specfilename);       /* can't free this easily */
        str_set(linestr,"");
-       if (optype == O_REQUIRE &&
+       if (optype == O_REQUIRE && &str_undef !=
          hfetch(stab_hash(incstab), specfilename, strlen(specfilename), 0)) {
-           filename = oldfile;
+           curcmd = oldcurcmd;
            tmps_base = oldtmps_base;
            st[++sp] = &str_yes;
+           perldb = oldperldb;
            return sp;
        }
-       else if (*filename == '/')
-           rsfp = fopen(filename,"r");
+       tmpfilename = savestr(specfilename);
+       if (index("/.", *tmpfilename))
+           rsfp = fopen(tmpfilename,"r");
        else {
            ar = stab_array(incstab);
-           Safefree(filename);
            for (i = 0; i <= ar->ary_fill; i++) {
-               (void)sprintf(buf,"%s/%s",str_get(afetch(ar,i,TRUE)),filename);
+               (void)sprintf(buf, "%s/%s",
+                 str_get(afetch(ar,i,TRUE)), specfilename);
                rsfp = fopen(buf,"r");
                if (rsfp) {
                    char *s = buf;
 
                    if (*s == '.' && s[1] == '/')
                        s += 2;
-                   filename = savestr(s);
+                   Safefree(tmpfilename);
+                   tmpfilename = savestr(s);
                    break;
                }
            }
        }
+       curcmd->c_filestab = fstab(tmpfilename);
+       Safefree(tmpfilename);
        if (!rsfp) {
-           filename = oldfile;
+           curcmd = oldcurcmd;
            tmps_base = oldtmps_base;
            if (optype == O_REQUIRE) {
                sprintf(tokenbuf,"Can't locate %s in @INC", specfilename);
@@ -855,6 +890,7 @@ int *arglast;
            }
            if (gimme != G_ARRAY)
                st[++sp] = &str_undef;
+           perldb = oldperldb;
            return sp;
        }
        curcmd->c_line = 0;
@@ -879,8 +915,10 @@ int *arglast;
     }
     else {
        error_count = 0;
-       if (rsfp)
+       if (rsfp) {
            retval = yyparse();
+           retval |= error_count;
+       }
        else if (last_root && *bufptr == *last_eval && strEQ(bufptr,last_eval)){
            retval = 0;
            eval_root = last_root;      /* no point in reparsing */
@@ -893,6 +931,7 @@ int *arglast;
            last_eval = savestr(bufptr);
            last_root = Nullcmd;
            retval = yyparse();
+           retval |= error_count;
            if (!retval)
                last_root = eval_root;
        }
@@ -900,7 +939,8 @@ int *arglast;
            retval = yyparse();
     }
     myroot = eval_root;                /* in case cmd_exec does another eval! */
-    if (retval || error_count) {
+
+    if (retval) {
        st = stack->ary_array;
        sp = arglast[0];
        if (gimme != G_ARRAY)
@@ -909,8 +949,6 @@ int *arglast;
        if (rsfp) {
            fclose(rsfp);
            rsfp = 0;
-           if (optype == O_REQUIRE)
-               fatal("%s", str_get(stab_val(stabent("@",TRUE))));
        }
     }
     else {
@@ -921,30 +959,40 @@ int *arglast;
                                /* if we don't save result, free zaps it */
        if (in_eval != 1 && myroot != last_root)
            cmd_free(myroot);
-       if (optype != O_EVAL) {
-           if (gimme == G_SCALAR ? str_true(st[sp]) : sp > arglast[0]) {
-               (void)hstore(stab_hash(incstab), specfilename,
-                 strlen(specfilename), str_make(filename,0), 0 );
-           }
-           else if (optype == O_REQUIRE)
-               fatal("%s did not return a true value", specfilename);
-       }
     }
+
+    perldb = oldperldb;
     in_eval--;
 #ifdef DEBUGGING
-       if (debug & 4) {
-           char *tmps = loop_stack[loop_ptr].loop_label;
-           deb("(Popping label #%d %s)\n",loop_ptr,
-               tmps ? tmps : "" );
-       }
+    if (debug & 4) {
+       char *tmps = loop_stack[loop_ptr].loop_label;
+       deb("(Popping label #%d %s)\n",loop_ptr,
+           tmps ? tmps : "" );
+    }
 #endif
     loop_ptr--;
-    filename = oldfile;
-    curcmd = oldcurcmd;
     tmps_base = oldtmps_base;
     curspat = oldspat;
     if (savestack->ary_fill > oldsave) /* let them use local() */
        restorelist(oldsave);
+
+    if (optype != O_EVAL) {
+       if (retval) {
+           if (optype == O_REQUIRE)
+               fatal("%s", str_get(stab_val(stabent("@",TRUE))));
+       }
+       else {
+           curcmd = oldcurcmd;
+           if (gimme == G_SCALAR ? str_true(st[sp]) : sp > arglast[0]) {
+               (void)hstore(stab_hash(incstab), specfilename,
+                 strlen(specfilename), str_smake(stab_val(curcmd->c_filestab)),
+                     0 );
+           }
+           else if (optype == O_REQUIRE)
+               fatal("%s did not return a true value", specfilename);
+       }
+    }
+    curcmd = oldcurcmd;
     return sp;
 }
 
@@ -1017,15 +1065,23 @@ char *s;
        s++;
        return s;
     case 'v':
+       fputs("\nThis is perl, version 3.0\n\n",stdout);
        fputs(rcsid,stdout);
        fputs("\nCopyright (c) 1989, 1990, Larry Wall\n",stdout);
 #ifdef MSDOS
        fputs("MS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n",
        stdout);
+#ifdef OS2
+        fputs("OS/2 port Copyright (c) 1990, Raymond Chen, Kai Uwe Rommel\n",
+        stdout);
+#endif
 #endif
        fputs("\n\
 Perl may be copied only under the terms of the GNU General Public License,\n\
 a copy of which can be found with the Perl 3.0 distribution kit.\n",stdout);
+#ifdef MSDOS
+        usage(origargv[0]);
+#endif
        exit(0);
     case 'w':
        dowarn = TRUE;
index 8eb0b4c..8ded8da 100644 (file)
--- a/usersub.c
+++ b/usersub.c
@@ -1,10 +1,13 @@
-/* $Header: usersub.c,v 3.0.1.1 90/08/09 05:40:45 lwall Locked $
+/* $Header: usersub.c,v 3.0.1.2 90/10/16 11:22:04 lwall Locked $
  *
  *  This file contains stubs for routines that the user may define to
  *  set up glue routines for C libraries or to decrypt encrypted scripts
  *  for execution.
  *
  * $Log:       usersub.c,v $
+ * Revision 3.0.1.2  90/10/16  11:22:04  lwall
+ * patch29: added waitpid
+ * 
  * Revision 3.0.1.1  90/08/09  05:40:45  lwall
  * patch19: Initial revision
  * 
@@ -96,9 +99,8 @@ VOID  (*func)();
     }
     close(p[1]);
     fclose(fil);
-    str = afetch(pidstatary,p[0],TRUE);
-    str_numset(str,(double)pipepid);
-    str->str_cur = 0;
+    str = afetch(fdpid,p[0],TRUE);
+    str->str_u.str_useful = pipepid;
     return fdopen(p[0], "r");
 }
 
diff --git a/util.c b/util.c
index 0487d93..74df0fd 100644 (file)
--- a/util.c
+++ b/util.c
@@ -1,4 +1,4 @@
-/* $Header: util.c,v 3.0.1.7 90/08/13 22:40:26 lwall Locked $
+/* $Header: util.c,v 3.0.1.8 90/10/16 11:26:57 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:       util.c,v $
+ * Revision 3.0.1.8  90/10/16  11:26:57  lwall
+ * patch29: added waitpid
+ * patch29: various portability fixes
+ * patch29: scripts now run at almost full speed under the debugger
+ * 
  * Revision 3.0.1.7  90/08/13  22:40:26  lwall
  * patch28: the NSIG hack didn't work right on Xenix
  * patch28: rename was busted on systems without rename system call
@@ -437,7 +442,7 @@ int iflag;
     register int i;
     register int len = str->str_cur;
     int rarest = 0;
-    int frequency = 256;
+    unsigned int frequency = 256;
 
     Str_Grow(str,len+258);
 #ifndef lint
@@ -479,7 +484,7 @@ int iflag;
     s = Null(unsigned char*);
 #endif
     if (iflag) {
-       register int tmp, foldtmp;
+       register unsigned int tmp, foldtmp;
        str->str_pok |= SP_CASEFOLD;
        for (i = 0; i < len; i++) {
            tmp=freq[s[i]];
@@ -559,7 +564,7 @@ STR *littlestr;
     s = big + littlelen;
     oldlittle = little = table - 2;
     if (littlestr->str_pok & SP_CASEFOLD) {    /* case insensitive? */
-       while (s < bigend) {
+       if (s < bigend) {
          top1:
            if (tmp = table[*s]) {
 #ifdef POINTERRIGOR
@@ -592,7 +597,7 @@ STR *littlestr;
        }
     }
     else {
-       while (s < bigend) {
+       if (s < bigend) {
          top2:
            if (tmp = table[*s]) {
 #ifdef POINTERRIGOR
@@ -777,7 +782,8 @@ long a1, a2, a3, a4;
     s += strlen(s);
     if (s[-1] != '\n') {
        if (curcmd->c_line) {
-           (void)sprintf(s," at %s line %ld", filename, (long)curcmd->c_line);
+           (void)sprintf(s," at %s line %ld",
+             stab_val(curcmd->c_filestab)->str_ptr, (long)curcmd->c_line);
            s += strlen(s);
        }
        if (last_in_stab &&
@@ -874,7 +880,8 @@ va_list args;
     s += strlen(s);
     if (s[-1] != '\n') {
        if (curcmd->c_line) {
-           (void)sprintf(s," at %s line %ld", filename, (long)curcmd->c_line);
+           (void)sprintf(s," at %s line %ld",
+             stab_val(curcmd->c_filestab)->str_ptr, (long)curcmd->c_line);
            s += strlen(s);
        }
        if (last_in_stab &&
@@ -1229,6 +1236,7 @@ char      *mode;
        if (tmpstab = stabent("$",allstabs))
            str_numset(STAB_STR(tmpstab),(double)getpid());
        forkprocess = 0;
+       hclear(pidstatus);      /* we have no children */
        return Nullfp;
 #undef THIS
 #undef THAT
@@ -1240,9 +1248,8 @@ char      *mode;
        close(p[this]);
        p[this] = p[that];
     }
-    str = afetch(pidstatary,p[this],TRUE);
-    str_numset(str,(double)pid);
-    str->str_cur = 0;
+    str = afetch(fdpid,p[this],TRUE);
+    str->str_u.str_useful = pid;
     forkprocess = pid;
     return fdopen(p[this], mode);
 }
@@ -1298,36 +1305,77 @@ FILE *ptr;
 #endif
     int status;
     STR *str;
-    register int pid;
+    int pid;
 
-    str = afetch(pidstatary,fileno(ptr),TRUE);
+    str = afetch(fdpid,fileno(ptr),TRUE);
+    astore(fdpid,fileno(ptr),Nullstr);
     fclose(ptr);
-    pid = (int)str_gnum(str);
-    if (!pid)
-       return -1;
+    pid = (int)str->str_u.str_useful;
     hstat = signal(SIGHUP, SIG_IGN);
     istat = signal(SIGINT, SIG_IGN);
     qstat = signal(SIGQUIT, SIG_IGN);
+    pid = wait4pid(pid, &status, 0);
+    signal(SIGHUP, hstat);
+    signal(SIGINT, istat);
+    signal(SIGQUIT, qstat);
+    return(pid < 0 ? pid : status);
+}
+
+int
+wait4pid(pid,statusp,flags)
+int pid;
+int *statusp;
+int flags;
+{
+    int result;
+    STR *str;
+    char spid[16];
+
+    if (!pid)
+       return -1;
 #ifdef WAIT4
-    if (wait4(pid,&status,0,Null(struct rusage *)) < 0)
-       status = -1;
+    return wait4(pid,statusp,flags,Null(struct rusage *));
 #else
-    if (pid < 0)               /* already exited? */
-       status = str->str_cur;
+#ifdef WAITPID
+    return waitpid(pid,statusp,flags);
+#else
+    if (pid > 0) {
+       sprintf(spid, "%d", pid);
+       str = hfetch(pidstatus,spid,strlen(pid),FALSE);
+       if (str != &str_undef) {
+           *statusp = (int)str->str_u.str_useful;
+           hdelete(pidstatus,spid,strlen(pid));
+           return pid;
+       }
+    }
+    else {
+       HENT *entry;
+
+       hiterinit(pidstatus);
+       if (entry = hiternext(pidstatus)) {
+           pid = atoi(hiterkey(entry,statusp));
+           str = hiterval(entry);
+           *statusp = (int)str->str_u.str_useful;
+           sprintf(spid, "%d", pid);
+           hdelete(pidstatus,spid,strlen(pid));
+           return pid;
+       }
+    }
+    if (flags)
+       fatal("Can't do waitpid with flags");
     else {
        int result;
+       register int count;
+       register STR *str;
 
-       while ((result = wait(&status)) != pid && result >= 0)
-           pidgone(result,status);
+       while ((result = wait(statusp)) != pid && pid > 0 && result >= 0)
+           pidgone(result,*statusp);
        if (result < 0)
-           status = -1;
+           *statusp = -1;
     }
 #endif
-    signal(SIGHUP, hstat);
-    signal(SIGINT, istat);
-    signal(SIGQUIT, qstat);
-    str_numset(str,0.0);
-    return(status);
+#endif
+    return result;
 }
 #endif /* !MSDOS */
 
@@ -1335,21 +1383,16 @@ pidgone(pid,status)
 int pid;
 int status;
 {
-#ifdef WAIT4
-    return;
+#if defined(WAIT4) || defined(WAITPID)
 #else
-    register int count;
     register STR *str;
+    char spid[16];
 
-    for (count = pidstatary->ary_fill; count >= 0; --count) {
-       if ((str = afetch(pidstatary,count,FALSE)) &&
-         ((int)str->str_u.str_nval) == pid) {
-           str_numset(str, -str->str_u.str_nval);
-           str->str_cur = status;
-           return;
-       }
-    }
+    sprintf(spid, "%d", pid);
+    str = hfetch(pidstatus,pid,strlen(pid),TRUE);
+    str->str_u.str_useful = status;
 #endif
+    return;
 }
 
 #ifndef MEMCMP
index 27b08b0..07f19a3 100644 (file)
@@ -1,4 +1,4 @@
-/* $Header: util.c,v 3.0 89/10/18 15:35:35 lwall Locked $
+/* $Header: util.c,v 3.0.1.1 90/10/16 11:34:06 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:       util.c,v $
+ * Revision 3.0.1.1  90/10/16  11:34:06  lwall
+ * patch29: removed #ifdef undef
+ * 
  * Revision 3.0  89/10/18  15:35:35  lwall
  * 3.0 baseline
  * 
@@ -103,36 +106,6 @@ register int len;
     return to;
 }
 
-#ifdef undef
-/* safe version of string concatenate, with \n deletion and space padding */
-
-char *
-safecat(to,from,len)
-char *to;
-register char *from;
-register int len;
-{
-    register char *dest = to;
-
-    len--;                             /* leave room for null */
-    if (*dest) {
-       while (len && *dest++) len--;
-       if (len) {
-           len--;
-           *(dest-1) = ' ';
-       }
-    }
-    if (from != Nullch)
-       while (len && (*dest++ = *from++)) len--;
-    if (len)
-       dest--;
-    if (*(dest-1) == '\n')
-       dest--;
-    *dest = '\0';
-    return to;
-}
-#endif
-
 /* copy a string up to some (non-backslashed) delimiter, if any */
 
 char *
index ce16453..555e13c 100644 (file)
@@ -1,4 +1,4 @@
-/* $Header: walk.c,v 3.0.1.5 90/08/09 05:55:01 lwall Locked $
+/* $Header: walk.c,v 3.0.1.6 90/10/16 11:35:51 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:       walk.c,v $
+ * Revision 3.0.1.6  90/10/16  11:35:51  lwall
+ * patch29: a2p mistranslated certain weird field separators
+ * 
  * Revision 3.0.1.5  90/08/09  05:55:01  lwall
  * patch19: a2p emited local($_) without a semicolon
  * patch19: a2p didn't make explicit split on whitespace skip leading whitespace
@@ -694,7 +697,7 @@ sub Pick {\n\
                i = fstr->str_ptr[1] & 127;
                if (index("*+?.[]()|^$\\",i))
                    sprintf(tokenbuf,"/\\%c/",i);
-               else if (i = ' ')
+               else if (i == ' ')
                    sprintf(tokenbuf,"' '");
                else
                    sprintf(tokenbuf,"/%c/",i);