perl 3.0 patch #12 patch #9, continued
Larry Wall [Wed, 28 Feb 1990 21:56:43 +0000 (21:56 +0000)]
See patch #9.

eg/relink [new file with mode: 0644]
eg/rename
eg/travesty [new file with mode: 0644]
lib/termcap.pl
patchlevel.h
stab.c
str.c
toke.c
util.c
x2p/s2p.SH
x2p/walk.c

diff --git a/eg/relink b/eg/relink
new file mode 100644 (file)
index 0000000..2d8e5f6
--- /dev/null
+++ b/eg/relink
@@ -0,0 +1,24 @@
+#!/usr/bin/perl
+
+($op = shift) || die "Usage: relink perlexpr [filenames]\n";
+if (!@ARGV) {
+    if (-t) {
+       @ARGV = <*>;
+    }
+    else {
+       @ARGV = <STDIN>;
+       chop(@ARGV);
+    }
+}
+for (@ARGV) {
+    next unless -l;            # symbolic link?
+    $name = $_;
+    $_ = readlink($_);
+    $was = $_;
+    eval $op;
+    die $@ if $@;
+    if ($was ne $_) {
+       unlink($name);
+       symlink($_, $name);
+    }
+}
index 1708d35..1bb19d7 100644 (file)
--- a/eg/rename
+++ b/eg/rename
@@ -1,9 +1,14 @@
 #!/usr/bin/perl
 
 ($op = shift) || die "Usage: rename perlexpr [filenames]\n";
-if ($#ARGV < 0) {
-    @ARGV = <stdin>;
-    chop(@ARGV);
+if (!@ARGV) {
+    if (-t) {
+       @ARGV = <*>;
+    }
+    else {
+       @ARGV = <STDIN>;
+       chop(@ARGV);
+    }
 }
 for (@ARGV) {
     $was = $_;
diff --git a/eg/travesty b/eg/travesty
new file mode 100644 (file)
index 0000000..7e6f983
--- /dev/null
@@ -0,0 +1,46 @@
+#!/usr/bin/perl
+
+while (<>) {
+    next if /^\./;
+    next if /^From / .. /^$/;
+    next if /^Path: / .. /^$/;
+    s/^\W+//;
+    push(@ary,split(' '));
+    while ($#ary > 1) {
+       $a = $p;
+       $p = $n;
+       $w = shift(@ary);
+       $n = $num{$w};
+       if ($n eq '') {
+           push(@word,$w);
+           $n = pack('S',$#word);
+           $num{$w} = $n;
+       }
+       $lookup{$a . $p} .= $n;
+    }
+}
+
+for (;;) {
+    $n = $lookup{$a . $p};
+    ($foo,$n) = each(lookup) if $n eq '';
+    $n = substr($n,int(rand(length($n))) & 0177776,2);
+    $a = $p;
+    $p = $n;
+    ($w) = unpack('S',$n);
+    $w = $word[$w];
+    $col += length($w) + 1;
+    if ($col >= 65) {
+       $col = 0;
+       print "\n";
+    }
+    else {
+       print ' ';
+    }
+    print $w;
+    if ($w =~ /\.$/) {
+       if (rand() < .1) {
+           print "\n";
+           $col = 80;
+       }
+    }
+}
index ab693f2..a92b714 100644 (file)
@@ -1,13 +1,13 @@
-;# $Header: termcap.pl,v 3.0 89/10/18 15:19:58 lwall Locked $
+;# $Header: termcap.pl,v 3.0.1.1 90/02/28 17:46:44 lwall Locked $
 ;#
 ;# Usage:
 ;#     do 'ioctl.pl';
 ;#     ioctl(TTY,$TIOCGETP,$foo);
 ;#     ($ispeed,$ospeed) = unpack('cc',$foo);
-;#     do 'termcap.pl';
-;#     do Tgetent('vt100');    # sets $TC{'cm'}, etc.
-;#     do Tgoto($TC{'cm'},$row,$col);
-;#     do Tputs($TC{'dl'},$affcnt,'FILEHANDLE');
+;#     do 'termcap.pl' || die "Can't get termcap.pl";
+;#     &Tgetent('vt100');      # sets $TC{'cm'}, etc.
+;#     &Tputs(&Tgoto($TC{'cm'},$col,$row), 0, 'FILEHANDLE');
+;#     &Tputs($TC{'dl'},$affcnt,'FILEHANDLE');
 ;#
 sub Tgetent {
     local($TERM) = @_;
@@ -47,7 +47,7 @@ sub Tgetent {
            \$entry .= \$_;
            ";
            eval $loop;
-       } while s/:tc=([^:]+):/:/, $TERM = $1;
+       } while s/:tc=([^:]+):/:/ && ($TERM = $1);
        $TERMCAP = $entry;
     }
 
@@ -70,7 +70,7 @@ sub Tgetent {
            s/\\f/\f/g;
            s/\\\^/\377/g;
            s/\^\?/\177/g;
-           s/\^(.)/pack('c',$1 & 031)/eg;
+           s/\^(.)/pack('c',$1 & 31)/eg;
            s/\\(.)/$1/g;
            s/\377/^/g;
            $TC{$entry} = $_ if $TC{$entry} eq '';
@@ -104,17 +104,18 @@ sub Tgoto {
     local($result) = '';
     local($after) = '';
     local($code,$tmp) = @_;
-    @_ = ($tmp,$code);
+    local(@tmp);
+    @tmp = ($tmp,$code);
     local($online) = 0;
     while ($string =~ /^([^%]*)%(.)(.*)/) {
        $result .= $1;
        $code = $2;
        $string = $3;
        if ($code eq 'd') {
-           $result .= sprintf("%d",shift(@_));
+           $result .= sprintf("%d",shift(@tmp));
        }
        elsif ($code eq '.') {
-           $tmp = shift(@_);
+           $tmp = shift(@tmp);
            if ($tmp == 0 || $tmp == 4 || $tmp == 10) {
                if ($online) {
                    ++$tmp, $after .= $TC{'up'} if $TC{'up'};
@@ -127,32 +128,32 @@ sub Tgoto {
            $online = !$online;
        }
        elsif ($code eq '+') {
-           $result .= sprintf("%c",shift(@_)+ord($string));
+           $result .= sprintf("%c",shift(@tmp)+ord($string));
            $string = substr($string,1,99);
            $online = !$online;
        }
        elsif ($code eq 'r') {
-           ($code,$tmp) = @_;
-           @_ = ($tmp,$code);
+           ($code,$tmp) = @tmp;
+           @tmp = ($tmp,$code);
            $online = !$online;
        }
        elsif ($code eq '>') {
            ($code,$tmp,$string) = unpack("CCa99",$string);
-           if ($_[$[] > $code) {
-               $_[$[] += $tmp;
+           if ($tmp[$[] > $code) {
+               $tmp[$[] += $tmp;
            }
        }
        elsif ($code eq '2') {
-           $result .= sprintf("%02d",shift(@_));
+           $result .= sprintf("%02d",shift(@tmp));
            $online = !$online;
        }
        elsif ($code eq '3') {
-           $result .= sprintf("%03d",shift(@_));
+           $result .= sprintf("%03d",shift(@tmp));
            $online = !$online;
        }
        elsif ($code eq 'i') {
-           ($code,$tmp) = @_;
-           @_ = ($code+1,$tmp+1);
+           ($code,$tmp) = @tmp;
+           @tmp = ($code+1,$tmp+1);
        }
        else {
            return "OOPS";
index 98702f8..bc5f1c8 100644 (file)
@@ -1 +1 @@
-#define PATCHLEVEL 11
+#define PATCHLEVEL 12
diff --git a/stab.c b/stab.c
index 2a5c5a3..1a561f4 100644 (file)
--- a/stab.c
+++ b/stab.c
@@ -1,4 +1,4 @@
-/* $Header: stab.c,v 3.0.1.3 89/12/21 20:18:40 lwall Locked $
+/* $Header: stab.c,v 3.0.1.4 90/02/28 18:19:14 lwall Locked $
  *
  *    Copyright (c) 1989, Larry Wall
  *
@@ -6,6 +6,13 @@
  *    as specified in the README file that comes with the perl 3.0 kit.
  *
  * $Log:       stab.c,v $
+ * Revision 3.0.1.4  90/02/28  18:19:14  lwall
+ * patch9: $0 is now always the command name
+ * patch9: you may now undef $/ to have no input record separator
+ * patch9: local($.) didn't work
+ * patch9: sometimes perl thought ordinary data was a symbol table entry
+ * patch9: stab_array() and stab_hash() weren't defined on MICROPORT
+ * 
  * Revision 3.0.1.3  89/12/21  20:18:40  lwall
  * patch7: ANSI strerror() is now supported
  * patch7: errno may now be a macro with an lvalue
@@ -50,7 +57,7 @@ STR *str;
        return stab_val(stab);
 
     switch (*stab->str_magic->str_ptr) {
-    case '0': case '1': case '2': case '3': case '4':
+    case '1': case '2': case '3': case '4':
     case '5': case '6': case '7': case '8': case '9': case '&':
        if (curspat) {
            paren = atoi(stab_name(stab));
@@ -128,9 +135,11 @@ STR *str;
        break;
 #endif
     case '/':
-       *tokenbuf = record_separator;
-       tokenbuf[1] = '\0';
-       str_nset(stab_val(stab),tokenbuf,rslen);
+       if (record_separator != 12345) {
+           *tokenbuf = record_separator;
+           tokenbuf[1] = '\0';
+           str_nset(stab_val(stab),tokenbuf,rslen);
+       }
        break;
     case '[':
        str_numset(stab_val(stab),(double)arybase);
@@ -228,7 +237,7 @@ STR *str;
        break;
     case '*':
        s = str_get(str);
-       if (strnNE(s,"Stab",4) || str->str_cur != sizeof(STBP)) {
+       if (strNE(s,"StB") || str->str_cur != sizeof(STBP)) {
            if (!*s) {
                STBP *stbp;
 
@@ -239,7 +248,7 @@ STR *str;
                stab->str_ptr = stbp;
                stab->str_len = stab->str_cur = sizeof(STBP);
                stab->str_pok = 1;
-               strncpy(stab_magic(stab),"Stab",4);
+               strcpy(stab_magic(stab),"StB");
                stab_val(stab) = Str_new(70,0);
                stab_line(stab) = line;
            }
@@ -264,6 +273,10 @@ STR *str;
 
     case 0:
        switch (*stab->str_magic->str_ptr) {
+       case '.':
+           if (localizing)
+               savesptr((STR**)&last_in_stab);
+           break;
        case '^':
            Safefree(stab_io(curoutstab)->top_name);
            stab_io(curoutstab)->top_name = s = savestr(str_get(str));
@@ -296,8 +309,14 @@ STR *str;
            multiline = (i != 0);
            break;
        case '/':
-           record_separator = *str_get(str);
-           rslen = str->str_cur;
+           if (str->str_ptr) {
+               record_separator = *str_get(str);
+               rslen = str->str_cur;
+           }
+           else {
+               record_separator = 12345;       /* fake a non-existent char */
+               rslen = 1;
+           }
            break;
        case '\\':
            if (ors)
@@ -588,7 +607,7 @@ int add;
        stab->str_ptr = stbp;
        stab->str_len = stab->str_cur = sizeof(STBP);
        stab->str_pok = 1;
-       strncpy(stab_magic(stab),"Stab",4);
+       strcpy(stab_magic(stab),"StB");
        stab_val(stab) = Str_new(72,0);
        stab_line(stab) = line;
        str_magic(stab,stab,'*',name,len);
@@ -661,3 +680,26 @@ register STAB *stab;
     stab->str_cur = 0;
 }
 
+#if defined(CRIPPLED_CC) && (defined(iAPX286) || defined(M_I286) || defined(I80286))
+#define MICROPORT
+#endif
+
+#ifdef MICROPORT       /* Microport 2.4 hack */
+ARRAY *stab_array(stab)
+register STAB *stab;
+{
+    if (((STBP*)(stab->str_ptr))->stbp_array) 
+       return ((STBP*)(stab->str_ptr))->stbp_array;
+    else
+       return ((STBP*)(aadd(stab)->str_ptr))->stbp_array;
+}
+
+HASH *stab_hash(stab)
+register STAB *stab;
+{
+    if (((STBP*)(stab->str_ptr))->stbp_hash)
+       return ((STBP*)(stab->str_ptr))->stbp_hash;
+    else
+       return ((STBP*)(hadd(stab)->str_ptr))->stbp_hash;
+}
+#endif                 /* Microport 2.4 hack */
diff --git a/str.c b/str.c
index 71a31b3..498e742 100644 (file)
--- a/str.c
+++ b/str.c
@@ -1,4 +1,4 @@
-/* $Header: str.c,v 3.0.1.4 89/12/21 20:21:35 lwall Locked $
+/* $Header: str.c,v 3.0.1.5 90/02/28 18:30:38 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:       str.c,v $
+ * Revision 3.0.1.5  90/02/28  18:30:38  lwall
+ * patch9: you may now undef $/ to have no input record separator
+ * patch9: nested evals clobbered their longjmp environment
+ * patch9: sometimes perl thought ordinary data was a symbol table entry
+ * patch9: insufficient space allocated for numeric string on sun4
+ * patch9: underscore in an array name in a double-quoted string not recognized
+ * patch9: "@foo{}" not recognized unless %foo defined
+ * patch9: "$foo[$[]" gives error
+ * 
  * Revision 3.0.1.4  89/12/21  20:21:35  lwall
  * patch7: errno may now be a macro with an lvalue
  * patch7: made nested or recursive foreach work right
@@ -129,7 +138,15 @@ register STR *str;
     if (!str)
        return "";
     if (str->str_nok) {
+/* this is a problem on the sun 4... 24 bytes is not always enough and the
+       exponent blows away the malloc stack
+       PEJ Wed Jan 31 18:41:34 CST 1990
+*/
+#ifdef sun4
+       STR_GROW(str, 30);
+#else
        STR_GROW(str, 24);
+#endif /* sun 4 */
        s = str->str_ptr;
        olderrno = errno;       /* some Xenix systems wipe out errno here */
 #if defined(scs) && defined(ns32000)
@@ -144,13 +161,21 @@ register STR *str;
 #endif /*scs*/
        errno = olderrno;
        while (*s) s++;
+#ifdef hcx
+       if (s[-1] == '.')
+           s--;
+#endif
     }
     else {
        if (str == &str_undef)
            return No;
        if (dowarn)
            warn("Use of uninitialized variable");
+#ifdef sun4
+       STR_GROW(str, 30);
+#else
        STR_GROW(str, 24);
+#endif
        s = str->str_ptr;
     }
     *s = '\0';
@@ -194,6 +219,8 @@ register STR *sstr;
 #ifdef TAINT
     tainted |= sstr->str_tainted;
 #endif
+    if (sstr == dstr)
+       return;
     if (!sstr)
        dstr->str_pok = dstr->str_nok = 0;
     else if (sstr->str_pok) {
@@ -206,7 +233,7 @@ register STR *sstr;
        else if (sstr->str_cur == sizeof(STBP)) {
            char *tmps = sstr->str_ptr;
 
-           if (*tmps == 'S' && bcmp(tmps,"Stab",4) == 0) {
+           if (*tmps == 'S' && bcmp(tmps,"StB",4) == 0) {
                dstr->str_magic = str_smake(sstr->str_magic);
                dstr->str_magic->str_rare = 'X';
            }
@@ -642,7 +669,7 @@ int append;
     register char *bp;         /* we're going to steal some values */
     register int cnt;          /*  from the stdio struct and put EVERYTHING */
     register STDCHAR *ptr;     /*   in the innermost loop into registers */
-    register char newline = record_separator;/* (assuming >= 6 registers) */
+    register int newline = record_separator;/* (assuming >= 6 registers) */
     int i;
     int bpx;
     int obpx;
@@ -742,15 +769,36 @@ STR *str;
     register ARG *arg;
     line_t oldline = line;
     int retval;
+    char *tmps;
 
     str_sset(linestr,str);
     in_eval++;
     oldoldbufptr = oldbufptr = bufptr = str_get(linestr);
     bufend = bufptr + linestr->str_cur;
-    if (setjmp(eval_env)) {
-       in_eval = 0;
+    if (++loop_ptr >= loop_max) {
+        loop_max += 128;
+        Renew(loop_stack, loop_max, struct loop);
+    }
+    loop_stack[loop_ptr].loop_label = "_EVAL_";
+    loop_stack[loop_ptr].loop_sp = 0;
+#ifdef DEBUGGING
+    if (debug & 4) {
+        deb("(Pushing label #%d _EVAL_)\n", loop_ptr);
+    }
+#endif
+    if (setjmp(loop_stack[loop_ptr].loop_env)) {
+       in_eval--;
+       loop_ptr--;
        fatal("%s\n",stab_val(stabent("@",TRUE))->str_ptr);
     }
+#ifdef DEBUGGING
+    if (debug & 4) {
+       tmps = loop_stack[loop_ptr].loop_label;
+       deb("(Popping label #%d %s)\n",loop_ptr,
+           tmps ? tmps : "" );
+    }
+#endif
+    loop_ptr--;
     error_count = 0;
     retval = yyparse();
     in_eval--;
@@ -803,11 +851,12 @@ STR *src;
          s+1 < send) {
            str_ncat(str,t,s-t);
            t = s;
-           if (*s == '$' && s[1] == '#' && isalpha(s[2]) || s[2] == '_')
+           if (*s == '$' && s[1] == '#' && (isalpha(s[2]) || s[2] == '_'))
                s++;
            s = scanreg(s,send,tokenbuf);
            if (*t == '@' &&
-             (!(stab = stabent(tokenbuf,FALSE)) || !stab_xarray(stab)) ) {
+             (!(stab = stabent(tokenbuf,FALSE)) || 
+                (*s == '{' ? !stab_xhash(stab) : !stab_xarray(stab)) )) {
                str_ncat(str,"@",1);
                s = ++t;
                continue;       /* grandfather @ from old scripts */
@@ -821,10 +870,18 @@ STR *src;
                checkpoint = s;
                do {
                    switch (*s) {
-                   case '[': case '{':
+                   case '[':
+                       if (s[-1] != '$')
+                           brackets++;
+                       break;
+                   case '{':
                        brackets++;
                        break;
-                   case ']': case '}':
+                   case ']':
+                       if (s[-1] != '$')
+                           brackets--;
+                       break;
+                   case '}':
                        brackets--;
                        break;
                    case '\'':
diff --git a/toke.c b/toke.c
index 67376ed..cf80f35 100644 (file)
--- a/toke.c
+++ b/toke.c
@@ -1,4 +1,4 @@
-/* $Header: toke.c,v 3.0.1.4 89/12/21 20:26:56 lwall Locked $
+/* $Header: toke.c,v 3.0.1.5 90/02/28 18:47:06 lwall Locked $
  *
  *    Copyright (c) 1989, Larry Wall
  *
@@ -6,6 +6,13 @@
  *    as specified in the README file that comes with the perl 3.0 kit.
  *
  * $Log:       toke.c,v $
+ * Revision 3.0.1.5  90/02/28  18:47:06  lwall
+ * patch9: return grandfathered to never be function call
+ * patch9: non-existent perldb.pl now gives reasonable error message
+ * patch9: perl can now start up other interpreters scripts
+ * patch9: line numbers were bogus during certain portions of foreach evaluation
+ * patch9: null hereis core dumped
+ * 
  * Revision 3.0.1.4  89/12/21  20:26:56  lwall
  * patch7: -d switch incompatible with -p or -n
  * patch7: " ''$foo'' " didn't parse right
@@ -78,6 +85,8 @@ char *reparse;                /* if non-null, scanreg found ${foo[$bar]} */
 #define LOP(f) return(*s == '(' || (s = skipspace(s), *s == '(') ? \
        (*s = META('('), bufptr = oldbufptr, '(') : \
        (yylval.ival=f,expectterm = TRUE,bufptr = s,(int)LISTOP))
+/* grandfather return to old style */
+#define OLDLOP(f) return(yylval.ival=f,expectterm = TRUE,bufptr = s,(int)LISTOP)
 
 char *
 skipspace(s)
@@ -171,7 +180,8 @@ yylex()
            if (minus_n || minus_p || perldb) {
                str_set(linestr,"");
                if (perldb)
-                   str_cat(linestr,"do 'perldb.pl'; print $@;");
+                   str_cat(linestr,
+"do 'perldb.pl' || die \"Can't find perldb.pl in @INC\"; print $@;");
                if (minus_n || minus_p) {
                    str_cat(linestr,"line: while (<>) {");
                    if (minus_a)
@@ -222,12 +232,42 @@ yylex()
        }
 #endif
        bufend = linestr->str_ptr + linestr->str_cur;
-       if (firstline) {
-           while (s < bufend && isspace(*s))
-               s++;
-           if (*s == ':')      /* for csh's that have to exec sh scripts */
-               s++;
-           firstline = FALSE;
+       if (line == 1) {
+           if (*s == '#' && s[1] == '!') {
+               if (!in_eval && !instr(s,"perl") && instr(origargv[0],"perl")) {
+                   char **newargv;
+                   char *cmd;
+
+                   s += 2;
+                   if (*s == ' ')
+                       s++;
+                   cmd = s;
+                   while (s < bufend && !isspace(*s))
+                       s++;
+                   *s++ = '\0';
+                   while (s < bufend && isspace(*s))
+                       s++;
+                   if (s < bufend) {
+                       Newz(899,newargv,origargc+3,char*);
+                       newargv[1] = s;
+                       while (s < bufend && !isspace(*s))
+                           s++;
+                       *s = '\0';
+                       Copy(origargv+1, newargv+2, origargc+1, char*);
+                   }
+                   else
+                       newargv = origargv;
+                   newargv[0] = cmd;
+                   execv(cmd,newargv);
+                   fatal("Can't exec %s", cmd);
+               }
+           }
+           else {
+               while (s < bufend && isspace(*s))
+                   s++;
+               if (*s == ':')  /* for csh's that have to exec sh scripts */
+                   s++;
+           }
        }
        goto retry;
     case ' ': case '\t': case '\f':
@@ -519,8 +559,10 @@ yylex()
            LFUN(O_CHOP);
        if (strEQ(d,"continue"))
            OPERATOR(CONTINUE);
-       if (strEQ(d,"chdir"))
+       if (strEQ(d,"chdir")) {
+           (void)stabent("ENV",TRUE);  /* may use HOME */
            UNI(O_CHDIR);
+       }
        if (strEQ(d,"close"))
            FOP(O_CLOSE);
        if (strEQ(d,"closedir"))
@@ -606,10 +648,10 @@ yylex()
        break;
     case 'f': case 'F':
        SNARFWORD;
-       if (strEQ(d,"for"))
-           OPERATOR(FOR);
-       if (strEQ(d,"foreach"))
+       if (strEQ(d,"for") || strEQ(d,"foreach")) {
+           yylval.ival = line;
            OPERATOR(FOR);
+       }
        if (strEQ(d,"format")) {
            d = bufend;
            while (s < d && isspace(*s))
@@ -819,6 +861,8 @@ yylex()
            FL2(O_PACK);
        if (strEQ(d,"package"))
            OPERATOR(PACKAGE);
+       if (strEQ(d,"pipe"))
+           FOP22(O_PIPE);
        break;
     case 'q': case 'Q':
        SNARFWORD;
@@ -834,7 +878,7 @@ yylex()
     case 'r': case 'R':
        SNARFWORD;
        if (strEQ(d,"return"))
-           LOP(O_RETURN);
+           OLDLOP(O_RETURN);
        if (strEQ(d,"reset"))
            UNI(O_RESET);
        if (strEQ(d,"redo"))
@@ -1483,7 +1527,8 @@ get_repl:
        tmpstr = spat->spat_repl[1].arg_ptr.arg_str;
        e = tmpstr->str_ptr + tmpstr->str_cur;
        for (t = tmpstr->str_ptr; t < e; t++) {
-           if (*t == '$' && t[1] && index("`'&+0123456789",t[1]))
+           if (*t == '$' && t[1] && (index("`'&+0123456789",t[1]) ||
+             (t[1] == '{' /*}*/ && isdigit(t[2])) ))
                spat->spat_flags &= ~SPAT_CONST;
        }
     }
@@ -1861,7 +1906,7 @@ register char *s;
                    term = tmps[5];
                multi_close = term;
            }
-           tmpstr = Str_new(87,0);
+           tmpstr = Str_new(87,80);
            if (hereis) {
                term = *tokenbuf;
                if (!rsfp) {
@@ -1946,7 +1991,7 @@ register char *s;
                if ((*s == '$' && s+1 < send &&
                    (alwaysdollar || /*(*/ (s[1] != ')' && s[1] != '|')) ) ||
                    (*s == '@' && s+1 < send) ) {
-                   len = scanreg(s,bufend,tokenbuf) - s;
+                   len = scanreg(s,send,tokenbuf) - s;
                    if (*s == '$' || strEQ(tokenbuf,"ARGV")
                      || strEQ(tokenbuf,"ENV")
                      || strEQ(tokenbuf,"SIG")
diff --git a/util.c b/util.c
index dd28d8d..96f142a 100644 (file)
--- a/util.c
+++ b/util.c
@@ -1,4 +1,4 @@
-/* $Header: util.c,v 3.0.1.3 89/12/21 20:27:41 lwall Locked $
+/* $Header: util.c,v 3.0.1.4 90/03/01 10:26:48 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:       util.c,v $
+ * Revision 3.0.1.4  90/03/01  10:26:48  lwall
+ * patch9: fbminstr() called instr() rather than ninstr()
+ * patch9: nested evals clobbered their longjmp environment
+ * patch9: piped opens returned undefined rather than 0 in child
+ * patch9: the x operator is now up to 10 times faster
+ * 
  * Revision 3.0.1.3  89/12/21  20:27:41  lwall
  * patch7: errno may now be a macro with an lvalue
  * 
@@ -479,7 +485,8 @@ STR *littlestr;
 
 #ifndef lint
     if (!(littlestr->str_pok & SP_FBM))
-       return instr((char*)big,littlestr->str_ptr);
+       return ninstr((char*)big,(char*)bigend,
+               littlestr->str_ptr, littlestr->str_ptr + littlestr->str_cur);
 #endif
 
     littlelen = littlestr->str_cur;
@@ -733,11 +740,33 @@ long a1, a2, a3, a4;
 {
     extern FILE *e_fp;
     extern char *e_tmpname;
+    char *tmps;
 
     mess(pat,a1,a2,a3,a4);
     if (in_eval) {
        str_set(stab_val(stabent("@",TRUE)),buf);
-       longjmp(eval_env,1);
+       tmps = "_EVAL_";
+       while (loop_ptr >= 0 && (!loop_stack[loop_ptr].loop_label ||
+         strNE(tmps,loop_stack[loop_ptr].loop_label) )) {
+#ifdef DEBUGGING
+           if (debug & 4) {
+               deb("(Skipping label #%d %s)\n",loop_ptr,
+                   loop_stack[loop_ptr].loop_label);
+           }
+#endif
+           loop_ptr--;
+       }
+#ifdef DEBUGGING
+       if (debug & 4) {
+           deb("(Found label #%d %s)\n",loop_ptr,
+               loop_stack[loop_ptr].loop_label);
+       }
+#endif
+       if (loop_ptr < 0) {
+           in_eval = 0;
+           fatal("Bad label: %s", tmps);
+       }
+       longjmp(loop_stack[loop_ptr].loop_env, 1);
     }
     fputs(buf,stderr);
     (void)fflush(stderr);
@@ -809,6 +838,7 @@ va_dcl
     va_list args;
     extern FILE *e_fp;
     extern char *e_tmpname;
+    char *tmps;
 
 #ifndef lint
     va_start(args);
@@ -819,7 +849,28 @@ va_dcl
     va_end(args);
     if (in_eval) {
        str_set(stab_val(stabent("@",TRUE)),buf);
-       longjmp(eval_env,1);
+       tmps = "_EVAL_";
+       while (loop_ptr >= 0 && (!loop_stack[loop_ptr].loop_label ||
+         strNE(tmps,loop_stack[loop_ptr].loop_label) )) {
+#ifdef DEBUGGING
+           if (debug & 4) {
+               deb("(Skipping label #%d %s)\n",loop_ptr,
+                   loop_stack[loop_ptr].loop_label);
+           }
+#endif
+           loop_ptr--;
+       }
+#ifdef DEBUGGING
+       if (debug & 4) {
+           deb("(Found label #%d %s)\n",loop_ptr,
+               loop_stack[loop_ptr].loop_label);
+       }
+#endif
+       if (loop_ptr < 0) {
+           in_eval = 0;
+           fatal("Bad label: %s", tmps);
+       }
+       longjmp(loop_stack[loop_ptr].loop_env, 1);
     }
     fputs(buf,stderr);
     (void)fflush(stderr);
@@ -1112,6 +1163,7 @@ char      *mode;
        }
        if (tmpstab = stabent("$",allstabs))
            str_numset(STAB_STR(tmpstab),(double)getpid());
+       forkprocess = 0;
        return Nullfp;
 #undef THIS
 #undef THAT
@@ -1235,3 +1287,27 @@ register int len;
     return 0;
 }
 #endif /* MEMCMP */
+
+void
+repeatcpy(to,from,len,count)
+register char *to;
+register char *from;
+int len;
+register int count;
+{
+    register int todo;
+    register char *frombase = from;
+
+    if (len == 1) {
+       todo = *from;
+       while (count-- > 0)
+           *to++ = todo;
+       return;
+    }
+    while (count-- > 0) {
+       for (todo = len; todo > 0; todo--) {
+           *to++ = *from++;
+       }
+       from = frombase;
+    }
+}
index fc85209..08230b0 100644 (file)
@@ -28,9 +28,12 @@ $spitshell >s2p <<!GROK!THIS!
 : In the following dollars and backticks do not need the extra backslash.
 $spitshell >>s2p <<'!NO!SUBS!'
 
-# $Header: s2p.SH,v 3.0.1.2 89/11/17 15:51:27 lwall Locked $
+# $Header: s2p.SH,v 3.0.1.3 90/03/01 10:31:21 lwall Locked $
 #
 # $Log:        s2p.SH,v $
+# Revision 3.0.1.3  90/03/01  10:31:21  lwall
+# patch9: s2p didn't handle \< and \>
+# 
 # Revision 3.0.1.2  89/11/17  15:51:27  lwall
 # patch5: in s2p, line labels without a subsequent statement were done wrong
 # patch5: s2p left residue in /tmp
@@ -426,6 +429,9 @@ ${space}next line;";
                        $len--;
                        $_ = substr($_,0,$i) . substr($_,$i+1,10000);
                    }
+                   elsif (!$repl && substr($_,$i,1) =~ /^[<>]$/) {
+                       substr($_,$i,1) = 'b';
+                   }
                }
                elsif ($c eq '[' && !$repl) {
                    $i++ if substr($_,$i,1) eq '^';
@@ -607,7 +613,8 @@ sub fetchpat {
            s/(.)//;
            $ch = $1;
            $delim = '' if $ch =~ /^[(){}\w]$/;
-           $delim .= $1;
+           $ch = 'b' if $ch =~ /^[<>]$/;
+           $delim .= $ch;
        }
        elsif ($delim eq '[') {
            $inbracket = 1;
index ca1214d..58494c9 100644 (file)
@@ -1,4 +1,4 @@
-/* $Header: walk.c,v 3.0.1.3 89/12/21 20:32:35 lwall Locked $
+/* $Header: walk.c,v 3.0.1.4 90/03/01 10:32:45 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.4  90/03/01  10:32:45  lwall
+ * patch9: a2p didn't put a $ on ExitValue
+ * 
  * Revision 3.0.1.3  89/12/21  20:32:35  lwall
  * patch7: in a2p, user-defined functions didn't work on some machines
  * 
@@ -158,7 +161,7 @@ int minprec;                        /* minimum precedence without parens */
            str_cat(str,"\n");
        }
        if (exitval)
-           str_cat(str,"exit ExitValue;\n");
+           str_cat(str,"exit $ExitValue;\n");
        if (subs->str_ptr) {
            str_cat(str,"\n");
            str_scat(str,subs);
@@ -1327,7 +1330,7 @@ sub Pick {\n\
        }
        else {
            if (len == 1) {
-               str_set(str,"ExitValue = ");
+               str_set(str,"$ExitValue = ");
                exitval = TRUE;
                str_scat(str,
                  fstr=walk(1,level,ops[node+1].ival,&numarg,P_ASSIGN));