From: Larry Wall Date: Tue, 5 Nov 1991 06:28:31 +0000 (+0000) Subject: perl 4.0 patch 17: patch #11, continued X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=de3bb51191e884300caf98892ecfcc0ca3ebc09c;p=p5sagit%2Fp5-mst-13.2.git perl 4.0 patch 17: patch #11, continued See patch #11. --- diff --git a/hints/sunos_4_0_1.sh b/hints/sunos_4_0_1.sh index 7fd8c88..99fce3f 100644 --- a/hints/sunos_4_0_1.sh +++ b/hints/sunos_4_0_1.sh @@ -1 +1 @@ -$ccflags="$ccflags -DFPUTS_BOTCH" +ccflags="$ccflags -DFPUTS_BOTCH" diff --git a/hints/sunos_4_0_2.sh b/hints/sunos_4_0_2.sh index 7fd8c88..99fce3f 100644 --- a/hints/sunos_4_0_2.sh +++ b/hints/sunos_4_0_2.sh @@ -1 +1 @@ -$ccflags="$ccflags -DFPUTS_BOTCH" +ccflags="$ccflags -DFPUTS_BOTCH" diff --git a/hints/ti1500.sh b/hints/ti1500.sh new file mode 100644 index 0000000..3d89250 --- /dev/null +++ b/hints/ti1500.sh @@ -0,0 +1 @@ +d_mymalloc='undef' diff --git a/hints/ultrix_4.sh b/hints/ultrix_4.sh index ffaf376..91e5d7d 100644 --- a/hints/ultrix_4.sh +++ b/hints/ultrix_4.sh @@ -6,6 +6,9 @@ Note that there is a bug in some versions of NFS on the DECStation that may cause utime() to work incorrectly. If so, regression test io/fs may fail if run under NFS. Ignore the failure. EOF + case "$tmp" in + *4.2*) d_volatile=undef;; + esac ;; esac case "$tmp" in diff --git a/patchlevel.h b/patchlevel.h index 29d9127..6dbf069 100644 --- a/patchlevel.h +++ b/patchlevel.h @@ -1 +1 @@ -#define PATCHLEVEL 16 +#define PATCHLEVEL 17 diff --git a/str.h b/str.h index 15c2c68..b2528bc 100644 --- a/str.h +++ b/str.h @@ -1,4 +1,4 @@ -/* $RCSfile: str.h,v $$Revision: 4.0.1.2 $$Date: 91/06/07 11:58:33 $ +/* $RCSfile: str.h,v $$Revision: 4.0.1.3 $$Date: 91/11/05 18:41:47 $ * * Copyright (c) 1991, Larry Wall * @@ -6,6 +6,10 @@ * License or the Artistic License, as specified in the README file. * * $Log: str.h,v $ + * Revision 4.0.1.3 91/11/05 18:41:47 lwall + * patch11: random cleanup + * patch11: solitary subroutine references no longer trigger typo warnings + * * Revision 4.0.1.2 91/06/07 11:58:33 lwall * patch4: new copyright notice * @@ -32,8 +36,8 @@ struct string { STRLEN str_cur; /* length of str_ptr as a C string */ STR *str_magic; /* while free, link to next free str */ /* while in use, ptr to "key" for magic items */ - char str_pok; /* state of str_ptr */ - char str_nok; /* state of str_nval */ + unsigned char str_pok; /* state of str_ptr */ + unsigned char str_nok; /* state of str_nval */ unsigned char str_rare; /* used by search strings */ unsigned char str_state; /* one of SS_* below */ /* also used by search strings for backoff */ @@ -57,8 +61,8 @@ struct stab { /* should be identical, except for str_ptr */ STRLEN str_cur; /* length of str_ptr as a C string */ STR *str_magic; /* while free, link to next free str */ /* while in use, ptr to "key" for magic items */ - char str_pok; /* state of str_ptr */ - char str_nok; /* state of str_nval */ + unsigned char str_pok; /* state of str_ptr */ + unsigned char str_nok; /* state of str_nval */ unsigned char str_rare; /* used by search strings */ unsigned char str_state; /* one of SS_* below */ /* also used by search strings for backoff */ @@ -136,3 +140,5 @@ int str_eq(); void str_magic(); void str_insert(); STRLEN str_len(); + +#define MULTI (3) diff --git a/t/cmd/subval.t b/t/cmd/subval.t index ba4d833..505025f 100644 --- a/t/cmd/subval.t +++ b/t/cmd/subval.t @@ -1,6 +1,6 @@ #!./perl -# $Header: subval.t,v 4.0 91/03/20 01:49:40 lwall Locked $ +# $RCSfile: subval.t,v $$Revision: 4.0.1.1 $$Date: 91/11/05 18:42:31 $ sub foo1 { 'true1'; @@ -102,7 +102,7 @@ print $x eq '1:2:3' ? "ok 26\n" : "not ok 26 $x\n"; sub somesub { local($num,$P,$F,$L) = @_; ($p,$f,$l) = caller; - print "$p:$f:$l" eq "$P:$F:$L" ? "ok $num\n" : "not ok $num\n"; + print "$p:$f:$l" eq "$P:$F:$L" ? "ok $num\n" : "not ok $num $p:$f:$l ne $P:$F:$L\n"; } &somesub(27, 'main', __FILE__, __LINE__); diff --git a/toke.c b/toke.c index d46a960..14ce7f6 100644 --- a/toke.c +++ b/toke.c @@ -1,4 +1,4 @@ -/* $RCSfile: toke.c,v $$Revision: 4.0.1.3 $$Date: 91/06/10 01:32:26 $ +/* $RCSfile: toke.c,v $$Revision: 4.0.1.4 $$Date: 91/11/05 19:02:48 $ * * Copyright (c) 1991, Larry Wall * @@ -6,6 +6,14 @@ * License or the Artistic License, as specified in the README file. * * $Log: toke.c,v $ + * Revision 4.0.1.4 91/11/05 19:02:48 lwall + * patch11: \x and \c were subject to double interpretation in regexps + * patch11: prepared for ctype implementations that don't define isascii() + * patch11: nested list operators could miscount parens + * patch11: once-thru blocks didn't display right in the debugger + * patch11: sort eval "whatever" didn't work + * patch11: underscore is now allowed within literal octal and hex numbers + * * Revision 4.0.1.3 91/06/10 01:32:26 lwall * patch10: m'$foo' now treats string as single quoted * patch10: certain pattern optimizations were botched @@ -41,7 +49,7 @@ /* which backslash sequences to keep in m// or s// */ -static char *patleave = "\\.^$@dDwWsSbB+*?|()-nrtf0123456789[{]}"; +static char *patleave = "\\.^$@dDwWsSbB+*?|()-nrtfeaxc0123456789[{]}"; char *reparse; /* if non-null, scanident found ${foo[$bar]} */ @@ -92,7 +100,7 @@ void checkcomma(); * paren came before the listop rather than after. */ #define LOP(f) return(CLINE, *s == '(' || (s = skipspace(s), *s == '(') ? \ - (*s = META('('), bufptr = oldbufptr, '(') : \ + (*s = (char) 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) @@ -101,7 +109,7 @@ char * skipspace(s) register char *s; { - while (s < bufend && isascii(*s) && isspace(*s)) + while (s < bufend && isSPACE(*s)) s++; return s; } @@ -175,8 +183,10 @@ yylex() #endif #ifdef BADSWITCH if (*s & 128) { - if ((*s & 127) == '(') + if ((*s & 127) == '(') { *s++ = '('; + oldbufptr = s; + } else warn("Unrecognized character \\%03o ignored", *s++ & 255); goto retry; @@ -184,8 +194,10 @@ yylex() #endif switch (*s) { default: - if ((*s & 127) == '(') + if ((*s & 127) == '(') { *s++ = '('; + oldbufptr = s; + } else warn("Unrecognized character \\%03o ignored", *s++ & 255); goto retry; @@ -238,7 +250,7 @@ yylex() if (rsfp) { if (preprocess) (void)mypclose(rsfp); - else if (rsfp == stdin) + else if ((FILE*)rsfp == stdin) clearerr(stdin); else (void)fclose(rsfp); @@ -283,15 +295,15 @@ yylex() if (*s == ' ') s++; cmd = s; - while (s < bufend && !isspace(*s)) + while (s < bufend && !isSPACE(*s)) s++; *s++ = '\0'; - while (s < bufend && isspace(*s)) + while (s < bufend && isSPACE(*s)) s++; if (s < bufend) { Newz(899,newargv,origargc+3,char*); newargv[1] = s; - while (s < bufend && !isspace(*s)) + while (s < bufend && !isSPACE(*s)) s++; *s = '\0'; Copy(origargv+1, newargv+2, origargc+1, char*); @@ -304,7 +316,7 @@ yylex() } } else { - while (s < bufend && isspace(*s)) + while (s < bufend && isSPACE(*s)) s++; if (*s == ':') /* for csh's that have to exec sh scripts */ s++; @@ -316,11 +328,14 @@ yylex() goto retry; case '#': if (preprocess && s == str_get(linestr) && - s[1] == ' ' && isdigit(s[2])) { - curcmd->c_line = atoi(s+2)-1; - for (s += 2; isdigit(*s); s++) ; + s[1] == ' ' && (isDIGIT(s[2]) || strnEQ(s+2,"line ",5)) ) { + while (*s && !isDIGIT(*s)) + s++; + curcmd->c_line = atoi(s)-1; + while (isDIGIT(*s)) + s++; d = bufend; - while (s < d && isspace(*s)) s++; + while (s < d && isSPACE(*s)) s++; s[strlen(s)-1] = '\0'; /* wipe out newline */ if (*s == '"') { s++; @@ -355,7 +370,7 @@ yylex() } goto retry; case '-': - if (s[1] && isalpha(s[1]) && !isalpha(s[2])) { + if (s[1] && isALPHA(s[1]) && !isALPHA(s[2])) { s++; switch (*s++) { case 'r': FTST(O_FTEREAD); @@ -441,7 +456,8 @@ yylex() OPERATOR(tmp); case '{': tmp = *s++; - if (isspace(*s) || *s == '#') + yylval.ival = curcmd->c_line; + if (isSPACE(*s) || *s == '#') cmdline = NOLINE; /* invalidate current command line number */ OPERATOR(tmp); case ';': @@ -464,9 +480,9 @@ yylex() s--; if (expectterm) { d = bufend; - while (s < d && isspace(*s)) + while (s < d && isSPACE(*s)) s++; - if (isalpha(*s) || *s == '_' || *s == '\'') + if (isALPHA(*s) || *s == '_' || *s == '\'') *(--s) = '\\'; /* force next ident to WORD */ OPERATOR(AMPER); } @@ -526,8 +542,7 @@ yylex() #define SNARFWORD \ d = tokenbuf; \ - while (isascii(*s) && \ - (isalpha(*s) || isdigit(*s) || *s == '_' || *s == '\'')) \ + while (isALNUM(*s) || *s == '\'') \ *d++ = *s++; \ while (d[-1] == '\'') \ d--,s--; \ @@ -535,7 +550,7 @@ yylex() d = tokenbuf; case '$': - if (s[1] == '#' && (isalpha(s[2]) || s[2] == '_')) { + if (s[1] == '#' && (isALPHA(s[2]) || s[2] == '_')) { s++; s = scanident(s,bufend,tokenbuf); yylval.stabval = aadd(stabent(tokenbuf,TRUE)); @@ -574,7 +589,7 @@ yylex() OPERATOR(tmp); case '.': - if (!expectterm || !isdigit(s[1])) { + if (!expectterm || !isDIGIT(s[1])) { tmp = *s++; if (*s == tmp) { s++; @@ -613,6 +628,7 @@ yylex() STAB *stab; int fd; + /*SUPPRESS 560*/ if (stab = stabent("DATA",FALSE)) { stab->str_pok |= SP_MULTI; stab_io(stab) = stio_new(); @@ -623,7 +639,7 @@ yylex() #endif if (preprocess) stab_io(stab)->type = '|'; - else if (rsfp == stdin) + else if ((FILE*)rsfp == stdin) stab_io(stab)->type = '-'; else stab_io(stab)->type = '<'; @@ -670,7 +686,10 @@ yylex() UNI(O_CALLER); if (strEQ(d,"crypt")) { #ifdef FCRYPT - init_des(); + static int cryptseen = 0; + + if (!cryptseen++) + init_des(); #endif FUN2(O_CRYPT); } @@ -689,9 +708,9 @@ yylex() SNARFWORD; if (strEQ(d,"do")) { d = bufend; - while (s < d && isspace(*s)) + while (s < d && isSPACE(*s)) s++; - if (isalpha(*s) || *s == '_') + if (isALPHA(*s) || *s == '_') *(--s) = '\\'; /* force next ident to WORD */ OPERATOR(DO); } @@ -755,9 +774,9 @@ yylex() } if (strEQ(d,"format")) { d = bufend; - while (s < d && isspace(*s)) + while (s < d && isSPACE(*s)) s++; - if (isalpha(*s) || *s == '_') + if (isALPHA(*s) || *s == '_') *(--s) = '\\'; /* force next ident to WORD */ in_format = TRUE; allstabs = TRUE; /* must initialize everything since */ @@ -1125,11 +1144,12 @@ yylex() if (strEQ(d,"sort")) { checkcomma(s,"subroutine name"); d = bufend; - while (s < d && isascii(*s) && isspace(*s)) s++; + while (s < d && isSPACE(*s)) s++; if (*s == ';' || *s == ')') /* probably a close */ fatal("sort is now a reserved word"); - if (isascii(*s) && (isalpha(*s) || *s == '_')) { - for (d = s; isalpha(*d) || isdigit(*d) || *d == '_'; d++) ; + if (isALPHA(*s) || *s == '_') { + /*SUPPRESS 530*/ + for (d = s; isALNUM(*d); d++) ; strncpy(tokenbuf,s,d-s); if (strNE(tokenbuf,"keys") && strNE(tokenbuf,"values") && @@ -1138,7 +1158,8 @@ yylex() strNE(tokenbuf,"readdir") && strNE(tokenbuf,"unpack") && strNE(tokenbuf,"do") && - (d >= bufend || isspace(*d)) ) + strNE(tokenbuf,"eval") && + (d >= bufend || isSPACE(*d)) ) *(--s) = '\\'; /* force next ident to WORD */ } LOP(O_SORT); @@ -1176,17 +1197,23 @@ yylex() if (strEQ(d,"substr")) FUN2x(O_SUBSTR); if (strEQ(d,"sub")) { + yylval.ival = savestack->ary_fill; /* restore stuff on reduce */ + if (perldb) { + savelong(&subline); + saveitem(subname); + } + subline = curcmd->c_line; d = bufend; - while (s < d && isspace(*s)) + while (s < d && isSPACE(*s)) s++; - if (isalpha(*s) || *s == '_' || *s == '\'') { + if (isALPHA(*s) || *s == '_' || *s == '\'') { if (perldb) { str_sset(subname,curstname); str_ncat(subname,"'",1); - for (d = s+1; - isalpha(*d) || isdigit(*d) || *d == '_' || *d == '\''; - d++); + for (d = s+1; isALNUM(*d) || *d == '\''; d++) + /*SUPPRESS 530*/ + ; if (d[-1] == '\'') d--; str_ncat(subname,s,d-s); @@ -1322,7 +1349,7 @@ yylex() yylval.cval = savestr(d); expectterm = FALSE; if (oldoldbufptr && oldoldbufptr < bufptr) { - while (isspace(*oldoldbufptr)) + while (isSPACE(*oldoldbufptr)) oldoldbufptr++; if (*oldoldbufptr == 'p' && strnEQ(oldoldbufptr,"print",5)) expectterm = TRUE; @@ -1341,13 +1368,13 @@ char *what; if (*s == '(') s++; - while (s < bufend && isascii(*s) && isspace(*s)) + while (s < bufend && isSPACE(*s)) s++; - if (isascii(*s) && (isalpha(*s) || *s == '_')) { + if (isALPHA(*s) || *s == '_') { someword = s++; - while (isalpha(*s) || isdigit(*s) || *s == '_') + while (isALNUM(*s)) s++; - while (s < bufend && isspace(*s)) + while (s < bufend && isSPACE(*s)) s++; if (*s == ',') { *s = '\0'; @@ -1375,12 +1402,12 @@ char *dest; reparse = Nullch; s++; d = dest; - if (isdigit(*s)) { - while (isdigit(*s)) + if (isDIGIT(*s)) { + while (isDIGIT(*s)) *d++ = *s++; } else { - while (isalpha(*s) || isdigit(*s) || *s == '_' || *s == '\'') + while (isALNUM(*s) || *s == '\'') *d++ = *s++; } while (d > dest+1 && d[-1] == '\'') @@ -1393,8 +1420,7 @@ char *dest; d = dest; brackets++; while (s < send && brackets) { - if (!reparse && (d == dest || (*s && isascii(*s) && - (isalpha(*s) || isdigit(*s) || *s == '_') ))) { + if (!reparse && (d == dest || (*s && isALNUM(*s) ))) { *d++ = *s++; continue; } @@ -1418,18 +1444,23 @@ char *dest; else d[1] = '\0'; } - if (*d == '^' && (isupper(*s) || index("[\\]^_?",*s))) + if (*d == '^' && (isUPPER(*s) || index("[\\]^_?", *s))) { +#ifdef DEBUGGING + if (*s == 'D') + debug |= 32768; +#endif *d = *s++ ^ 64; + } return s; } -STR * +void scanconst(spat,string,len) SPAT *spat; char *string; int len; { - register STR *retstr; + register STR *tmpstr; register char *t; register char *d; register char *e; @@ -1437,27 +1468,28 @@ int len; static char *vert = "|"; if (ninstr(string, string+len, vert, vert+1)) - return Nullstr; + return; if (*string == '^') string++, len--; - retstr = Str_new(86,len); - str_nset(retstr,string,len); - t = str_get(retstr); + tmpstr = Str_new(86,len); + str_nset(tmpstr,string,len); + t = str_get(tmpstr); e = t + len; - retstr->str_u.str_useful = 100; + tmpstr->str_u.str_useful = 100; for (d=t; d < e; ) { switch (*d) { case '{': - if (isdigit(d[1])) + if (isDIGIT(d[1])) e = d; else goto defchar; break; case '.': case '[': case '$': case '(': case ')': case '|': case '+': + case '^': e = d; break; case '\\': - if (d[1] && index("wWbB0123456789sSdDlLuUE",d[1])) { + if (d[1] && index("wWbB0123456789sSdDlLuUExc",d[1])) { e = d; break; } @@ -1494,18 +1526,17 @@ int len; } } if (d == t) { - str_free(retstr); - return Nullstr; + str_free(tmpstr); + return; } *d = '\0'; - retstr->str_cur = d - t; + tmpstr->str_cur = d - t; if (d == t+len) spat->spat_flags |= SPAT_ALL; if (*origstring != '^') spat->spat_flags |= SPAT_SCANFIRST; - spat->spat_short = retstr; + spat->spat_short = tmpstr; spat->spat_slen = d - t; - return retstr; } char * @@ -1663,15 +1694,15 @@ register char *s; arg->arg_type = O_ITEM; arg[1].arg_type = A_DOUBLE; arg[1].arg_ptr.arg_str = str_smake(str); - d = scanident(d,bufend,buf); + d = scanident(d,e,buf); (void)stabent(buf,TRUE); /* make sure it's created */ for (; *d; d++) { if (*d == '$' && d[1] && d[-1] != '\\' && d[1] != '|') { - d = scanident(d,bufend,buf); + d = scanident(d,e,buf); (void)stabent(buf,TRUE); } else if (*d == '@' && d[-1] != '\\') { - d = scanident(d,bufend,buf); + d = scanident(d,e,buf); if (strEQ(buf,"ARGV") || strEQ(buf,"ENV") || strEQ(buf,"SIG") || strEQ(buf,"INC")) (void)stabent(buf,TRUE); @@ -1701,7 +1732,7 @@ get_repl: e = tmpstr->str_ptr + tmpstr->str_cur; for (t = tmpstr->str_ptr; t < e; t++) { if (*t == '$' && t[1] && (index("`'&+0123456789",t[1]) || - (t[1] == '{' /*}*/ && isdigit(t[2])) )) + (t[1] == '{' /*}*/ && isDIGIT(t[2])) )) spat->spat_flags &= ~SPAT_CONST; } } @@ -1710,7 +1741,9 @@ get_repl: s++; if ((spat->spat_repl[1].arg_type & A_MASK) == A_DOUBLE) spat->spat_repl[1].arg_type = A_SINGLE; - spat->spat_repl = make_op(O_EVAL,2, + spat->spat_repl = make_op( + (spat->spat_repl[1].arg_type == A_SINGLE ? O_EVALONCE : O_EVAL), + 2, spat->spat_repl, Nullarg, Nullarg); @@ -1950,6 +1983,9 @@ register char *s; switch (*s) { default: goto out; + case '_': + s++; + break; case '8': case '9': if (shift != 4) yyerror("Illegal octal digit"); @@ -1984,7 +2020,7 @@ register char *s; decimal: arg[1].arg_type = A_SINGLE; d = tokenbuf; - while (isdigit(*s) || *s == '_') { + while (isDIGIT(*s) || *s == '_') { if (*s == '_') s++; else @@ -1992,7 +2028,7 @@ register char *s; } if (*s == '.' && s[1] && index("0123456789eE ;",s[1])) { *d++ = *s++; - while (isdigit(*s) || *s == '_') { + while (isDIGIT(*s) || *s == '_') { if (*s == '_') s++; else @@ -2003,7 +2039,7 @@ register char *s; *d++ = *s++; if (*s == '+' || *s == '-') *d++ = *s++; - while (isdigit(*s)) + while (isDIGIT(*s)) *d++ = *s++; } *d = '\0'; @@ -2034,7 +2070,7 @@ register char *s; s++, term = '\''; else term = '"'; - while (isascii(*s) && (isalpha(*s) || isdigit(*s) || *s == '_')) + while (isALNUM(*s)) *d++ = *s++; } /* assuming tokenbuf won't clobber */ *d++ = '\n'; @@ -2057,8 +2093,7 @@ register char *s; if (s < bufend) s++; if (*d == '$') d++; - while (*d && - (isalpha(*d) || isdigit(*d) || *d == '_' || *d == '\'')) + while (*d && (isALNUM(*d) || *d == '\'')) d++; if (d - tokenbuf != len) { d = tokenbuf; @@ -2209,7 +2244,7 @@ register char *s; s = tmpstr->str_ptr; send = s + tmpstr->str_cur; while (s < send) { /* see if we can make SINGLE */ - if (*s == '\\' && s[1] && isdigit(s[1]) && !isdigit(s[2]) && + if (*s == '\\' && s[1] && isDIGIT(s[1]) && !isDIGIT(s[2]) && !alwaysdollar && s[1] != '0') *s = '$'; /* grandfather \digit in subst */ if ((*s == '$' || *s == '@') && s+1 < send && @@ -2228,6 +2263,8 @@ register char *s; if ((*s == '$' && s+1 < send && (alwaysdollar || /*(*/ (s[1] != ')' && s[1] != '|')) ) || (*s == '@' && s+1 < send) ) { + if (s[1] == '#' && (isALPHA(s[2]) || s[2] == '_')) + *d++ = *s++; len = scanident(s,send,tokenbuf) - s; if (*s == '$' || strEQ(tokenbuf,"ARGV") || strEQ(tokenbuf,"ENV") @@ -2258,7 +2295,7 @@ register char *s; case 'c': s++; *d = *s++; - if (islower(*d)) + if (isLOWER(*d)) *d = toupper(*d); *d++ ^= 64; continue; @@ -2337,6 +2374,7 @@ load_format() astore(stab_xarray(curcmd->c_filestab), (int)curcmd->c_line,tmpstr); } if (*s == '.') { + /*SUPPRESS 530*/ for (t = s+1; *t == ' ' || *t == '\t'; t++) ; if (*t == '\n') { bufptr = s; @@ -2479,7 +2517,7 @@ load_format() } else { eol[-1] = '\n'; - while (s < eol && isspace(*s)) + while (s < eol && isSPACE(*s)) s++; t = s; while (s < eol) { @@ -2487,7 +2525,7 @@ load_format() case ' ': case '\t': case '\n': case ';': str_ncat(str, t, s - t); str_ncat(str, "," ,1); - while (s < eol && (isspace(*s) || *s == ';')) + while (s < eol && (isSPACE(*s) || *s == ';')) s++; t = s; break; diff --git a/usub/usersub.c b/usub/usersub.c index 559f9a4..ffbfbe1 100644 --- a/usub/usersub.c +++ b/usub/usersub.c @@ -1,6 +1,9 @@ -/* $Header: usersub.c,v 4.0 91/03/20 01:56:34 lwall Locked $ +/* $RCSfile: usersub.c,v $$Revision: 4.0.1.1 $$Date: 91/11/05 19:07:24 $ * * $Log: usersub.c,v $ + * Revision 4.0.1.1 91/11/05 19:07:24 lwall + * patch11: there are now subroutines for calling back from C into Perl + * * Revision 4.0 91/03/20 01:56:34 lwall * 4.0 baseline. * @@ -18,3 +21,52 @@ userinit() init_curses(); } +/* Be sure to refetch the stack pointer after calling these routines. */ + +int +callback(subname, sp, gimme, hasargs, numargs) +char *subname; +int sp; /* stack pointer after args are pushed */ +int gimme; /* called in array or scalar context */ +int hasargs; /* whether to create a @_ array for routine */ +int numargs; /* how many args are pushed on the stack */ +{ + static ARG myarg[3]; /* fake syntax tree node */ + int arglast[3]; + + arglast[2] = sp; + sp -= numargs; + arglast[1] = sp--; + arglast[0] = sp; + + if (!myarg[0].arg_ptr.arg_str) + myarg[0].arg_ptr.arg_str = str_make("",0); + + myarg[1].arg_type = A_WORD; + myarg[1].arg_ptr.arg_stab = stabent(subname, FALSE); + + myarg[2].arg_type = hasargs ? A_EXPR : A_NULL; + + return do_subr(myarg, gimme, arglast); +} + +int +callv(subname, sp, gimme, argv) +char *subname; +register int sp; /* current stack pointer */ +int gimme; /* called in array or scalar context */ +register char **argv; /* null terminated arg list, NULL for no arglist */ +{ + register int items = 0; + int hasargs = (argv != 0); + + astore(stack, ++sp, Nullstr); /* reserve spot for 1st return arg */ + if (hasargs) { + while (*argv) { + astore(stack, ++sp, str_2mortal(str_make(*argv,0))); + items++; + argv++; + } + } + return callback(subname, sp, gimme, hasargs, items); +} diff --git a/util.c b/util.c index af1a2b7..e55b2ef 100644 --- a/util.c +++ b/util.c @@ -1,4 +1,4 @@ -/* $RCSfile: util.c,v $$Revision: 4.0.1.2 $$Date: 91/06/07 12:10:42 $ +/* $RCSfile: util.c,v $$Revision: 4.0.1.3 $$Date: 91/11/05 19:18:26 $ * * Copyright (c) 1991, Larry Wall * @@ -6,6 +6,12 @@ * License or the Artistic License, as specified in the README file. * * $Log: util.c,v $ + * Revision 4.0.1.3 91/11/05 19:18:26 lwall + * patch11: safe malloc code now integrated into Perl's malloc when possible + * patch11: index("little", "longer string") could visit faraway places + * patch11: warn '-' x 10000 dumped core + * patch11: forked exec on non-existent program now issues a warning + * * Revision 4.0.1.2 91/06/07 12:10:42 lwall * patch4: new copyright notice * patch4: made some allowances for "semi-standard" C @@ -20,6 +26,7 @@ * 4.0 baseline. * */ +/*SUPPRESS 112*/ #include "EXTERN.h" #include "perl.h" @@ -45,6 +52,8 @@ #define FLUSH +#ifndef safemalloc + static char nomem[] = "Out of memory!\n"; /* paranoid version of malloc */ @@ -173,10 +182,13 @@ char *where; # endif #endif if (where) { + /*SUPPRESS 701*/ free(where); } } +#endif /* !safemalloc */ + #ifdef LEAKTEST #define ALIGN sizeof(long) @@ -222,7 +234,7 @@ xstat() register int i; for (i = 0; i < MAXXCOUNT; i++) { - if (xcount[i] != lastxcount[i]) { + if (xcount[i] > lastxcount[i]) { fprintf(stderr,"%2d %2d\t%ld\n", i / 100, i % 100, xcount[i]); lastxcount[i] = xcount[i]; } @@ -307,6 +319,8 @@ char *lend; if (!first && little > littleend) return big; + if (bigend - big < littleend - little) + return Nullch; bigend -= littleend - little++; while (big <= bigend) { if (*big++ != first) @@ -433,8 +447,8 @@ int iflag; { register unsigned char *s; register unsigned char *table; - register int i; - register int len = str->str_cur; + register unsigned int i; + register unsigned int len = str->str_cur; int rarest = 0; unsigned int frequency = 256; @@ -564,6 +578,7 @@ STR *littlestr; if (littlestr->str_pok & SP_CASEFOLD) { /* case insensitive? */ if (s < bigend) { top1: + /*SUPPRESS 560*/ if (tmp = table[*s]) { #ifdef POINTERRIGOR if (bigend - s > tmp) { @@ -597,6 +612,7 @@ STR *littlestr; else { if (s < bigend) { top2: + /*SUPPRESS 560*/ if (tmp = table[*s]) { #ifdef POINTERRIGOR if (bigend - s > tmp) { @@ -660,17 +676,82 @@ STR *littlestr; big = Null(unsigned char*); #endif bigend = big + bigstr->str_cur; - big -= previous; while (pos < previous) { #ifndef lint if (!(pos += screamnext[pos])) #endif return Nullch; } +#ifdef POINTERRIGOR if (littlestr->str_pok & SP_CASEFOLD) { /* case insignificant? */ do { - if (big[pos] != first && big[pos] != fold[first]) - continue; +#ifndef lint + while (big[pos-previous] != first && big[pos-previous] != fold[first] + && (pos += screamnext[pos]) ) + /*SUPPRESS 530*/ + ; +#endif + for (x=big+pos+1-previous,s=little; s < littleend; /**/ ) { + if (x >= bigend) + return Nullch; + if (*s++ != *x++ && fold[*(s-1)] != *(x-1)) { + s--; + break; + } + } + if (s == littleend) +#ifndef lint + return (char *)(big+pos-previous); +#else + return Nullch; +#endif + } while ( +#ifndef lint + pos += screamnext[pos] /* does this goof up anywhere? */ +#else + pos += screamnext[0] +#endif + ); + } + else { + do { +#ifndef lint + while (big[pos-previous] != first && (pos += screamnext[pos])) + /*SUPPRESS 530*/ + ; +#endif + for (x=big+pos+1-previous,s=little; s < littleend; /**/ ) { + if (x >= bigend) + return Nullch; + if (*s++ != *x++) { + s--; + break; + } + } + if (s == littleend) +#ifndef lint + return (char *)(big+pos-previous); +#else + return Nullch; +#endif + } while ( +#ifndef lint + pos += screamnext[pos] +#else + pos += screamnext[0] +#endif + ); + } +#else /* !POINTERRIGOR */ + big -= previous; + if (littlestr->str_pok & SP_CASEFOLD) { /* case insignificant? */ + do { +#ifndef lint + while (big[pos] != first && big[pos] != fold[first] + && (pos += screamnext[pos]) ) + /*SUPPRESS 530*/ + ; +#endif for (x=big+pos+1,s=little; s < littleend; /**/ ) { if (x >= bigend) return Nullch; @@ -695,8 +776,11 @@ STR *littlestr; } else { do { - if (big[pos] != first) - continue; +#ifndef lint + while (big[pos] != first && (pos += screamnext[pos])) + /*SUPPRESS 530*/ + ; +#endif for (x=big+pos+1,s=little; s < littleend; /**/ ) { if (x >= bigend) return Nullch; @@ -719,6 +803,7 @@ STR *littlestr; #endif ); } +#endif /* POINTERRIGOR */ return Nullch; } @@ -774,10 +859,20 @@ char *pat; long a1, a2, a3, a4; { char *s; + int usermess = strEQ(pat,"%s"); + STR *tmpstr; s = buf; - (void)sprintf(s,pat,a1,a2,a3,a4); - s += strlen(s); + if (usermess) { + tmpstr = str_mortal(&str_undef); + str_set(tmpstr, (char*)a1); + *s++ = tmpstr->str_ptr[tmpstr->str_cur-1]; + } + else { + (void)sprintf(s,pat,a1,a2,a3,a4); + s += strlen(s); + } + if (s[-1] != '\n') { if (curcmd->c_line) { (void)sprintf(s," at %s line %ld", @@ -793,7 +888,13 @@ long a1, a2, a3, a4; s += strlen(s); } (void)strcpy(s,".\n"); + if (usermess) + str_cat(tmpstr,buf+1); } + if (usermess) + return tmpstr->str_ptr; + else + return buf; } /*VARARGS1*/ @@ -804,10 +905,11 @@ long a1, a2, a3, a4; extern FILE *e_fp; extern char *e_tmpname; char *tmps; + char *message; - mess(pat,a1,a2,a3,a4); + message = mess(pat,a1,a2,a3,a4); if (in_eval) { - str_set(stab_val(stabent("@",TRUE)),buf); + str_set(stab_val(stabent("@",TRUE)),message); tmps = "_EVAL_"; while (loop_ptr >= 0 && (!loop_stack[loop_ptr].loop_label || strNE(tmps,loop_stack[loop_ptr].loop_label) )) { @@ -831,7 +933,7 @@ long a1, a2, a3, a4; } longjmp(loop_stack[loop_ptr].loop_env, 1); } - fputs(buf,stderr); + fputs(message,stderr); (void)fflush(stderr); if (e_fp) (void)UNLINK(e_tmpname); @@ -844,8 +946,10 @@ warn(pat,a1,a2,a3,a4) char *pat; long a1, a2, a3, a4; { - mess(pat,a1,a2,a3,a4); - fputs(buf,stderr); + char *message; + + message = mess(pat,a1,a2,a3,a4); + fputs(message,stderr); #ifdef LEAKTEST #ifdef DEBUGGING if (debug & 4096) @@ -856,11 +960,14 @@ long a1, a2, a3, a4; } #else /*VARARGS0*/ +char * mess(args) va_list args; { char *pat; char *s; + STR *tmpstr; + int usermess; #ifndef HAS_VPRINTF #ifdef CHARVSPRINTF char *vsprintf(); @@ -869,15 +976,23 @@ va_list args; #endif #endif - s = buf; #ifdef lint pat = Nullch; #else pat = va_arg(args, char *); #endif - (void) vsprintf(s,pat,args); + s = buf; + usermess = strEQ(pat, "%s"); + if (usermess) { + tmpstr = str_mortal(&str_undef); + str_set(tmpstr, va_arg(args, char *)); + *s++ = tmpstr->str_ptr[tmpstr->str_cur-1]; + } + else { + (void) vsprintf(s,pat,args); + s += strlen(s); + } - s += strlen(s); if (s[-1] != '\n') { if (curcmd->c_line) { (void)sprintf(s," at %s line %ld", @@ -893,7 +1008,14 @@ va_list args; s += strlen(s); } (void)strcpy(s,".\n"); + if (usermess) + str_cat(tmpstr,buf+1); } + + if (usermess) + return tmpstr->str_ptr; + else + return buf; } /*VARARGS0*/ @@ -904,16 +1026,17 @@ va_dcl extern FILE *e_fp; extern char *e_tmpname; char *tmps; + char *message; #ifndef lint va_start(args); #else args = 0; #endif - mess(args); + message = mess(args); va_end(args); if (in_eval) { - str_set(stab_val(stabent("@",TRUE)),buf); + str_set(stab_val(stabent("@",TRUE)),message); tmps = "_EVAL_"; while (loop_ptr >= 0 && (!loop_stack[loop_ptr].loop_label || strNE(tmps,loop_stack[loop_ptr].loop_label) )) { @@ -937,7 +1060,7 @@ va_dcl } longjmp(loop_stack[loop_ptr].loop_env, 1); } - fputs(buf,stderr); + fputs(message,stderr); (void)fflush(stderr); if (e_fp) (void)UNLINK(e_tmpname); @@ -950,16 +1073,17 @@ warn(va_alist) va_dcl { va_list args; + char *message; #ifndef lint va_start(args); #else args = 0; #endif - mess(args); + message = mess(args); va_end(args); - fputs(buf,stderr); + fputs(message,stderr); #ifdef LEAKTEST #ifdef DEBUGGING if (debug & 4096) @@ -981,6 +1105,7 @@ char *nam, *val; int max; char **tmpenv; + /*SUPPRESS 530*/ for (max = i; environ[max]; max++) ; New(901,tmpenv, max+2, char*); for (j=0; jstr_u.str_useful; astore(fdpid,fileno(ptr),Nullstr); fclose(ptr); - pid = (int)str->str_u.str_useful; hstat = signal(SIGHUP, SIG_IGN); istat = signal(SIGINT, SIG_IGN); qstat = signal(SIGQUIT, SIG_IGN); @@ -1340,9 +1467,11 @@ int pid; int *statusp; int flags; { +#if !defined(HAS_WAIT4) && !defined(HAS_WAITPID) int result; STR *str; char spid[16]; +#endif if (!pid) return -1; @@ -1387,6 +1516,7 @@ int flags; #endif } +/*SUPPRESS 590*/ pidgone(pid,status) int pid; int status; diff --git a/util.h b/util.h index 8d013ff..a712436 100644 --- a/util.h +++ b/util.h @@ -1,4 +1,4 @@ -/* $RCSfile: util.h,v $$Revision: 4.0.1.1 $$Date: 91/06/07 12:11:00 $ +/* $RCSfile: util.h,v $$Revision: 4.0.1.2 $$Date: 91/11/05 19:18:40 $ * * Copyright (c) 1991, Larry Wall * @@ -6,6 +6,9 @@ * License or the Artistic License, as specified in the README file. * * $Log: util.h,v $ + * Revision 4.0.1.2 91/11/05 19:18:40 lwall + * patch11: safe malloc code now integrated into Perl's malloc when possible + * * Revision 4.0.1.1 91/06/07 12:11:00 lwall * patch4: new copyright notice * @@ -17,8 +20,10 @@ EXT int *screamfirst INIT(Null(int*)); EXT int *screamnext INIT(Null(int*)); +#ifndef safemalloc char *safemalloc(); char *saferealloc(); +#endif char *cpytill(); char *instr(); char *fbminstr();