perl 4.0 patch 16: patch #11, continued
Larry Wall [Tue, 5 Nov 1991 06:28:06 +0000 (06:28 +0000)]
See patch #11.

hints/stellar.sh [new file with mode: 0644]
lib/perldb.pl
patchlevel.h
perly.y
regcomp.c
regexec.c
stab.c
stab.h
str.c
t/op/stat.t

diff --git a/hints/stellar.sh b/hints/stellar.sh
new file mode 100644 (file)
index 0000000..23e15e9
--- /dev/null
@@ -0,0 +1,2 @@
+optimize="-O0"
+ccflags="$ccflags -nw"
index 8d16054..917469b 100644 (file)
@@ -1,6 +1,10 @@
 package DB;
 
-$header = '$RCSfile: perldb.pl,v $$Revision: 4.0.1.1 $$Date: 91/06/07 11:17:44 $';
+# modified Perl debugger, to be run from Emacs in perldb-mode
+# Ray Lischner (uunet!mntgfx!lisch) as of 5 Nov 1990
+# Johan Vromans -- upgrade to 4.0 pl 10
+
+$header = '$RCSfile: perldb.pl,v $$Revision: 4.0.1.2 $$Date: 91/11/05 17:55:58 $';
 #
 # This file is automatically included if you do perl -d.
 # It's probably not useful to include this yourself.
@@ -10,6 +14,9 @@ $header = '$RCSfile: perldb.pl,v $$Revision: 4.0.1.1 $$Date: 91/06/07 11:17:44 $
 # have a breakpoint.  It also inserts a do 'perldb.pl' before the first line.
 #
 # $Log:        perldb.pl,v $
+# Revision 4.0.1.2  91/11/05  17:55:58  lwall
+# patch11: perldb.pl modified to run within emacs in perldb-mode
+# 
 # Revision 4.0.1.1  91/06/07  11:17:44  lwall
 # patch4: added $^P variable to control calling of perldb routines
 # patch4: debugger sometimes listed wrong number of lines for a statement
@@ -57,8 +64,16 @@ select(STDOUT);
 $| = 1;                                # for real STDOUT
 $sub = '';
 
+# Is Perl being run from Emacs?
+$emacs = $main'ARGV[$[] eq '-emacs';
+shift(@main'ARGV) if $emacs;
+
 $header =~ s/.Header: ([^,]+),v(\s+\S+\s+\S+).*$/$1$2/;
-print OUT "\nLoading DB routines from $header\n\nEnter h for help.\n\n";
+print OUT "\nLoading DB routines from $header\n";
+print OUT ("Emacs support ",
+          $emacs ? "enabled" : "available",
+          ".\n");
+print OUT "\nEnter h for help.\n\n";
 
 sub DB {
     &save;
@@ -78,11 +93,15 @@ sub DB {
        }
     }
     if ($single || $trace || $signal) {
-       print OUT "$package'" unless $sub =~ /'/;
-       print OUT "$sub($filename:$line):\t",$dbline[$line];
-       for ($i = $line + 1; $i <= $max && $dbline[$i] == 0; ++$i) {
-           last if $dbline[$i] =~ /^\s*(;|}|#|\n)/;
-           print OUT "$sub($filename:$i):\t",$dbline[$i];
+       if ($emacs) {
+           print OUT "\032\032$filename:$line:0\n";
+       } else {
+           print OUT "$package'" unless $sub =~ /'/;
+           print OUT "$sub($filename:$line):\t",$dbline[$line];
+           for ($i = $line + 1; $i <= $max && $dbline[$i] == 0; ++$i) {
+               last if $dbline[$i] =~ /^\s*(}|#|\n)/;
+               print OUT "$sub($filename:$i):\t",$dbline[$i];
+           }
        }
     }
     $evalarg = $action, &eval if $action;
@@ -244,9 +263,14 @@ command            Execute as a perl statement in current package.
                    $i = $2;
                    $i = $line if $i eq '.';
                    $i = 1 if $i < 1;
-                   for (; $i <= $end; $i++) {
-                       print OUT "$i:\t", $dbline[$i];
-                       last if $signal;
+                   if ($emacs) {
+                       print OUT "\032\032$filename:$i:0\n";
+                       $i = $end;
+                   } else {
+                       for (; $i <= $end; $i++) {
+                           print OUT "$i:\t", $dbline[$i];
+                           last if $signal;
+                       }
                    }
                    $start = $i;        # remember in case they want more
                    $start = $max if $start > $max;
@@ -393,7 +417,11 @@ command            Execute as a perl statement in current package.
                        $start = 1 if ($start > $max);
                        last if ($start == $end);
                        if ($dbline[$start] =~ m'."\n$pat\n".'i) {
-                           print OUT "$start:\t", $dbline[$start], "\n";
+                           if ($emacs) {
+                               print OUT "\032\032$filename:$start:0\n";
+                           } else {
+                               print OUT "$start:\t", $dbline[$start], "\n";
+                           }
                            last;
                        }
                    } ';
@@ -417,7 +445,11 @@ command            Execute as a perl statement in current package.
                        $start = $max if ($start <= 0);
                        last if ($start == $end);
                        if ($dbline[$start] =~ m'."\n$pat\n".'i) {
-                           print OUT "$start:\t", $dbline[$start], "\n";
+                           if ($emacs) {
+                               print OUT "\032\032$filename:$start:0\n";
+                           } else {
+                               print OUT "$start:\t", $dbline[$start], "\n";
+                           }
                            last;
                        }
                    } ';
index 69d9c2f..29d9127 100644 (file)
@@ -1 +1 @@
-#define PATCHLEVEL 15
+#define PATCHLEVEL 16
diff --git a/perly.y b/perly.y
index 4032e10..5f31fd1 100644 (file)
--- a/perly.y
+++ b/perly.y
@@ -1,4 +1,4 @@
-/* $RCSfile: perly.y,v $$Revision: 4.0.1.1 $$Date: 91/06/07 11:42:34 $
+/* $RCSfile: perly.y,v $$Revision: 4.0.1.2 $$Date: 91/11/05 18:17:38 $
  *
  *    Copyright (c) 1991, Larry Wall
  *
@@ -6,6 +6,11 @@
  *    License or the Artistic License, as specified in the README file.
  *
  * $Log:       perly.y,v $
+ * Revision 4.0.1.2  91/11/05  18:17:38  lwall
+ * patch11: extra comma at end of list is now allowed in more places (Hi, Felix!)
+ * patch11: once-thru blocks didn't display right in the debugger
+ * patch11: debugger got confused over nested subroutine definitions
+ * 
  * Revision 4.0.1.1  91/06/07  11:42:34  lwall
  * patch4: new copyright notice
  * 
 #include "INTERN.h"
 #include "perl.h"
 
+/*SUPPRESS 530*/
+/*SUPPRESS 593*/
+/*SUPPRESS 595*/
+
 STAB *scrstab;
 ARG *arg4;     /* rarely used arguments to make_op() */
 ARG *arg5;
@@ -36,6 +45,8 @@ ARG *arg5;
     FCMD *formval;
 }
 
+%token <ival> '{' ')'
+
 %token <cval> WORD
 %token <ival> APPEND OPEN SSELECT LOOPEX
 %token <ival> USING FORMAT DO SHIFT PUSH POP LVALFUN
@@ -49,7 +60,7 @@ ARG *arg5;
 %token <arg> SUBST PATTERN
 %token <arg> RSTRING TRANS
 
-%type <ival> prog decl format remember
+%type <ival> prog decl format remember crp
 %type <cmdval> block lineseq line loop cond sideff nexpr else
 %type <arg> expr sexpr cexpr csexpr term handle aryword hshword
 %type <arg> texpr listop bareword
@@ -110,6 +121,8 @@ else        :       /* NULL */
 
 block  :       '{' remember lineseq '}'
                        { $$ = block_head($3);
+                         if (cmdline > $1)
+                             cmdline = $1;
                          if (savestack->ary_fill > $2)
                            restorelist($2); }
        ;
@@ -190,7 +203,7 @@ loop        :       label WHILE '(' texpr ')' compblock
                        { cmdline = $2;
                            $$ = wopt(add_label($1,
                            invert(make_ccmd(C_WHILE, cmd_to_arg($3),$4)) )); }
-       |       label FOR REG '(' expr ')' compblock
+       |       label FOR REG '(' expr crp compblock
                        { cmdline = $2;
                            /*
                             * The following gobbledygook catches EXPRs that
@@ -229,7 +242,7 @@ loop        :       label WHILE '(' texpr ')' compblock
                                make_ccmd(C_WHILE,$5,$7) )));
                            }
                        }
-       |       label FOR '(' expr ')' compblock
+       |       label FOR '(' expr crp compblock
                        { cmdline = $2;
                            if ($4->arg_type != O_ARRAY) {
                                scrstab = aadd(genstab());
@@ -303,7 +316,10 @@ format     :       FORMAT WORD '=' FORMLIST
        ;
 
 subrout        :       SUB WORD block
-                       { make_sub($2,$3); }
+                       { make_sub($2,$3);
+                         cmdline = NOLINE;
+                         if (savestack->ary_fill > $1)
+                           restorelist($1); }
        ;
 
 package :      PACKAGE WORD ';'
@@ -443,13 +459,11 @@ term      :       '-' term %prec UMINUS
                                stab2arg(A_STAB,
                                  $1 == O_FTTTY?stabent("STDIN",TRUE):defstab),
                                Nullarg, Nullarg); }
-       |       LOCAL '(' expr ')'
+       |       LOCAL '(' expr crp
                        { $$ = l(localize(make_op(O_ASSIGN, 1,
                                localize(listish(make_list($3))),
                                Nullarg,Nullarg))); }
-       |       '(' expr ',' ')'
-                       { $$ = make_list($2); }
-       |       '(' expr ')'
+       |       '(' expr crp
                        { $$ = make_list($2); }
        |       '(' ')'
                        { $$ = make_list(Nullarg); }
@@ -478,7 +492,7 @@ term        :       '-' term %prec UMINUS
                                stab2arg(A_STAB,hadd($1)),
                                jmaybe($3),
                                Nullarg); }
-       |       '(' expr ')' '[' expr ']'       %prec '('
+       |       '(' expr crp '[' expr ']'       %prec '('
                        { $$ = make_op(O_LSLICE, 3,
                                Nullarg,
                                listish(make_list($5)),
@@ -513,40 +527,40 @@ term      :       '-' term %prec UMINUS
                        { $$ = $1; }
        |       TRANS   %prec '('
                        { $$ = $1; }
-       |       DO WORD '(' expr ')'
+       |       DO WORD '(' expr crp
                        { $$ = make_op((perldb ? O_DBSUBR : O_SUBR), 2,
-                               stab2arg(A_WORD,stabent($2,TRUE)),
+                               stab2arg(A_WORD,stabent($2,MULTI)),
                                make_list($4),
                                Nullarg); Safefree($2); $2 = Nullch;
                            $$->arg_flags |= AF_DEPR; }
-       |       AMPER WORD '(' expr ')'
+       |       AMPER WORD '(' expr crp
                        { $$ = make_op((perldb ? O_DBSUBR : O_SUBR), 2,
-                               stab2arg(A_WORD,stabent($2,TRUE)),
+                               stab2arg(A_WORD,stabent($2,MULTI)),
                                make_list($4),
                                Nullarg); Safefree($2); $2 = Nullch; }
        |       DO WORD '(' ')'
                        { $$ = make_op((perldb ? O_DBSUBR : O_SUBR), 2,
-                               stab2arg(A_WORD,stabent($2,TRUE)),
+                               stab2arg(A_WORD,stabent($2,MULTI)),
                                make_list(Nullarg),
                                Nullarg);
                            $$->arg_flags |= AF_DEPR; }
        |       AMPER WORD '(' ')'
                        { $$ = make_op((perldb ? O_DBSUBR : O_SUBR), 2,
-                               stab2arg(A_WORD,stabent($2,TRUE)),
+                               stab2arg(A_WORD,stabent($2,MULTI)),
                                make_list(Nullarg),
                                Nullarg); }
        |       AMPER WORD
                        { $$ = make_op((perldb ? O_DBSUBR : O_SUBR), 2,
-                               stab2arg(A_WORD,stabent($2,TRUE)),
+                               stab2arg(A_WORD,stabent($2,MULTI)),
                                Nullarg,
                                Nullarg); }
-       |       DO REG '(' expr ')'
+       |       DO REG '(' expr crp
                        { $$ = make_op((perldb ? O_DBSUBR : O_SUBR), 2,
                                stab2arg(A_STAB,$2),
                                make_list($4),
                                Nullarg);
                            $$->arg_flags |= AF_DEPR; }
-       |       AMPER REG '(' expr ')'
+       |       AMPER REG '(' expr crp
                        { $$ = make_op((perldb ? O_DBSUBR : O_SUBR), 2,
                                stab2arg(A_STAB,$2),
                                make_list($4),
@@ -574,10 +588,18 @@ term      :       '-' term %prec UMINUS
                            Nullarg,Nullarg); }
        |       UNIOP
                        { $$ = make_op($1,0,Nullarg,Nullarg,Nullarg); }
+       |       UNIOP block
+                       { $$ = make_op($1,1,cmd_to_arg($2),Nullarg,Nullarg); }
        |       UNIOP sexpr
                        { $$ = make_op($1,1,$2,Nullarg,Nullarg); }
        |       SSELECT
                        { $$ = make_op(O_SELECT, 0, Nullarg, Nullarg, Nullarg);}
+       |       SSELECT  WORD
+                       { $$ = make_op(O_SELECT, 1,
+                           stab2arg(A_WORD,stabent($2,TRUE)),
+                           Nullarg,
+                           Nullarg);
+                           Safefree($2); $2 = Nullch; }
        |       SSELECT '(' handle ')'
                        { $$ = make_op(O_SELECT, 1, $3, Nullarg, Nullarg); }
        |       SSELECT '(' sexpr csexpr csexpr csexpr ')'
@@ -628,10 +650,10 @@ term      :       '-' term %prec UMINUS
        |       FILOP25 '(' handle ',' handle csexpr csexpr cexpr ')'
                        { arg4 = $7; arg5 = $8;
                          $$ = make_op($1, 5, $3, $5, $6); }
-       |       PUSH '(' aryword cexpr ')'
+       |       PUSH '(' aryword ',' expr crp
                        { $$ = make_op($1, 2,
                            $3,
-                           make_list($4),
+                           make_list($5),
                            Nullarg); }
        |       POP aryword     %prec '('
                        { $$ = make_op(O_POP, 1, $2, Nullarg, Nullarg); }
@@ -671,7 +693,7 @@ term        :       '-' term %prec UMINUS
                            $3,
                            listish(make_list($4)),
                            Nullarg); }
-       |       FLIST '(' expr ')'
+       |       FLIST '(' expr crp
                        { $$ = make_op($1, 1,
                            make_list($3),
                            Nullarg,
@@ -752,6 +774,11 @@ listop     :       LISTOP
                                stab2arg(A_STAB,$2),
                                maybelistish($1,make_list($3)),
                                Nullarg); }
+       |       LISTOP block expr
+                       { $$ = make_op($1,2,
+                               cmd_to_arg($2),
+                               maybelistish($1,make_list($3)),
+                               Nullarg); }
        ;
 
 handle :       WORD
@@ -774,6 +801,12 @@ hshword    :       WORD
                        { $$ = stab2arg(A_STAB,$1); }
        ;
 
+crp    :       ',' ')'
+                       { $$ = 1; }
+       |       ')'
+                       { $$ = 0; }
+       ;
+
 /*
  * NOTE:  The following entry must stay at the end of the file so that
  * reduce/reduce conflicts resolve to it only if it's the only option.
@@ -785,7 +818,7 @@ bareword:   WORD
                            $$->arg_type = O_ITEM;
                            $$[1].arg_type = A_SINGLE;
                            $$[1].arg_ptr.arg_str = str_make($1,0);
-                           for (s = $1; *s && islower(*s); s++) ;
+                           for (s = $1; *s && isLOWER(*s); s++) ;
                            if (dowarn && !*s)
                                warn(
                                  "\"%s\" may clash with future reserved word",
index 92e43a3..0fd50c0 100644 (file)
--- a/regcomp.c
+++ b/regcomp.c
@@ -7,9 +7,15 @@
  * blame Henry for some of the lack of readability.
  */
 
-/* $RCSfile: regcomp.c,v $$Revision: 4.0.1.2 $$Date: 91/06/07 11:48:24 $
+/* $RCSfile: regcomp.c,v $$Revision: 4.0.1.3 $$Date: 91/11/05 18:22:28 $
  *
  * $Log:       regcomp.c,v $
+ * Revision 4.0.1.3  91/11/05  18:22:28  lwall
+ * patch11: minimum match length calculation in regexp is now cumulative
+ * patch11: initial .* in pattern had dependency on value of $*
+ * patch11: certain patterns made use of garbage pointers from uncleared memory
+ * patch11: prepared for ctype implementations that don't define isascii()
+ * 
  * Revision 4.0.1.2  91/06/07  11:48:24  lwall
  * patch4: new copyright notice
  * patch4: /(x+) \1/ incorrectly optimized to not match "xxx xx"
@@ -22,7 +28,7 @@
  * 4.0 baseline.
  * 
  */
-
+/*SUPPRESS 112*/
 /*
  * regcomp and regexec -- regsub and regerror are not used in perl
  *
@@ -150,6 +156,7 @@ int fold;
        int backish;
        int backest;
        int curback;
+       int minlen;
        extern char *safemalloc();
        extern char *savestr();
        int sawplus = 0;
@@ -168,7 +175,7 @@ int fold;
        regnpar = 1;
        regsize = 0L;
        regcode = &regdummy;
-       regc(MAGIC);
+       regc((char)MAGIC);
        if (reg(0, &flags) == NULL) {
                Safefree(regprecomp);
                regprecomp = Nullch;
@@ -193,7 +200,7 @@ int fold;
        regparse = exp;
        regnpar = 1;
        regcode = r->program;
-       regc(MAGIC);
+       regc((char)MAGIC);
        if (reg(0, &flags) == NULL)
                return(NULL);
 
@@ -233,7 +240,8 @@ int fold;
                        r->regstclass = first;
                else if (OP(first) == BOL ||
                    (OP(first) == STAR && OP(NEXTOPER(first)) == ANY) ) {
-                       r->reganch = ROPT_ANCH; /* kinda turn .* into ^.* */
+                       /* kinda turn .* into ^.* */
+                       r->reganch = ROPT_ANCH | ROPT_IMPLICIT;
                        first = NEXTOPER(first);
                        goto again;
                }
@@ -259,6 +267,7 @@ int fold;
                longish = str_make("",0);
                longest = str_make("",0);
                len = 0;
+               minlen = 0;
                curback = 0;
                backish = 0;
                backest = 0;
@@ -278,6 +287,7 @@ int fold;
                            first = scan;
                            while (OP(t = regnext(scan)) == CLOSE)
                                scan = t;
+                           minlen += *OPERAND(first);
                            if (curback - backish == len) {
                                str_ncat(longish, OPERAND(first)+1,
                                    *OPERAND(first));
@@ -303,9 +313,16 @@ int fold;
                                backest = backish;
                            }
                            str_nset(longish,"",0);
+                           if (OP(scan) == PLUS &&
+                             index(simple,OP(NEXTOPER(scan))))
+                               minlen++;
+                           else if (OP(scan) == CURLY &&
+                             index(simple,OP(NEXTOPER(scan)+4)))
+                               minlen += ARG1(scan);
                        }
                        else if (index(simple,OP(scan))) {
                            curback++;
+                           minlen++;
                            len = 0;
                            if (longish->str_cur > longest->str_cur) {
                                str_sset(longest,longish);
@@ -328,8 +345,9 @@ int fold;
                    &&
                    (!r->regstart
                     ||
-                    !fbminstr(r->regstart->str_ptr,
-                         r->regstart->str_ptr + r->regstart->str_cur,
+                    !fbminstr((unsigned char*) r->regstart->str_ptr,
+                         (unsigned char *) r->regstart->str_ptr
+                           + r->regstart->str_cur,
                          longest)
                    )
                   )
@@ -354,8 +372,9 @@ int fold;
 
        r->do_folding = fold;
        r->nparens = regnpar - 1;
-       New(1002, r->startp, regnpar, char*);
-       New(1002, r->endp, regnpar, char*);
+       r->minlen = minlen;
+       Newz(1002, r->startp, regnpar, char*);
+       Newz(1002, r->endp, regnpar, char*);
 #ifdef DEBUGGING
        if (debug & 512)
                regdump(r);
@@ -515,7 +534,7 @@ int *flagp;
        if (op == '{' && regcurly(regparse)) {
            next = regparse + 1;
            max = Nullch;
-           while (isdigit(*next) || *next == ',') {
+           while (isDIGIT(*next) || *next == ',') {
                if (*next == ',') {
                    if (max)
                        break;
@@ -758,7 +777,7 @@ int *flagp;
                            else {
                                regsawback = 1;
                                ret = reganode(REF, num);
-                               while (isascii(*regparse) && isdigit(*regparse))
+                               while (isDIGIT(*regparse))
                                    regparse++;
                                *flagp |= SIMPLE;
                            }
@@ -839,14 +858,14 @@ int *flagp;
                                case 'c':
                                    p++;
                                    ender = *p++;
-                                   if (islower(ender))
+                                   if (isLOWER(ender))
                                        ender = toupper(ender);
                                    ender ^= 64;
                                    break;
                                case '0': case '1': case '2': case '3':case '4':
                                case '5': case '6': case '7': case '8':case '9':
                                    if (*p == '0' ||
-                                     (isdigit(p[1]) && atoi(p) >= regnpar) ) {
+                                     (isDIGIT(p[1]) && atoi(p) >= regnpar) ) {
                                        ender = scanoct(p, 3, &numlen);
                                        p += numlen;
                                    }
@@ -868,7 +887,7 @@ int *flagp;
                                ender = *p++;
                                break;
                            }
-                           if (regfold && isupper(ender))
+                           if (regfold && isUPPER(ender))
                                    ender = tolower(ender);
                            if (ISMULT2(p)) { /* Back off on ?+*. */
                                if (len)
@@ -992,7 +1011,7 @@ regclass()
                                break;
                        case 'c':
                                class = *regparse++;
-                               if (islower(class))
+                               if (isLOWER(class))
                                    class = toupper(class);
                                class ^= 64;
                                break;
@@ -1019,7 +1038,7 @@ regclass()
                }
                for ( ; lastclass <= class; lastclass++) {
                        regset(bits,def,lastclass);
-                       if (regfold && isupper(lastclass))
+                       if (regfold && isUPPER(lastclass))
                                regset(bits,def,tolower(lastclass));
                }
                lastclass = class;
@@ -1226,13 +1245,13 @@ register char *s;
 {
     if (*s++ != '{')
        return FALSE;
-    if (!isdigit(*s))
+    if (!isDIGIT(*s))
        return FALSE;
-    while (isdigit(*s))
+    while (isDIGIT(*s))
        s++;
     if (*s == ',')
        s++;
-    while (isdigit(*s))
+    while (isDIGIT(*s))
        s++;
     if (*s != '}')
        return FALSE;
@@ -1292,9 +1311,12 @@ regexp *r;
                fprintf(stderr,"anchored ");
        if (r->reganch & ROPT_SKIP)
                fprintf(stderr,"plus ");
+       if (r->reganch & ROPT_IMPLICIT)
+               fprintf(stderr,"implicit ");
        if (r->regmust != NULL)
                fprintf(stderr,"must have \"%s\" back %d ", r->regmust->str_ptr,
                  r->regback);
+       fprintf(stderr, "minlen %d ", r->minlen);
        fprintf(stderr,"\n");
 }
 
index bb63eda..226aab4 100644 (file)
--- a/regexec.c
+++ b/regexec.c
@@ -7,9 +7,13 @@
  * blame Henry for some of the lack of readability.
  */
 
-/* $RCSfile: regexec.c,v $$Revision: 4.0.1.2 $$Date: 91/06/07 11:50:33 $
+/* $RCSfile: regexec.c,v $$Revision: 4.0.1.3 $$Date: 91/11/05 18:23:55 $
  *
  * $Log:       regexec.c,v $
+ * Revision 4.0.1.3  91/11/05  18:23:55  lwall
+ * patch11: prepared for ctype implementations that don't define isascii()
+ * patch11: initial .* in pattern had dependency on value of $*
+ * 
  * Revision 4.0.1.2  91/06/07  11:50:33  lwall
  * patch4: new copyright notice
  * patch4: // wouldn't use previous pattern if it started with a null character
@@ -21,7 +25,7 @@
  * 4.0 baseline.
  * 
  */
-
+/*SUPPRESS 112*/
 /*
  * regcomp and regexec -- regsub and regerror are not used in perl
  *
 int regnarrate = 0;
 #endif
 
-#define isALNUM(c) (isascii(c) && (isalpha(c) || isdigit(c) || c == '_'))
-#define isSPACE(c) (isascii(c) && isspace(c))
-#define isDIGIT(c) (isascii(c) && isdigit(c))
-#define isUPPER(c) (isascii(c) && isupper(c))
-
 /*
  * regexec and friends
  */
@@ -221,7 +220,7 @@ int safebase;       /* no need to remember string in subbase */
        if (prog->reganch & ROPT_ANCH) {
                if (regtry(prog, string))
                        goto got_it;
-               else if (multiline) {
+               else if (multiline || (prog->reganch & ROPT_IMPLICIT)) {
                        if (minlen)
                            dontbother = minlen - 1;
                        strend -= dontbother;
@@ -279,6 +278,7 @@ int safebase;       /* no need to remember string in subbase */
                }
                goto phooey;
        }
+       /*SUPPRESS 560*/
        if (c = prog->regstclass) {
                int doevery = (prog->reganch & ROPT_SKIP) == 0;
 
@@ -721,6 +721,7 @@ char *prog;
                                                if (regmatch(NEXTOPER(scan)))
                                                        return(1);
 #ifdef REGALIGN
+                                               /*SUPPRESS 560*/
                                                if (n = NEXT(scan))
                                                    scan += n;
                                                else
diff --git a/stab.c b/stab.c
index b8e76d4..d141da3 100644 (file)
--- a/stab.c
+++ b/stab.c
@@ -1,4 +1,4 @@
-/* $RCSfile: stab.c,v $$Revision: 4.0.1.2 $$Date: 91/06/07 11:55:53 $
+/* $RCSfile: stab.c,v $$Revision: 4.0.1.3 $$Date: 91/11/05 18:35:33 $
  *
  *    Copyright (c) 1991, Larry Wall
  *
@@ -6,6 +6,13 @@
  *    License or the Artistic License, as specified in the README file.
  *
  * $Log:       stab.c,v $
+ * Revision 4.0.1.3  91/11/05  18:35:33  lwall
+ * patch11: length($x) was sometimes wrong for numeric $x
+ * patch11: perl now issues warning if $SIG{'ALARM'} is referenced
+ * patch11: *foo = undef coredumped
+ * patch11: solitary subroutine references no longer trigger typo warnings
+ * patch11: local(*FILEHANDLE) had a memory leak
+ * 
  * Revision 4.0.1.2  91/06/07  11:55:53  lwall
  * patch4: new copyright notice
  * patch4: added $^P variable to control calling of perldb routines
@@ -247,7 +254,7 @@ STR *str;
     char *s;
 
     if (str->str_rare)
-       return stab_val(stab)->str_cur;
+       return str_len(stab_val(stab));
 
     switch (*stab->str_magic->str_ptr) {
     case '1': case '2': case '3': case '4':
@@ -303,7 +310,7 @@ STR *str;
     case '\\':
        return (STRLEN)orslen;
     default:
-       return stab_str(str)->str_cur;
+       return str_len(stab_str(str));
     }
 }
 
@@ -311,7 +318,7 @@ stabset(mstr,str)
 register STR *mstr;
 STR *str;
 {
-    STAB *stab = mstr->str_u.str_stab;
+    STAB *stab;
     register char *s;
     int i;
 
@@ -338,6 +345,8 @@ STR *str;
     case 'S':
        s = str_get(str);
        i = whichsig(mstr->str_ptr);    /* ...no, a brick */
+       if (!i && (dowarn || strEQ(mstr->str_ptr,"ALARM")))
+           warn("No such signal: SIG%s", mstr->str_ptr);
        if (strEQ(s,"IGNORE"))
 #ifndef lint
            (void)signal(i,SIG_IGN);
@@ -356,6 +365,7 @@ STR *str;
        break;
 #ifdef SOME_DBM
     case 'D':
+       stab = mstr->str_u.str_stab;
        hdbmstore(stab_hash(stab),mstr->str_ptr,mstr->str_cur,str);
        break;
 #endif
@@ -363,6 +373,7 @@ STR *str;
        {
            CMD *cmd;
 
+           stab = mstr->str_u.str_stab;
            i = str_true(str);
            str = afetch(stab_xarray(stab),atoi(mstr->str_ptr), FALSE);
            cmd = str->str_magic->str_u.str_cmd;
@@ -371,16 +382,19 @@ STR *str;
        }
        break;
     case '#':
+       stab = mstr->str_u.str_stab;
        afill(stab_array(stab), (int)str_gnum(str) - arybase);
        break;
     case 'X':  /* merely a copy of a * string */
        break;
     case '*':
-       s = str_get(str);
+       s = str->str_pok ? str_get(str) : "";
        if (strNE(s,"StB") || str->str_cur != sizeof(STBP)) {
+           stab = mstr->str_u.str_stab;
            if (!*s) {
                STBP *stbp;
 
+               /*SUPPRESS 701*/
                (void)savenostab(stab); /* schedule a free of this stab */
                if (stab->str_len)
                    Safefree(stab->str_ptr);
@@ -402,7 +416,7 @@ STR *str;
                if (!stab_io(stab))
                    stab_io(stab) = stio_new();
            }
-           str_sset(str,stab);
+           str_sset(str, (STR*) stab);
        }
        break;
     case 's': {
@@ -422,6 +436,9 @@ STR *str;
        break;
 
     case 0:
+       /*SUPPRESS 560*/
+       if (!(stab = mstr->str_u.str_stab))
+           break;
        switch (*stab->str_magic->str_ptr) {
        case '\004':    /* ^D */
 #ifdef DEBUGGING
@@ -711,6 +728,7 @@ int sig;
                sig_name[sig], stab_name(stab) );
        return;
     }
+    /*SUPPRESS 701*/
     saveaptr(&stack);
     str = Str_new(15, sizeof(CSV));
     str->str_state = SS_SCSV;
@@ -791,7 +809,7 @@ int add;
     char *prevquote = Nullch;
     bool global = FALSE;
 
-    if (isascii(*name) && isupper(*name)) {
+    if (isUPPER(*name)) {
        if (*name > 'I') {
            if (*name == 'S' && (
              strEQ(name, "SIG") ||
@@ -822,9 +840,9 @@ int add;
        sawquote = Nullch;
        name++;
     }
-    else if (!isalpha(*name) || global)
+    else if (!isALPHA(*name) || global)
        stash = defstash;
-    else if (curcmd == &compiling)
+    else if ((CMD*)curcmd == &compiling)
        stash = curstash;
     else
        stash = curcmd->c_stash;
@@ -833,6 +851,7 @@ int add;
        char *s, *d;
 
        *sawquote = '\0';
+       /*SUPPRESS 560*/
        if (s = prevquote) {
            strncpy(tmpbuf,name,s-name+1);
            d = tmpbuf+(s-name+1);
@@ -869,12 +888,14 @@ int add;
        strcpy(stab_magic(stab),"StB");
        stab_val(stab) = Str_new(72,0);
        stab_line(stab) = curcmd->c_line;
-       str_magic(stab,stab,'*',name,len);
+       str_magic((STR*)stab, stab, '*', name, len);
        stab_stash(stab) = stash;
-       if (isdigit(*name) && *name != '0') {
+       if (isDIGIT(*name) && *name != '0') {
            stab_flags(stab) = SF_VMAGIC;
            str_magic(stab_val(stab), stab, 0, Nullch, 0);
        }
+       if (add & 2)
+           stab->str_pok |= SP_MULTI;
        return stab;
     }
 }
@@ -945,11 +966,14 @@ register STAB *stab;
     stab_xhash(stab) = Null(HASH*);
     str_free(stab_val(stab));
     stab_val(stab) = Nullstr;
+    /*SUPPRESS 560*/
     if (stio = stab_io(stab)) {
        do_close(stab,FALSE);
        Safefree(stio->top_name);
        Safefree(stio->fmt_name);
+       Safefree(stio);
     }
+    /*SUPPRESS 560*/
     if (sub = stab_sub(stab)) {
        afree(sub->tosave);
        cmd_free(sub->cmd);
diff --git a/stab.h b/stab.h
index ddb7d38..3025342 100644 (file)
--- a/stab.h
+++ b/stab.h
@@ -1,4 +1,4 @@
-/* $RCSfile: stab.h,v $$Revision: 4.0.1.1 $$Date: 91/06/07 11:56:35 $
+/* $RCSfile: stab.h,v $$Revision: 4.0.1.2 $$Date: 91/11/05 18:36:15 $
  *
  *    Copyright (c) 1991, Larry Wall
  *
@@ -6,6 +6,9 @@
  *    License or the Artistic License, as specified in the README file.
  *
  * $Log:       stab.h,v $
+ * Revision 4.0.1.2  91/11/05  18:36:15  lwall
+ * patch11: length($x) was sometimes wrong for numeric $x
+ * 
  * Revision 4.0.1.1  91/06/07  11:56:35  lwall
  * patch4: new copyright notice
  * patch4: length($`), length($&), length($') now optimized to avoid string copy
@@ -100,7 +103,7 @@ struct sub {
 STRLEN stab_len();
 
 #define STAB_STR(s) (tmpstab = (s), stab_flags(tmpstab) & SF_VMAGIC ? stab_str(stab_val(tmpstab)->str_magic) : stab_val(tmpstab))
-#define STAB_LEN(s) (tmpstab = (s), stab_flags(tmpstab) & SF_VMAGIC ? stab_len(stab_val(tmpstab)->str_magic) : stab_val(tmpstab)->str_cur)
+#define STAB_LEN(s) (tmpstab = (s), stab_flags(tmpstab) & SF_VMAGIC ? stab_len(stab_val(tmpstab)->str_magic) : str_len(stab_val(tmpstab)))
 #define STAB_GET(s) (tmpstab = (s), str_get(stab_flags(tmpstab) & SF_VMAGIC ? stab_str(tmpstab->str_magic) : stab_val(tmpstab)))
 #define STAB_GNUM(s) (tmpstab = (s), str_gnum(stab_flags(tmpstab) & SF_VMAGIC ? stab_str(tmpstab->str_magic) : stab_val(tmpstab)))
 
diff --git a/str.c b/str.c
index cf5e1f9..4fdc063 100644 (file)
--- a/str.c
+++ b/str.c
@@ -1,4 +1,4 @@
-/* $RCSfile: str.c,v $$Revision: 4.0.1.3 $$Date: 91/06/10 01:27:54 $
+/* $RCSfile: str.c,v $$Revision: 4.0.1.4 $$Date: 91/11/05 18:40:51 $
  *
  *    Copyright (c) 1991, Larry Wall
  *
@@ -6,6 +6,11 @@
  *    License or the Artistic License, as specified in the README file.
  *
  * $Log:       str.c,v $
+ * Revision 4.0.1.4  91/11/05  18:40:51  lwall
+ * patch11: $foo .= <BAR> could overrun malloced memory
+ * patch11: \$ didn't always make it through double-quoter to regexp routines
+ * patch11: prepared for ctype implementations that don't define isascii()
+ * 
  * Revision 4.0.1.3  91/06/10  01:27:54  lwall
  * patch10: $) and $| incorrectly handled in run-time patterns
  * 
@@ -255,6 +260,7 @@ register STR *sstr;
            }
            str_nset(dstr,sstr->str_ptr,sstr->str_cur);
        }
+       /*SUPPRESS 560*/
        if (dstr->str_nok = sstr->str_nok)
            dstr->str_u.str_nval = sstr->str_u.str_nval;
        else {
@@ -556,6 +562,7 @@ STRLEN littlelen;
        *mid = '\0';
        bigstr->str_cur = mid - big;
     }
+    /*SUPPRESS 560*/
     else if (i = mid - big) {  /* faster from front */
        midend -= littlelen;
        mid = midend;
@@ -709,11 +716,13 @@ register STR *str2;
        (void)str_2ptr(str2);
 
     if (str1->str_cur < str2->str_cur) {
+       /*SUPPRESS 560*/
        if (retval = memcmp(str1->str_ptr, str2->str_ptr, str1->str_cur))
            return retval < 0 ? -1 : 1;
        else
            return -1;
     }
+    /*SUPPRESS 560*/
     else if (retval = memcmp(str1->str_ptr, str2->str_ptr, str2->str_cur))
        return retval < 0 ? -1 : 1;
     else if (str1->str_cur == str2->str_cur)
@@ -742,7 +751,7 @@ int append;
     cnt = fp->_cnt;                    /* get count into register */
     str->str_nok = 0;                  /* invalidate number */
     str->str_pok = 1;                  /* validate pointer */
-    if (str->str_len <= cnt + 1) {     /* make sure we have the room */
+    if (str->str_len - append <= cnt + 1) { /* make sure we have the room */
        if (cnt > 80 && str->str_len > append) {
            shortbuffered = cnt - str->str_len + append + 1;
            cnt -= shortbuffered;
@@ -928,14 +937,21 @@ STR *src;
        if (*s == '\\' && s[1] && index("$@[{\\]}lLuUE",s[1])) {
            str_ncat(str, t, s - t);
            ++s;
-           if (isalpha(*s)) {
+           if (isALPHA(*s)) {
                str_ncat(str, "$c", 2);
                sawcase = (*s != 'E');
            }
            else {
-               if (*nointrp && s+1 < send)
-                   if (*s != '@' && (*s != '$' || index(nointrp,s[1])))
+               if (*nointrp) {         /* in a regular expression */
+                   if (*s == '@')      /* always strip \@ */ /*SUPPRESS 530*/
+                       ;
+                   else if (*s == '$') {
+                       if (s+1 >= send || index(nointrp, s[1]))
+                           str_ncat(str,s-1,1); /* only strip \$ for vars */
+                   }
+                   else                /* don't strip \\, \[, \{ etc. */
                        str_ncat(str,s-1,1);
+               }
                str_ncat(str, "$b", 2);
            }
            str_ncat(str, s, 1);
@@ -952,7 +968,7 @@ STR *src;
        else if ((*s == '@' || *s == '$') && 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 = scanident(s,send,tokenbuf);
            if (*t == '@' &&
@@ -988,6 +1004,7 @@ STR *src;
                    case '\'':
                    case '"':
                        if (s[-1] != '$') {
+                           /*SUPPRESS 68*/
                            s = cpytill(tokenbuf,s+1,send,*s,&len);
                            if (s >= send)
                                fatal("Unterminated string");
@@ -1002,10 +1019,10 @@ STR *src;
                    d = checkpoint;
                    if (*d == '{' && s[-1] == '}') {    /* maybe {n,m} */
                        ++d;
-                       if (isdigit(*d)) {      /* matches /^{\d,?\d*}$/ */
+                       if (isDIGIT(*d)) {      /* matches /^{\d,?\d*}$/ */
                            if (*++d == ',')
                                ++d;
-                           while (isdigit(*d))
+                           while (isDIGIT(*d))
                                d++;
                            if (d == s - 1)
                                s = checkpoint;         /* Is {n,m}! Backoff! */
@@ -1022,9 +1039,9 @@ STR *src;
                            weight += 150;
                        else if (d[1] == '$')
                            weight -= 3;
-                       if (isdigit(d[1])) {
+                       if (isDIGIT(d[1])) {
                            if (d[2]) {
-                               if (isdigit(d[2]) && !d[3])
+                               if (isDIGIT(d[2]) && !d[3])
                                    weight -= 10;
                            }
                            else
@@ -1037,8 +1054,7 @@ STR *src;
                            case '&':
                            case '$':
                                weight -= seen[un_char] * 10;
-                               if (isalpha(d[1]) || isdigit(d[1]) ||
-                                 d[1] == '_') {
+                               if (isALNUM(d[1])) {
                                    d = scanident(d,s,tokenbuf);
                                    if (stabent(tokenbuf,FALSE))
                                        weight -= 100;
@@ -1062,9 +1078,9 @@ STR *src;
                                        weight += 1;
                                    else if (index("rnftb",d[1]))
                                        weight += 40;
-                                   else if (isdigit(d[1])) {
+                                   else if (isDIGIT(d[1])) {
                                        weight += 40;
-                                       while (d[1] && isdigit(d[1]))
+                                       while (d[1] && isDIGIT(d[1]))
                                            d++;
                                    }
                                }
@@ -1082,7 +1098,7 @@ STR *src;
                                else
                                    weight -= 1;
                            default:
-                               if (isalpha(*d) && d[1] && isalpha(d[1])) {
+                               if (isALPHA(*d) && d[1] && isALPHA(d[1])) {
                                    bufptr = d;
                                    if (yylex() != WORD)
                                        weight -= 150;
@@ -1243,7 +1259,7 @@ register char *s;
 register char *send;
 {
     while (s < send) {
-       if (isascii(*s) && islower(*s))
+       if (isLOWER(*s))
            *s = toupper(*s);
        s++;
     }
@@ -1254,7 +1270,7 @@ register char *s;
 register char *send;
 {
     while (s < send) {
-       if (isascii(*s) && isupper(*s))
+       if (isUPPER(*s))
            *s = tolower(*s);
        s++;
     }
@@ -1280,22 +1296,22 @@ register STR *str;
        return;
     }
     d = str->str_ptr;
-    while (isalpha(*d)) d++;
-    while (isdigit(*d)) d++;
+    while (isALPHA(*d)) d++;
+    while (isDIGIT(*d)) d++;
     if (*d) {
         str_numset(str,atof(str->str_ptr) + 1.0);  /* punt */
        return;
     }
     d--;
     while (d >= str->str_ptr) {
-       if (isdigit(*d)) {
+       if (isDIGIT(*d)) {
            if (++*d <= '9')
                return;
            *(d--) = '0';
        }
        else {
            ++*d;
-           if (isalpha(*d))
+           if (isALPHA(*d))
                return;
            *(d--) -= 'z' - 'a' + 1;
        }
@@ -1305,7 +1321,7 @@ register STR *str;
     str->str_cur++;
     for (d = str->str_ptr + str->str_cur; d > str->str_ptr; d--)
        *d = d[-1];
-    if (isdigit(d[1]))
+    if (isDIGIT(d[1]))
        *d = '1';
     else
        *d = d[1];
index 92da97a..1d1b22c 100644 (file)
@@ -1,6 +1,6 @@
 #!./perl
 
-# $RCSfile: stat.t,v $$Revision: 4.0.1.1 $$Date: 91/06/07 12:02:42 $
+# $RCSfile: stat.t,v $$Revision: 4.0.1.2 $$Date: 91/11/05 18:44:44 $
 
 print "1..56\n";
 
@@ -9,15 +9,15 @@ chop($cwd = `pwd`);
 $DEV = `ls -l /dev`;
 
 unlink "Op.stat.tmp";
-open(foo, ">Op.stat.tmp");
+open(FOO, ">Op.stat.tmp");
 
 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
-    $blksize,$blocks) = stat(foo);
+    $blksize,$blocks) = stat(FOO);
 if ($nlink == 1) {print "ok 1\n";} else {print "not ok 1\n";}
 if ($mtime && $mtime == $ctime) {print "ok 2\n";} else {print "not ok 2\n";}
 
-print foo "Now is the time for all good men to come to.\n";
-close(foo);
+print FOO "Now is the time for all good men to come to.\n";
+close(FOO);
 
 sleep 2;
 
@@ -141,24 +141,33 @@ if (! -B 'op/stat.t') {print "ok 42\n";} else {print "not ok 42\n";}
 if (-B './perl') {print "ok 43\n";} else {print "not ok 43\n";}
 if (! -T './perl') {print "ok 44\n";} else {print "not ok 44\n";}
 
-open(foo,'op/stat.t');
-if (-T foo) {print "ok 45\n";} else {print "not ok 45\n";}
-if (! -B foo) {print "ok 46\n";} else {print "not ok 46\n";}
-$_ = <foo>;
-if (/perl/) {print "ok 47\n";} else {print "not ok 47\n";}
-if (-T foo) {print "ok 48\n";} else {print "not ok 48\n";}
-if (! -B foo) {print "ok 49\n";} else {print "not ok 49\n";}
-close(foo);
-
-open(foo,'op/stat.t');
-$_ = <foo>;
-if (/perl/) {print "ok 50\n";} else {print "not ok 50\n";}
-if (-T foo) {print "ok 51\n";} else {print "not ok 51\n";}
-if (! -B foo) {print "ok 52\n";} else {print "not ok 52\n";}
-seek(foo,0,0);
-if (-T foo) {print "ok 53\n";} else {print "not ok 53\n";}
-if (! -B foo) {print "ok 54\n";} else {print "not ok 54\n";}
-close(foo);
+open(FOO,'op/stat.t');
+eval { -T FOO; };
+if ($@ =~ /not implemented/) {
+    print "# $@";
+    for (45 .. 54) {
+       print "ok $_\n";
+    }
+}
+else {
+    if (-T FOO) {print "ok 45\n";} else {print "not ok 45\n";}
+    if (! -B FOO) {print "ok 46\n";} else {print "not ok 46\n";}
+    $_ = <FOO>;
+    if (/perl/) {print "ok 47\n";} else {print "not ok 47\n";}
+    if (-T FOO) {print "ok 48\n";} else {print "not ok 48\n";}
+    if (! -B FOO) {print "ok 49\n";} else {print "not ok 49\n";}
+    close(FOO);
+
+    open(FOO,'op/stat.t');
+    $_ = <FOO>;
+    if (/perl/) {print "ok 50\n";} else {print "not ok 50\n";}
+    if (-T FOO) {print "ok 51\n";} else {print "not ok 51\n";}
+    if (! -B FOO) {print "ok 52\n";} else {print "not ok 52\n";}
+    seek(FOO,0,0);
+    if (-T FOO) {print "ok 53\n";} else {print "not ok 53\n";}
+    if (! -B FOO) {print "ok 54\n";} else {print "not ok 54\n";}
+}
+close(FOO);
 
 if (-T '/dev/null') {print "ok 55\n";} else {print "not ok 55\n";}
 if (-B '/dev/null') {print "ok 56\n";} else {print "not ok 56\n";}