From: Larry Wall Date: Tue, 5 Nov 1991 06:28:06 +0000 (+0000) Subject: perl 4.0 patch 16: patch #11, continued X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=f0fcb5529109ae3ced6c7fbb8cbd77162fa9bfdb;p=p5sagit%2Fp5-mst-13.2.git perl 4.0 patch 16: patch #11, continued See patch #11. --- diff --git a/hints/stellar.sh b/hints/stellar.sh new file mode 100644 index 0000000..23e15e9 --- /dev/null +++ b/hints/stellar.sh @@ -0,0 +1,2 @@ +optimize="-O0" +ccflags="$ccflags -nw" diff --git a/lib/perldb.pl b/lib/perldb.pl index 8d16054..917469b 100644 --- a/lib/perldb.pl +++ b/lib/perldb.pl @@ -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; } } '; diff --git a/patchlevel.h b/patchlevel.h index 69d9c2f..29d9127 100644 --- a/patchlevel.h +++ b/patchlevel.h @@ -1 +1 @@ -#define PATCHLEVEL 15 +#define PATCHLEVEL 16 diff --git a/perly.y b/perly.y index 4032e10..5f31fd1 100644 --- 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 * @@ -18,6 +23,10 @@ #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 '{' ')' + %token WORD %token APPEND OPEN SSELECT LOOPEX %token USING FORMAT DO SHIFT PUSH POP LVALFUN @@ -49,7 +60,7 @@ ARG *arg5; %token SUBST PATTERN %token RSTRING TRANS -%type prog decl format remember +%type prog decl format remember crp %type block lineseq line loop cond sideff nexpr else %type expr sexpr cexpr csexpr term handle aryword hshword %type 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", diff --git a/regcomp.c b/regcomp.c index 92e43a3..0fd50c0 100644 --- 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 = ®dummy; - 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"); } diff --git a/regexec.c b/regexec.c index bb63eda..226aab4 100644 --- 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 * @@ -65,11 +69,6 @@ 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 --- 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 --- 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 --- 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 .= 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]; diff --git a/t/op/stat.t b/t/op/stat.t index 92da97a..1d1b22c 100644 --- a/t/op/stat.t +++ b/t/op/stat.t @@ -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";} -$_ = ; -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'); -$_ = ; -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";} + $_ = ; + 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'); + $_ = ; + 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";}