From: Larry Wall Date: Thu, 4 Feb 1993 22:50:33 +0000 (+0000) Subject: perl 4.0 patch 36: (combined patch) X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=e334a159a5616cab575044bafaf68f75b7bb3a16;p=p5sagit%2Fp5-mst-13.2.git perl 4.0 patch 36: (combined patch) Since Ed Barton sent me a patch for the malignent form of "Malformed cmd links", I finally broke down and made a patch for the various other little things that have been accumulating on version 4. --- diff --git a/cons.c b/cons.c index 54fa14d..8b1210d 100644 --- a/cons.c +++ b/cons.c @@ -85,6 +85,7 @@ CMD *cmd; Nullarg,mycompblock)); saw_return = FALSE; cmd->c_flags |= CF_TERM; + cmd->c_head = cmd; } sub->cmd = cmd; if (perldb) { @@ -1353,7 +1354,8 @@ int willsave; /* willsave passes down the tree */ /* in any event, save the iterator */ - (void)apush(tosave,cmd->c_short); + if (cmd->c_short) /* Better safe than sorry */ + (void)apush(tosave,cmd->c_short); } shouldsave |= tmpsave; } @@ -1420,7 +1422,7 @@ int willsave; shouldsave = TRUE; break; } - if (willsave) + if (willsave && arg->arg_ptr.arg_str) (void)apush(tosave,arg->arg_ptr.arg_str); return shouldsave; } diff --git a/cons.c.orig b/cons.c.orig new file mode 100644 index 0000000..54fa14d --- /dev/null +++ b/cons.c.orig @@ -0,0 +1,1442 @@ +/* $RCSfile: cons.c,v $$Revision: 4.0.1.3 $$Date: 92/06/08 12:18:35 $ + * + * Copyright (c) 1991, Larry Wall + * + * You may distribute under the terms of either the GNU General Public + * License or the Artistic License, as specified in the README file. + * + * $Log: cons.c,v $ + * Revision 4.0.1.3 92/06/08 12:18:35 lwall + * patch20: removed implicit int declarations on funcions + * patch20: deleted some minor memory leaks + * patch20: fixed double debug break in foreach with implicit array assignment + * patch20: fixed confusion between a *var's real name and its effective name + * patch20: Perl now distinguishes overlapped copies from non-overlapped + * patch20: debugger sometimes displayed wrong source line + * patch20: various error messages have been clarified + * patch20: an eval block containing a null block or statement could dump core + * + * Revision 4.0.1.2 91/11/05 16:15:13 lwall + * patch11: debugger got confused over nested subroutine definitions + * patch11: prepared for ctype implementations that don't define isascii() + * + * Revision 4.0.1.1 91/06/07 10:31:15 lwall + * patch4: new copyright notice + * patch4: added global modifier for pattern matches + * + * Revision 4.0 91/03/20 01:05:51 lwall + * 4.0 baseline. + * + */ + +#include "EXTERN.h" +#include "perl.h" +#include "perly.h" + +extern char *tokename[]; +extern int yychar; + +static int cmd_tosave(); +static int arg_tosave(); +static int spat_tosave(); +static void make_cswitch(); +static void make_nswitch(); + +static bool saw_return; + +SUBR * +make_sub(name,cmd) +char *name; +CMD *cmd; +{ + register SUBR *sub; + STAB *stab = stabent(name,TRUE); + + if (sub = stab_sub(stab)) { + if (dowarn) { + CMD *oldcurcmd = curcmd; + + if (cmd) + curcmd = cmd; + warn("Subroutine %s redefined",name); + curcmd = oldcurcmd; + } + if (!sub->usersub && sub->cmd) { + cmd_free(sub->cmd); + sub->cmd = Nullcmd; + afree(sub->tosave); + } + Safefree(sub); + } + Newz(101,sub,1,SUBR); + stab_sub(stab) = sub; + sub->filestab = curcmd->c_filestab; + saw_return = FALSE; + tosave = anew(Nullstab); + tosave->ary_fill = 0; /* make 1 based */ + (void)cmd_tosave(cmd,FALSE); /* this builds the tosave array */ + sub->tosave = tosave; + if (saw_return) { + struct compcmd mycompblock; + + mycompblock.comp_true = cmd; + mycompblock.comp_alt = Nullcmd; + cmd = add_label(savestr("_SUB_"),make_ccmd(C_BLOCK,0, + Nullarg,mycompblock)); + saw_return = FALSE; + cmd->c_flags |= CF_TERM; + } + sub->cmd = cmd; + if (perldb) { + STR *str; + STR *tmpstr = str_mortal(&str_undef); + + sprintf(buf,"%s:%ld",stab_val(curcmd->c_filestab)->str_ptr, subline); + str = str_make(buf,0); + str_cat(str,"-"); + sprintf(buf,"%ld",(long)curcmd->c_line); + str_cat(str,buf); + stab_efullname(tmpstr,stab); + hstore(stab_xhash(DBsub), tmpstr->str_ptr, tmpstr->str_cur, str, 0); + } + Safefree(name); + return sub; +} + +SUBR * +make_usub(name, ix, subaddr, filename) +char *name; +int ix; +int (*subaddr)(); +char *filename; +{ + register SUBR *sub; + STAB *stab = stabent(name,allstabs); + + if (!stab) /* unused function */ + return Null(SUBR*); + if (sub = stab_sub(stab)) { + if (dowarn) + warn("Subroutine %s redefined",name); + if (!sub->usersub && sub->cmd) { + cmd_free(sub->cmd); + sub->cmd = Nullcmd; + afree(sub->tosave); + } + Safefree(sub); + } + Newz(101,sub,1,SUBR); + stab_sub(stab) = sub; + sub->filestab = fstab(filename); + sub->usersub = subaddr; + sub->userindex = ix; + return sub; +} + +void +make_form(stab,fcmd) +STAB *stab; +FCMD *fcmd; +{ + if (stab_form(stab)) { + FCMD *tmpfcmd; + FCMD *nextfcmd; + + for (tmpfcmd = stab_form(stab); tmpfcmd; tmpfcmd = nextfcmd) { + nextfcmd = tmpfcmd->f_next; + if (tmpfcmd->f_expr) + arg_free(tmpfcmd->f_expr); + if (tmpfcmd->f_unparsed) + str_free(tmpfcmd->f_unparsed); + if (tmpfcmd->f_pre) + Safefree(tmpfcmd->f_pre); + Safefree(tmpfcmd); + } + } + stab_form(stab) = fcmd; +} + +CMD * +block_head(tail) +register CMD *tail; +{ + CMD *head; + register int opt; + register int last_opt = 0; + register STAB *last_stab = Nullstab; + register int count = 0; + register CMD *switchbeg = Nullcmd; + + if (tail == Nullcmd) { + return tail; + } + head = tail->c_head; + + for (tail = head; tail; tail = tail->c_next) { + + /* save one measly dereference at runtime */ + if (tail->c_type == C_IF) { + if (!(tail->ucmd.ccmd.cc_alt = tail->ucmd.ccmd.cc_alt->c_next)) + tail->c_flags |= CF_TERM; + } + else if (tail->c_type == C_EXPR) { + ARG *arg; + + if (tail->ucmd.acmd.ac_expr) + arg = tail->ucmd.acmd.ac_expr; + else + arg = tail->c_expr; + if (arg) { + if (arg->arg_type == O_RETURN) + tail->c_flags |= CF_TERM; + else if (arg->arg_type == O_ITEM && arg[1].arg_type == A_CMD) + tail->c_flags |= CF_TERM; + } + } + if (!tail->c_next) + tail->c_flags |= CF_TERM; + + if (tail->c_expr && (tail->c_flags & CF_OPTIMIZE) == CFT_FALSE) + opt_arg(tail,1, tail->c_type == C_EXPR); + + /* now do a little optimization on case-ish structures */ + switch(tail->c_flags & (CF_OPTIMIZE|CF_FIRSTNEG|CF_INVERT)) { + case CFT_ANCHOR: + case CFT_STROP: + opt = (tail->c_flags & CF_NESURE) ? CFT_STROP : 0; + break; + case CFT_CCLASS: + opt = CFT_STROP; + break; + case CFT_NUMOP: + opt = (tail->c_slen == O_NE ? 0 : CFT_NUMOP); + if ((tail->c_flags&(CF_NESURE|CF_EQSURE)) != (CF_NESURE|CF_EQSURE)) + opt = 0; + break; + default: + opt = 0; + } + if (opt && opt == last_opt && tail->c_stab == last_stab) + count++; + else { + if (count >= 3) { /* is this the breakeven point? */ + if (last_opt == CFT_NUMOP) + make_nswitch(switchbeg,count); + else + make_cswitch(switchbeg,count); + } + if (opt) { + count = 1; + switchbeg = tail; + } + else + count = 0; + } + last_opt = opt; + last_stab = tail->c_stab; + } + if (count >= 3) { /* is this the breakeven point? */ + if (last_opt == CFT_NUMOP) + make_nswitch(switchbeg,count); + else + make_cswitch(switchbeg,count); + } + return head; +} + +/* We've spotted a sequence of CMDs that all test the value of the same + * spat. Thus we can insert a SWITCH in front and jump directly + * to the correct one. + */ +static void +make_cswitch(head,count) +register CMD *head; +int count; +{ + register CMD *cur; + register CMD **loc; + register int i; + register int min = 255; + register int max = 0; + + /* make a new head in the exact same spot */ + New(102,cur, 1, CMD); + StructCopy(head,cur,CMD); + Zero(head,1,CMD); + head->c_head = cur->c_head; + head->c_type = C_CSWITCH; + head->c_next = cur; /* insert new cmd at front of list */ + head->c_stab = cur->c_stab; + + Newz(103,loc,258,CMD*); + loc++; /* lie a little */ + while (count--) { + if ((cur->c_flags & CF_OPTIMIZE) == CFT_CCLASS) { + for (i = 0; i <= 255; i++) { + if (!loc[i] && cur->c_short->str_ptr[i>>3] & (1 << (i&7))) { + loc[i] = cur; + if (i < min) + min = i; + if (i > max) + max = i; + } + } + } + else { + i = *cur->c_short->str_ptr & 255; + if (!loc[i]) { + loc[i] = cur; + if (i < min) + min = i; + if (i > max) + max = i; + } + } + cur = cur->c_next; + } + max++; + if (min > 0) + Move(&loc[min],&loc[0], max - min, CMD*); + loc--; + min--; + max -= min; + for (i = 0; i <= max; i++) + if (!loc[i]) + loc[i] = cur; + Renew(loc,max+1,CMD*); /* chop it down to size */ + head->ucmd.scmd.sc_offset = min; + head->ucmd.scmd.sc_max = max; + head->ucmd.scmd.sc_next = loc; +} + +static void +make_nswitch(head,count) +register CMD *head; +int count; +{ + register CMD *cur = head; + register CMD **loc; + register int i; + register int min = 32767; + register int max = -32768; + int origcount = count; + double value; /* or your money back! */ + short changed; /* so triple your money back! */ + + while (count--) { + i = (int)str_gnum(cur->c_short); + value = (double)i; + if (value != cur->c_short->str_u.str_nval) + return; /* fractional values--just forget it */ + changed = i; + if (changed != i) + return; /* too big for a short */ + if (cur->c_slen == O_LE) + i++; + else if (cur->c_slen == O_GE) /* we only do < or > here */ + i--; + if (i < min) + min = i; + if (i > max) + max = i; + cur = cur->c_next; + } + count = origcount; + if (max - min > count * 2 + 10) /* too sparse? */ + return; + + /* now make a new head in the exact same spot */ + New(104,cur, 1, CMD); + StructCopy(head,cur,CMD); + Zero(head,1,CMD); + head->c_head = cur->c_head; + head->c_type = C_NSWITCH; + head->c_next = cur; /* insert new cmd at front of list */ + head->c_stab = cur->c_stab; + + Newz(105,loc, max - min + 3, CMD*); + loc++; + max -= min; + max++; + while (count--) { + i = (int)str_gnum(cur->c_short); + i -= min; + switch(cur->c_slen) { + case O_LE: + i++; + case O_LT: + for (i--; i >= -1; i--) + if (!loc[i]) + loc[i] = cur; + break; + case O_GE: + i--; + case O_GT: + for (i++; i <= max; i++) + if (!loc[i]) + loc[i] = cur; + break; + case O_EQ: + if (!loc[i]) + loc[i] = cur; + break; + } + cur = cur->c_next; + } + loc--; + min--; + max++; + for (i = 0; i <= max; i++) + if (!loc[i]) + loc[i] = cur; + head->ucmd.scmd.sc_offset = min; + head->ucmd.scmd.sc_max = max; + head->ucmd.scmd.sc_next = loc; +} + +CMD * +append_line(head,tail) +register CMD *head; +register CMD *tail; +{ + if (tail == Nullcmd) + return head; + if (!tail->c_head) /* make sure tail is well formed */ + tail->c_head = tail; + if (head != Nullcmd) { + tail = tail->c_head; /* get to start of tail list */ + if (!head->c_head) + head->c_head = head; /* start a new head list */ + while (head->c_next) { + head->c_next->c_head = head->c_head; + head = head->c_next; /* get to end of head list */ + } + head->c_next = tail; /* link to end of old list */ + tail->c_head = head->c_head; /* propagate head pointer */ + } + while (tail->c_next) { + tail->c_next->c_head = tail->c_head; + tail = tail->c_next; + } + return tail; +} + +CMD * +dodb(cur) +CMD *cur; +{ + register CMD *cmd; + register CMD *head = cur->c_head; + STR *str; + + if (!head) + head = cur; + if (!head->c_line) + return cur; + str = afetch(stab_xarray(curcmd->c_filestab),(int)head->c_line,FALSE); + if (str == &str_undef || str->str_nok) + return cur; + str->str_u.str_nval = (double)head->c_line; + str->str_nok = 1; + Newz(106,cmd,1,CMD); + str_magic(str, curcmd->c_filestab, 0, Nullch, 0); + str->str_magic->str_u.str_cmd = cmd; + cmd->c_type = C_EXPR; + cmd->ucmd.acmd.ac_stab = Nullstab; + cmd->ucmd.acmd.ac_expr = Nullarg; + cmd->c_expr = make_op(O_SUBR, 2, + stab2arg(A_WORD,DBstab), + Nullarg, + Nullarg); + /*SUPPRESS 53*/ + cmd->c_flags |= CF_COND|CF_DBSUB|CFT_D0; + cmd->c_line = head->c_line; + cmd->c_label = head->c_label; + cmd->c_filestab = curcmd->c_filestab; + cmd->c_stash = curstash; + return append_line(cmd, cur); +} + +CMD * +make_acmd(type,stab,cond,arg) +int type; +STAB *stab; +ARG *cond; +ARG *arg; +{ + register CMD *cmd; + + Newz(107,cmd,1,CMD); + cmd->c_type = type; + cmd->ucmd.acmd.ac_stab = stab; + cmd->ucmd.acmd.ac_expr = arg; + cmd->c_expr = cond; + if (cond) + cmd->c_flags |= CF_COND; + if (cmdline == NOLINE) + cmd->c_line = curcmd->c_line; + else { + cmd->c_line = cmdline; + cmdline = NOLINE; + } + cmd->c_filestab = curcmd->c_filestab; + cmd->c_stash = curstash; + if (perldb) + cmd = dodb(cmd); + return cmd; +} + +CMD * +make_ccmd(type,debuggable,arg,cblock) +int type; +int debuggable; +ARG *arg; +struct compcmd cblock; +{ + register CMD *cmd; + + Newz(108,cmd, 1, CMD); + cmd->c_type = type; + cmd->c_expr = arg; + cmd->ucmd.ccmd.cc_true = cblock.comp_true; + cmd->ucmd.ccmd.cc_alt = cblock.comp_alt; + if (arg) + cmd->c_flags |= CF_COND; + if (cmdline == NOLINE) + cmd->c_line = curcmd->c_line; + else { + cmd->c_line = cmdline; + cmdline = NOLINE; + } + cmd->c_filestab = curcmd->c_filestab; + cmd->c_stash = curstash; + if (perldb && debuggable) + cmd = dodb(cmd); + return cmd; +} + +CMD * +make_icmd(type,arg,cblock) +int type; +ARG *arg; +struct compcmd cblock; +{ + register CMD *cmd; + register CMD *alt; + register CMD *cur; + register CMD *head; + struct compcmd ncblock; + + Newz(109,cmd, 1, CMD); + head = cmd; + cmd->c_type = type; + cmd->c_expr = arg; + cmd->ucmd.ccmd.cc_true = cblock.comp_true; + cmd->ucmd.ccmd.cc_alt = cblock.comp_alt; + if (arg) + cmd->c_flags |= CF_COND; + if (cmdline == NOLINE) + cmd->c_line = curcmd->c_line; + else { + cmd->c_line = cmdline; + cmdline = NOLINE; + } + cmd->c_filestab = curcmd->c_filestab; + cmd->c_stash = curstash; + cur = cmd; + alt = cblock.comp_alt; + while (alt && alt->c_type == C_ELSIF) { + cur = alt; + alt = alt->ucmd.ccmd.cc_alt; + } + if (alt) { /* a real life ELSE at the end? */ + ncblock.comp_true = alt; + ncblock.comp_alt = Nullcmd; + alt = append_line(cur,make_ccmd(C_ELSE,1,Nullarg,ncblock)); + cur->ucmd.ccmd.cc_alt = alt; + } + else + alt = cur; /* no ELSE, so cur is proxy ELSE */ + + cur = cmd; + while (cmd) { /* now point everyone at the ELSE */ + cur = cmd; + cmd = cur->ucmd.ccmd.cc_alt; + cur->c_head = head; + if (cur->c_type == C_ELSIF) + cur->c_type = C_IF; + if (cur->c_type == C_IF) + cur->ucmd.ccmd.cc_alt = alt; + if (cur == alt) + break; + cur->c_next = cmd; + } + if (perldb) + cur = dodb(cur); + return cur; +} + +void +opt_arg(cmd,fliporflop,acmd) +register CMD *cmd; +int fliporflop; +int acmd; +{ + register ARG *arg; + int opt = CFT_EVAL; + int sure = 0; + ARG *arg2; + int context = 0; /* 0 = normal, 1 = before &&, 2 = before || */ + int flp = fliporflop; + + if (!cmd) + return; + if (!(arg = cmd->c_expr)) { + cmd->c_flags &= ~CF_COND; + return; + } + + /* Can we turn && and || into if and unless? */ + + if (acmd && !cmd->ucmd.acmd.ac_expr && !(cmd->c_flags & CF_TERM) && + (arg->arg_type == O_AND || arg->arg_type == O_OR) ) { + dehoist(arg,1); + arg[2].arg_type &= A_MASK; /* don't suppress eval */ + dehoist(arg,2); + cmd->ucmd.acmd.ac_expr = arg[2].arg_ptr.arg_arg; + cmd->c_expr = arg[1].arg_ptr.arg_arg; + if (arg->arg_type == O_OR) + cmd->c_flags ^= CF_INVERT; /* || is like unless */ + arg->arg_len = 0; + free_arg(arg); + arg = cmd->c_expr; + } + + /* Turn "if (!expr)" into "unless (expr)" */ + + if (!(cmd->c_flags & CF_TERM)) { /* unless return value wanted */ + while (arg->arg_type == O_NOT) { + dehoist(arg,1); + cmd->c_flags ^= CF_INVERT; /* flip sense of cmd */ + cmd->c_expr = arg[1].arg_ptr.arg_arg; /* hoist the rest of expr */ + free_arg(arg); + arg = cmd->c_expr; /* here we go again */ + } + } + + if (!arg->arg_len) { /* sanity check */ + cmd->c_flags |= opt; + return; + } + + /* for "cond .. cond" we set up for the initial check */ + + if (arg->arg_type == O_FLIP) + context |= 4; + + /* for "cond && expr" and "cond || expr" we can ignore expr, sort of */ + + morecontext: + if (arg->arg_type == O_AND) + context |= 1; + else if (arg->arg_type == O_OR) + context |= 2; + if (context && (arg[flp].arg_type & A_MASK) == A_EXPR) { + arg = arg[flp].arg_ptr.arg_arg; + flp = 1; + if (arg->arg_type == O_AND || arg->arg_type == O_OR) + goto morecontext; + } + if ((context & 3) == 3) + return; + + if (arg[flp].arg_flags & (AF_PRE|AF_POST)) { + cmd->c_flags |= opt; + if (acmd && !cmd->ucmd.acmd.ac_expr && !(cmd->c_flags & CF_TERM) + && cmd->c_expr->arg_type == O_ITEM) { + arg[flp].arg_flags &= ~AF_POST; /* prefer ++$foo to $foo++ */ + arg[flp].arg_flags |= AF_PRE; /* if value not wanted */ + } + return; /* side effect, can't optimize */ + } + + if (arg->arg_type == O_ITEM || arg->arg_type == O_FLIP || + arg->arg_type == O_AND || arg->arg_type == O_OR) { + if ((arg[flp].arg_type & A_MASK) == A_SINGLE) { + opt = (str_true(arg[flp].arg_ptr.arg_str) ? CFT_TRUE : CFT_FALSE); + cmd->c_short = str_smake(arg[flp].arg_ptr.arg_str); + goto literal; + } + else if ((arg[flp].arg_type & A_MASK) == A_STAB || + (arg[flp].arg_type & A_MASK) == A_LVAL) { + cmd->c_stab = arg[flp].arg_ptr.arg_stab; + if (!context) + arg[flp].arg_ptr.arg_stab = Nullstab; + opt = CFT_REG; + literal: + if (!context) { /* no && or ||? */ + arg_free(arg); + cmd->c_expr = Nullarg; + } + if (!(context & 1)) + cmd->c_flags |= CF_EQSURE; + if (!(context & 2)) + cmd->c_flags |= CF_NESURE; + } + } + else if (arg->arg_type == O_MATCH || arg->arg_type == O_SUBST || + arg->arg_type == O_NMATCH || arg->arg_type == O_NSUBST) { + if ((arg[1].arg_type == A_STAB || arg[1].arg_type == A_LVAL) && + (arg[2].arg_type & A_MASK) == A_SPAT && + arg[2].arg_ptr.arg_spat->spat_short && + (arg->arg_type == O_SUBST || arg->arg_type == O_NSUBST || + (arg[2].arg_ptr.arg_spat->spat_flags & SPAT_GLOBAL) == 0 )) { + cmd->c_stab = arg[1].arg_ptr.arg_stab; + cmd->c_short = str_smake(arg[2].arg_ptr.arg_spat->spat_short); + cmd->c_slen = arg[2].arg_ptr.arg_spat->spat_slen; + if (arg[2].arg_ptr.arg_spat->spat_flags & SPAT_ALL && + !(arg[2].arg_ptr.arg_spat->spat_flags & SPAT_ONCE) && + (arg->arg_type == O_MATCH || arg->arg_type == O_NMATCH) ) + sure |= CF_EQSURE; /* (SUBST must be forced even */ + /* if we know it will work.) */ + if (arg->arg_type != O_SUBST) { + str_free(arg[2].arg_ptr.arg_spat->spat_short); + arg[2].arg_ptr.arg_spat->spat_short = Nullstr; + arg[2].arg_ptr.arg_spat->spat_slen = 0; /* only one chk */ + } + sure |= CF_NESURE; /* normally only sure if it fails */ + if (arg->arg_type == O_NMATCH || arg->arg_type == O_NSUBST) + cmd->c_flags |= CF_FIRSTNEG; + if (context & 1) { /* only sure if thing is false */ + if (cmd->c_flags & CF_FIRSTNEG) + sure &= ~CF_NESURE; + else + sure &= ~CF_EQSURE; + } + else if (context & 2) { /* only sure if thing is true */ + if (cmd->c_flags & CF_FIRSTNEG) + sure &= ~CF_EQSURE; + else + sure &= ~CF_NESURE; + } + if (sure & (CF_EQSURE|CF_NESURE)) { /* if we know anything*/ + if (arg[2].arg_ptr.arg_spat->spat_flags & SPAT_SCANFIRST) + opt = CFT_SCAN; + else + opt = CFT_ANCHOR; + if (sure == (CF_EQSURE|CF_NESURE) /* really sure? */ + && arg->arg_type == O_MATCH + && context & 4 + && fliporflop == 1) { + spat_free(arg[2].arg_ptr.arg_spat); + arg[2].arg_ptr.arg_spat = Nullspat; /* don't do twice */ + } + else + cmd->c_spat = arg[2].arg_ptr.arg_spat; + cmd->c_flags |= sure; + } + } + } + else if (arg->arg_type == O_SEQ || arg->arg_type == O_SNE || + arg->arg_type == O_SLT || arg->arg_type == O_SGT) { + if (arg[1].arg_type == A_STAB || arg[1].arg_type == A_LVAL) { + if (arg[2].arg_type == A_SINGLE) { + /*SUPPRESS 594*/ + char *junk = str_get(arg[2].arg_ptr.arg_str); + + cmd->c_stab = arg[1].arg_ptr.arg_stab; + cmd->c_short = str_smake(arg[2].arg_ptr.arg_str); + cmd->c_slen = cmd->c_short->str_cur+1; + switch (arg->arg_type) { + case O_SLT: case O_SGT: + sure |= CF_EQSURE; + cmd->c_flags |= CF_FIRSTNEG; + break; + case O_SNE: + cmd->c_flags |= CF_FIRSTNEG; + /* FALL THROUGH */ + case O_SEQ: + sure |= CF_NESURE|CF_EQSURE; + break; + } + if (context & 1) { /* only sure if thing is false */ + if (cmd->c_flags & CF_FIRSTNEG) + sure &= ~CF_NESURE; + else + sure &= ~CF_EQSURE; + } + else if (context & 2) { /* only sure if thing is true */ + if (cmd->c_flags & CF_FIRSTNEG) + sure &= ~CF_EQSURE; + else + sure &= ~CF_NESURE; + } + if (sure & (CF_EQSURE|CF_NESURE)) { + opt = CFT_STROP; + cmd->c_flags |= sure; + } + } + } + } + else if (arg->arg_type == O_EQ || arg->arg_type == O_NE || + arg->arg_type == O_LE || arg->arg_type == O_GE || + arg->arg_type == O_LT || arg->arg_type == O_GT) { + if (arg[1].arg_type == A_STAB || arg[1].arg_type == A_LVAL) { + if (arg[2].arg_type == A_SINGLE) { + cmd->c_stab = arg[1].arg_ptr.arg_stab; + if (dowarn) { + STR *str = arg[2].arg_ptr.arg_str; + + if ((!str->str_nok && !looks_like_number(str))) + warn("Possible use of == on string value"); + } + cmd->c_short = str_nmake(str_gnum(arg[2].arg_ptr.arg_str)); + cmd->c_slen = arg->arg_type; + sure |= CF_NESURE|CF_EQSURE; + if (context & 1) { /* only sure if thing is false */ + sure &= ~CF_EQSURE; + } + else if (context & 2) { /* only sure if thing is true */ + sure &= ~CF_NESURE; + } + if (sure & (CF_EQSURE|CF_NESURE)) { + opt = CFT_NUMOP; + cmd->c_flags |= sure; + } + } + } + } + else if (arg->arg_type == O_ASSIGN && + (arg[1].arg_type == A_STAB || arg[1].arg_type == A_LVAL) && + arg[1].arg_ptr.arg_stab == defstab && + arg[2].arg_type == A_EXPR ) { + arg2 = arg[2].arg_ptr.arg_arg; + if (arg2->arg_type == O_ITEM && arg2[1].arg_type == A_READ) { + opt = CFT_GETS; + cmd->c_stab = arg2[1].arg_ptr.arg_stab; + if (!(stab_io(arg2[1].arg_ptr.arg_stab)->flags & IOF_ARGV)) { + free_arg(arg2); + arg[2].arg_ptr.arg_arg = Nullarg; + free_arg(arg); + cmd->c_expr = Nullarg; + } + } + } + else if (arg->arg_type == O_CHOP && + (arg[1].arg_type == A_STAB || arg[1].arg_type == A_LVAL) ) { + opt = CFT_CHOP; + cmd->c_stab = arg[1].arg_ptr.arg_stab; + free_arg(arg); + cmd->c_expr = Nullarg; + } + if (context & 4) + opt |= CF_FLIP; + cmd->c_flags |= opt; + + if (cmd->c_flags & CF_FLIP) { + if (fliporflop == 1) { + arg = cmd->c_expr; /* get back to O_FLIP arg */ + New(110,arg[3].arg_ptr.arg_cmd, 1, CMD); + Copy(cmd, arg[3].arg_ptr.arg_cmd, 1, CMD); + New(111,arg[4].arg_ptr.arg_cmd,1,CMD); + Copy(cmd, arg[4].arg_ptr.arg_cmd, 1, CMD); + opt_arg(arg[4].arg_ptr.arg_cmd,2,acmd); + arg->arg_len = 2; /* this is a lie */ + } + else { + if ((opt & CF_OPTIMIZE) == CFT_EVAL) + cmd->c_flags = (cmd->c_flags & ~CF_OPTIMIZE) | CFT_UNFLIP; + } + } +} + +CMD * +add_label(lbl,cmd) +char *lbl; +register CMD *cmd; +{ + if (cmd) + cmd->c_label = lbl; + return cmd; +} + +CMD * +addcond(cmd, arg) +register CMD *cmd; +register ARG *arg; +{ + cmd->c_expr = arg; + cmd->c_flags |= CF_COND; + return cmd; +} + +CMD * +addloop(cmd, arg) +register CMD *cmd; +register ARG *arg; +{ + void while_io(); + + cmd->c_expr = arg; + cmd->c_flags |= CF_COND|CF_LOOP; + + if (!(cmd->c_flags & CF_INVERT)) + while_io(cmd); /* add $_ =, if necessary */ + + if (cmd->c_type == C_BLOCK) + cmd->c_flags &= ~CF_COND; + else { + arg = cmd->ucmd.acmd.ac_expr; + if (arg && arg->arg_type == O_ITEM && arg[1].arg_type == A_CMD) + cmd->c_flags &= ~CF_COND; /* "do {} while" happens at least once */ + if (arg && (arg->arg_flags & AF_DEPR) && + (arg->arg_type == O_SUBR || arg->arg_type == O_DBSUBR) ) + cmd->c_flags &= ~CF_COND; /* likewise for "do subr() while" */ + } + return cmd; +} + +CMD * +invert(cmd) +CMD *cmd; +{ + register CMD *targ = cmd; + if (targ->c_head) + targ = targ->c_head; + if (targ->c_flags & CF_DBSUB) + targ = targ->c_next; + targ->c_flags ^= CF_INVERT; + return cmd; +} + +void +cpy7bit(d,s,l) +register char *d; +register char *s; +register int l; +{ + while (l--) + *d++ = *s++ & 127; + *d = '\0'; +} + +int +yyerror(s) +char *s; +{ + char tmpbuf[258]; + char tmp2buf[258]; + char *tname = tmpbuf; + + if (bufptr > oldoldbufptr && bufptr - oldoldbufptr < 200 && + oldoldbufptr != oldbufptr && oldbufptr != bufptr) { + while (isSPACE(*oldoldbufptr)) + oldoldbufptr++; + cpy7bit(tmp2buf, oldoldbufptr, bufptr - oldoldbufptr); + sprintf(tname,"next 2 tokens \"%s\"",tmp2buf); + } + else if (bufptr > oldbufptr && bufptr - oldbufptr < 200 && + oldbufptr != bufptr) { + while (isSPACE(*oldbufptr)) + oldbufptr++; + cpy7bit(tmp2buf, oldbufptr, bufptr - oldbufptr); + sprintf(tname,"next token \"%s\"",tmp2buf); + } + else if (yychar > 256) + tname = "next token ???"; + else if (!yychar) + (void)strcpy(tname,"at EOF"); + else if (yychar < 32) + (void)sprintf(tname,"next char ^%c",yychar+64); + else if (yychar == 127) + (void)strcpy(tname,"at EOF"); + else + (void)sprintf(tname,"next char %c",yychar); + (void)sprintf(buf, "%s in file %s at line %d, %s\n", + s,stab_val(curcmd->c_filestab)->str_ptr,curcmd->c_line,tname); + if (curcmd->c_line == multi_end && multi_start < multi_end) + sprintf(buf+strlen(buf), + " (Might be a runaway multi-line %c%c string starting on line %d)\n", + multi_open,multi_close,multi_start); + if (in_eval) + str_cat(stab_val(stabent("@",TRUE)),buf); + else + fputs(buf,stderr); + if (++error_count >= 10) + fatal("%s has too many errors.\n", + stab_val(curcmd->c_filestab)->str_ptr); +} + +void +while_io(cmd) +register CMD *cmd; +{ + register ARG *arg = cmd->c_expr; + STAB *asgnstab; + + /* hoist "while ()" up into command block */ + + if (arg && arg->arg_type == O_ITEM && arg[1].arg_type == A_READ) { + cmd->c_flags &= ~CF_OPTIMIZE; /* clear optimization type */ + cmd->c_flags |= CFT_GETS; /* and set it to do the input */ + cmd->c_stab = arg[1].arg_ptr.arg_stab; + if (stab_io(arg[1].arg_ptr.arg_stab)->flags & IOF_ARGV) { + cmd->c_expr = l(make_op(O_ASSIGN, 2, /* fake up "$_ =" */ + stab2arg(A_LVAL,defstab), arg, Nullarg)); + } + else { + free_arg(arg); + cmd->c_expr = Nullarg; + } + } + else if (arg && arg->arg_type == O_ITEM && arg[1].arg_type == A_INDREAD) { + cmd->c_flags &= ~CF_OPTIMIZE; /* clear optimization type */ + cmd->c_flags |= CFT_INDGETS; /* and set it to do the input */ + cmd->c_stab = arg[1].arg_ptr.arg_stab; + free_arg(arg); + cmd->c_expr = Nullarg; + } + else if (arg && arg->arg_type == O_ITEM && arg[1].arg_type == A_GLOB) { + if ((cmd->c_flags & CF_OPTIMIZE) == CFT_ARRAY) + asgnstab = cmd->c_stab; + else + asgnstab = defstab; + cmd->c_expr = l(make_op(O_ASSIGN, 2, /* fake up "$foo =" */ + stab2arg(A_LVAL,asgnstab), arg, Nullarg)); + cmd->c_flags &= ~CF_OPTIMIZE; /* clear optimization type */ + } +} + +CMD * +wopt(cmd) +register CMD *cmd; +{ + register CMD *tail; + CMD *newtail; + register int i; + + if (cmd->c_expr && (cmd->c_flags & CF_OPTIMIZE) == CFT_FALSE) + opt_arg(cmd,1, cmd->c_type == C_EXPR); + + while_io(cmd); /* add $_ =, if necessary */ + + /* First find the end of the true list */ + + tail = cmd->ucmd.ccmd.cc_true; + if (tail == Nullcmd) + return cmd; + New(112,newtail, 1, CMD); /* guaranteed continue */ + for (;;) { + /* optimize "next" to point directly to continue block */ + if (tail->c_type == C_EXPR && + tail->ucmd.acmd.ac_expr && + tail->ucmd.acmd.ac_expr->arg_type == O_NEXT && + (tail->ucmd.acmd.ac_expr->arg_len == 0 || + (cmd->c_label && + strEQ(cmd->c_label, + tail->ucmd.acmd.ac_expr[1].arg_ptr.arg_str->str_ptr) ))) + { + arg_free(tail->ucmd.acmd.ac_expr); + tail->ucmd.acmd.ac_expr = Nullarg; + tail->c_type = C_NEXT; + if (cmd->ucmd.ccmd.cc_alt != Nullcmd) + tail->ucmd.ccmd.cc_alt = cmd->ucmd.ccmd.cc_alt; + else + tail->ucmd.ccmd.cc_alt = newtail; + tail->ucmd.ccmd.cc_true = Nullcmd; + } + else if (tail->c_type == C_IF && !tail->ucmd.ccmd.cc_alt) { + if (cmd->ucmd.ccmd.cc_alt != Nullcmd) + tail->ucmd.ccmd.cc_alt = cmd->ucmd.ccmd.cc_alt; + else + tail->ucmd.ccmd.cc_alt = newtail; + } + else if (tail->c_type == C_CSWITCH || tail->c_type == C_NSWITCH) { + if (cmd->ucmd.ccmd.cc_alt != Nullcmd) { + for (i = tail->ucmd.scmd.sc_max; i >= 0; i--) + if (!tail->ucmd.scmd.sc_next[i]) + tail->ucmd.scmd.sc_next[i] = cmd->ucmd.ccmd.cc_alt; + } + else { + for (i = tail->ucmd.scmd.sc_max; i >= 0; i--) + if (!tail->ucmd.scmd.sc_next[i]) + tail->ucmd.scmd.sc_next[i] = newtail; + } + } + + if (!tail->c_next) + break; + tail = tail->c_next; + } + + /* if there's a continue block, link it to true block and find end */ + + if (cmd->ucmd.ccmd.cc_alt != Nullcmd) { + tail->c_next = cmd->ucmd.ccmd.cc_alt; + tail = tail->c_next; + for (;;) { + /* optimize "next" to point directly to continue block */ + if (tail->c_type == C_EXPR && + tail->ucmd.acmd.ac_expr && + tail->ucmd.acmd.ac_expr->arg_type == O_NEXT && + (tail->ucmd.acmd.ac_expr->arg_len == 0 || + (cmd->c_label && + strEQ(cmd->c_label, + tail->ucmd.acmd.ac_expr[1].arg_ptr.arg_str->str_ptr) ))) + { + arg_free(tail->ucmd.acmd.ac_expr); + tail->ucmd.acmd.ac_expr = Nullarg; + tail->c_type = C_NEXT; + tail->ucmd.ccmd.cc_alt = newtail; + tail->ucmd.ccmd.cc_true = Nullcmd; + } + else if (tail->c_type == C_IF && !tail->ucmd.ccmd.cc_alt) { + tail->ucmd.ccmd.cc_alt = newtail; + } + else if (tail->c_type == C_CSWITCH || tail->c_type == C_NSWITCH) { + for (i = tail->ucmd.scmd.sc_max; i >= 0; i--) + if (!tail->ucmd.scmd.sc_next[i]) + tail->ucmd.scmd.sc_next[i] = newtail; + } + + if (!tail->c_next) + break; + tail = tail->c_next; + } + /*SUPPRESS 530*/ + for ( ; tail->c_next; tail = tail->c_next) ; + } + + /* Here's the real trick: link the end of the list back to the beginning, + * inserting a "last" block to break out of the loop. This saves one or + * two procedure calls every time through the loop, because of how cmd_exec + * does tail recursion. + */ + + tail->c_next = newtail; + tail = newtail; + if (!cmd->ucmd.ccmd.cc_alt) + cmd->ucmd.ccmd.cc_alt = tail; /* every loop has a continue now */ + +#ifndef lint + Copy((char *)cmd, (char *)tail, 1, CMD); +#endif + tail->c_type = C_EXPR; + tail->c_flags ^= CF_INVERT; /* turn into "last unless" */ + tail->c_next = tail->ucmd.ccmd.cc_true; /* loop directly back to top */ + tail->ucmd.acmd.ac_expr = make_op(O_LAST,0,Nullarg,Nullarg,Nullarg); + tail->ucmd.acmd.ac_stab = Nullstab; + return cmd; +} + +CMD * +over(eachstab,cmd) +STAB *eachstab; +register CMD *cmd; +{ + /* hoist "for $foo (@bar)" up into command block */ + + cmd->c_flags &= ~CF_OPTIMIZE; /* clear optimization type */ + cmd->c_flags |= CFT_ARRAY; /* and set it to do the iteration */ + cmd->c_stab = eachstab; + cmd->c_short = Str_new(23,0); /* just to save a field in struct cmd */ + cmd->c_short->str_u.str_useful = -1; + + return cmd; +} + +void +cmd_free(cmd) +register CMD *cmd; +{ + register CMD *tofree; + register CMD *head = cmd; + + if (!cmd) + return; + if (cmd->c_head != cmd) + warn("Malformed cmd links\n"); + while (cmd) { + if (cmd->c_type != C_WHILE) { /* WHILE block is duplicated */ + if (cmd->c_label) { + Safefree(cmd->c_label); + cmd->c_label = Nullch; + } + if (cmd->c_short) { + str_free(cmd->c_short); + cmd->c_short = Nullstr; + } + if (cmd->c_expr) { + arg_free(cmd->c_expr); + cmd->c_expr = Nullarg; + } + } + switch (cmd->c_type) { + case C_WHILE: + case C_BLOCK: + case C_ELSE: + case C_IF: + if (cmd->ucmd.ccmd.cc_true) { + cmd_free(cmd->ucmd.ccmd.cc_true); + cmd->ucmd.ccmd.cc_true = Nullcmd; + } + break; + case C_EXPR: + if (cmd->ucmd.acmd.ac_expr) { + arg_free(cmd->ucmd.acmd.ac_expr); + cmd->ucmd.acmd.ac_expr = Nullarg; + } + break; + } + tofree = cmd; + cmd = cmd->c_next; + if (tofree != head) /* to get Saber to shut up */ + Safefree(tofree); + if (cmd && cmd == head) /* reached end of while loop */ + break; + } + Safefree(head); +} + +void +arg_free(arg) +register ARG *arg; +{ + register int i; + + if (!arg) + return; + for (i = 1; i <= arg->arg_len; i++) { + switch (arg[i].arg_type & A_MASK) { + case A_NULL: + if (arg->arg_type == O_TRANS) { + Safefree(arg[i].arg_ptr.arg_cval); + arg[i].arg_ptr.arg_cval = Nullch; + } + break; + case A_LEXPR: + if (arg->arg_type == O_AASSIGN && + arg[i].arg_ptr.arg_arg->arg_type == O_LARRAY) { + char *name = + stab_name(arg[i].arg_ptr.arg_arg[1].arg_ptr.arg_stab); + + if (strnEQ("_GEN_",name, 5)) /* array for foreach */ + hdelete(defstash,name,strlen(name)); + } + /* FALL THROUGH */ + case A_EXPR: + arg_free(arg[i].arg_ptr.arg_arg); + arg[i].arg_ptr.arg_arg = Nullarg; + break; + case A_CMD: + cmd_free(arg[i].arg_ptr.arg_cmd); + arg[i].arg_ptr.arg_cmd = Nullcmd; + break; + case A_WORD: + case A_STAB: + case A_LVAL: + case A_READ: + case A_GLOB: + case A_ARYLEN: + case A_LARYLEN: + case A_ARYSTAB: + case A_LARYSTAB: + break; + case A_SINGLE: + case A_DOUBLE: + case A_BACKTICK: + str_free(arg[i].arg_ptr.arg_str); + arg[i].arg_ptr.arg_str = Nullstr; + break; + case A_SPAT: + spat_free(arg[i].arg_ptr.arg_spat); + arg[i].arg_ptr.arg_spat = Nullspat; + break; + } + } + free_arg(arg); +} + +void +spat_free(spat) +register SPAT *spat; +{ + register SPAT *sp; + HENT *entry; + + if (!spat) + return; + if (spat->spat_runtime) { + arg_free(spat->spat_runtime); + spat->spat_runtime = Nullarg; + } + if (spat->spat_repl) { + arg_free(spat->spat_repl); + spat->spat_repl = Nullarg; + } + if (spat->spat_short) { + str_free(spat->spat_short); + spat->spat_short = Nullstr; + } + if (spat->spat_regexp) { + regfree(spat->spat_regexp); + spat->spat_regexp = Null(REGEXP*); + } + + /* now unlink from spat list */ + + for (entry = defstash->tbl_array['_']; entry; entry = entry->hent_next) { + register HASH *stash; + STAB *stab = (STAB*)entry->hent_val; + + if (!stab) + continue; + stash = stab_hash(stab); + if (!stash || stash->tbl_spatroot == Null(SPAT*)) + continue; + if (stash->tbl_spatroot == spat) + stash->tbl_spatroot = spat->spat_next; + else { + for (sp = stash->tbl_spatroot; + sp && sp->spat_next != spat; + sp = sp->spat_next) + /*SUPPRESS 530*/ + ; + if (sp) + sp->spat_next = spat->spat_next; + } + } + Safefree(spat); +} + +/* Recursively descend a command sequence and push the address of any string + * that needs saving on recursion onto the tosave array. + */ + +static int +cmd_tosave(cmd,willsave) +register CMD *cmd; +int willsave; /* willsave passes down the tree */ +{ + register CMD *head = cmd; + int shouldsave = FALSE; /* shouldsave passes up the tree */ + int tmpsave; + register CMD *lastcmd = Nullcmd; + + while (cmd) { + if (cmd->c_expr) + shouldsave |= arg_tosave(cmd->c_expr,willsave); + switch (cmd->c_type) { + case C_WHILE: + if (cmd->ucmd.ccmd.cc_true) { + tmpsave = cmd_tosave(cmd->ucmd.ccmd.cc_true,willsave); + + /* Here we check to see if the temporary array generated for + * a foreach needs to be localized because of recursion. + */ + if (tmpsave && (cmd->c_flags & CF_OPTIMIZE) == CFT_ARRAY) { + if (lastcmd && + lastcmd->c_type == C_EXPR && + lastcmd->c_expr) { + ARG *arg = lastcmd->c_expr; + + if (arg->arg_type == O_ASSIGN && + arg[1].arg_type == A_LEXPR && + arg[1].arg_ptr.arg_arg->arg_type == O_LARRAY && + strnEQ("_GEN_", + stab_name( + arg[1].arg_ptr.arg_arg[1].arg_ptr.arg_stab), + 5)) { /* array generated for foreach */ + (void)localize(arg); + } + } + + /* in any event, save the iterator */ + + (void)apush(tosave,cmd->c_short); + } + shouldsave |= tmpsave; + } + break; + case C_BLOCK: + case C_ELSE: + case C_IF: + if (cmd->ucmd.ccmd.cc_true) + shouldsave |= cmd_tosave(cmd->ucmd.ccmd.cc_true,willsave); + break; + case C_EXPR: + if (cmd->ucmd.acmd.ac_expr) + shouldsave |= arg_tosave(cmd->ucmd.acmd.ac_expr,willsave); + break; + } + lastcmd = cmd; + cmd = cmd->c_next; + if (cmd && cmd == head) /* reached end of while loop */ + break; + } + return shouldsave; +} + +static int +arg_tosave(arg,willsave) +register ARG *arg; +int willsave; +{ + register int i; + int shouldsave = FALSE; + + for (i = arg->arg_len; i >= 1; i--) { + switch (arg[i].arg_type & A_MASK) { + case A_NULL: + break; + case A_LEXPR: + case A_EXPR: + shouldsave |= arg_tosave(arg[i].arg_ptr.arg_arg,shouldsave); + break; + case A_CMD: + shouldsave |= cmd_tosave(arg[i].arg_ptr.arg_cmd,shouldsave); + break; + case A_WORD: + case A_STAB: + case A_LVAL: + case A_READ: + case A_GLOB: + case A_ARYLEN: + case A_SINGLE: + case A_DOUBLE: + case A_BACKTICK: + break; + case A_SPAT: + shouldsave |= spat_tosave(arg[i].arg_ptr.arg_spat); + break; + } + } + switch (arg->arg_type) { + case O_RETURN: + saw_return = TRUE; + break; + case O_EVAL: + case O_SUBR: + shouldsave = TRUE; + break; + } + if (willsave) + (void)apush(tosave,arg->arg_ptr.arg_str); + return shouldsave; +} + +static int +spat_tosave(spat) +register SPAT *spat; +{ + int shouldsave = FALSE; + + if (spat->spat_runtime) + shouldsave |= arg_tosave(spat->spat_runtime,FALSE); + if (spat->spat_repl) { + shouldsave |= arg_tosave(spat->spat_repl,FALSE); + } + + return shouldsave; +} + diff --git a/cons.c.rej b/cons.c.rej new file mode 100644 index 0000000..6617f73 --- /dev/null +++ b/cons.c.rej @@ -0,0 +1,48 @@ +*************** +*** 1,4 **** +! /* $RCSfile: cons.c,v $$Revision: 4.0.1.3 $$Date: 1992/06/08 12:18:35 $ + * + * Copyright (c) 1991, Larry Wall + * +--- 1,4 ---- +! /* $RCSfile: cons.c,v $$Revision: 4.0.1.4 $$Date: 1993/02/05 19:30:15 $ + * + * Copyright (c) 1991, Larry Wall + * +*************** +*** 6,12 **** + * License or the Artistic License, as specified in the README file. + * + * $Log: cons.c,v $ +! * Revision 4.0.1.3 1992/06/08 12:18:35 lwall + * patch20: removed implicit int declarations on funcions + * patch20: deleted some minor memory leaks + * patch20: fixed double debug break in foreach with implicit array assignment +--- 6,15 ---- + * License or the Artistic License, as specified in the README file. + * + * $Log: cons.c,v $ +! * Revision 4.0.1.4 1993/02/05 19:30:15 lwall +! * patch36: fixed various little coredump bugs +! * +! * Revision 4.0.1.3 92/06/08 12:18:35 lwall + * patch20: removed implicit int declarations on funcions + * patch20: deleted some minor memory leaks + * patch20: fixed double debug break in foreach with implicit array assignment +*************** +*** 15,21 **** + * patch20: debugger sometimes displayed wrong source line + * patch20: various error messages have been clarified + * patch20: an eval block containing a null block or statement could dump core +! * + * Revision 4.0.1.2 91/11/05 16:15:13 lwall + * patch11: debugger got confused over nested subroutine definitions + * patch11: prepared for ctype implementations that don't define isascii() +--- 18,24 ---- + * patch20: debugger sometimes displayed wrong source line + * patch20: various error messages have been clarified + * patch20: an eval block containing a null block or statement could dump core +! * + * Revision 4.0.1.2 91/11/05 16:15:13 lwall + * patch11: debugger got confused over nested subroutine definitions + * patch11: prepared for ctype implementations that don't define isascii() diff --git a/doarg.c b/doarg.c index ca1014c..483157f 100644 --- a/doarg.c +++ b/doarg.c @@ -208,6 +208,7 @@ int sp; STABSET(str); str_numset(arg->arg_ptr.arg_str, 1.0); stack->ary_array[++sp] = arg->arg_ptr.arg_str; + str->str_nok = 0; return sp; } /*SUPPRESS 560*/ @@ -223,6 +224,7 @@ int sp; STABSET(str); str_numset(arg->arg_ptr.arg_str, 1.0); stack->ary_array[++sp] = arg->arg_ptr.arg_str; + str->str_nok = 0; return sp; } else if (clen) { @@ -232,6 +234,7 @@ int sp; STABSET(str); str_numset(arg->arg_ptr.arg_str, 1.0); stack->ary_array[++sp] = arg->arg_ptr.arg_str; + str->str_nok = 0; return sp; } else { @@ -239,6 +242,7 @@ int sp; STABSET(str); str_numset(arg->arg_ptr.arg_str, 1.0); stack->ary_array[++sp] = arg->arg_ptr.arg_str; + str->str_nok = 0; return sp; } /* NOTREACHED */ @@ -268,6 +272,7 @@ int sp; STABSET(str); str_numset(arg->arg_ptr.arg_str, (double)iters); stack->ary_array[++sp] = arg->arg_ptr.arg_str; + str->str_nok = 0; return sp; } str_numset(arg->arg_ptr.arg_str, 0.0); @@ -322,6 +327,7 @@ int sp; STABSET(str); str_numset(arg->arg_ptr.arg_str, (double)iters); stack->ary_array[++sp] = arg->arg_ptr.arg_str; + str->str_nok = 0; return sp; } str_numset(arg->arg_ptr.arg_str, 0.0); diff --git a/doarg.c.orig b/doarg.c.orig new file mode 100644 index 0000000..ca1014c --- /dev/null +++ b/doarg.c.orig @@ -0,0 +1,1837 @@ +/* $RCSfile: doarg.c,v $$Revision: 4.0.1.7 $$Date: 92/06/11 21:07:11 $ + * + * Copyright (c) 1991, Larry Wall + * + * You may distribute under the terms of either the GNU General Public + * License or the Artistic License, as specified in the README file. + * + * $Log: doarg.c,v $ + * Revision 4.0.1.7 92/06/11 21:07:11 lwall + * patch34: join with null list attempted negative allocation + * patch34: sprintf("%6.4s", "abcdefg") didn't print "abcd " + * + * Revision 4.0.1.6 92/06/08 12:34:30 lwall + * patch20: removed implicit int declarations on funcions + * patch20: pattern modifiers i and o didn't interact right + * patch20: join() now pre-extends target string to avoid excessive copying + * patch20: fixed confusion between a *var's real name and its effective name + * patch20: subroutines didn't localize $`, $&, $', $1 et al correctly + * patch20: usersub routines didn't reclaim temp values soon enough + * patch20: ($<,$>) = ... didn't work on some architectures + * patch20: added Atari ST portability + * + * Revision 4.0.1.5 91/11/11 16:31:58 lwall + * patch19: added little-endian pack/unpack options + * + * Revision 4.0.1.4 91/11/05 16:35:06 lwall + * patch11: /$foo/o optimizer could access deallocated data + * patch11: minimum match length calculation in regexp is now cumulative + * patch11: added some support for 64-bit integers + * patch11: prepared for ctype implementations that don't define isascii() + * patch11: sprintf() now supports any length of s field + * patch11: indirect subroutine calls through magic vars (e.g. &$1) didn't work + * patch11: defined(&$foo) and undef(&$foo) didn't work + * + * Revision 4.0.1.3 91/06/10 01:18:41 lwall + * patch10: pack(hh,1) dumped core + * + * Revision 4.0.1.2 91/06/07 10:42:17 lwall + * patch4: new copyright notice + * patch4: // wouldn't use previous pattern if it started with a null character + * patch4: //o and s///o now optimize themselves fully at runtime + * patch4: added global modifier for pattern matches + * patch4: undef @array disabled "@array" interpolation + * patch4: chop("") was returning "\0" rather than "" + * patch4: vector logical operations &, | and ^ sometimes returned null string + * patch4: syscall couldn't pass numbers with most significant bit set on sparcs + * + * Revision 4.0.1.1 91/04/11 17:40:14 lwall + * patch1: fixed undefined environ problem + * patch1: fixed debugger coredump on subroutines + * + * Revision 4.0 91/03/20 01:06:42 lwall + * 4.0 baseline. + * + */ + +#include "EXTERN.h" +#include "perl.h" + +#if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX) +#include +#endif + +extern unsigned char fold[]; + +#ifdef BUGGY_MSC + #pragma function(memcmp) +#endif /* BUGGY_MSC */ + +static void doencodes(); + +int +do_subst(str,arg,sp) +STR *str; +ARG *arg; +int sp; +{ + register SPAT *spat; + SPAT *rspat; + register STR *dstr; + register char *s = str_get(str); + char *strend = s + str->str_cur; + register char *m; + char *c; + register char *d; + int clen; + int iters = 0; + int maxiters = (strend - s) + 10; + register int i; + bool once; + char *orig; + int safebase; + + rspat = spat = arg[2].arg_ptr.arg_spat; + if (!spat || !s) + fatal("panic: do_subst"); + else if (spat->spat_runtime) { + nointrp = "|)"; + (void)eval(spat->spat_runtime,G_SCALAR,sp); + m = str_get(dstr = stack->ary_array[sp+1]); + nointrp = ""; + if (spat->spat_regexp) { + regfree(spat->spat_regexp); + spat->spat_regexp = Null(REGEXP*); /* required if regcomp pukes */ + } + spat->spat_regexp = regcomp(m,m+dstr->str_cur, + spat->spat_flags & SPAT_FOLD); + if (spat->spat_flags & SPAT_KEEP) { + if (!(spat->spat_flags & SPAT_FOLD)) + scanconst(spat, m, dstr->str_cur); + arg_free(spat->spat_runtime); /* it won't change, so */ + spat->spat_runtime = Nullarg; /* no point compiling again */ + hoistmust(spat); + if (curcmd->c_expr && (curcmd->c_flags & CF_OPTIMIZE) == CFT_EVAL) { + curcmd->c_flags &= ~CF_OPTIMIZE; + opt_arg(curcmd, 1, curcmd->c_type == C_EXPR); + } + } + } +#ifdef DEBUGGING + if (debug & 8) { + deb("2.SPAT /%s/\n",spat->spat_regexp->precomp); + } +#endif + safebase = ((!spat->spat_regexp || !spat->spat_regexp->nparens) && + !sawampersand); + if (!spat->spat_regexp->prelen && lastspat) + spat = lastspat; + orig = m = s; + if (hint) { + if (hint < s || hint > strend) + fatal("panic: hint in do_match"); + s = hint; + hint = Nullch; + if (spat->spat_regexp->regback >= 0) { + s -= spat->spat_regexp->regback; + if (s < m) + s = m; + } + else + s = m; + } + else if (spat->spat_short) { + if (spat->spat_flags & SPAT_SCANFIRST) { + if (str->str_pok & SP_STUDIED) { + if (screamfirst[spat->spat_short->str_rare] < 0) + goto nope; + else if (!(s = screaminstr(str,spat->spat_short))) + goto nope; + } +#ifndef lint + else if (!(s = fbminstr((unsigned char*)s, (unsigned char*)strend, + spat->spat_short))) + goto nope; +#endif + if (s && spat->spat_regexp->regback >= 0) { + ++spat->spat_short->str_u.str_useful; + s -= spat->spat_regexp->regback; + if (s < m) + s = m; + } + else + s = m; + } + else if (!multiline && (*spat->spat_short->str_ptr != *s || + bcmp(spat->spat_short->str_ptr, s, spat->spat_slen) )) + goto nope; + if (--spat->spat_short->str_u.str_useful < 0) { + str_free(spat->spat_short); + spat->spat_short = Nullstr; /* opt is being useless */ + } + } + once = !(rspat->spat_flags & SPAT_GLOBAL); + if (rspat->spat_flags & SPAT_CONST) { /* known replacement string? */ + if ((rspat->spat_repl[1].arg_type & A_MASK) == A_SINGLE) + dstr = rspat->spat_repl[1].arg_ptr.arg_str; + else { /* constant over loop, anyway */ + (void)eval(rspat->spat_repl,G_SCALAR,sp); + dstr = stack->ary_array[sp+1]; + } + c = str_get(dstr); + clen = dstr->str_cur; + if (clen <= spat->spat_regexp->minlen) { + /* can do inplace substitution */ + if (regexec(spat->spat_regexp, s, strend, orig, 0, + str->str_pok & SP_STUDIED ? str : Nullstr, safebase)) { + if (spat->spat_regexp->subbase) /* oops, no we can't */ + goto long_way; + d = s; + lastspat = spat; + str->str_pok = SP_VALID; /* disable possible screamer */ + if (once) { + m = spat->spat_regexp->startp[0]; + d = spat->spat_regexp->endp[0]; + s = orig; + if (m - s > strend - d) { /* faster to shorten from end */ + if (clen) { + Copy(c, m, clen, char); + m += clen; + } + i = strend - d; + if (i > 0) { + Move(d, m, i, char); + m += i; + } + *m = '\0'; + str->str_cur = m - s; + STABSET(str); + str_numset(arg->arg_ptr.arg_str, 1.0); + stack->ary_array[++sp] = arg->arg_ptr.arg_str; + return sp; + } + /*SUPPRESS 560*/ + else if (i = m - s) { /* faster from front */ + d -= clen; + m = d; + str_chop(str,d-i); + s += i; + while (i--) + *--d = *--s; + if (clen) + Copy(c, m, clen, char); + STABSET(str); + str_numset(arg->arg_ptr.arg_str, 1.0); + stack->ary_array[++sp] = arg->arg_ptr.arg_str; + return sp; + } + else if (clen) { + d -= clen; + str_chop(str,d); + Copy(c,d,clen,char); + STABSET(str); + str_numset(arg->arg_ptr.arg_str, 1.0); + stack->ary_array[++sp] = arg->arg_ptr.arg_str; + return sp; + } + else { + str_chop(str,d); + STABSET(str); + str_numset(arg->arg_ptr.arg_str, 1.0); + stack->ary_array[++sp] = arg->arg_ptr.arg_str; + return sp; + } + /* NOTREACHED */ + } + do { + if (iters++ > maxiters) + fatal("Substitution loop"); + m = spat->spat_regexp->startp[0]; + /*SUPPRESS 560*/ + if (i = m - s) { + if (s != d) + Move(s,d,i,char); + d += i; + } + if (clen) { + Copy(c,d,clen,char); + d += clen; + } + s = spat->spat_regexp->endp[0]; + } while (regexec(spat->spat_regexp, s, strend, orig, s == m, + Nullstr, TRUE)); /* (don't match same null twice) */ + if (s != d) { + i = strend - s; + str->str_cur = d - str->str_ptr + i; + Move(s,d,i+1,char); /* include the Null */ + } + STABSET(str); + str_numset(arg->arg_ptr.arg_str, (double)iters); + stack->ary_array[++sp] = arg->arg_ptr.arg_str; + return sp; + } + str_numset(arg->arg_ptr.arg_str, 0.0); + stack->ary_array[++sp] = arg->arg_ptr.arg_str; + return sp; + } + } + else + c = Nullch; + if (regexec(spat->spat_regexp, s, strend, orig, 0, + str->str_pok & SP_STUDIED ? str : Nullstr, safebase)) { + long_way: + dstr = Str_new(25,str_len(str)); + str_nset(dstr,m,s-m); + if (spat->spat_regexp->subbase) + curspat = spat; + lastspat = spat; + do { + if (iters++ > maxiters) + fatal("Substitution loop"); + if (spat->spat_regexp->subbase + && spat->spat_regexp->subbase != orig) { + m = s; + s = orig; + orig = spat->spat_regexp->subbase; + s = orig + (m - s); + strend = s + (strend - m); + } + m = spat->spat_regexp->startp[0]; + str_ncat(dstr,s,m-s); + s = spat->spat_regexp->endp[0]; + if (c) { + if (clen) + str_ncat(dstr,c,clen); + } + else { + char *mysubbase = spat->spat_regexp->subbase; + + spat->spat_regexp->subbase = Nullch; /* so recursion works */ + (void)eval(rspat->spat_repl,G_SCALAR,sp); + str_scat(dstr,stack->ary_array[sp+1]); + if (spat->spat_regexp->subbase) + Safefree(spat->spat_regexp->subbase); + spat->spat_regexp->subbase = mysubbase; + } + if (once) + break; + } while (regexec(spat->spat_regexp, s, strend, orig, s == m, Nullstr, + safebase)); + str_ncat(dstr,s,strend - s); + str_replace(str,dstr); + STABSET(str); + str_numset(arg->arg_ptr.arg_str, (double)iters); + stack->ary_array[++sp] = arg->arg_ptr.arg_str; + return sp; + } + str_numset(arg->arg_ptr.arg_str, 0.0); + stack->ary_array[++sp] = arg->arg_ptr.arg_str; + return sp; + +nope: + ++spat->spat_short->str_u.str_useful; + str_numset(arg->arg_ptr.arg_str, 0.0); + stack->ary_array[++sp] = arg->arg_ptr.arg_str; + return sp; +} +#ifdef BUGGY_MSC + #pragma intrinsic(memcmp) +#endif /* BUGGY_MSC */ + +int +do_trans(str,arg) +STR *str; +ARG *arg; +{ + register short *tbl; + register char *s; + register int matches = 0; + register int ch; + register char *send; + register char *d; + register int squash = arg[2].arg_len & 1; + + tbl = (short*) arg[2].arg_ptr.arg_cval; + s = str_get(str); + send = s + str->str_cur; + if (!tbl || !s) + fatal("panic: do_trans"); +#ifdef DEBUGGING + if (debug & 8) { + deb("2.TBL\n"); + } +#endif + if (!arg[2].arg_len) { + while (s < send) { + if ((ch = tbl[*s & 0377]) >= 0) { + matches++; + *s = ch; + } + s++; + } + } + else { + d = s; + while (s < send) { + if ((ch = tbl[*s & 0377]) >= 0) { + *d = ch; + if (matches++ && squash) { + if (d[-1] == *d) + matches--; + else + d++; + } + else + d++; + } + else if (ch == -1) /* -1 is unmapped character */ + *d++ = *s; /* -2 is delete character */ + s++; + } + matches += send - d; /* account for disappeared chars */ + *d = '\0'; + str->str_cur = d - str->str_ptr; + } + STABSET(str); + return matches; +} + +void +do_join(str,arglast) +register STR *str; +int *arglast; +{ + register STR **st = stack->ary_array; + int sp = arglast[1]; + register int items = arglast[2] - sp; + register char *delim = str_get(st[sp]); + register STRLEN len; + int delimlen = st[sp]->str_cur; + + st += sp + 1; + + len = (items > 0 ? (delimlen * (items - 1) ) : 0); + if (str->str_len < len + items) { /* current length is way too short */ + while (items-- > 0) { + if (*st) + len += (*st)->str_cur; + st++; + } + STR_GROW(str, len + 1); /* so try to pre-extend */ + + items = arglast[2] - sp; + st -= items; + } + + if (items-- > 0) + str_sset(str, *st++); + else + str_set(str,""); + len = delimlen; + if (len) { + for (; items > 0; items--,st++) { + str_ncat(str,delim,len); + str_scat(str,*st); + } + } + else { + for (; items > 0; items--,st++) + str_scat(str,*st); + } + STABSET(str); +} + +void +do_pack(str,arglast) +register STR *str; +int *arglast; +{ + register STR **st = stack->ary_array; + register int sp = arglast[1]; + register int items; + register char *pat = str_get(st[sp]); + register char *patend = pat + st[sp]->str_cur; + register int len; + int datumtype; + STR *fromstr; + /*SUPPRESS 442*/ + static char *null10 = "\0\0\0\0\0\0\0\0\0\0"; + static char *space10 = " "; + + /* These must not be in registers: */ + char achar; + short ashort; + int aint; + unsigned int auint; + long along; + unsigned long aulong; +#ifdef QUAD + quad aquad; + unsigned quad auquad; +#endif + char *aptr; + float afloat; + double adouble; + + items = arglast[2] - sp; + st += ++sp; + str_nset(str,"",0); + while (pat < patend) { +#define NEXTFROM (items-- > 0 ? *st++ : &str_no) + datumtype = *pat++; + if (*pat == '*') { + len = index("@Xxu",datumtype) ? 0 : items; + pat++; + } + else if (isDIGIT(*pat)) { + len = *pat++ - '0'; + while (isDIGIT(*pat)) + len = (len * 10) + (*pat++ - '0'); + } + else + len = 1; + switch(datumtype) { + default: + break; + case '%': + fatal("% may only be used in unpack"); + case '@': + len -= str->str_cur; + if (len > 0) + goto grow; + len = -len; + if (len > 0) + goto shrink; + break; + case 'X': + shrink: + if (str->str_cur < len) + fatal("X outside of string"); + str->str_cur -= len; + str->str_ptr[str->str_cur] = '\0'; + break; + case 'x': + grow: + while (len >= 10) { + str_ncat(str,null10,10); + len -= 10; + } + str_ncat(str,null10,len); + break; + case 'A': + case 'a': + fromstr = NEXTFROM; + aptr = str_get(fromstr); + if (pat[-1] == '*') + len = fromstr->str_cur; + if (fromstr->str_cur > len) + str_ncat(str,aptr,len); + else { + str_ncat(str,aptr,fromstr->str_cur); + len -= fromstr->str_cur; + if (datumtype == 'A') { + while (len >= 10) { + str_ncat(str,space10,10); + len -= 10; + } + str_ncat(str,space10,len); + } + else { + while (len >= 10) { + str_ncat(str,null10,10); + len -= 10; + } + str_ncat(str,null10,len); + } + } + break; + case 'B': + case 'b': + { + char *savepat = pat; + int saveitems; + + fromstr = NEXTFROM; + saveitems = items; + aptr = str_get(fromstr); + if (pat[-1] == '*') + len = fromstr->str_cur; + pat = aptr; + aint = str->str_cur; + str->str_cur += (len+7)/8; + STR_GROW(str, str->str_cur + 1); + aptr = str->str_ptr + aint; + if (len > fromstr->str_cur) + len = fromstr->str_cur; + aint = len; + items = 0; + if (datumtype == 'B') { + for (len = 0; len++ < aint;) { + items |= *pat++ & 1; + if (len & 7) + items <<= 1; + else { + *aptr++ = items & 0xff; + items = 0; + } + } + } + else { + for (len = 0; len++ < aint;) { + if (*pat++ & 1) + items |= 128; + if (len & 7) + items >>= 1; + else { + *aptr++ = items & 0xff; + items = 0; + } + } + } + if (aint & 7) { + if (datumtype == 'B') + items <<= 7 - (aint & 7); + else + items >>= 7 - (aint & 7); + *aptr++ = items & 0xff; + } + pat = str->str_ptr + str->str_cur; + while (aptr <= pat) + *aptr++ = '\0'; + + pat = savepat; + items = saveitems; + } + break; + case 'H': + case 'h': + { + char *savepat = pat; + int saveitems; + + fromstr = NEXTFROM; + saveitems = items; + aptr = str_get(fromstr); + if (pat[-1] == '*') + len = fromstr->str_cur; + pat = aptr; + aint = str->str_cur; + str->str_cur += (len+1)/2; + STR_GROW(str, str->str_cur + 1); + aptr = str->str_ptr + aint; + if (len > fromstr->str_cur) + len = fromstr->str_cur; + aint = len; + items = 0; + if (datumtype == 'H') { + for (len = 0; len++ < aint;) { + if (isALPHA(*pat)) + items |= ((*pat++ & 15) + 9) & 15; + else + items |= *pat++ & 15; + if (len & 1) + items <<= 4; + else { + *aptr++ = items & 0xff; + items = 0; + } + } + } + else { + for (len = 0; len++ < aint;) { + if (isALPHA(*pat)) + items |= (((*pat++ & 15) + 9) & 15) << 4; + else + items |= (*pat++ & 15) << 4; + if (len & 1) + items >>= 4; + else { + *aptr++ = items & 0xff; + items = 0; + } + } + } + if (aint & 1) + *aptr++ = items & 0xff; + pat = str->str_ptr + str->str_cur; + while (aptr <= pat) + *aptr++ = '\0'; + + pat = savepat; + items = saveitems; + } + break; + case 'C': + case 'c': + while (len-- > 0) { + fromstr = NEXTFROM; + aint = (int)str_gnum(fromstr); + achar = aint; + str_ncat(str,&achar,sizeof(char)); + } + break; + /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */ + case 'f': + case 'F': + while (len-- > 0) { + fromstr = NEXTFROM; + afloat = (float)str_gnum(fromstr); + str_ncat(str, (char *)&afloat, sizeof (float)); + } + break; + case 'd': + case 'D': + while (len-- > 0) { + fromstr = NEXTFROM; + adouble = (double)str_gnum(fromstr); + str_ncat(str, (char *)&adouble, sizeof (double)); + } + break; + case 'n': + while (len-- > 0) { + fromstr = NEXTFROM; + ashort = (short)str_gnum(fromstr); +#ifdef HAS_HTONS + ashort = htons(ashort); +#endif + str_ncat(str,(char*)&ashort,sizeof(short)); + } + break; + case 'v': + while (len-- > 0) { + fromstr = NEXTFROM; + ashort = (short)str_gnum(fromstr); +#ifdef HAS_HTOVS + ashort = htovs(ashort); +#endif + str_ncat(str,(char*)&ashort,sizeof(short)); + } + break; + case 'S': + case 's': + while (len-- > 0) { + fromstr = NEXTFROM; + ashort = (short)str_gnum(fromstr); + str_ncat(str,(char*)&ashort,sizeof(short)); + } + break; + case 'I': + while (len-- > 0) { + fromstr = NEXTFROM; + auint = U_I(str_gnum(fromstr)); + str_ncat(str,(char*)&auint,sizeof(unsigned int)); + } + break; + case 'i': + while (len-- > 0) { + fromstr = NEXTFROM; + aint = (int)str_gnum(fromstr); + str_ncat(str,(char*)&aint,sizeof(int)); + } + break; + case 'N': + while (len-- > 0) { + fromstr = NEXTFROM; + aulong = U_L(str_gnum(fromstr)); +#ifdef HAS_HTONL + aulong = htonl(aulong); +#endif + str_ncat(str,(char*)&aulong,sizeof(unsigned long)); + } + break; + case 'V': + while (len-- > 0) { + fromstr = NEXTFROM; + aulong = U_L(str_gnum(fromstr)); +#ifdef HAS_HTOVL + aulong = htovl(aulong); +#endif + str_ncat(str,(char*)&aulong,sizeof(unsigned long)); + } + break; + case 'L': + while (len-- > 0) { + fromstr = NEXTFROM; + aulong = U_L(str_gnum(fromstr)); + str_ncat(str,(char*)&aulong,sizeof(unsigned long)); + } + break; + case 'l': + while (len-- > 0) { + fromstr = NEXTFROM; + along = (long)str_gnum(fromstr); + str_ncat(str,(char*)&along,sizeof(long)); + } + break; +#ifdef QUAD + case 'Q': + while (len-- > 0) { + fromstr = NEXTFROM; + auquad = (unsigned quad)str_gnum(fromstr); + str_ncat(str,(char*)&auquad,sizeof(unsigned quad)); + } + break; + case 'q': + while (len-- > 0) { + fromstr = NEXTFROM; + aquad = (quad)str_gnum(fromstr); + str_ncat(str,(char*)&aquad,sizeof(quad)); + } + break; +#endif /* QUAD */ + case 'p': + while (len-- > 0) { + fromstr = NEXTFROM; + aptr = str_get(fromstr); + str_ncat(str,(char*)&aptr,sizeof(char*)); + } + break; + case 'u': + fromstr = NEXTFROM; + aptr = str_get(fromstr); + aint = fromstr->str_cur; + STR_GROW(str,aint * 4 / 3); + if (len <= 1) + len = 45; + else + len = len / 3 * 3; + while (aint > 0) { + int todo; + + if (aint > len) + todo = len; + else + todo = aint; + doencodes(str, aptr, todo); + aint -= todo; + aptr += todo; + } + break; + } + } + STABSET(str); +} +#undef NEXTFROM + +static void +doencodes(str, s, len) +register STR *str; +register char *s; +register int len; +{ + char hunk[5]; + + *hunk = len + ' '; + str_ncat(str, hunk, 1); + hunk[4] = '\0'; + while (len > 0) { + hunk[0] = ' ' + (077 & (*s >> 2)); + hunk[1] = ' ' + (077 & ((*s << 4) & 060 | (s[1] >> 4) & 017)); + hunk[2] = ' ' + (077 & ((s[1] << 2) & 074 | (s[2] >> 6) & 03)); + hunk[3] = ' ' + (077 & (s[2] & 077)); + str_ncat(str, hunk, 4); + s += 3; + len -= 3; + } + for (s = str->str_ptr; *s; s++) { + if (*s == ' ') + *s = '`'; + } + str_ncat(str, "\n", 1); +} + +void +do_sprintf(str,len,sarg) +register STR *str; +register int len; +register STR **sarg; +{ + register char *s; + register char *t; + register char *f; + bool dolong; +#ifdef QUAD + bool doquad; +#endif /* QUAD */ + char ch; + static STR *sargnull = &str_no; + register char *send; + register STR *arg; + char *xs; + int xlen; + int pre; + int post; + double value; + + str_set(str,""); + len--; /* don't count pattern string */ + t = s = str_get(*sarg); + send = s + (*sarg)->str_cur; + sarg++; + for ( ; ; len--) { + + /*SUPPRESS 560*/ + if (len <= 0 || !(arg = *sarg++)) + arg = sargnull; + + /*SUPPRESS 530*/ + for ( ; t < send && *t != '%'; t++) ; + if (t >= send) + break; /* end of format string, ignore extra args */ + f = t; + *buf = '\0'; + xs = buf; +#ifdef QUAD + doquad = +#endif /* QUAD */ + dolong = FALSE; + pre = post = 0; + for (t++; t < send; t++) { + switch (*t) { + default: + ch = *(++t); + *t = '\0'; + (void)sprintf(xs,f); + len++, sarg--; + xlen = strlen(xs); + break; + case '0': case '1': case '2': case '3': case '4': + case '5': case '6': case '7': case '8': case '9': + case '.': case '#': case '-': case '+': case ' ': + continue; + case 'l': +#ifdef QUAD + if (dolong) { + dolong = FALSE; + doquad = TRUE; + } else +#endif + dolong = TRUE; + continue; + case 'c': + ch = *(++t); + *t = '\0'; + xlen = (int)str_gnum(arg); + if (strEQ(f,"%c")) { /* some printfs fail on null chars */ + *xs = xlen; + xs[1] = '\0'; + xlen = 1; + } + else { + (void)sprintf(xs,f,xlen); + xlen = strlen(xs); + } + break; + case 'D': + dolong = TRUE; + /* FALL THROUGH */ + case 'd': + ch = *(++t); + *t = '\0'; +#ifdef QUAD + if (doquad) + (void)sprintf(buf,s,(quad)str_gnum(arg)); + else +#endif + if (dolong) + (void)sprintf(xs,f,(long)str_gnum(arg)); + else + (void)sprintf(xs,f,(int)str_gnum(arg)); + xlen = strlen(xs); + break; + case 'X': case 'O': + dolong = TRUE; + /* FALL THROUGH */ + case 'x': case 'o': case 'u': + ch = *(++t); + *t = '\0'; + value = str_gnum(arg); +#ifdef QUAD + if (doquad) + (void)sprintf(buf,s,(unsigned quad)value); + else +#endif + if (dolong) + (void)sprintf(xs,f,U_L(value)); + else + (void)sprintf(xs,f,U_I(value)); + xlen = strlen(xs); + break; + case 'E': case 'e': case 'f': case 'G': case 'g': + ch = *(++t); + *t = '\0'; + (void)sprintf(xs,f,str_gnum(arg)); + xlen = strlen(xs); + break; + case 's': + ch = *(++t); + *t = '\0'; + xs = str_get(arg); + xlen = arg->str_cur; + if (*xs == 'S' && xs[1] == 't' && xs[2] == 'B' && xs[3] == '\0' + && xlen == sizeof(STBP)) { + STR *tmpstr = Str_new(24,0); + + stab_efullname(tmpstr, ((STAB*)arg)); /* a stab value! */ + sprintf(tokenbuf,"*%s",tmpstr->str_ptr); + /* reformat to non-binary */ + xs = tokenbuf; + xlen = strlen(tokenbuf); + str_free(tmpstr); + } + if (strEQ(f,"%s")) { /* some printfs fail on >128 chars */ + break; /* so handle simple cases */ + } + else if (f[1] == '-') { + char *mp = index(f, '.'); + int min = atoi(f+2); + + if (mp) { + int max = atoi(mp+1); + + if (xlen > max) + xlen = max; + } + if (xlen < min) + post = min - xlen; + break; + } + else if (isDIGIT(f[1])) { + char *mp = index(f, '.'); + int min = atoi(f+1); + + if (mp) { + int max = atoi(mp+1); + + if (xlen > max) + xlen = max; + } + if (xlen < min) + pre = min - xlen; + break; + } + strcpy(tokenbuf+64,f); /* sprintf($s,...$s...) */ + *t = ch; + (void)sprintf(buf,tokenbuf+64,xs); + xs = buf; + xlen = strlen(xs); + break; + } + /* end of switch, copy results */ + *t = ch; + STR_GROW(str, str->str_cur + (f - s) + xlen + 1 + pre + post); + str_ncat(str, s, f - s); + if (pre) { + repeatcpy(str->str_ptr + str->str_cur, " ", 1, pre); + str->str_cur += pre; + } + str_ncat(str, xs, xlen); + if (post) { + repeatcpy(str->str_ptr + str->str_cur, " ", 1, post); + str->str_cur += post; + } + s = t; + break; /* break from for loop */ + } + } + str_ncat(str, s, t - s); + STABSET(str); +} + +STR * +do_push(ary,arglast) +register ARRAY *ary; +int *arglast; +{ + register STR **st = stack->ary_array; + register int sp = arglast[1]; + register int items = arglast[2] - sp; + register STR *str = &str_undef; + + for (st += ++sp; items > 0; items--,st++) { + str = Str_new(26,0); + if (*st) + str_sset(str,*st); + (void)apush(ary,str); + } + return str; +} + +void +do_unshift(ary,arglast) +register ARRAY *ary; +int *arglast; +{ + register STR **st = stack->ary_array; + register int sp = arglast[1]; + register int items = arglast[2] - sp; + register STR *str; + register int i; + + aunshift(ary,items); + i = 0; + for (st += ++sp; i < items; i++,st++) { + str = Str_new(27,0); + str_sset(str,*st); + (void)astore(ary,i,str); + } +} + +int +do_subr(arg,gimme,arglast) +register ARG *arg; +int gimme; +int *arglast; +{ + register STR **st = stack->ary_array; + register int sp = arglast[1]; + register int items = arglast[2] - sp; + register SUBR *sub; + SPAT * VOLATILE oldspat = curspat; + STR *str; + STAB *stab; + int oldsave = savestack->ary_fill; + int oldtmps_base = tmps_base; + int hasargs = ((arg[2].arg_type & A_MASK) != A_NULL); + register CSV *csv; + + if ((arg[1].arg_type & A_MASK) == A_WORD) + stab = arg[1].arg_ptr.arg_stab; + else { + STR *tmpstr = STAB_STR(arg[1].arg_ptr.arg_stab); + + if (tmpstr) + stab = stabent(str_get(tmpstr),TRUE); + else + stab = Nullstab; + } + if (!stab) + fatal("Undefined subroutine called"); + if (!(sub = stab_sub(stab))) { + STR *tmpstr = arg[0].arg_ptr.arg_str; + + stab_efullname(tmpstr, stab); + fatal("Undefined subroutine \"%s\" called",tmpstr->str_ptr); + } + if (arg->arg_type == O_DBSUBR && !sub->usersub) { + str = stab_val(DBsub); + saveitem(str); + stab_efullname(str,stab); + sub = stab_sub(DBsub); + if (!sub) + fatal("No DBsub routine"); + } + str = Str_new(15, sizeof(CSV)); + str->str_state = SS_SCSV; + (void)apush(savestack,str); + csv = (CSV*)str->str_ptr; + csv->sub = sub; + csv->stab = stab; + csv->curcsv = curcsv; + csv->curcmd = curcmd; + csv->depth = sub->depth; + csv->wantarray = gimme; + csv->hasargs = hasargs; + curcsv = csv; + tmps_base = tmps_max; + if (sub->usersub) { + csv->hasargs = 0; + csv->savearray = Null(ARRAY*);; + csv->argarray = Null(ARRAY*); + st[sp] = arg->arg_ptr.arg_str; + if (!hasargs) + items = 0; + sp = (*sub->usersub)(sub->userindex,sp,items); + } + else { + if (hasargs) { + csv->savearray = stab_xarray(defstab); + csv->argarray = afake(defstab, items, &st[sp+1]); + stab_xarray(defstab) = csv->argarray; + } + sub->depth++; + if (sub->depth >= 2) { /* save temporaries on recursion? */ + if (sub->depth == 100 && dowarn) + warn("Deep recursion on subroutine \"%s\"",stab_ename(stab)); + savelist(sub->tosave->ary_array,sub->tosave->ary_fill); + } + sp = cmd_exec(sub->cmd,gimme, --sp); /* so do it already */ + } + + st = stack->ary_array; + tmps_base = oldtmps_base; + for (items = arglast[0] + 1; items <= sp; items++) + st[items] = str_mortal(st[items]); + /* in case restore wipes old str */ + restorelist(oldsave); + curspat = oldspat; + return sp; +} + +int +do_assign(arg,gimme,arglast) +register ARG *arg; +int gimme; +int *arglast; +{ + + register STR **st = stack->ary_array; + STR **firstrelem = st + arglast[1] + 1; + STR **firstlelem = st + arglast[0] + 1; + STR **lastrelem = st + arglast[2]; + STR **lastlelem = st + arglast[1]; + register STR **relem; + register STR **lelem; + + register STR *str; + register ARRAY *ary; + register int makelocal; + HASH *hash; + int i; + + makelocal = (arg->arg_flags & AF_LOCAL) != 0; + localizing = makelocal; + delaymagic = DM_DELAY; /* catch simultaneous items */ + + /* If there's a common identifier on both sides we have to take + * special care that assigning the identifier on the left doesn't + * clobber a value on the right that's used later in the list. + */ + if (arg->arg_flags & AF_COMMON) { + for (relem = firstrelem; relem <= lastrelem; relem++) { + /*SUPPRESS 560*/ + if (str = *relem) + *relem = str_mortal(str); + } + } + relem = firstrelem; + lelem = firstlelem; + ary = Null(ARRAY*); + hash = Null(HASH*); + while (lelem <= lastlelem) { + str = *lelem++; + if (str->str_state >= SS_HASH) { + if (str->str_state == SS_ARY) { + if (makelocal) + ary = saveary(str->str_u.str_stab); + else { + ary = stab_array(str->str_u.str_stab); + ary->ary_fill = -1; + } + i = 0; + while (relem <= lastrelem) { /* gobble up all the rest */ + str = Str_new(28,0); + if (*relem) + str_sset(str,*relem); + *(relem++) = str; + (void)astore(ary,i++,str); + } + } + else if (str->str_state == SS_HASH) { + char *tmps; + STR *tmpstr; + int magic = 0; + STAB *tmpstab = str->str_u.str_stab; + + if (makelocal) + hash = savehash(str->str_u.str_stab); + else { + hash = stab_hash(str->str_u.str_stab); + if (tmpstab == envstab) { + magic = 'E'; + environ[0] = Nullch; + } + else if (tmpstab == sigstab) { + magic = 'S'; +#ifndef NSIG +#define NSIG 32 +#endif + for (i = 1; i < NSIG; i++) + signal(i, SIG_DFL); /* crunch, crunch, crunch */ + } +#ifdef SOME_DBM + else if (hash->tbl_dbm) + magic = 'D'; +#endif + hclear(hash, magic == 'D'); /* wipe any dbm file too */ + + } + while (relem < lastrelem) { /* gobble up all the rest */ + if (*relem) + str = *(relem++); + else + str = &str_no, relem++; + tmps = str_get(str); + tmpstr = Str_new(29,0); + if (*relem) + str_sset(tmpstr,*relem); /* value */ + *(relem++) = tmpstr; + (void)hstore(hash,tmps,str->str_cur,tmpstr,0); + if (magic) { + str_magic(tmpstr, tmpstab, magic, tmps, str->str_cur); + stabset(tmpstr->str_magic, tmpstr); + } + } + } + else + fatal("panic: do_assign"); + } + else { + if (makelocal) + saveitem(str); + if (relem <= lastrelem) { + str_sset(str, *relem); + *(relem++) = str; + } + else { + str_sset(str, &str_undef); + if (gimme == G_ARRAY) { + i = ++lastrelem - firstrelem; + relem++; /* tacky, I suppose */ + astore(stack,i,str); + if (st != stack->ary_array) { + st = stack->ary_array; + firstrelem = st + arglast[1] + 1; + firstlelem = st + arglast[0] + 1; + lastlelem = st + arglast[1]; + lastrelem = st + i; + relem = lastrelem + 1; + } + } + } + STABSET(str); + } + } + if (delaymagic & ~DM_DELAY) { + if (delaymagic & DM_UID) { +#ifdef HAS_SETREUID + (void)setreuid(uid,euid); +#else /* not HAS_SETREUID */ +#ifdef HAS_SETRUID + if ((delaymagic & DM_UID) == DM_RUID) { + (void)setruid(uid); + delaymagic =~ DM_RUID; + } +#endif /* HAS_SETRUID */ +#ifdef HAS_SETEUID + if ((delaymagic & DM_UID) == DM_EUID) { + (void)seteuid(uid); + delaymagic =~ DM_EUID; + } +#endif /* HAS_SETEUID */ + if (delaymagic & DM_UID) { + if (uid != euid) + fatal("No setreuid available"); + (void)setuid(uid); + } +#endif /* not HAS_SETREUID */ + uid = (int)getuid(); + euid = (int)geteuid(); + } + if (delaymagic & DM_GID) { +#ifdef HAS_SETREGID + (void)setregid(gid,egid); +#else /* not HAS_SETREGID */ +#ifdef HAS_SETRGID + if ((delaymagic & DM_GID) == DM_RGID) { + (void)setrgid(gid); + delaymagic =~ DM_RGID; + } +#endif /* HAS_SETRGID */ +#ifdef HAS_SETEGID + if ((delaymagic & DM_GID) == DM_EGID) { + (void)setegid(gid); + delaymagic =~ DM_EGID; + } +#endif /* HAS_SETEGID */ + if (delaymagic & DM_GID) { + if (gid != egid) + fatal("No setregid available"); + (void)setgid(gid); + } +#endif /* not HAS_SETREGID */ + gid = (int)getgid(); + egid = (int)getegid(); + } + } + delaymagic = 0; + localizing = FALSE; + if (gimme == G_ARRAY) { + i = lastrelem - firstrelem + 1; + if (ary || hash) + Copy(firstrelem, firstlelem, i, STR*); + return arglast[0] + i; + } + else { + str_numset(arg->arg_ptr.arg_str,(double)(arglast[2] - arglast[1])); + *firstlelem = arg->arg_ptr.arg_str; + return arglast[0] + 1; + } +} + +int /*SUPPRESS 590*/ +do_study(str,arg,gimme,arglast) +STR *str; +ARG *arg; +int gimme; +int *arglast; +{ + register unsigned char *s; + register int pos = str->str_cur; + register int ch; + register int *sfirst; + register int *snext; + static int maxscream = -1; + static STR *lastscream = Nullstr; + int retval; + int retarg = arglast[0] + 1; + +#ifndef lint + s = (unsigned char*)(str_get(str)); +#else + s = Null(unsigned char*); +#endif + if (lastscream) + lastscream->str_pok &= ~SP_STUDIED; + lastscream = str; + if (pos <= 0) { + retval = 0; + goto ret; + } + if (pos > maxscream) { + if (maxscream < 0) { + maxscream = pos + 80; + New(301,screamfirst, 256, int); + New(302,screamnext, maxscream, int); + } + else { + maxscream = pos + pos / 4; + Renew(screamnext, maxscream, int); + } + } + + sfirst = screamfirst; + snext = screamnext; + + if (!sfirst || !snext) + fatal("do_study: out of memory"); + + for (ch = 256; ch; --ch) + *sfirst++ = -1; + sfirst -= 256; + + while (--pos >= 0) { + ch = s[pos]; + if (sfirst[ch] >= 0) + snext[pos] = sfirst[ch] - pos; + else + snext[pos] = -pos; + sfirst[ch] = pos; + + /* If there were any case insensitive searches, we must assume they + * all are. This speeds up insensitive searches much more than + * it slows down sensitive ones. + */ + if (sawi) + sfirst[fold[ch]] = pos; + } + + str->str_pok |= SP_STUDIED; + retval = 1; + ret: + str_numset(arg->arg_ptr.arg_str,(double)retval); + stack->ary_array[retarg] = arg->arg_ptr.arg_str; + return retarg; +} + +int /*SUPPRESS 590*/ +do_defined(str,arg,gimme,arglast) +STR *str; +register ARG *arg; +int gimme; +int *arglast; +{ + register int type; + register int retarg = arglast[0] + 1; + int retval; + ARRAY *ary; + HASH *hash; + + if ((arg[1].arg_type & A_MASK) != A_LEXPR) + fatal("Illegal argument to defined()"); + arg = arg[1].arg_ptr.arg_arg; + type = arg->arg_type; + + if (type == O_SUBR || type == O_DBSUBR) { + if ((arg[1].arg_type & A_MASK) == A_WORD) + retval = stab_sub(arg[1].arg_ptr.arg_stab) != 0; + else { + STR *tmpstr = STAB_STR(arg[1].arg_ptr.arg_stab); + + retval = tmpstr && stab_sub(stabent(str_get(tmpstr),TRUE)) != 0; + } + } + else if (type == O_ARRAY || type == O_LARRAY || + type == O_ASLICE || type == O_LASLICE ) + retval = ((ary = stab_xarray(arg[1].arg_ptr.arg_stab)) != 0 + && ary->ary_max >= 0 ); + else if (type == O_HASH || type == O_LHASH || + type == O_HSLICE || type == O_LHSLICE ) + retval = ((hash = stab_xhash(arg[1].arg_ptr.arg_stab)) != 0 + && hash->tbl_array); + else + retval = FALSE; + str_numset(str,(double)retval); + stack->ary_array[retarg] = str; + return retarg; +} + +int /*SUPPRESS 590*/ +do_undef(str,arg,gimme,arglast) +STR *str; +register ARG *arg; +int gimme; +int *arglast; +{ + register int type; + register STAB *stab; + int retarg = arglast[0] + 1; + + if ((arg[1].arg_type & A_MASK) != A_LEXPR) + fatal("Illegal argument to undef()"); + arg = arg[1].arg_ptr.arg_arg; + type = arg->arg_type; + + if (type == O_ARRAY || type == O_LARRAY) { + stab = arg[1].arg_ptr.arg_stab; + afree(stab_xarray(stab)); + stab_xarray(stab) = anew(stab); /* so "@array" still works */ + } + else if (type == O_HASH || type == O_LHASH) { + stab = arg[1].arg_ptr.arg_stab; + if (stab == envstab) + environ[0] = Nullch; + else if (stab == sigstab) { + int i; + + for (i = 1; i < NSIG; i++) + signal(i, SIG_DFL); /* munch, munch, munch */ + } + (void)hfree(stab_xhash(stab), TRUE); + stab_xhash(stab) = Null(HASH*); + } + else if (type == O_SUBR || type == O_DBSUBR) { + stab = arg[1].arg_ptr.arg_stab; + if ((arg[1].arg_type & A_MASK) != A_WORD) { + STR *tmpstr = STAB_STR(arg[1].arg_ptr.arg_stab); + + if (tmpstr) + stab = stabent(str_get(tmpstr),TRUE); + else + stab = Nullstab; + } + if (stab && stab_sub(stab)) { + cmd_free(stab_sub(stab)->cmd); + stab_sub(stab)->cmd = Nullcmd; + afree(stab_sub(stab)->tosave); + Safefree(stab_sub(stab)); + stab_sub(stab) = Null(SUBR*); + } + } + else + fatal("Can't undefine that kind of object"); + str_numset(str,0.0); + stack->ary_array[retarg] = str; + return retarg; +} + +int +do_vec(lvalue,astr,arglast) +int lvalue; +STR *astr; +int *arglast; +{ + STR **st = stack->ary_array; + int sp = arglast[0]; + register STR *str = st[++sp]; + register int offset = (int)str_gnum(st[++sp]); + register int size = (int)str_gnum(st[++sp]); + unsigned char *s = (unsigned char*)str_get(str); + unsigned long retnum; + int len; + + sp = arglast[1]; + offset *= size; /* turn into bit offset */ + len = (offset + size + 7) / 8; + if (offset < 0 || size < 1) + retnum = 0; + else if (!lvalue && len > str->str_cur) + retnum = 0; + else { + if (len > str->str_cur) { + STR_GROW(str,len); + (void)memzero(str->str_ptr + str->str_cur, len - str->str_cur); + str->str_cur = len; + } + s = (unsigned char*)str_get(str); + if (size < 8) + retnum = (s[offset >> 3] >> (offset & 7)) & ((1 << size) - 1); + else { + offset >>= 3; + if (size == 8) + retnum = s[offset]; + else if (size == 16) + retnum = ((unsigned long) s[offset] << 8) + s[offset+1]; + else if (size == 32) + retnum = ((unsigned long) s[offset] << 24) + + ((unsigned long) s[offset + 1] << 16) + + (s[offset + 2] << 8) + s[offset+3]; + } + + if (lvalue) { /* it's an lvalue! */ + struct lstring *lstr = (struct lstring*)astr; + + astr->str_magic = str; + st[sp]->str_rare = 'v'; + lstr->lstr_offset = offset; + lstr->lstr_len = size; + } + } + + str_numset(astr,(double)retnum); + st[sp] = astr; + return sp; +} + +void +do_vecset(mstr,str) +STR *mstr; +STR *str; +{ + struct lstring *lstr = (struct lstring*)str; + register int offset; + register int size; + register unsigned char *s = (unsigned char*)mstr->str_ptr; + register unsigned long lval = U_L(str_gnum(str)); + int mask; + + mstr->str_rare = 0; + str->str_magic = Nullstr; + offset = lstr->lstr_offset; + size = lstr->lstr_len; + if (size < 8) { + mask = (1 << size) - 1; + size = offset & 7; + lval &= mask; + offset >>= 3; + s[offset] &= ~(mask << size); + s[offset] |= lval << size; + } + else { + if (size == 8) + s[offset] = lval & 255; + else if (size == 16) { + s[offset] = (lval >> 8) & 255; + s[offset+1] = lval & 255; + } + else if (size == 32) { + s[offset] = (lval >> 24) & 255; + s[offset+1] = (lval >> 16) & 255; + s[offset+2] = (lval >> 8) & 255; + s[offset+3] = lval & 255; + } + } +} + +void +do_chop(astr,str) +register STR *astr; +register STR *str; +{ + register char *tmps; + register int i; + ARRAY *ary; + HASH *hash; + HENT *entry; + + if (!str) + return; + if (str->str_state == SS_ARY) { + ary = stab_array(str->str_u.str_stab); + for (i = 0; i <= ary->ary_fill; i++) + do_chop(astr,ary->ary_array[i]); + return; + } + if (str->str_state == SS_HASH) { + hash = stab_hash(str->str_u.str_stab); + (void)hiterinit(hash); + /*SUPPRESS 560*/ + while (entry = hiternext(hash)) + do_chop(astr,hiterval(hash,entry)); + return; + } + tmps = str_get(str); + if (tmps && str->str_cur) { + tmps += str->str_cur - 1; + str_nset(astr,tmps,1); /* remember last char */ + *tmps = '\0'; /* wipe it out */ + str->str_cur = tmps - str->str_ptr; + str->str_nok = 0; + STABSET(str); + } + else + str_nset(astr,"",0); +} + +void +do_vop(optype,str,left,right) +STR *str; +STR *left; +STR *right; +{ + register char *s; + register char *l = str_get(left); + register char *r = str_get(right); + register int len; + + len = left->str_cur; + if (len > right->str_cur) + len = right->str_cur; + if (str->str_cur > len) + str->str_cur = len; + else if (str->str_cur < len) { + STR_GROW(str,len); + (void)memzero(str->str_ptr + str->str_cur, len - str->str_cur); + str->str_cur = len; + } + str->str_pok = 1; + str->str_nok = 0; + s = str->str_ptr; + if (!s) { + str_nset(str,"",0); + s = str->str_ptr; + } + switch (optype) { + case O_BIT_AND: + while (len--) + *s++ = *l++ & *r++; + break; + case O_XOR: + while (len--) + *s++ = *l++ ^ *r++; + goto mop_up; + case O_BIT_OR: + while (len--) + *s++ = *l++ | *r++; + mop_up: + len = str->str_cur; + if (right->str_cur > len) + str_ncat(str,right->str_ptr+len,right->str_cur - len); + else if (left->str_cur > len) + str_ncat(str,left->str_ptr+len,left->str_cur - len); + break; + } +} + +int +do_syscall(arglast) +int *arglast; +{ + register STR **st = stack->ary_array; + register int sp = arglast[1]; + register int items = arglast[2] - sp; +#ifdef atarist + unsigned long arg[14]; /* yes, we really need that many ! */ +#else + unsigned long arg[8]; +#endif + register int i = 0; + int retval = -1; + +#ifdef HAS_SYSCALL +#ifdef TAINT + for (st += ++sp; items--; st++) + tainted |= (*st)->str_tainted; + st = stack->ary_array; + sp = arglast[1]; + items = arglast[2] - sp; +#endif +#ifdef TAINT + taintproper("Insecure dependency in syscall"); +#endif + /* This probably won't work on machines where sizeof(long) != sizeof(int) + * or where sizeof(long) != sizeof(char*). But such machines will + * not likely have syscall implemented either, so who cares? + */ + while (items--) { + if (st[++sp]->str_nok || !i) + arg[i++] = (unsigned long)str_gnum(st[sp]); +#ifndef lint + else + arg[i++] = (unsigned long)st[sp]->str_ptr; +#endif /* lint */ + } + sp = arglast[1]; + items = arglast[2] - sp; + switch (items) { + case 0: + fatal("Too few args to syscall"); + case 1: + retval = syscall(arg[0]); + break; + case 2: + retval = syscall(arg[0],arg[1]); + break; + case 3: + retval = syscall(arg[0],arg[1],arg[2]); + break; + case 4: + retval = syscall(arg[0],arg[1],arg[2],arg[3]); + break; + case 5: + retval = syscall(arg[0],arg[1],arg[2],arg[3],arg[4]); + break; + case 6: + retval = syscall(arg[0],arg[1],arg[2],arg[3],arg[4],arg[5]); + break; + case 7: + retval = syscall(arg[0],arg[1],arg[2],arg[3],arg[4],arg[5],arg[6]); + break; + case 8: + retval = syscall(arg[0],arg[1],arg[2],arg[3],arg[4],arg[5],arg[6], + arg[7]); + break; +#ifdef atarist + case 9: + retval = syscall(arg[0],arg[1],arg[2],arg[3],arg[4],arg[5],arg[6], + arg[7], arg[8]); + break; + case 10: + retval = syscall(arg[0],arg[1],arg[2],arg[3],arg[4],arg[5],arg[6], + arg[7], arg[8], arg[9]); + break; + case 11: + retval = syscall(arg[0],arg[1],arg[2],arg[3],arg[4],arg[5],arg[6], + arg[7], arg[8], arg[9], arg[10]); + break; + case 12: + retval = syscall(arg[0],arg[1],arg[2],arg[3],arg[4],arg[5],arg[6], + arg[7], arg[8], arg[9], arg[10], arg[11]); + break; + case 13: + retval = syscall(arg[0],arg[1],arg[2],arg[3],arg[4],arg[5],arg[6], + arg[7], arg[8], arg[9], arg[10], arg[11], arg[12]); + break; + case 14: + retval = syscall(arg[0],arg[1],arg[2],arg[3],arg[4],arg[5],arg[6], + arg[7], arg[8], arg[9], arg[10], arg[11], arg[12], arg[13]); + break; +#endif /* atarist */ + } + return retval; +#else + fatal("syscall() unimplemented"); +#endif +} + + diff --git a/doarg.c.rej b/doarg.c.rej new file mode 100644 index 0000000..2862a88 --- /dev/null +++ b/doarg.c.rej @@ -0,0 +1,37 @@ +*************** +*** 1,4 **** +! /* $RCSfile: doarg.c,v $$Revision: 4.0.1.7 $$Date: 1992/06/11 21:07:11 $ + * + * Copyright (c) 1991, Larry Wall + * +--- 1,4 ---- +! /* $RCSfile: doarg.c,v $$Revision: 4.0.1.8 $$Date: 1993/02/05 19:32:27 $ + * + * Copyright (c) 1991, Larry Wall + * +*************** +*** 6,15 **** + * License or the Artistic License, as specified in the README file. + * + * $Log: doarg.c,v $ +! * Revision 4.0.1.7 1992/06/11 21:07:11 lwall + * patch34: join with null list attempted negative allocation + * patch34: sprintf("%6.4s", "abcdefg") didn't print "abcd " +! * + * Revision 4.0.1.6 92/06/08 12:34:30 lwall + * patch20: removed implicit int declarations on funcions + * patch20: pattern modifiers i and o didn't interact right +--- 6,18 ---- + * License or the Artistic License, as specified in the README file. + * + * $Log: doarg.c,v $ +! * Revision 4.0.1.8 1993/02/05 19:32:27 lwall +! * patch36: substitution didn't always invalidate numericity +! * +! * Revision 4.0.1.7 92/06/11 21:07:11 lwall + * patch34: join with null list attempted negative allocation + * patch34: sprintf("%6.4s", "abcdefg") didn't print "abcd " +! * + * Revision 4.0.1.6 92/06/08 12:34:30 lwall + * patch20: removed implicit int declarations on funcions + * patch20: pattern modifiers i and o didn't interact right diff --git a/form.c b/form.c index 0eb0976..5ae139d 100644 --- a/form.c +++ b/form.c @@ -104,6 +104,7 @@ int sp; CMD mycmd; STR *str; char *chophere; + int blank = TRUE; mycmd.c_type = C_NULL; orec->o_lines = 0; @@ -114,10 +115,17 @@ int sp; if (s = fcmd->f_pre) { while (*s) { if (*s == '\n') { - while (d > orec->o_str && (d[-1] == ' ' || d[-1] == '\t')) - d--; + t = orec->o_str; + if (blank && (fcmd->f_flags & FC_REPEAT)) { + while (d > t && (d[-1] != '\n')) + d--; + } + else { + while (d > t && (d[-1] == ' ' || d[-1] == '\t')) + d--; + } if (fcmd->f_flags & FC_NOBLANK) { - if (d == orec->o_str || d[-1] == '\n') { + if (blank || d == orec->o_str || d[-1] == '\n') { orec->o_lines--; /* don't print blank line */ linebeg = fcmd->f_next; break; @@ -129,6 +137,7 @@ int sp; } else linebeg = fcmd->f_next; + blank = TRUE; } *d++ = *s++; } @@ -149,6 +158,8 @@ int sp; while (size && *s && *s != '\n') { if (*s == '\t') *s = ' '; + else if (*s != ' ') + blank = FALSE; size--; if (*s && index(chopset,(*d++ = *s++))) chophere = s; @@ -201,6 +212,8 @@ int sp; while (size && *s && *s != '\n') { if (*s == '\t') *s = ' '; + else if (*s != ' ') + blank = FALSE; size--; if (*s && index(chopset,*s++)) chophere = s; @@ -245,6 +258,8 @@ int sp; while (size && *s && *s != '\n') { if (*s == '\t') *s = ' '; + else if (*s != ' ') + blank = FALSE; size--; if (*s && index(chopset,*s++)) chophere = s; @@ -318,6 +333,7 @@ int sp; } break; } + blank = FALSE; value = str_gnum(str); if (fcmd->f_flags & FC_DP) { sprintf(d, "%#*.*f", size, fcmd->f_decimals, value); diff --git a/form.c.orig b/form.c.orig new file mode 100644 index 0000000..0eb0976 --- /dev/null +++ b/form.c.orig @@ -0,0 +1,397 @@ +/* $RCSfile: form.c,v $$Revision: 4.0.1.3 $$Date: 92/06/08 13:21:42 $ + * + * Copyright (c) 1991, Larry Wall + * + * You may distribute under the terms of either the GNU General Public + * License or the Artistic License, as specified in the README file. + * + * $Log: form.c,v $ + * Revision 4.0.1.3 92/06/08 13:21:42 lwall + * patch20: removed implicit int declarations on funcions + * patch20: form feed for formats is now specifiable via $^L + * patch20: Perl now distinguishes overlapped copies from non-overlapped + * + * Revision 4.0.1.2 91/11/05 17:18:43 lwall + * patch11: formats didn't fill their fields as well as they could + * patch11: ^ fields chopped hyphens on line break + * patch11: # fields could write outside allocated memory + * + * Revision 4.0.1.1 91/06/07 11:07:59 lwall + * patch4: new copyright notice + * patch4: default top-of-form format is now FILEHANDLE_TOP + * + * Revision 4.0 91/03/20 01:19:23 lwall + * 4.0 baseline. + * + */ + +#include "EXTERN.h" +#include "perl.h" + +/* Forms stuff */ + +static int countlines(); + +void +form_parseargs(fcmd) +register FCMD *fcmd; +{ + register int i; + register ARG *arg; + register int items; + STR *str; + ARG *parselist(); + line_t oldline = curcmd->c_line; + int oldsave = savestack->ary_fill; + + str = fcmd->f_unparsed; + curcmd->c_line = fcmd->f_line; + fcmd->f_unparsed = Nullstr; + (void)savehptr(&curstash); + curstash = str->str_u.str_hash; + arg = parselist(str); + restorelist(oldsave); + + items = arg->arg_len - 1; /* ignore $$ on end */ + for (i = 1; i <= items; i++) { + if (!fcmd || fcmd->f_type == F_NULL) + fatal("Too many field values"); + dehoist(arg,i); + fcmd->f_expr = make_op(O_ITEM,1, + arg[i].arg_ptr.arg_arg,Nullarg,Nullarg); + if (fcmd->f_flags & FC_CHOP) { + if ((fcmd->f_expr[1].arg_type & A_MASK) == A_STAB) + fcmd->f_expr[1].arg_type = A_LVAL; + else if ((fcmd->f_expr[1].arg_type & A_MASK) == A_EXPR) + fcmd->f_expr[1].arg_type = A_LEXPR; + else + fatal("^ field requires scalar lvalue"); + } + fcmd = fcmd->f_next; + } + if (fcmd && fcmd->f_type) + fatal("Not enough field values"); + curcmd->c_line = oldline; + Safefree(arg); + str_free(str); +} + +int newsize; + +#define CHKLEN(allow) \ +newsize = (d - orec->o_str) + (allow); \ +if (newsize >= curlen) { \ + curlen = d - orec->o_str; \ + GROWSTR(&orec->o_str,&orec->o_len,orec->o_len + (allow)); \ + d = orec->o_str + curlen; /* in case it moves */ \ + curlen = orec->o_len - 2; \ +} + +void +format(orec,fcmd,sp) +register struct outrec *orec; +register FCMD *fcmd; +int sp; +{ + register char *d = orec->o_str; + register char *s; + register int curlen = orec->o_len - 2; + register int size; + FCMD *nextfcmd; + FCMD *linebeg = fcmd; + char tmpchar; + char *t; + CMD mycmd; + STR *str; + char *chophere; + + mycmd.c_type = C_NULL; + orec->o_lines = 0; + for (; fcmd; fcmd = nextfcmd) { + nextfcmd = fcmd->f_next; + CHKLEN(fcmd->f_presize); + /*SUPPRESS 560*/ + if (s = fcmd->f_pre) { + while (*s) { + if (*s == '\n') { + while (d > orec->o_str && (d[-1] == ' ' || d[-1] == '\t')) + d--; + if (fcmd->f_flags & FC_NOBLANK) { + if (d == orec->o_str || d[-1] == '\n') { + orec->o_lines--; /* don't print blank line */ + linebeg = fcmd->f_next; + break; + } + else if (fcmd->f_flags & FC_REPEAT) + nextfcmd = linebeg; + else + linebeg = fcmd->f_next; + } + else + linebeg = fcmd->f_next; + } + *d++ = *s++; + } + } + if (fcmd->f_unparsed) + form_parseargs(fcmd); + switch (fcmd->f_type) { + case F_NULL: + orec->o_lines++; + break; + case F_LEFT: + (void)eval(fcmd->f_expr,G_SCALAR,sp); + str = stack->ary_array[sp+1]; + s = str_get(str); + size = fcmd->f_size; + CHKLEN(size); + chophere = Nullch; + while (size && *s && *s != '\n') { + if (*s == '\t') + *s = ' '; + size--; + if (*s && index(chopset,(*d++ = *s++))) + chophere = s; + if (*s == '\n' && (fcmd->f_flags & FC_CHOP)) + *s = ' '; + } + if (size || !*s) + chophere = s; + else if (chophere && chophere < s && *s && index(chopset,*s)) + chophere = s; + if (fcmd->f_flags & FC_CHOP) { + if (!chophere) + chophere = s; + size += (s - chophere); + d -= (s - chophere); + if (fcmd->f_flags & FC_MORE && + *chophere && strNE(chophere,"\n")) { + while (size < 3) { + d--; + size++; + } + while (d[-1] == ' ' && size < fcmd->f_size) { + d--; + size++; + } + *d++ = '.'; + *d++ = '.'; + *d++ = '.'; + size -= 3; + } + while (*chophere && index(chopset,*chophere) + && isSPACE(*chophere)) + chophere++; + str_chop(str,chophere); + } + if (fcmd->f_next && fcmd->f_next->f_pre[0] == '\n') + size = 0; /* no spaces before newline */ + while (size) { + size--; + *d++ = ' '; + } + break; + case F_RIGHT: + (void)eval(fcmd->f_expr,G_SCALAR,sp); + str = stack->ary_array[sp+1]; + t = s = str_get(str); + size = fcmd->f_size; + CHKLEN(size); + chophere = Nullch; + while (size && *s && *s != '\n') { + if (*s == '\t') + *s = ' '; + size--; + if (*s && index(chopset,*s++)) + chophere = s; + if (*s == '\n' && (fcmd->f_flags & FC_CHOP)) + *s = ' '; + } + if (size || !*s) + chophere = s; + else if (chophere && chophere < s && *s && index(chopset,*s)) + chophere = s; + if (fcmd->f_flags & FC_CHOP) { + if (!chophere) + chophere = s; + size += (s - chophere); + s = chophere; + while (*chophere && index(chopset,*chophere) + && isSPACE(*chophere)) + chophere++; + } + tmpchar = *s; + *s = '\0'; + while (size) { + size--; + *d++ = ' '; + } + size = s - t; + Copy(t,d,size,char); + d += size; + *s = tmpchar; + if (fcmd->f_flags & FC_CHOP) + str_chop(str,chophere); + break; + case F_CENTER: { + int halfsize; + + (void)eval(fcmd->f_expr,G_SCALAR,sp); + str = stack->ary_array[sp+1]; + t = s = str_get(str); + size = fcmd->f_size; + CHKLEN(size); + chophere = Nullch; + while (size && *s && *s != '\n') { + if (*s == '\t') + *s = ' '; + size--; + if (*s && index(chopset,*s++)) + chophere = s; + if (*s == '\n' && (fcmd->f_flags & FC_CHOP)) + *s = ' '; + } + if (size || !*s) + chophere = s; + else if (chophere && chophere < s && *s && index(chopset,*s)) + chophere = s; + if (fcmd->f_flags & FC_CHOP) { + if (!chophere) + chophere = s; + size += (s - chophere); + s = chophere; + while (*chophere && index(chopset,*chophere) + && isSPACE(*chophere)) + chophere++; + } + tmpchar = *s; + *s = '\0'; + halfsize = size / 2; + while (size > halfsize) { + size--; + *d++ = ' '; + } + size = s - t; + Copy(t,d,size,char); + d += size; + *s = tmpchar; + if (fcmd->f_next && fcmd->f_next->f_pre[0] == '\n') + size = 0; /* no spaces before newline */ + else + size = halfsize; + while (size) { + size--; + *d++ = ' '; + } + if (fcmd->f_flags & FC_CHOP) + str_chop(str,chophere); + break; + } + case F_LINES: + (void)eval(fcmd->f_expr,G_SCALAR,sp); + str = stack->ary_array[sp+1]; + s = str_get(str); + size = str_len(str); + CHKLEN(size+1); + orec->o_lines += countlines(s,size) - 1; + Copy(s,d,size,char); + d += size; + if (size && s[size-1] != '\n') { + *d++ = '\n'; + orec->o_lines++; + } + linebeg = fcmd->f_next; + break; + case F_DECIMAL: { + double value; + + (void)eval(fcmd->f_expr,G_SCALAR,sp); + str = stack->ary_array[sp+1]; + size = fcmd->f_size; + CHKLEN(size+1); + /* If the field is marked with ^ and the value is undefined, + blank it out. */ + if ((fcmd->f_flags & FC_CHOP) && !str->str_pok && !str->str_nok) { + while (size) { + size--; + *d++ = ' '; + } + break; + } + value = str_gnum(str); + if (fcmd->f_flags & FC_DP) { + sprintf(d, "%#*.*f", size, fcmd->f_decimals, value); + } else { + sprintf(d, "%*.0f", size, value); + } + d += size; + break; + } + } + } + CHKLEN(1); + *d++ = '\0'; +} + +static int +countlines(s,size) +register char *s; +register int size; +{ + register int count = 0; + + while (size--) { + if (*s++ == '\n') + count++; + } + return count; +} + +void +do_write(orec,stab,sp) +struct outrec *orec; +STAB *stab; +int sp; +{ + register STIO *stio = stab_io(stab); + FILE *ofp = stio->ofp; + +#ifdef DEBUGGING + if (debug & 256) + fprintf(stderr,"left=%ld, todo=%ld\n", + (long)stio->lines_left, (long)orec->o_lines); +#endif + if (stio->lines_left < orec->o_lines) { + if (!stio->top_stab) { + STAB *topstab; + char tmpbuf[256]; + + if (!stio->top_name) { + if (!stio->fmt_name) + stio->fmt_name = savestr(stab_name(stab)); + sprintf(tmpbuf, "%s_TOP", stio->fmt_name); + topstab = stabent(tmpbuf,FALSE); + if (topstab && stab_form(topstab)) + stio->top_name = savestr(tmpbuf); + else + stio->top_name = savestr("top"); + } + topstab = stabent(stio->top_name,FALSE); + if (!topstab || !stab_form(topstab)) { + stio->lines_left = 100000000; + goto forget_top; + } + stio->top_stab = topstab; + } + if (stio->lines_left >= 0 && stio->page > 0) + fwrite(formfeed->str_ptr, formfeed->str_cur, 1, ofp); + stio->lines_left = stio->page_len; + stio->page++; + format(&toprec,stab_form(stio->top_stab),sp); + fputs(toprec.o_str,ofp); + stio->lines_left -= toprec.o_lines; + } + forget_top: + fputs(orec->o_str,ofp); + stio->lines_left -= orec->o_lines; +} diff --git a/form.c.rej b/form.c.rej new file mode 100644 index 0000000..86f5bed --- /dev/null +++ b/form.c.rej @@ -0,0 +1,39 @@ +*************** +*** 1,4 **** +! /* $RCSfile: form.c,v $$Revision: 4.0.1.3 $$Date: 1992/06/08 13:21:42 $ + * + * Copyright (c) 1991, Larry Wall + * +--- 1,4 ---- +! /* $RCSfile: form.c,v $$Revision: 4.0.1.4 $$Date: 1993/02/05 19:34:32 $ + * + * Copyright (c) 1991, Larry Wall + * +*************** +*** 6,16 **** + * License or the Artistic License, as specified in the README file. + * + * $Log: form.c,v $ +! * Revision 4.0.1.3 1992/06/08 13:21:42 lwall + * patch20: removed implicit int declarations on funcions + * patch20: form feed for formats is now specifiable via $^L + * patch20: Perl now distinguishes overlapped copies from non-overlapped +! * + * Revision 4.0.1.2 91/11/05 17:18:43 lwall + * patch11: formats didn't fill their fields as well as they could + * patch11: ^ fields chopped hyphens on line break +--- 6,19 ---- + * License or the Artistic License, as specified in the README file. + * + * $Log: form.c,v $ +! * Revision 4.0.1.4 1993/02/05 19:34:32 lwall +! * patch36: formats now ignore literal text for ~~ loop determination +! * +! * Revision 4.0.1.3 92/06/08 13:21:42 lwall + * patch20: removed implicit int declarations on funcions + * patch20: form feed for formats is now specifiable via $^L + * patch20: Perl now distinguishes overlapped copies from non-overlapped +! * + * Revision 4.0.1.2 91/11/05 17:18:43 lwall + * patch11: formats didn't fill their fields as well as they could + * patch11: ^ fields chopped hyphens on line break diff --git a/hints/dec_osf1.sh b/hints/dec_osf1.sh new file mode 100644 index 0000000..07f594e --- /dev/null +++ b/hints/dec_osf1.sh @@ -0,0 +1,11 @@ +d_crypt='undef' # The function is there, but it is empty +d_odbm='undef' # We don't need both odbm and ndbm +gidtype='gid_t' +groupstype='int' +libpth="$libpth /usr/shlib" # Use the shared libraries if possible +libc='/usr/shlib/libc.so' # The archive version is /lib/libc.a +case `uname -m` in + mips|alpha) optimize="$optimize -O2 -Olimit 2900" + ccflags="$ccflags -std1 -D_BSD" ;; + *) ccflags="$ccflags -D_BSD" ;; +esac diff --git a/hints/solaris_2_1.sh b/hints/solaris_2_1.sh new file mode 100644 index 0000000..de405bc --- /dev/null +++ b/hints/solaris_2_1.sh @@ -0,0 +1,4 @@ +d_vfork='undef' +d_wait4='undef' +i_dirent='undef' +i_sys_dir='define' diff --git a/lib/bigfloat.pl b/lib/bigfloat.pl index 52fb7e3..278f11d 100644 --- a/lib/bigfloat.pl +++ b/lib/bigfloat.pl @@ -67,7 +67,7 @@ sub norm { #(mantissa, exponent) return fnum_str # negation sub main'fneg { #(fnum_str) return fnum_str local($_) = &'fnorm($_[0]); - vec($_,0,8) =^ ord('+') ^ ord('-') unless $_ eq '+0E+0'; # flip sign + vec($_,0,8) ^= ord('+') ^ ord('-') unless $_ eq '+0E+0'; # flip sign s/^H/N/; $_; } diff --git a/lib/bigint.pl b/lib/bigint.pl index 9a52fb7..5c79da9 100644 --- a/lib/bigint.pl +++ b/lib/bigint.pl @@ -154,7 +154,7 @@ sub add { #(int_num_array, int_num_array) return int_num_array $car = 0; for $x (@x) { last unless @y || $car; - $x -= 1e5 if $car = (($x += shift @y + $car) >= 1e5); + $x -= 1e5 if $car = (($x += shift(@y) + $car) >= 1e5); } for $y (@y) { last unless $car; @@ -169,7 +169,7 @@ sub sub { #(int_num_array, int_num_array) return int_num_array $bar = 0; for $sx (@sx) { last unless @y || $bar; - $sx += 1e5 if $bar = (($sx -= shift @sy + $bar) < 0); + $sx += 1e5 if $bar = (($sx -= shift(@sy) + $bar) < 0); } @sx; } diff --git a/lib/getcwd.pl b/lib/getcwd.pl index 114e890..a3214ba 100644 --- a/lib/getcwd.pl +++ b/lib/getcwd.pl @@ -42,9 +42,9 @@ sub getcwd closedir(getcwd'PARENT); #'); return ''; } - unless (@tst = stat("$dotdots/$dir")) + unless (@tst = lstat("$dotdots/$dir")) { - warn "stat($dotdots/$dir): $!"; + warn "lstat($dotdots/$dir): $!"; closedir(getcwd'PARENT); #'); return ''; } diff --git a/lib/timelocal.pl b/lib/timelocal.pl index 5be3840..95b47e1 100644 --- a/lib/timelocal.pl +++ b/lib/timelocal.pl @@ -36,6 +36,7 @@ CONFIG: { $MIN = 60 * $SEC; $HR = 60 * $MIN; $DAYS = 24 * $HR; + $YearFix = ((gmtime(946684800))[5] == 100) ? 100 : 0; } sub timegm { @@ -65,6 +66,7 @@ sub cheat { die "Month out of range 0..11 in ctime.pl\n" if $month > 11; $guess = $^T; @g = gmtime($guess); + $year += $YearFix if $year < $epoch[5]; while ($diff = $year - $g[5]) { $guess += $diff * (363 * $DAYS); @g = gmtime($guess); diff --git a/patchlevel.h b/patchlevel.h index 68fcfef..d248b35 100644 --- a/patchlevel.h +++ b/patchlevel.h @@ -1 +1 @@ -#define PATCHLEVEL 35 +#define PATCHLEVEL 36 diff --git a/perl.c b/perl.c index 7a41d2b..046bb60 100644 --- a/perl.c +++ b/perl.c @@ -128,7 +128,7 @@ setuid perl scripts securely.\n"); #ifdef TAINT #ifndef DOSUID if (uid == euid && gid == egid) - taintanyway == TRUE; /* running taintperl explicitly */ + taintanyway = TRUE; /* running taintperl explicitly */ #endif #endif (void)sprintf(index(rcsid,'#'), "%d\n", PATCHLEVEL); @@ -1168,6 +1168,8 @@ int *arglast; eval_root = myroot; else if (in_eval != 1 && myroot != last_root) cmd_free(myroot); + if (eval_root == myroot) + eval_root = Nullcmd; } perldb = oldperldb; diff --git a/perl.c.orig b/perl.c.orig new file mode 100644 index 0000000..7a41d2b --- /dev/null +++ b/perl.c.orig @@ -0,0 +1,1440 @@ +char rcsid[] = "$RCSfile: perl.c,v $$Revision: 4.0.1.7 $$Date: 92/06/08 14:50:39 $\nPatch level: ###\n"; +/* + * Copyright (c) 1991, Larry Wall + * + * You may distribute under the terms of either the GNU General Public + * License or the Artistic License, as specified in the README file. + * + * $Log: perl.c,v $ + * Revision 4.0.1.7 92/06/08 14:50:39 lwall + * patch20: PERLLIB now supports multiple directories + * patch20: running taintperl explicitly now does checks even if $< == $> + * patch20: -e 'cmd' no longer fails silently if /tmp runs out of space + * patch20: perl -P now uses location of sed determined by Configure + * patch20: form feed for formats is now specifiable via $^L + * patch20: paragraph mode now skips extra newlines automatically + * patch20: eval "1 #comment" didn't work + * patch20: couldn't require . files + * patch20: semantic compilation errors didn't abort execution + * + * Revision 4.0.1.6 91/11/11 16:38:45 lwall + * patch19: default arg for shift was wrong after first subroutine definition + * patch19: op/regexp.t failed from missing arg to bcmp() + * + * Revision 4.0.1.5 91/11/05 18:03:32 lwall + * patch11: random cleanup + * patch11: $0 was being truncated at times + * patch11: cppstdin now installed outside of source directory + * patch11: -P didn't allow use of #elif or #undef + * patch11: prepared for ctype implementations that don't define isascii() + * patch11: added eval {} + * patch11: eval confused by string containing null + * + * Revision 4.0.1.4 91/06/10 01:23:07 lwall + * patch10: perl -v printed incorrect copyright notice + * + * Revision 4.0.1.3 91/06/07 11:40:18 lwall + * patch4: changed old $^P to $^X + * + * Revision 4.0.1.2 91/06/07 11:26:16 lwall + * patch4: new copyright notice + * patch4: added $^P variable to control calling of perldb routines + * patch4: added $^F variable to specify maximum system fd, default 2 + * patch4: debugger lost track of lines in eval + * + * Revision 4.0.1.1 91/04/11 17:49:05 lwall + * patch1: fixed undefined environ problem + * + * Revision 4.0 91/03/20 01:37:44 lwall + * 4.0 baseline. + * + */ + +/*SUPPRESS 560*/ + +#include "EXTERN.h" +#include "perl.h" +#include "perly.h" +#include "patchlevel.h" + +char *getenv(); + +#ifdef IAMSUID +#ifndef DOSUID +#define DOSUID +#endif +#endif + +#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW +#ifdef DOSUID +#undef DOSUID +#endif +#endif + +static char* moreswitches(); +static void incpush(); +static char* cddir; +static bool minus_c; +static char patchlevel[6]; +static char *nrs = "\n"; +static int nrschar = '\n'; /* final char of rs, or 0777 if none */ +static int nrslen = 1; + +main(argc,argv,env) +register int argc; +register char **argv; +register char **env; +{ + register STR *str; + register char *s; + char *scriptname; + char *getenv(); + bool dosearch = FALSE; +#ifdef DOSUID + char *validarg = ""; +#endif + +#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW +#ifdef IAMSUID +#undef IAMSUID + fatal("suidperl is no longer needed since the kernel can now execute\n\ +setuid perl scripts securely.\n"); +#endif +#endif + + origargv = argv; + origargc = argc; + origenviron = environ; + uid = (int)getuid(); + euid = (int)geteuid(); + gid = (int)getgid(); + egid = (int)getegid(); + sprintf(patchlevel,"%3.3s%2.2d", index(rcsid,'4'), PATCHLEVEL); +#ifdef MSDOS + /* + * There is no way we can refer to them from Perl so close them to save + * space. The other alternative would be to provide STDAUX and STDPRN + * filehandles. + */ + (void)fclose(stdaux); + (void)fclose(stdprn); +#endif + if (do_undump) { + origfilename = savestr(argv[0]); + do_undump = 0; + loop_ptr = -1; /* start label stack again */ + goto just_doit; + } +#ifdef TAINT +#ifndef DOSUID + if (uid == euid && gid == egid) + taintanyway == TRUE; /* running taintperl explicitly */ +#endif +#endif + (void)sprintf(index(rcsid,'#'), "%d\n", PATCHLEVEL); + linestr = Str_new(65,80); + str_nset(linestr,"",0); + str = str_make("",0); /* first used for -I flags */ + curstash = defstash = hnew(0); + curstname = str_make("main",4); + stab_xhash(stabent("_main",TRUE)) = defstash; + defstash->tbl_name = "main"; + incstab = hadd(aadd(stabent("INC",TRUE))); + incstab->str_pok |= SP_MULTI; + for (argc--,argv++; argc > 0; argc--,argv++) { + if (argv[0][0] != '-' || !argv[0][1]) + break; +#ifdef DOSUID + if (*validarg) + validarg = " PHOOEY "; + else + validarg = argv[0]; +#endif + s = argv[0]+1; + reswitch: + switch (*s) { + case '0': + case 'a': + case 'c': + case 'd': + case 'D': + case 'i': + case 'l': + case 'n': + case 'p': + case 'u': + case 'U': + case 'v': + case 'w': + if (s = moreswitches(s)) + goto reswitch; + break; + + case 'e': +#ifdef TAINT + if (euid != uid || egid != gid) + fatal("No -e allowed in setuid scripts"); +#endif + if (!e_fp) { + e_tmpname = savestr(TMPPATH); + (void)mktemp(e_tmpname); + if (!*e_tmpname) + fatal("Can't mktemp()"); + e_fp = fopen(e_tmpname,"w"); + if (!e_fp) + fatal("Cannot open temporary file"); + } + if (argv[1]) { + fputs(argv[1],e_fp); + argc--,argv++; + } + (void)putc('\n', e_fp); + break; + case 'I': +#ifdef TAINT + if (euid != uid || egid != gid) + fatal("No -I allowed in setuid scripts"); +#endif + str_cat(str,"-"); + str_cat(str,s); + str_cat(str," "); + if (*++s) { + (void)apush(stab_array(incstab),str_make(s,0)); + } + else if (argv[1]) { + (void)apush(stab_array(incstab),str_make(argv[1],0)); + str_cat(str,argv[1]); + argc--,argv++; + str_cat(str," "); + } + break; + case 'P': +#ifdef TAINT + if (euid != uid || egid != gid) + fatal("No -P allowed in setuid scripts"); +#endif + preprocess = TRUE; + s++; + goto reswitch; + case 's': +#ifdef TAINT + if (euid != uid || egid != gid) + fatal("No -s allowed in setuid scripts"); +#endif + doswitches = TRUE; + s++; + goto reswitch; + case 'S': +#ifdef TAINT + if (euid != uid || egid != gid) + fatal("No -S allowed in setuid scripts"); +#endif + dosearch = TRUE; + s++; + goto reswitch; + case 'x': + doextract = TRUE; + s++; + if (*s) + cddir = savestr(s); + break; + case '-': + argc--,argv++; + goto switch_end; + case 0: + break; + default: + fatal("Unrecognized switch: -%s",s); + } + } + switch_end: + scriptname = argv[0]; + if (e_fp) { + if (fflush(e_fp) || ferror(e_fp) || fclose(e_fp)) + fatal("Can't write to temp file for -e: %s", strerror(errno)); + argc++,argv--; + scriptname = e_tmpname; + } + +#ifdef DOSISH +#define PERLLIB_SEP ';' +#else +#define PERLLIB_SEP ':' +#endif +#ifndef TAINT /* Can't allow arbitrary PERLLIB in setuid script */ + incpush(getenv("PERLLIB")); +#endif /* TAINT */ + +#ifndef PRIVLIB +#define PRIVLIB "/usr/local/lib/perl" +#endif + incpush(PRIVLIB); + (void)apush(stab_array(incstab),str_make(".",1)); + + str_set(&str_no,No); + str_set(&str_yes,Yes); + + /* open script */ + + if (scriptname == Nullch) +#ifdef MSDOS + { + if ( isatty(fileno(stdin)) ) + moreswitches("v"); + scriptname = "-"; + } +#else + scriptname = "-"; +#endif + if (dosearch && !index(scriptname, '/') && (s = getenv("PATH"))) { + char *xfound = Nullch, *xfailed = Nullch; + int len; + + bufend = s + strlen(s); + while (*s) { +#ifndef DOSISH + s = cpytill(tokenbuf,s,bufend,':',&len); +#else +#ifdef atarist + for (len = 0; *s && *s != ',' && *s != ';'; tokenbuf[len++] = *s++); + tokenbuf[len] = '\0'; +#else + for (len = 0; *s && *s != ';'; tokenbuf[len++] = *s++); + tokenbuf[len] = '\0'; +#endif +#endif + if (*s) + s++; +#ifndef DOSISH + if (len && tokenbuf[len-1] != '/') +#else +#ifdef atarist + if (len && ((tokenbuf[len-1] != '\\') && (tokenbuf[len-1] != '/'))) +#else + if (len && tokenbuf[len-1] != '\\') +#endif +#endif + (void)strcat(tokenbuf+len,"/"); + (void)strcat(tokenbuf+len,scriptname); +#ifdef DEBUGGING + if (debug & 1) + fprintf(stderr,"Looking for %s\n",tokenbuf); +#endif + if (stat(tokenbuf,&statbuf) < 0) /* not there? */ + continue; + if (S_ISREG(statbuf.st_mode) + && cando(S_IRUSR,TRUE,&statbuf) && cando(S_IXUSR,TRUE,&statbuf)) { + xfound = tokenbuf; /* bingo! */ + break; + } + if (!xfailed) + xfailed = savestr(tokenbuf); + } + if (!xfound) + fatal("Can't execute %s", xfailed ? xfailed : scriptname ); + if (xfailed) + Safefree(xfailed); + scriptname = savestr(xfound); + } + + fdpid = anew(Nullstab); /* for remembering popen pids by fd */ + pidstatus = hnew(COEFFSIZE);/* for remembering status of dead pids */ + + origfilename = savestr(scriptname); + curcmd->c_filestab = fstab(origfilename); + if (strEQ(origfilename,"-")) + scriptname = ""; + if (preprocess) { + char *cpp = CPPSTDIN; + + if (strEQ(cpp,"cppstdin")) + sprintf(tokenbuf, "%s/%s", SCRIPTDIR, cpp); + else + sprintf(tokenbuf, "%s", cpp); + str_cat(str,"-I"); + str_cat(str,PRIVLIB); +#ifdef MSDOS + (void)sprintf(buf, "\ +sed %s -e \"/^[^#]/b\" \ + -e \"/^#[ ]*include[ ]/b\" \ + -e \"/^#[ ]*define[ ]/b\" \ + -e \"/^#[ ]*if[ ]/b\" \ + -e \"/^#[ ]*ifdef[ ]/b\" \ + -e \"/^#[ ]*ifndef[ ]/b\" \ + -e \"/^#[ ]*else/b\" \ + -e \"/^#[ ]*elif[ ]/b\" \ + -e \"/^#[ ]*undef[ ]/b\" \ + -e \"/^#[ ]*endif/b\" \ + -e \"s/^#.*//\" \ + %s | %s -C %s %s", + (doextract ? "-e \"1,/^#/d\n\"" : ""), +#else + (void)sprintf(buf, "\ +%s %s -e '/^[^#]/b' \ + -e '/^#[ ]*include[ ]/b' \ + -e '/^#[ ]*define[ ]/b' \ + -e '/^#[ ]*if[ ]/b' \ + -e '/^#[ ]*ifdef[ ]/b' \ + -e '/^#[ ]*ifndef[ ]/b' \ + -e '/^#[ ]*else/b' \ + -e '/^#[ ]*elif[ ]/b' \ + -e '/^#[ ]*undef[ ]/b' \ + -e '/^#[ ]*endif/b' \ + -e 's/^[ ]*#.*//' \ + %s | %s -C %s %s", +#ifdef LOC_SED + LOC_SED, +#else + "sed", +#endif + (doextract ? "-e '1,/^#/d\n'" : ""), +#endif + scriptname, tokenbuf, str_get(str), CPPMINUS); +#ifdef DEBUGGING + if (debug & 64) { + fputs(buf,stderr); + fputs("\n",stderr); + } +#endif + doextract = FALSE; +#ifdef IAMSUID /* actually, this is caught earlier */ + if (euid != uid && !euid) { /* if running suidperl */ +#ifdef HAS_SETEUID + (void)seteuid(uid); /* musn't stay setuid root */ +#else +#ifdef HAS_SETREUID + (void)setreuid(-1, uid); +#else + setuid(uid); +#endif +#endif + if (geteuid() != uid) + fatal("Can't do seteuid!\n"); + } +#endif /* IAMSUID */ + rsfp = mypopen(buf,"r"); + } + else if (!*scriptname) { +#ifdef TAINT + if (euid != uid || egid != gid) + fatal("Can't take set-id script from stdin"); +#endif + rsfp = stdin; + } + else + rsfp = fopen(scriptname,"r"); + if ((FILE*)rsfp == Nullfp) { +#ifdef DOSUID +#ifndef IAMSUID /* in case script is not readable before setuid */ + if (euid && stat(stab_val(curcmd->c_filestab)->str_ptr,&statbuf) >= 0 && + statbuf.st_mode & (S_ISUID|S_ISGID)) { + (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel); + execv(buf, origargv); /* try again */ + fatal("Can't do setuid\n"); + } +#endif +#endif + fatal("Can't open perl script \"%s\": %s\n", + stab_val(curcmd->c_filestab)->str_ptr, strerror(errno)); + } + str_free(str); /* free -I directories */ + str = Nullstr; + + /* do we need to emulate setuid on scripts? */ + + /* This code is for those BSD systems that have setuid #! scripts disabled + * in the kernel because of a security problem. Merely defining DOSUID + * in perl will not fix that problem, but if you have disabled setuid + * scripts in the kernel, this will attempt to emulate setuid and setgid + * on scripts that have those now-otherwise-useless bits set. The setuid + * root version must be called suidperl or sperlN.NNN. If regular perl + * discovers that it has opened a setuid script, it calls suidperl with + * the same argv that it had. If suidperl finds that the script it has + * just opened is NOT setuid root, it sets the effective uid back to the + * uid. We don't just make perl setuid root because that loses the + * effective uid we had before invoking perl, if it was different from the + * uid. + * + * DOSUID must be defined in both perl and suidperl, and IAMSUID must + * be defined in suidperl only. suidperl must be setuid root. The + * Configure script will set this up for you if you want it. + * + * There is also the possibility of have a script which is running + * set-id due to a C wrapper. We want to do the TAINT checks + * on these set-id scripts, but don't want to have the overhead of + * them in normal perl, and can't use suidperl because it will lose + * the effective uid info, so we have an additional non-setuid root + * version called taintperl or tperlN.NNN that just does the TAINT checks. + */ + +#ifdef DOSUID + if (fstat(fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */ + fatal("Can't stat script \"%s\"",origfilename); + if (statbuf.st_mode & (S_ISUID|S_ISGID)) { + int len; + +#ifdef IAMSUID +#ifndef HAS_SETREUID + /* On this access check to make sure the directories are readable, + * there is actually a small window that the user could use to make + * filename point to an accessible directory. So there is a faint + * chance that someone could execute a setuid script down in a + * non-accessible directory. I don't know what to do about that. + * But I don't think it's too important. The manual lies when + * it says access() is useful in setuid programs. + */ + if (access(stab_val(curcmd->c_filestab)->str_ptr,1)) /*double check*/ + fatal("Permission denied"); +#else + /* If we can swap euid and uid, then we can determine access rights + * with a simple stat of the file, and then compare device and + * inode to make sure we did stat() on the same file we opened. + * Then we just have to make sure he or she can execute it. + */ + { + struct stat tmpstatbuf; + + if (setreuid(euid,uid) < 0 || getuid() != euid || geteuid() != uid) + fatal("Can't swap uid and euid"); /* really paranoid */ + if (stat(stab_val(curcmd->c_filestab)->str_ptr,&tmpstatbuf) < 0) + fatal("Permission denied"); /* testing full pathname here */ + if (tmpstatbuf.st_dev != statbuf.st_dev || + tmpstatbuf.st_ino != statbuf.st_ino) { + (void)fclose(rsfp); + if (rsfp = mypopen("/bin/mail root","w")) { /* heh, heh */ + fprintf(rsfp, +"User %d tried to run dev %d ino %d in place of dev %d ino %d!\n\ +(Filename of set-id script was %s, uid %d gid %d.)\n\nSincerely,\nperl\n", + uid,tmpstatbuf.st_dev, tmpstatbuf.st_ino, + statbuf.st_dev, statbuf.st_ino, + stab_val(curcmd->c_filestab)->str_ptr, + statbuf.st_uid, statbuf.st_gid); + (void)mypclose(rsfp); + } + fatal("Permission denied\n"); + } + if (setreuid(uid,euid) < 0 || getuid() != uid || geteuid() != euid) + fatal("Can't reswap uid and euid"); + if (!cando(S_IXUSR,FALSE,&statbuf)) /* can real uid exec? */ + fatal("Permission denied\n"); + } +#endif /* HAS_SETREUID */ +#endif /* IAMSUID */ + + if (!S_ISREG(statbuf.st_mode)) + fatal("Permission denied"); + if (statbuf.st_mode & S_IWOTH) + fatal("Setuid/gid script is writable by world"); + doswitches = FALSE; /* -s is insecure in suid */ + curcmd->c_line++; + if (fgets(tokenbuf,sizeof tokenbuf, rsfp) == Nullch || + strnNE(tokenbuf,"#!",2) ) /* required even on Sys V */ + fatal("No #! line"); + s = tokenbuf+2; + if (*s == ' ') s++; + while (!isSPACE(*s)) s++; + if (strnNE(s-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */ + fatal("Not a perl script"); + while (*s == ' ' || *s == '\t') s++; + /* + * #! arg must be what we saw above. They can invoke it by + * mentioning suidperl explicitly, but they may not add any strange + * arguments beyond what #! says if they do invoke suidperl that way. + */ + len = strlen(validarg); + if (strEQ(validarg," PHOOEY ") || + strnNE(s,validarg,len) || !isSPACE(s[len])) + fatal("Args must match #! line"); + +#ifndef IAMSUID + if (euid != uid && (statbuf.st_mode & S_ISUID) && + euid == statbuf.st_uid) + if (!do_undump) + fatal("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\ +FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n"); +#endif /* IAMSUID */ + + if (euid) { /* oops, we're not the setuid root perl */ + (void)fclose(rsfp); +#ifndef IAMSUID + (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel); + execv(buf, origargv); /* try again */ +#endif + fatal("Can't do setuid\n"); + } + + if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) { +#ifdef HAS_SETEGID + (void)setegid(statbuf.st_gid); +#else +#ifdef HAS_SETREGID + (void)setregid((GIDTYPE)-1,statbuf.st_gid); +#else + setgid(statbuf.st_gid); +#endif +#endif + if (getegid() != statbuf.st_gid) + fatal("Can't do setegid!\n"); + } + if (statbuf.st_mode & S_ISUID) { + if (statbuf.st_uid != euid) +#ifdef HAS_SETEUID + (void)seteuid(statbuf.st_uid); /* all that for this */ +#else +#ifdef HAS_SETREUID + (void)setreuid((UIDTYPE)-1,statbuf.st_uid); +#else + setuid(statbuf.st_uid); +#endif +#endif + if (geteuid() != statbuf.st_uid) + fatal("Can't do seteuid!\n"); + } + else if (uid) { /* oops, mustn't run as root */ +#ifdef HAS_SETEUID + (void)seteuid((UIDTYPE)uid); +#else +#ifdef HAS_SETREUID + (void)setreuid((UIDTYPE)-1,(UIDTYPE)uid); +#else + setuid((UIDTYPE)uid); +#endif +#endif + if (geteuid() != uid) + fatal("Can't do seteuid!\n"); + } + uid = (int)getuid(); + euid = (int)geteuid(); + gid = (int)getgid(); + egid = (int)getegid(); + if (!cando(S_IXUSR,TRUE,&statbuf)) + fatal("Permission denied\n"); /* they can't do this */ + } +#ifdef IAMSUID + else if (preprocess) + fatal("-P not allowed for setuid/setgid script\n"); + else + fatal("Script is not setuid/setgid in suidperl\n"); +#else +#ifndef TAINT /* we aren't taintperl or suidperl */ + /* script has a wrapper--can't run suidperl or we lose euid */ + else if (euid != uid || egid != gid) { + (void)fclose(rsfp); + (void)sprintf(buf, "%s/tperl%s", BIN, patchlevel); + execv(buf, origargv); /* try again */ + fatal("Can't run setuid script with taint checks"); + } +#endif /* TAINT */ +#endif /* IAMSUID */ +#else /* !DOSUID */ +#ifndef TAINT /* we aren't taintperl or suidperl */ + if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */ +#ifndef SETUID_SCRIPTS_ARE_SECURE_NOW + fstat(fileno(rsfp),&statbuf); /* may be either wrapped or real suid */ + if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID) + || + (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID) + ) + if (!do_undump) + fatal("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\ +FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n"); +#endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */ + /* not set-id, must be wrapped */ + (void)fclose(rsfp); + (void)sprintf(buf, "%s/tperl%s", BIN, patchlevel); + execv(buf, origargv); /* try again */ + fatal("Can't run setuid script with taint checks"); + } +#endif /* TAINT */ +#endif /* DOSUID */ + +#if !defined(IAMSUID) && !defined(TAINT) + + /* skip forward in input to the real script? */ + + while (doextract) { + if ((s = str_gets(linestr, rsfp, 0)) == Nullch) + fatal("No Perl script found in input\n"); + if (*s == '#' && s[1] == '!' && instr(s,"perl")) { + ungetc('\n',rsfp); /* to keep line count right */ + doextract = FALSE; + if (s = instr(s,"perl -")) { + s += 6; + /*SUPPRESS 530*/ + while (s = moreswitches(s)) ; + } + if (cddir && chdir(cddir) < 0) + fatal("Can't chdir to %s",cddir); + } + } +#endif /* !defined(IAMSUID) && !defined(TAINT) */ + + defstab = stabent("_",TRUE); + + subname = str_make("main",4); + if (perldb) { + debstash = hnew(0); + stab_xhash(stabent("_DB",TRUE)) = debstash; + curstash = debstash; + dbargs = stab_xarray(aadd((tmpstab = stabent("args",TRUE)))); + tmpstab->str_pok |= SP_MULTI; + dbargs->ary_flags = 0; + DBstab = stabent("DB",TRUE); + DBstab->str_pok |= SP_MULTI; + DBline = stabent("dbline",TRUE); + DBline->str_pok |= SP_MULTI; + DBsub = hadd(tmpstab = stabent("sub",TRUE)); + tmpstab->str_pok |= SP_MULTI; + DBsingle = stab_val((tmpstab = stabent("single",TRUE))); + tmpstab->str_pok |= SP_MULTI; + DBtrace = stab_val((tmpstab = stabent("trace",TRUE))); + tmpstab->str_pok |= SP_MULTI; + DBsignal = stab_val((tmpstab = stabent("signal",TRUE))); + tmpstab->str_pok |= SP_MULTI; + curstash = defstash; + } + + /* init tokener */ + + bufend = bufptr = str_get(linestr); + + savestack = anew(Nullstab); /* for saving non-local values */ + stack = anew(Nullstab); /* for saving non-local values */ + stack->ary_flags = 0; /* not a real array */ + afill(stack,63); afill(stack,-1); /* preextend stack */ + afill(savestack,63); afill(savestack,-1); + + /* now parse the script */ + + error_count = 0; + if (yyparse() || error_count) { + if (minus_c) + fatal("%s had compilation errors.\n", origfilename); + else { + fatal("Execution of %s aborted due to compilation errors.\n", + origfilename); + } + } + + New(50,loop_stack,128,struct loop); +#ifdef DEBUGGING + if (debug) { + New(51,debname,128,char); + New(52,debdelim,128,char); + } +#endif + curstash = defstash; + + preprocess = FALSE; + if (e_fp) { + e_fp = Nullfp; + (void)UNLINK(e_tmpname); + } + + /* initialize everything that won't change if we undump */ + + if (sigstab = stabent("SIG",allstabs)) { + sigstab->str_pok |= SP_MULTI; + (void)hadd(sigstab); + } + + magicalize("!#?^~=-%.+&*()<>,\\/[|`':\004\t\020\024\027\006"); + userinit(); /* in case linked C routines want magical variables */ + + amperstab = stabent("&",allstabs); + leftstab = stabent("`",allstabs); + rightstab = stabent("'",allstabs); + sawampersand = (amperstab || leftstab || rightstab); + if (tmpstab = stabent(":",allstabs)) + str_set(stab_val(tmpstab),chopset); + if (tmpstab = stabent("\024",allstabs)) + time(&basetime); + + /* these aren't necessarily magical */ + if (tmpstab = stabent("\014",allstabs)) { + str_set(stab_val(tmpstab),"\f"); + formfeed = stab_val(tmpstab); + } + if (tmpstab = stabent(";",allstabs)) + str_set(STAB_STR(tmpstab),"\034"); + if (tmpstab = stabent("]",allstabs)) { + str = STAB_STR(tmpstab); + str_set(str,rcsid); + str->str_u.str_nval = atof(patchlevel); + str->str_nok = 1; + } + str_nset(stab_val(stabent("\"", TRUE)), " ", 1); + + stdinstab = stabent("STDIN",TRUE); + stdinstab->str_pok |= SP_MULTI; + if (!stab_io(stdinstab)) + stab_io(stdinstab) = stio_new(); + stab_io(stdinstab)->ifp = stdin; + tmpstab = stabent("stdin",TRUE); + stab_io(tmpstab) = stab_io(stdinstab); + tmpstab->str_pok |= SP_MULTI; + + tmpstab = stabent("STDOUT",TRUE); + tmpstab->str_pok |= SP_MULTI; + if (!stab_io(tmpstab)) + stab_io(tmpstab) = stio_new(); + stab_io(tmpstab)->ofp = stab_io(tmpstab)->ifp = stdout; + defoutstab = tmpstab; + tmpstab = stabent("stdout",TRUE); + stab_io(tmpstab) = stab_io(defoutstab); + tmpstab->str_pok |= SP_MULTI; + + curoutstab = stabent("STDERR",TRUE); + curoutstab->str_pok |= SP_MULTI; + if (!stab_io(curoutstab)) + stab_io(curoutstab) = stio_new(); + stab_io(curoutstab)->ofp = stab_io(curoutstab)->ifp = stderr; + tmpstab = stabent("stderr",TRUE); + stab_io(tmpstab) = stab_io(curoutstab); + tmpstab->str_pok |= SP_MULTI; + curoutstab = defoutstab; /* switch back to STDOUT */ + + statname = Str_new(66,0); /* last filename we did stat on */ + + /* now that script is parsed, we can modify record separator */ + + rs = nrs; + rslen = nrslen; + rschar = nrschar; + rspara = (nrslen == 2); + str_nset(stab_val(stabent("/", TRUE)), rs, rslen); + + if (do_undump) + my_unexec(); + + just_doit: /* come here if running an undumped a.out */ + argc--,argv++; /* skip name of script */ + if (doswitches) { + for (; argc > 0 && **argv == '-'; argc--,argv++) { + if (argv[0][1] == '-') { + argc--,argv++; + break; + } + if (s = index(argv[0], '=')) { + *s++ = '\0'; + str_set(stab_val(stabent(argv[0]+1,TRUE)),s); + } + else + str_numset(stab_val(stabent(argv[0]+1,TRUE)),(double)1.0); + } + } +#ifdef TAINT + tainted = 1; +#endif + if (tmpstab = stabent("0",allstabs)) { + str_set(stab_val(tmpstab),origfilename); + magicname("0", Nullch, 0); + } + if (tmpstab = stabent("\030",allstabs)) + str_set(stab_val(tmpstab),origargv[0]); + if (argvstab = stabent("ARGV",allstabs)) { + argvstab->str_pok |= SP_MULTI; + (void)aadd(argvstab); + aclear(stab_array(argvstab)); + for (; argc > 0; argc--,argv++) { + (void)apush(stab_array(argvstab),str_make(argv[0],0)); + } + } +#ifdef TAINT + (void) stabent("ENV",TRUE); /* must test PATH and IFS */ +#endif + if (envstab = stabent("ENV",allstabs)) { + envstab->str_pok |= SP_MULTI; + (void)hadd(envstab); + hclear(stab_hash(envstab), FALSE); + if (env != environ) + environ[0] = Nullch; + for (; *env; env++) { + if (!(s = index(*env,'='))) + continue; + *s++ = '\0'; + str = str_make(s--,0); + str_magic(str, envstab, 'E', *env, s - *env); + (void)hstore(stab_hash(envstab), *env, s - *env, str, 0); + *s = '='; + } + } +#ifdef TAINT + tainted = 0; +#endif + if (tmpstab = stabent("$",allstabs)) + str_numset(STAB_STR(tmpstab),(double)getpid()); + + if (dowarn) { + stab_check('A','Z'); + stab_check('a','z'); + } + + if (setjmp(top_env)) /* sets goto_targ on longjump */ + loop_ptr = -1; /* start label stack again */ + +#ifdef DEBUGGING + if (debug & 1024) + dump_all(); + if (debug) + fprintf(stderr,"\nEXECUTING...\n\n"); +#endif + + if (minus_c) { + fprintf(stderr,"%s syntax OK\n", origfilename); + exit(0); + } + + /* do it */ + + (void) cmd_exec(main_root,G_SCALAR,-1); + + if (goto_targ) + fatal("Can't find label \"%s\"--aborting",goto_targ); + exit(0); + /* NOTREACHED */ +} + +void +magicalize(list) +register char *list; +{ + char sym[2]; + + sym[1] = '\0'; + while (*sym = *list++) + magicname(sym, Nullch, 0); +} + +void +magicname(sym,name,namlen) +char *sym; +char *name; +int namlen; +{ + register STAB *stab; + + if (stab = stabent(sym,allstabs)) { + stab_flags(stab) = SF_VMAGIC; + str_magic(stab_val(stab), stab, 0, name, namlen); + } +} + +static void +incpush(p) +char *p; +{ + char *s; + + if (!p) + return; + + /* Break at all separators */ + while (*p) { + /* First, skip any consecutive separators */ + while ( *p == PERLLIB_SEP ) { + /* Uncomment the next line for PATH semantics */ + /* (void)apush(stab_array(incstab), str_make(".", 1)); */ + p++; + } + if ( (s = index(p, PERLLIB_SEP)) != Nullch ) { + (void)apush(stab_array(incstab), str_make(p, (int)(s - p))); + p = s + 1; + } else { + (void)apush(stab_array(incstab), str_make(p, 0)); + break; + } + } +} + +void +savelines(array, str) +ARRAY *array; +STR *str; +{ + register char *s = str->str_ptr; + register char *send = str->str_ptr + str->str_cur; + register char *t; + register int line = 1; + + while (s && s < send) { + STR *tmpstr = Str_new(85,0); + + t = index(s, '\n'); + if (t) + t++; + else + t = send; + + str_nset(tmpstr, s, t - s); + astore(array, line++, tmpstr); + s = t; + } +} + +/* this routine is in perl.c by virtue of being sort of an alternate main() */ + +int +do_eval(str,optype,stash,savecmd,gimme,arglast) +STR *str; +int optype; +HASH *stash; +int savecmd; +int gimme; +int *arglast; +{ + STR **st = stack->ary_array; + int retval; + CMD *myroot = Nullcmd; + ARRAY *ar; + int i; + CMD * VOLATILE oldcurcmd = curcmd; + VOLATILE int oldtmps_base = tmps_base; + VOLATILE int oldsave = savestack->ary_fill; + VOLATILE int oldperldb = perldb; + SPAT * VOLATILE oldspat = curspat; + SPAT * VOLATILE oldlspat = lastspat; + static char *last_eval = Nullch; + static long last_elen = 0; + static CMD *last_root = Nullcmd; + VOLATILE int sp = arglast[0]; + char *specfilename; + char *tmpfilename; + int parsing = 1; + + tmps_base = tmps_max; + if (curstash != stash) { + (void)savehptr(&curstash); + curstash = stash; + } + str_set(stab_val(stabent("@",TRUE)),""); + if (curcmd->c_line == 0) /* don't debug debugger... */ + perldb = FALSE; + curcmd = &compiling; + if (optype == O_EVAL) { /* normal eval */ + curcmd->c_filestab = fstab("(eval)"); + curcmd->c_line = 1; + str_sset(linestr,str); + str_cat(linestr,";\n;\n"); /* be kind to them */ + if (perldb) + savelines(stab_xarray(curcmd->c_filestab), linestr); + } + else { + if (last_root && !in_eval) { + Safefree(last_eval); + last_eval = Nullch; + cmd_free(last_root); + last_root = Nullcmd; + } + specfilename = str_get(str); + str_set(linestr,""); + if (optype == O_REQUIRE && &str_undef != + hfetch(stab_hash(incstab), specfilename, strlen(specfilename), 0)) { + curcmd = oldcurcmd; + tmps_base = oldtmps_base; + st[++sp] = &str_yes; + perldb = oldperldb; + return sp; + } + tmpfilename = savestr(specfilename); + if (*tmpfilename == '/' || + (*tmpfilename == '.' && + (tmpfilename[1] == '/' || + (tmpfilename[1] == '.' && tmpfilename[2] == '/')))) + { + rsfp = fopen(tmpfilename,"r"); + } + else { + ar = stab_array(incstab); + for (i = 0; i <= ar->ary_fill; i++) { + (void)sprintf(buf, "%s/%s", + str_get(afetch(ar,i,TRUE)), specfilename); + rsfp = fopen(buf,"r"); + if (rsfp) { + char *s = buf; + + if (*s == '.' && s[1] == '/') + s += 2; + Safefree(tmpfilename); + tmpfilename = savestr(s); + break; + } + } + } + curcmd->c_filestab = fstab(tmpfilename); + Safefree(tmpfilename); + tmpfilename = Nullch; + if (!rsfp) { + curcmd = oldcurcmd; + tmps_base = oldtmps_base; + if (optype == O_REQUIRE) { + sprintf(tokenbuf,"Can't locate %s in @INC", specfilename); + if (instr(tokenbuf,".h ")) + strcat(tokenbuf," (change .h to .ph maybe?)"); + if (instr(tokenbuf,".ph ")) + strcat(tokenbuf," (did you run h2ph?)"); + fatal("%s",tokenbuf); + } + if (gimme != G_ARRAY) + st[++sp] = &str_undef; + perldb = oldperldb; + return sp; + } + curcmd->c_line = 0; + } + in_eval++; + oldoldbufptr = oldbufptr = bufptr = str_get(linestr); + bufend = bufptr + linestr->str_cur; + if (++loop_ptr >= loop_max) { + loop_max += 128; + Renew(loop_stack, loop_max, struct loop); + } + loop_stack[loop_ptr].loop_label = "_EVAL_"; + loop_stack[loop_ptr].loop_sp = sp; +#ifdef DEBUGGING + if (debug & 4) { + deb("(Pushing label #%d _EVAL_)\n", loop_ptr); + } +#endif + eval_root = Nullcmd; + if (setjmp(loop_stack[loop_ptr].loop_env)) { + retval = 1; + } + else { + error_count = 0; + if (rsfp) { + retval = yyparse(); + retval |= error_count; + } + else if (last_root && last_elen == bufend - bufptr + && *bufptr == *last_eval && !bcmp(bufptr,last_eval,last_elen)){ + retval = 0; + eval_root = last_root; /* no point in reparsing */ + } + else if (in_eval == 1 && !savecmd) { + if (last_root) { + Safefree(last_eval); + last_eval = Nullch; + cmd_free(last_root); + } + last_root = Nullcmd; + last_elen = bufend - bufptr; + last_eval = nsavestr(bufptr, last_elen); + retval = yyparse(); + retval |= error_count; + if (!retval) + last_root = eval_root; + if (!last_root) { + Safefree(last_eval); + last_eval = Nullch; + } + } + else + retval = yyparse(); + } + myroot = eval_root; /* in case cmd_exec does another eval! */ + + if (retval || error_count) { + st = stack->ary_array; + sp = arglast[0]; + if (gimme != G_ARRAY) + st[++sp] = &str_undef; + if (parsing) { +#ifndef MANGLEDPARSE +#ifdef DEBUGGING + if (debug & 128) + fprintf(stderr,"Freeing eval_root %lx\n",(long)eval_root); +#endif + cmd_free(eval_root); +#endif + /*SUPPRESS 29*/ /*SUPPRESS 30*/ + if ((CMD*)eval_root == last_root) + last_root = Nullcmd; + eval_root = myroot = Nullcmd; + } + if (rsfp) { + fclose(rsfp); + rsfp = 0; + } + } + else { + parsing = 0; + sp = cmd_exec(eval_root,gimme,sp); + st = stack->ary_array; + for (i = arglast[0] + 1; i <= sp; i++) + st[i] = str_mortal(st[i]); + /* if we don't save result, free zaps it */ + if (savecmd) + eval_root = myroot; + else if (in_eval != 1 && myroot != last_root) + cmd_free(myroot); + } + + perldb = oldperldb; + in_eval--; +#ifdef DEBUGGING + if (debug & 4) { + char *tmps = loop_stack[loop_ptr].loop_label; + deb("(Popping label #%d %s)\n",loop_ptr, + tmps ? tmps : "" ); + } +#endif + loop_ptr--; + tmps_base = oldtmps_base; + curspat = oldspat; + lastspat = oldlspat; + if (savestack->ary_fill > oldsave) /* let them use local() */ + restorelist(oldsave); + + if (optype != O_EVAL) { + if (retval) { + if (optype == O_REQUIRE) + fatal("%s", str_get(stab_val(stabent("@",TRUE)))); + } + else { + curcmd = oldcurcmd; + if (gimme == G_SCALAR ? str_true(st[sp]) : sp > arglast[0]) { + (void)hstore(stab_hash(incstab), specfilename, + strlen(specfilename), str_smake(stab_val(curcmd->c_filestab)), + 0 ); + } + else if (optype == O_REQUIRE) + fatal("%s did not return a true value", specfilename); + } + } + curcmd = oldcurcmd; + return sp; +} + +int +do_try(cmd,gimme,arglast) +CMD *cmd; +int gimme; +int *arglast; +{ + STR **st = stack->ary_array; + + CMD * VOLATILE oldcurcmd = curcmd; + VOLATILE int oldtmps_base = tmps_base; + VOLATILE int oldsave = savestack->ary_fill; + SPAT * VOLATILE oldspat = curspat; + SPAT * VOLATILE oldlspat = lastspat; + VOLATILE int sp = arglast[0]; + + tmps_base = tmps_max; + str_set(stab_val(stabent("@",TRUE)),""); + in_eval++; + if (++loop_ptr >= loop_max) { + loop_max += 128; + Renew(loop_stack, loop_max, struct loop); + } + loop_stack[loop_ptr].loop_label = "_EVAL_"; + loop_stack[loop_ptr].loop_sp = sp; +#ifdef DEBUGGING + if (debug & 4) { + deb("(Pushing label #%d _EVAL_)\n", loop_ptr); + } +#endif + if (setjmp(loop_stack[loop_ptr].loop_env)) { + st = stack->ary_array; + sp = arglast[0]; + if (gimme != G_ARRAY) + st[++sp] = &str_undef; + } + else { + sp = cmd_exec(cmd,gimme,sp); + st = stack->ary_array; +/* for (i = arglast[0] + 1; i <= sp; i++) + st[i] = str_mortal(st[i]); not needed, I think */ + /* if we don't save result, free zaps it */ + } + + in_eval--; +#ifdef DEBUGGING + if (debug & 4) { + char *tmps = loop_stack[loop_ptr].loop_label; + deb("(Popping label #%d %s)\n",loop_ptr, + tmps ? tmps : "" ); + } +#endif + loop_ptr--; + tmps_base = oldtmps_base; + curspat = oldspat; + lastspat = oldlspat; + curcmd = oldcurcmd; + if (savestack->ary_fill > oldsave) /* let them use local() */ + restorelist(oldsave); + + return sp; +} + +/* This routine handles any switches that can be given during run */ + +static char * +moreswitches(s) +char *s; +{ + int numlen; + + switch (*s) { + case '0': + nrschar = scanoct(s, 4, &numlen); + nrs = nsavestr("\n",1); + *nrs = nrschar; + if (nrschar > 0377) { + nrslen = 0; + nrs = ""; + } + else if (!nrschar && numlen >= 2) { + nrslen = 2; + nrs = "\n\n"; + nrschar = '\n'; + } + return s + numlen; + case 'a': + minus_a = TRUE; + s++; + return s; + case 'c': + minus_c = TRUE; + s++; + return s; + case 'd': +#ifdef TAINT + if (euid != uid || egid != gid) + fatal("No -d allowed in setuid scripts"); +#endif + perldb = TRUE; + s++; + return s; + case 'D': +#ifdef DEBUGGING +#ifdef TAINT + if (euid != uid || egid != gid) + fatal("No -D allowed in setuid scripts"); +#endif + debug = atoi(s+1) | 32768; +#else + warn("Recompile perl with -DDEBUGGING to use -D switch\n"); +#endif + /*SUPPRESS 530*/ + for (s++; isDIGIT(*s); s++) ; + return s; + case 'i': + inplace = savestr(s+1); + /*SUPPRESS 530*/ + for (s = inplace; *s && !isSPACE(*s); s++) ; + *s = '\0'; + break; + case 'I': +#ifdef TAINT + if (euid != uid || egid != gid) + fatal("No -I allowed in setuid scripts"); +#endif + if (*++s) { + (void)apush(stab_array(incstab),str_make(s,0)); + } + else + fatal("No space allowed after -I"); + break; + case 'l': + minus_l = TRUE; + s++; + if (isDIGIT(*s)) { + ors = savestr("\n"); + orslen = 1; + *ors = scanoct(s, 3 + (*s == '0'), &numlen); + s += numlen; + } + else { + ors = nsavestr(nrs,nrslen); + orslen = nrslen; + } + return s; + case 'n': + minus_n = TRUE; + s++; + return s; + case 'p': + minus_p = TRUE; + s++; + return s; + case 'u': + do_undump = TRUE; + s++; + return s; + case 'U': + unsafe = TRUE; + s++; + return s; + case 'v': + fputs("\nThis is perl, version 4.0\n\n",stdout); + fputs(rcsid,stdout); + fputs("\nCopyright (c) 1989, 1990, 1991, Larry Wall\n",stdout); +#ifdef MSDOS + fputs("MS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n", + stdout); +#ifdef OS2 + fputs("OS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n", + stdout); +#endif +#endif +#ifdef atarist + fputs("atariST series port, ++jrb bammi@cadence.com\n", stdout); +#endif + fputs("\n\ +Perl may be copied only under the terms of either the Artistic License or the\n\ +GNU General Public License, which may be found in the Perl 4.0 source kit.\n",stdout); +#ifdef MSDOS + usage(origargv[0]); +#endif + exit(0); + case 'w': + dowarn = TRUE; + s++; + return s; + case ' ': + case '\n': + case '\t': + break; + default: + fatal("Switch meaningless after -x: -%s",s); + } + return Nullch; +} + +/* compliments of Tom Christiansen */ + +/* unexec() can be found in the Gnu emacs distribution */ + +void +my_unexec() +{ +#ifdef UNEXEC + int status; + extern int etext; + static char dumpname[BUFSIZ]; + static char perlpath[256]; + + sprintf (dumpname, "%s.perldump", origfilename); + sprintf (perlpath, "%s/perl", BIN); + + status = unexec(dumpname, perlpath, &etext, sbrk(0), 0); + if (status) + fprintf(stderr, "unexec of %s into %s failed!\n", perlpath, dumpname); + exit(status); +#else +#ifdef DOSISH + abort(); /* nothing else to do */ +#else /* ! MSDOS */ +# ifndef SIGABRT +# define SIGABRT SIGILL +# endif +# ifndef SIGILL +# define SIGILL 6 /* blech */ +# endif + kill(getpid(),SIGABRT); /* for use with undump */ +#endif /* ! MSDOS */ +#endif +} + diff --git a/perl.c.rej b/perl.c.rej new file mode 100644 index 0000000..f9653c9 --- /dev/null +++ b/perl.c.rej @@ -0,0 +1,49 @@ +*************** +*** 1,4 **** +! char rcsid[] = "$RCSfile: perl.c,v $$Revision: 4.0.1.7 $$Date: 1992/06/08 14:50:39 $\nPatch level: ###\n"; + /* + * Copyright (c) 1991, Larry Wall + * +--- 1,4 ---- +! char rcsid[] = "$RCSfile: perl.c,v $$Revision: 4.0.1.8 $$Date: 1993/02/05 19:39:30 $\nPatch level: ###\n"; + /* + * Copyright (c) 1991, Larry Wall + * +*************** +*** 6,12 **** + * License or the Artistic License, as specified in the README file. + * + * $Log: perl.c,v $ +! * Revision 4.0.1.7 1992/06/08 14:50:39 lwall + * patch20: PERLLIB now supports multiple directories + * patch20: running taintperl explicitly now does checks even if $< == $> + * patch20: -e 'cmd' no longer fails silently if /tmp runs out of space +--- 6,16 ---- + * License or the Artistic License, as specified in the README file. + * + * $Log: perl.c,v $ +! * Revision 4.0.1.8 1993/02/05 19:39:30 lwall +! * patch36: the taintanyway code wasn't tainting anyway +! * patch36: Malformed cmd links core dump apparently fixed +! * +! * Revision 4.0.1.7 92/06/08 14:50:39 lwall + * patch20: PERLLIB now supports multiple directories + * patch20: running taintperl explicitly now does checks even if $< == $> + * patch20: -e 'cmd' no longer fails silently if /tmp runs out of space +*************** +*** 16,22 **** + * patch20: eval "1 #comment" didn't work + * patch20: couldn't require . files + * patch20: semantic compilation errors didn't abort execution +! * + * Revision 4.0.1.6 91/11/11 16:38:45 lwall + * patch19: default arg for shift was wrong after first subroutine definition + * patch19: op/regexp.t failed from missing arg to bcmp() +--- 20,26 ---- + * patch20: eval "1 #comment" didn't work + * patch20: couldn't require . files + * patch20: semantic compilation errors didn't abort execution +! * + * Revision 4.0.1.6 91/11/11 16:38:45 lwall + * patch19: default arg for shift was wrong after first subroutine definition + * patch19: op/regexp.t failed from missing arg to bcmp() diff --git a/perl.h b/perl.h index 5d9f002..9d48512 100644 --- a/perl.h +++ b/perl.h @@ -868,7 +868,7 @@ EXT int lastsize; EXT char *hexdigit INIT("0123456789abcdef0123456789ABCDEFx"); EXT char *origfilename; -EXT FILE * VOLATILE rsfp; +EXT FILE * VOLATILE rsfp INIT(Nullfp); EXT char buf[1024]; EXT char *bufptr; EXT char *oldbufptr; @@ -952,7 +952,7 @@ void scanconst(); EXT struct stat statbuf; EXT struct stat statcache; EXT STAB *statstab INIT(Nullstab); -EXT STR *statname; +EXT STR *statname INIT(Nullstr); #ifndef MSDOS EXT struct tms timesbuf; #endif diff --git a/perl.h.orig b/perl.h.orig new file mode 100644 index 0000000..5d9f002 --- /dev/null +++ b/perl.h.orig @@ -0,0 +1,1057 @@ +/* $RCSfile: perl.h,v $$Revision: 4.0.1.6 $$Date: 92/06/08 14:55:10 $ + * + * Copyright (c) 1991, Larry Wall + * + * You may distribute under the terms of either the GNU General Public + * License or the Artistic License, as specified in the README file. + * + * $Log: perl.h,v $ + * Revision 4.0.1.6 92/06/08 14:55:10 lwall + * patch20: added Atari ST portability + * patch20: bcopy() and memcpy() now tested for overlap safety + * patch20: Perl now distinguishes overlapped copies from non-overlapped + * patch20: removed implicit int declarations on functions + * + * Revision 4.0.1.5 91/11/11 16:41:07 lwall + * patch19: uts wrongly defines S_ISDIR() et al + * patch19: too many preprocessors can't expand a macro right in #if + * patch19: added little-endian pack/unpack options + * + * Revision 4.0.1.4 91/11/05 18:06:10 lwall + * patch11: various portability fixes + * patch11: added support for dbz + * patch11: added some support for 64-bit integers + * patch11: hex() didn't understand leading 0x + * + * Revision 4.0.1.3 91/06/10 01:25:10 lwall + * patch10: certain pattern optimizations were botched + * + * Revision 4.0.1.2 91/06/07 11:28:33 lwall + * patch4: new copyright notice + * patch4: made some allowances for "semi-standard" C + * patch4: many, many itty-bitty portability fixes + * + * Revision 4.0.1.1 91/04/11 17:49:51 lwall + * patch1: hopefully straightened out some of the Xenix mess + * + * Revision 4.0 91/03/20 01:37:56 lwall + * 4.0 baseline. + * + */ + +#define VOIDWANT 1 +#include "config.h" + +#ifdef MYMALLOC +# ifdef HIDEMYMALLOC +# define malloc Mymalloc +# define realloc Myremalloc +# define free Myfree +# endif +# define safemalloc malloc +# define saferealloc realloc +# define safefree free +#endif + +/* work around some libPW problems */ +#define fatal Myfatal +#ifdef DOINIT +char Error[1]; +#endif + +/* define this once if either system, instead of cluttering up the src */ +#if defined(MSDOS) || defined(atarist) +#define DOSISH 1 +#endif + +#ifdef DOSISH +/* This stuff now in the MS-DOS config.h file. */ +#else /* !MSDOS */ + +/* + * The following symbols are defined if your operating system supports + * functions by that name. All Unixes I know of support them, thus they + * are not checked by the configuration script, but are directly defined + * here. + */ +#define HAS_ALARM +#define HAS_CHOWN +#define HAS_CHROOT +#define HAS_FORK +#define HAS_GETLOGIN +#define HAS_GETPPID +#define HAS_KILL +#define HAS_LINK +#define HAS_PIPE +#define HAS_WAIT +#define HAS_UMASK +/* + * The following symbols are defined if your operating system supports + * password and group functions in general. All Unix systems do. + */ +#define HAS_GROUP +#define HAS_PASSWD + +#endif /* !MSDOS */ + +#if defined(__STDC__) || defined(_AIX) || defined(__stdc__) +# define STANDARD_C 1 +#endif + +#if defined(HASVOLATILE) || defined(STANDARD_C) +#define VOLATILE volatile +#else +#define VOLATILE +#endif + +#ifdef IAMSUID +# ifndef TAINT +# define TAINT +# endif +#endif + +#ifndef HAS_VFORK +# define vfork fork +#endif + +#ifdef HAS_GETPGRP2 +# ifndef HAS_GETPGRP +# define HAS_GETPGRP +# endif +# define getpgrp getpgrp2 +#endif + +#ifdef HAS_SETPGRP2 +# ifndef HAS_SETPGRP +# define HAS_SETPGRP +# endif +# define setpgrp setpgrp2 +#endif + +#include +#include +#include +#ifndef MSDOS +#ifdef PARAM_NEEDS_TYPES +#include +#endif +#include +#endif +#ifdef STANDARD_C +/* Use all the "standard" definitions */ +#include +#include +#define MEM_SIZE size_t +#else +typedef unsigned int MEM_SIZE; +#endif /* STANDARD_C */ + +#if defined(HAS_MEMCMP) && defined(mips) && defined(ultrix) +#undef HAS_MEMCMP +#endif + +#ifdef HAS_MEMCPY +# ifndef STANDARD_C +# ifndef memcpy + extern char * memcpy(); +# endif +# endif +#else +# ifndef memcpy +# ifdef HAS_BCOPY +# define memcpy(d,s,l) bcopy(s,d,l) +# else +# define memcpy(d,s,l) my_bcopy(s,d,l) +# endif +# endif +#endif /* HAS_MEMCPY */ + +#ifdef HAS_MEMSET +# ifndef STANDARD_C +# ifndef memset + extern char *memset(); +# endif +# endif +# define memzero(d,l) memset(d,0,l) +#else +# ifndef memzero +# ifdef HAS_BZERO +# define memzero(d,l) bzero(d,l) +# else +# define memzero(d,l) my_bzero(d,l) +# endif +# endif +#endif /* HAS_MEMSET */ + +#ifdef HAS_MEMCMP +# ifndef STANDARD_C +# ifndef memcmp + extern int memcmp(); +# endif +# endif +#else +# ifndef memcmp +# define memcmp(s1,s2,l) my_memcmp(s1,s2,l) +# endif +#endif /* HAS_MEMCMP */ + +/* we prefer bcmp slightly for comparisons that don't care about ordering */ +#ifndef HAS_BCMP +# ifndef bcmp +# define bcmp(s1,s2,l) memcmp(s1,s2,l) +# endif +#endif /* HAS_BCMP */ + +#ifndef HAS_MEMMOVE +#if defined(HAS_BCOPY) && defined(SAFE_BCOPY) +#define memmove(d,s,l) bcopy(s,d,l) +#else +#if defined(HAS_MEMCPY) && defined(SAFE_MEMCPY) +#define memmove(d,s,l) memcpy(d,s,l) +#else +#define memmove(d,s,l) my_bcopy(s,d,l) +#endif +#endif +#endif + +#ifndef _TYPES_ /* If types.h defines this it's easy. */ +#ifndef major /* Does everyone's types.h define this? */ +#include +#endif +#endif + +#ifdef I_NETINET_IN +#include +#endif + +#include +#if defined(uts) || defined(UTekV) +#undef S_ISDIR +#undef S_ISCHR +#undef S_ISBLK +#undef S_ISREG +#undef S_ISFIFO +#undef S_ISLNK +#define S_ISDIR(P) (((P)&S_IFMT)==S_IFDIR) +#define S_ISCHR(P) (((P)&S_IFMT)==S_IFCHR) +#define S_ISBLK(P) (((P)&S_IFMT)==S_IFBLK) +#define S_ISREG(P) (((P)&S_IFMT)==S_IFREG) +#define S_ISFIFO(P) (((P)&S_IFMT)==S_IFIFO) +#ifdef S_IFLNK +#define S_ISLNK(P) (((P)&S_IFMT)==S_IFLNK) +#endif +#endif + +#ifdef I_TIME +# include +#endif + +#ifdef I_SYS_TIME +# ifdef SYSTIMEKERNEL +# define KERNEL +# endif +# include +# ifdef SYSTIMEKERNEL +# undef KERNEL +# endif +#endif + +#ifndef MSDOS +#include +#endif + +#if defined(HAS_STRERROR) && (!defined(HAS_MKDIR) || !defined(HAS_RMDIR)) +#undef HAS_STRERROR +#endif + +#include +#ifndef MSDOS +#ifndef errno +extern int errno; /* ANSI allows errno to be an lvalue expr */ +#endif +#endif + +#ifndef strerror +#ifdef HAS_STRERROR +char *strerror(); +#else +extern int sys_nerr; +extern char *sys_errlist[]; +#define strerror(e) ((e) < 0 || (e) >= sys_nerr ? "(unknown)" : sys_errlist[e]) +#endif +#endif + +#ifdef I_SYSIOCTL +#ifndef _IOCTL_ +#include +#endif +#endif + +#if defined(mc300) || defined(mc500) || defined(mc700) || defined(mc6000) +#ifdef HAS_SOCKETPAIR +#undef HAS_SOCKETPAIR +#endif +#ifdef HAS_NDBM +#undef HAS_NDBM +#endif +#endif + +#ifdef WANT_DBZ +#include +#define SOME_DBM +#define dbm_fetch(db,dkey) fetch(dkey) +#define dbm_delete(db,dkey) fatal("dbz doesn't implement delete") +#define dbm_store(db,dkey,dcontent,flags) store(dkey,dcontent) +#define dbm_close(db) dbmclose() +#define dbm_firstkey(db) (fatal("dbz doesn't implement traversal"),fetch()) +#define nextkey() (fatal("dbz doesn't implement traversal"),fetch()) +#define dbm_nextkey(db) (fatal("dbz doesn't implement traversal"),fetch()) +#ifdef HAS_NDBM +#undef HAS_NDBM +#endif +#ifndef HAS_ODBM +#define HAS_ODBM +#endif +#else +#ifdef HAS_GDBM +#ifdef I_GDBM +#include +#endif +#define SOME_DBM +#ifdef HAS_NDBM +#undef HAS_NDBM +#endif +#ifdef HAS_ODBM +#undef HAS_ODBM +#endif +#else +#ifdef HAS_NDBM +#include +#define SOME_DBM +#ifdef HAS_ODBM +#undef HAS_ODBM +#endif +#else +#ifdef HAS_ODBM +#ifdef NULL +#undef NULL /* suppress redefinition message */ +#endif +#include +#ifdef NULL +#undef NULL +#endif +#define NULL 0 /* silly thing is, we don't even use this */ +#define SOME_DBM +#define dbm_fetch(db,dkey) fetch(dkey) +#define dbm_delete(db,dkey) delete(dkey) +#define dbm_store(db,dkey,dcontent,flags) store(dkey,dcontent) +#define dbm_close(db) dbmclose() +#define dbm_firstkey(db) firstkey() +#endif /* HAS_ODBM */ +#endif /* HAS_NDBM */ +#endif /* HAS_GDBM */ +#endif /* WANT_DBZ */ +#ifdef SOME_DBM +EXT char *dbmkey; +EXT int dbmlen; +#endif + +#if INTSIZE == 2 +#define htoni htons +#define ntohi ntohs +#else +#define htoni htonl +#define ntohi ntohl +#endif + +#if defined(I_DIRENT) +# include +# define DIRENT dirent +#else +# ifdef I_SYS_NDIR +# include +# define DIRENT direct +# else +# ifdef I_SYS_DIR +# ifdef hp9000s500 +# include /* may be wrong in the future */ +# else +# include +# endif +# define DIRENT direct +# endif +# endif +#endif + +#ifdef FPUTS_BOTCH +/* work around botch in SunOS 4.0.1 and 4.0.2 */ +# ifndef fputs +# define fputs(str,fp) fprintf(fp,"%s",str) +# endif +#endif + +/* + * The following gobbledygook brought to you on behalf of __STDC__. + * (I could just use #ifndef __STDC__, but this is more bulletproof + * in the face of half-implementations.) + */ + +#ifndef S_IFMT +# ifdef _S_IFMT +# define S_IFMT _S_IFMT +# else +# define S_IFMT 0170000 +# endif +#endif + +#ifndef S_ISDIR +# define S_ISDIR(m) ((m & S_IFMT) == S_IFDIR) +#endif + +#ifndef S_ISCHR +# define S_ISCHR(m) ((m & S_IFMT) == S_IFCHR) +#endif + +#ifndef S_ISBLK +# ifdef S_IFBLK +# define S_ISBLK(m) ((m & S_IFMT) == S_IFBLK) +# else +# define S_ISBLK(m) (0) +# endif +#endif + +#ifndef S_ISREG +# define S_ISREG(m) ((m & S_IFMT) == S_IFREG) +#endif + +#ifndef S_ISFIFO +# ifdef S_IFIFO +# define S_ISFIFO(m) ((m & S_IFMT) == S_IFIFO) +# else +# define S_ISFIFO(m) (0) +# endif +#endif + +#ifndef S_ISLNK +# ifdef _S_ISLNK +# define S_ISLNK(m) _S_ISLNK(m) +# else +# ifdef _S_IFLNK +# define S_ISLNK(m) ((m & S_IFMT) == _S_IFLNK) +# else +# ifdef S_IFLNK +# define S_ISLNK(m) ((m & S_IFMT) == S_IFLNK) +# else +# define S_ISLNK(m) (0) +# endif +# endif +# endif +#endif + +#ifndef S_ISSOCK +# ifdef _S_ISSOCK +# define S_ISSOCK(m) _S_ISSOCK(m) +# else +# ifdef _S_IFSOCK +# define S_ISSOCK(m) ((m & S_IFMT) == _S_IFSOCK) +# else +# ifdef S_IFSOCK +# define S_ISSOCK(m) ((m & S_IFMT) == S_IFSOCK) +# else +# define S_ISSOCK(m) (0) +# endif +# endif +# endif +#endif + +#ifndef S_IRUSR +# ifdef S_IREAD +# define S_IRUSR S_IREAD +# define S_IWUSR S_IWRITE +# define S_IXUSR S_IEXEC +# else +# define S_IRUSR 0400 +# define S_IWUSR 0200 +# define S_IXUSR 0100 +# endif +# define S_IRGRP (S_IRUSR>>3) +# define S_IWGRP (S_IWUSR>>3) +# define S_IXGRP (S_IXUSR>>3) +# define S_IROTH (S_IRUSR>>6) +# define S_IWOTH (S_IWUSR>>6) +# define S_IXOTH (S_IXUSR>>6) +#endif + +#ifndef S_ISUID +# define S_ISUID 04000 +#endif + +#ifndef S_ISGID +# define S_ISGID 02000 +#endif + +#ifdef f_next +#undef f_next +#endif + +#if defined(cray) || defined(gould) || defined(i860) +# define SLOPPYDIVIDE +#endif + +#if defined(cray) || defined(convex) || defined (uts) || BYTEORDER > 0xffff +# define QUAD +#endif + +#ifdef QUAD +# ifdef cray +# define quad int +# else +# if defined(convex) || defined (uts) +# define quad long long +# else +# define quad long +# endif +# endif +#endif + +typedef MEM_SIZE STRLEN; + +typedef struct arg ARG; +typedef struct cmd CMD; +typedef struct formcmd FCMD; +typedef struct scanpat SPAT; +typedef struct stio STIO; +typedef struct sub SUBR; +typedef struct string STR; +typedef struct atbl ARRAY; +typedef struct htbl HASH; +typedef struct regexp REGEXP; +typedef struct stabptrs STBP; +typedef struct stab STAB; +typedef struct callsave CSV; + +#include "handy.h" +#include "regexp.h" +#include "str.h" +#include "util.h" +#include "form.h" +#include "stab.h" +#include "spat.h" +#include "arg.h" +#include "cmd.h" +#include "array.h" +#include "hash.h" + +#if defined(iAPX286) || defined(M_I286) || defined(I80286) +# define I286 +#endif + +#ifndef STANDARD_C +#ifdef CHARSPRINTF + char *sprintf(); +#else + int sprintf(); +#endif +#endif + +EXT char *Yes INIT("1"); +EXT char *No INIT(""); + +/* "gimme" values */ + +/* Note: cmd.c assumes that it can use && to produce one of these values! */ +#define G_SCALAR 0 +#define G_ARRAY 1 + +#ifdef CRIPPLED_CC +int str_true(); +#else /* !CRIPPLED_CC */ +#define str_true(str) (Str = (str), \ + (Str->str_pok ? \ + ((*Str->str_ptr > '0' || \ + Str->str_cur > 1 || \ + (Str->str_cur && *Str->str_ptr != '0')) ? 1 : 0) \ + : \ + (Str->str_nok ? (Str->str_u.str_nval != 0.0) : 0 ) )) +#endif /* CRIPPLED_CC */ + +#ifdef DEBUGGING +#define str_peek(str) (Str = (str), \ + (Str->str_pok ? \ + Str->str_ptr : \ + (Str->str_nok ? \ + (sprintf(tokenbuf,"num(%g)",Str->str_u.str_nval), \ + (char*)tokenbuf) : \ + "" ))) +#endif + +#ifdef CRIPPLED_CC +char *str_get(); +#else +#ifdef TAINT +#define str_get(str) (Str = (str), tainted |= Str->str_tainted, \ + (Str->str_pok ? Str->str_ptr : str_2ptr(Str))) +#else +#define str_get(str) (Str = (str), (Str->str_pok ? Str->str_ptr : str_2ptr(Str))) +#endif /* TAINT */ +#endif /* CRIPPLED_CC */ + +#ifdef CRIPPLED_CC +double str_gnum(); +#else /* !CRIPPLED_CC */ +#ifdef TAINT +#define str_gnum(str) (Str = (str), tainted |= Str->str_tainted, \ + (Str->str_nok ? Str->str_u.str_nval : str_2num(Str))) +#else /* !TAINT */ +#define str_gnum(str) (Str = (str), (Str->str_nok ? Str->str_u.str_nval : str_2num(Str))) +#endif /* TAINT*/ +#endif /* CRIPPLED_CC */ +EXT STR *Str; + +#define GROWSTR(pp,lp,len) if (*(lp) < (len)) growstr(pp,lp,len) + +#ifndef DOSISH +#define STR_GROW(str,len) if ((str)->str_len < (len)) str_grow(str,len) +#define Str_Grow str_grow +#else +/* extra parentheses intentionally NOT placed around "len"! */ +#define STR_GROW(str,len) if ((str)->str_len < (unsigned long)len) \ + str_grow(str,(unsigned long)len) +#define Str_Grow(str,len) str_grow(str,(unsigned long)(len)) +#endif /* DOSISH */ + +#ifndef BYTEORDER +#define BYTEORDER 0x1234 +#endif + +#if defined(htonl) && !defined(HAS_HTONL) +#define HAS_HTONL +#endif +#if defined(htons) && !defined(HAS_HTONS) +#define HAS_HTONS +#endif +#if defined(ntohl) && !defined(HAS_NTOHL) +#define HAS_NTOHL +#endif +#if defined(ntohs) && !defined(HAS_NTOHS) +#define HAS_NTOHS +#endif +#ifndef HAS_HTONL +#if (BYTEORDER & 0xffff) != 0x4321 +#define HAS_HTONS +#define HAS_HTONL +#define HAS_NTOHS +#define HAS_NTOHL +#define MYSWAP +#define htons my_swap +#define htonl my_htonl +#define ntohs my_swap +#define ntohl my_ntohl +#endif +#else +#if (BYTEORDER & 0xffff) == 0x4321 +#undef HAS_HTONS +#undef HAS_HTONL +#undef HAS_NTOHS +#undef HAS_NTOHL +#endif +#endif + +/* + * Little-endian byte order functions - 'v' for 'VAX', or 'reVerse'. + * -DWS + */ +#if BYTEORDER != 0x1234 +# define HAS_VTOHL +# define HAS_VTOHS +# define HAS_HTOVL +# define HAS_HTOVS +# if BYTEORDER == 0x4321 +# define vtohl(x) ((((x)&0xFF)<<24) \ + +(((x)>>24)&0xFF) \ + +(((x)&0x0000FF00)<<8) \ + +(((x)&0x00FF0000)>>8) ) +# define vtohs(x) ((((x)&0xFF)<<8) + (((x)>>8)&0xFF)) +# define htovl(x) vtohl(x) +# define htovs(x) vtohs(x) +# endif + /* otherwise default to functions in util.c */ +#endif + +#ifdef CASTNEGFLOAT +#define U_S(what) ((unsigned short)(what)) +#define U_I(what) ((unsigned int)(what)) +#define U_L(what) ((unsigned long)(what)) +#else +unsigned long castulong(); +#define U_S(what) ((unsigned int)castulong(what)) +#define U_I(what) ((unsigned int)castulong(what)) +#define U_L(what) (castulong(what)) +#endif + +CMD *add_label(); +CMD *block_head(); +CMD *append_line(); +CMD *make_acmd(); +CMD *make_ccmd(); +CMD *make_icmd(); +CMD *invert(); +CMD *addcond(); +CMD *addloop(); +CMD *wopt(); +CMD *over(); + +STAB *stabent(); +STAB *genstab(); + +ARG *stab2arg(); +ARG *op_new(); +ARG *make_op(); +ARG *make_match(); +ARG *make_split(); +ARG *rcatmaybe(); +ARG *listish(); +ARG *maybelistish(); +ARG *localize(); +ARG *fixeval(); +ARG *jmaybe(); +ARG *l(); +ARG *fixl(); +ARG *mod_match(); +ARG *make_list(); +ARG *cmd_to_arg(); +ARG *addflags(); +ARG *hide_ary(); +ARG *cval_to_arg(); + +STR *str_new(); +STR *stab_str(); + +int apply(); +int do_each(); +int do_subr(); +int do_match(); +int do_unpack(); +int eval(); /* this evaluates expressions */ +int do_eval(); /* this evaluates eval operator */ +int do_assign(); + +SUBR *make_sub(); + +FCMD *load_format(); + +char *scanpat(); +char *scansubst(); +char *scantrans(); +char *scanstr(); +char *scanident(); +char *str_append_till(); +char *str_gets(); +char *str_grow(); + +bool do_open(); +bool do_close(); +bool do_print(); +bool do_aprint(); +bool do_exec(); +bool do_aexec(); + +int do_subst(); +int cando(); +int ingroup(); +int whichsig(); +int userinit(); +#ifdef CRYPTSCRIPT +void cryptswitch(); +#endif + +void str_replace(); +void str_inc(); +void str_dec(); +void str_free(); +void cmd_free(); +void arg_free(); +void spat_free(); +void regfree(); +void stab_clear(); +void do_chop(); +void do_vop(); +void do_write(); +void do_join(); +void do_sprintf(); +void do_accept(); +void do_pipe(); +void do_vecset(); +void do_unshift(); +void do_execfree(); +void magicalize(); +void magicname(); +void savelist(); +void saveitem(); +void saveint(); +void savelong(); +void savesptr(); +void savehptr(); +void restorelist(); +void repeatcpy(); +void make_form(); +void dehoist(); +void format(); +void my_unexec(); +void fatal(); +void warn(); +#ifdef DEBUGGING +void dump_all(); +void dump_cmd(); +void dump_arg(); +void dump_flags(); +void dump_stab(); +void dump_spat(); +#endif +#ifdef MSTATS +void mstats(); +#endif + +HASH *savehash(); +ARRAY *saveary(); + +EXT char **origargv; +EXT int origargc; +EXT char **origenviron; +extern char **environ; + +EXT long subline INIT(0); +EXT STR *subname INIT(Nullstr); +EXT int arybase INIT(0); + +struct outrec { + long o_lines; + char *o_str; + int o_len; +}; + +EXT struct outrec outrec; +EXT struct outrec toprec; + +EXT STAB *stdinstab INIT(Nullstab); +EXT STAB *last_in_stab INIT(Nullstab); +EXT STAB *defstab INIT(Nullstab); +EXT STAB *argvstab INIT(Nullstab); +EXT STAB *envstab INIT(Nullstab); +EXT STAB *sigstab INIT(Nullstab); +EXT STAB *defoutstab INIT(Nullstab); +EXT STAB *curoutstab INIT(Nullstab); +EXT STAB *argvoutstab INIT(Nullstab); +EXT STAB *incstab INIT(Nullstab); +EXT STAB *leftstab INIT(Nullstab); +EXT STAB *amperstab INIT(Nullstab); +EXT STAB *rightstab INIT(Nullstab); +EXT STAB *DBstab INIT(Nullstab); +EXT STAB *DBline INIT(Nullstab); +EXT STAB *DBsub INIT(Nullstab); + +EXT HASH *defstash; /* main symbol table */ +EXT HASH *curstash; /* symbol table for current package */ +EXT HASH *debstash; /* symbol table for perldb package */ + +EXT STR *curstname; /* name of current package */ + +EXT STR *freestrroot INIT(Nullstr); +EXT STR *lastretstr INIT(Nullstr); +EXT STR *DBsingle INIT(Nullstr); +EXT STR *DBtrace INIT(Nullstr); +EXT STR *DBsignal INIT(Nullstr); +EXT STR *formfeed INIT(Nullstr); + +EXT int lastspbase; +EXT int lastsize; + +EXT char *hexdigit INIT("0123456789abcdef0123456789ABCDEFx"); +EXT char *origfilename; +EXT FILE * VOLATILE rsfp; +EXT char buf[1024]; +EXT char *bufptr; +EXT char *oldbufptr; +EXT char *oldoldbufptr; +EXT char *bufend; + +EXT STR *linestr INIT(Nullstr); + +EXT char *rs INIT("\n"); +EXT int rschar INIT('\n'); /* final char of rs, or 0777 if none */ +EXT int rslen INIT(1); +EXT bool rspara INIT(FALSE); +EXT char *ofs INIT(Nullch); +EXT int ofslen INIT(0); +EXT char *ors INIT(Nullch); +EXT int orslen INIT(0); +EXT char *ofmt INIT(Nullch); +EXT char *inplace INIT(Nullch); +EXT char *nointrp INIT(""); + +EXT bool preprocess INIT(FALSE); +EXT bool minus_n INIT(FALSE); +EXT bool minus_p INIT(FALSE); +EXT bool minus_l INIT(FALSE); +EXT bool minus_a INIT(FALSE); +EXT bool doswitches INIT(FALSE); +EXT bool dowarn INIT(FALSE); +EXT bool doextract INIT(FALSE); +EXT bool allstabs INIT(FALSE); /* init all customary symbols in symbol table?*/ +EXT bool sawampersand INIT(FALSE); /* must save all match strings */ +EXT bool sawstudy INIT(FALSE); /* do fbminstr on all strings */ +EXT bool sawi INIT(FALSE); /* study must assume case insensitive */ +EXT bool sawvec INIT(FALSE); +EXT bool localizing INIT(FALSE); /* are we processing a local() list? */ + +#ifndef MAXSYSFD +# define MAXSYSFD 2 +#endif +EXT int maxsysfd INIT(MAXSYSFD); /* top fd to pass to subprocesses */ + +#ifdef CSH +EXT char *cshname INIT(CSH); +EXT int cshlen INIT(0); +#endif /* CSH */ + +#ifdef TAINT +EXT bool tainted INIT(FALSE); /* using variables controlled by $< */ +EXT bool taintanyway INIT(FALSE); /* force taint checks when !set?id */ +#endif + +EXT bool nomemok INIT(FALSE); /* let malloc context handle nomem */ + +#ifndef DOSISH +#define TMPPATH "/tmp/perl-eXXXXXX" +#else +#define TMPPATH "plXXXXXX" +#endif /* MSDOS */ +EXT char *e_tmpname; +EXT FILE *e_fp INIT(Nullfp); + +EXT char tokenbuf[256]; +EXT int expectterm INIT(TRUE); /* how to interpret ambiguous tokens */ +EXT VOLATILE int in_eval INIT(FALSE); /* trap fatal errors? */ +EXT int multiline INIT(0); /* $*--do strings hold >1 line? */ +EXT int forkprocess; /* so do_open |- can return proc# */ +EXT int do_undump INIT(0); /* -u or dump seen? */ +EXT int error_count INIT(0); /* how many errors so far, max 10 */ +EXT int multi_start INIT(0); /* 1st line of multi-line string */ +EXT int multi_end INIT(0); /* last line of multi-line string */ +EXT int multi_open INIT(0); /* delimiter of said string */ +EXT int multi_close INIT(0); /* delimiter of said string */ + +FILE *popen(); +/* char *str_get(); */ +STR *interp(); +void free_arg(); +STIO *stio_new(); +void hoistmust(); +void scanconst(); + +EXT struct stat statbuf; +EXT struct stat statcache; +EXT STAB *statstab INIT(Nullstab); +EXT STR *statname; +#ifndef MSDOS +EXT struct tms timesbuf; +#endif +EXT int uid; +EXT int euid; +EXT int gid; +EXT int egid; +UIDTYPE getuid(); +UIDTYPE geteuid(); +GIDTYPE getgid(); +GIDTYPE getegid(); +EXT int unsafe; + +#ifdef DEBUGGING +EXT VOLATILE int debug INIT(0); +EXT int dlevel INIT(0); +EXT int dlmax INIT(128); +EXT char *debname; +EXT char *debdelim; +#define YYDEBUG 1 +#endif +EXT int perldb INIT(0); +#define YYMAXDEPTH 300 + +EXT line_t cmdline INIT(NOLINE); + +EXT STR str_undef; +EXT STR str_no; +EXT STR str_yes; + +/* runtime control stuff */ + +EXT struct loop { + char *loop_label; /* what the loop was called, if anything */ + int loop_sp; /* stack pointer to copy stuff down to */ + jmp_buf loop_env; +} *loop_stack; + +EXT int loop_ptr INIT(-1); +EXT int loop_max INIT(128); + +EXT jmp_buf top_env; + +EXT char * VOLATILE goto_targ INIT(Nullch); /* cmd_exec gets strange when set */ + +struct ufuncs { + int (*uf_val)(); + int (*uf_set)(); + int uf_index; +}; + +EXT ARRAY *stack; /* THE STACK */ + +EXT ARRAY * VOLATILE savestack; /* to save non-local values on */ + +EXT ARRAY *tosave; /* strings to save on recursive subroutine */ + +EXT ARRAY *lineary; /* lines of script for debugger */ +EXT ARRAY *dbargs; /* args to call listed by caller function */ + +EXT ARRAY *fdpid; /* keep fd-to-pid mappings for mypopen */ +EXT HASH *pidstatus; /* keep pid-to-status mappings for waitpid */ + +EXT int *di; /* for tmp use in debuggers */ +EXT char *dc; +EXT short *ds; + +/* Fix these up for __STDC__ */ +EXT time_t basetime INIT(0); +char *mktemp(); +#ifndef STANDARD_C +/* All of these are in stdlib.h or time.h for ANSI C */ +double atof(); +long time(); +struct tm *gmtime(), *localtime(); +char *index(), *rindex(); +char *strcpy(), *strcat(); +#endif /* ! STANDARD_C */ + +#ifdef EUNICE +#define UNLINK unlnk +int unlnk(); +#else +#define UNLINK unlink +#endif + +#ifndef HAS_SETREUID +#ifdef HAS_SETRESUID +#define setreuid(r,e) setresuid(r,e,-1) +#define HAS_SETREUID +#endif +#endif +#ifndef HAS_SETREGID +#ifdef HAS_SETRESGID +#define setregid(r,e) setresgid(r,e,-1) +#define HAS_SETREGID +#endif +#endif + +#define SCAN_DEF 0 +#define SCAN_TR 1 +#define SCAN_REPL 2 diff --git a/perl.h.rej b/perl.h.rej new file mode 100644 index 0000000..0ecf644 --- /dev/null +++ b/perl.h.rej @@ -0,0 +1,41 @@ +*************** +*** 1,4 **** +! /* $RCSfile: perl.h,v $$Revision: 4.0.1.6 $$Date: 1992/06/08 14:55:10 $ + * + * Copyright (c) 1991, Larry Wall + * +--- 1,4 ---- +! /* $RCSfile: perl.h,v $$Revision: 4.0.1.7 $$Date: 1993/02/05 19:40:30 $ + * + * Copyright (c) 1991, Larry Wall + * +*************** +*** 6,17 **** + * License or the Artistic License, as specified in the README file. + * + * $Log: perl.h,v $ +! * Revision 4.0.1.6 1992/06/08 14:55:10 lwall + * patch20: added Atari ST portability + * patch20: bcopy() and memcpy() now tested for overlap safety + * patch20: Perl now distinguishes overlapped copies from non-overlapped + * patch20: removed implicit int declarations on functions +! * + * Revision 4.0.1.5 91/11/11 16:41:07 lwall + * patch19: uts wrongly defines S_ISDIR() et al + * patch19: too many preprocessors can't expand a macro right in #if +--- 6,20 ---- + * License or the Artistic License, as specified in the README file. + * + * $Log: perl.h,v $ +! * Revision 4.0.1.7 1993/02/05 19:40:30 lwall +! * patch36: worked around certain busted compilers that don't init statics right +! * +! * Revision 4.0.1.6 92/06/08 14:55:10 lwall + * patch20: added Atari ST portability + * patch20: bcopy() and memcpy() now tested for overlap safety + * patch20: Perl now distinguishes overlapped copies from non-overlapped + * patch20: removed implicit int declarations on functions +! * + * Revision 4.0.1.5 91/11/11 16:41:07 lwall + * patch19: uts wrongly defines S_ISDIR() et al + * patch19: too many preprocessors can't expand a macro right in #if diff --git a/perly.y b/perly.y index a52f18a..0a1c2c9 100644 --- a/perly.y +++ b/perly.y @@ -544,7 +544,7 @@ term : '-' term %prec UMINUS | DELETE '(' REG '{' expr ';' '}' ')' %prec '(' { $$ = make_op(O_DELETE, 2, stab2arg(A_STAB,hadd($3)), - jmaybe($4), + jmaybe($5), Nullarg); expectterm = FALSE; } | ARYLEN %prec '(' diff --git a/perly.y.orig b/perly.y.orig new file mode 100644 index 0000000..a52f18a --- /dev/null +++ b/perly.y.orig @@ -0,0 +1,870 @@ +/* $RCSfile: perly.y,v $$Revision: 4.0.1.5 $$Date: 92/06/11 21:12:50 $ + * + * Copyright (c) 1991, Larry Wall + * + * You may distribute under the terms of either the GNU General Public + * License or the Artistic License, as specified in the README file. + * + * $Log: perly.y,v $ + * Revision 4.0.1.5 92/06/11 21:12:50 lwall + * patch34: expectterm incorrectly set to indicate start of program or block + * + * Revision 4.0.1.4 92/06/08 17:33:25 lwall + * patch20: one of the backdoors to expectterm was on the wrong reduction + * + * Revision 4.0.1.3 92/06/08 15:18:16 lwall + * patch20: an expression may now start with a bareword + * patch20: relaxed requirement for semicolon at the end of a block + * patch20: added ... as variant on .. + * patch20: fixed double debug break in foreach with implicit array assignment + * patch20: if {block} {block} didn't work any more + * patch20: deleted some minor memory leaks + * + * 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 + * + * Revision 4.0 91/03/20 01:38:40 lwall + * 4.0 baseline. + * + */ + +%{ +#include "INTERN.h" +#include "perl.h" + +/*SUPPRESS 530*/ +/*SUPPRESS 593*/ +/*SUPPRESS 595*/ + +STAB *scrstab; +ARG *arg4; /* rarely used arguments to make_op() */ +ARG *arg5; + +%} + +%start prog + +%union { + int ival; + char *cval; + ARG *arg; + CMD *cmdval; + struct compcmd compval; + STAB *stabval; + FCMD *formval; +} + +%token '{' ')' + +%token WORD LABEL +%token APPEND OPEN SSELECT LOOPEX DOTDOT +%token USING FORMAT DO SHIFT PUSH POP LVALFUN +%token WHILE UNTIL IF UNLESS ELSE ELSIF CONTINUE SPLIT FLIST +%token FOR FILOP FILOP2 FILOP3 FILOP4 FILOP22 FILOP25 +%token FUNC0 FUNC1 FUNC2 FUNC2x FUNC3 FUNC4 FUNC5 HSHFUN HSHFUN3 +%token FLIST2 SUB FILETEST LOCAL DELETE +%token RELOP EQOP MULOP ADDOP PACKAGE AMPER +%token FORMLIST +%token REG ARYLEN ARY HSH STAR +%token SUBST PATTERN +%token RSTRING TRANS + +%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 +%type label +%type compblock + +%nonassoc LISTOP +%left ',' +%right '=' +%right '?' ':' +%nonassoc DOTDOT +%left OROR +%left ANDAND +%left '|' '^' +%left '&' +%nonassoc EQOP +%nonassoc RELOP +%nonassoc UNIOP +%nonassoc FILETEST +%left LS RS +%left ADDOP +%left MULOP +%left MATCH NMATCH +%right '!' '~' UMINUS +%right POW +%nonassoc INC DEC +%left '(' + +%% /* RULES */ + +prog : /* NULL */ + { +#if defined(YYDEBUG) && defined(DEBUGGING) + yydebug = (debug & 1); +#endif + expectterm = 2; + } + /*CONTINUED*/ lineseq + { if (in_eval) + eval_root = block_head($2); + else + main_root = block_head($2); } + ; + +compblock: block CONTINUE block + { $$.comp_true = $1; $$.comp_alt = $3; } + | block else + { $$.comp_true = $1; $$.comp_alt = $2; } + ; + +else : /* NULL */ + { $$ = Nullcmd; } + | ELSE block + { $$ = $2; } + | ELSIF '(' expr ')' compblock + { cmdline = $1; + $$ = make_ccmd(C_ELSIF,1,$3,$5); } + ; + +block : '{' remember lineseq '}' + { $$ = block_head($3); + if (cmdline > (line_t)$1) + cmdline = $1; + if (savestack->ary_fill > $2) + restorelist($2); + expectterm = 2; } + ; + +remember: /* NULL */ /* in case they push a package name */ + { $$ = savestack->ary_fill; } + ; + +lineseq : /* NULL */ + { $$ = Nullcmd; } + | lineseq line + { $$ = append_line($1,$2); } + ; + +line : decl + { $$ = Nullcmd; } + | label cond + { $$ = add_label($1,$2); } + | loop /* loops add their own labels */ + | label ';' + { if ($1 != Nullch) { + $$ = add_label($1, make_acmd(C_EXPR, Nullstab, + Nullarg, Nullarg) ); + } + else { + $$ = Nullcmd; + cmdline = NOLINE; + } + expectterm = 2; } + | label sideff ';' + { $$ = add_label($1,$2); + expectterm = 2; } + ; + +sideff : error + { $$ = Nullcmd; } + | expr + { $$ = make_acmd(C_EXPR, Nullstab, $1, Nullarg); } + | expr IF expr + { $$ = addcond( + make_acmd(C_EXPR, Nullstab, Nullarg, $1), $3); } + | expr UNLESS expr + { $$ = addcond(invert( + make_acmd(C_EXPR, Nullstab, Nullarg, $1)), $3); } + | expr WHILE expr + { $$ = addloop( + make_acmd(C_EXPR, Nullstab, Nullarg, $1), $3); } + | expr UNTIL expr + { $$ = addloop(invert( + make_acmd(C_EXPR, Nullstab, Nullarg, $1)), $3); } + ; + +cond : IF '(' expr ')' compblock + { cmdline = $1; + $$ = make_icmd(C_IF,$3,$5); } + | UNLESS '(' expr ')' compblock + { cmdline = $1; + $$ = invert(make_icmd(C_IF,$3,$5)); } + | IF block compblock + { cmdline = $1; + $$ = make_icmd(C_IF,cmd_to_arg($2),$3); } + | UNLESS block compblock + { cmdline = $1; + $$ = invert(make_icmd(C_IF,cmd_to_arg($2),$3)); } + ; + +loop : label WHILE '(' texpr ')' compblock + { cmdline = $2; + $$ = wopt(add_label($1, + make_ccmd(C_WHILE,1,$4,$6) )); } + | label UNTIL '(' expr ')' compblock + { cmdline = $2; + $$ = wopt(add_label($1, + invert(make_ccmd(C_WHILE,1,$4,$6)) )); } + | label WHILE block compblock + { cmdline = $2; + $$ = wopt(add_label($1, + make_ccmd(C_WHILE, 1, cmd_to_arg($3),$4) )); } + | label UNTIL block compblock + { cmdline = $2; + $$ = wopt(add_label($1, + invert(make_ccmd(C_WHILE,1,cmd_to_arg($3),$4)) )); } + | label FOR REG '(' expr crp compblock + { cmdline = $2; + /* + * The following gobbledygook catches EXPRs that + * aren't explicit array refs and translates + * foreach VAR (EXPR) { + * into + * @ary = EXPR; + * foreach VAR (@ary) { + * where @ary is a hidden array made by genstab(). + * (Note that @ary may become a local array if + * it is determined that it might be called + * recursively. See cmd_tosave().) + */ + if ($5->arg_type != O_ARRAY) { + scrstab = aadd(genstab()); + $$ = append_line( + make_acmd(C_EXPR, Nullstab, + l(make_op(O_ASSIGN,2, + listish(make_op(O_ARRAY, 1, + stab2arg(A_STAB,scrstab), + Nullarg,Nullarg )), + listish(make_list($5)), + Nullarg)), + Nullarg), + wopt(over($3,add_label($1, + make_ccmd(C_WHILE, 0, + make_op(O_ARRAY, 1, + stab2arg(A_STAB,scrstab), + Nullarg,Nullarg ), + $7))))); + $$->c_line = $2; + $$->c_head->c_line = $2; + } + else { + $$ = wopt(over($3,add_label($1, + make_ccmd(C_WHILE,1,$5,$7) ))); + } + } + | label FOR '(' expr crp compblock + { cmdline = $2; + if ($4->arg_type != O_ARRAY) { + scrstab = aadd(genstab()); + $$ = append_line( + make_acmd(C_EXPR, Nullstab, + l(make_op(O_ASSIGN,2, + listish(make_op(O_ARRAY, 1, + stab2arg(A_STAB,scrstab), + Nullarg,Nullarg )), + listish(make_list($4)), + Nullarg)), + Nullarg), + wopt(over(defstab,add_label($1, + make_ccmd(C_WHILE, 0, + make_op(O_ARRAY, 1, + stab2arg(A_STAB,scrstab), + Nullarg,Nullarg ), + $6))))); + $$->c_line = $2; + $$->c_head->c_line = $2; + } + else { /* lisp, anyone? */ + $$ = wopt(over(defstab,add_label($1, + make_ccmd(C_WHILE,1,$4,$6) ))); + } + } + | label FOR '(' nexpr ';' texpr ';' nexpr ')' block + /* basically fake up an initialize-while lineseq */ + { yyval.compval.comp_true = $10; + yyval.compval.comp_alt = $8; + cmdline = $2; + $$ = append_line($4,wopt(add_label($1, + make_ccmd(C_WHILE,1,$6,yyval.compval) ))); } + | label compblock /* a block is a loop that happens once */ + { $$ = add_label($1,make_ccmd(C_BLOCK,1,Nullarg,$2)); } + ; + +nexpr : /* NULL */ + { $$ = Nullcmd; } + | sideff + ; + +texpr : /* NULL means true */ + { (void)scanstr("1",SCAN_DEF); $$ = yylval.arg; } + | expr + ; + +label : /* empty */ + { $$ = Nullch; } + | LABEL + ; + +decl : format + { $$ = 0; } + | subrout + { $$ = 0; } + | package + { $$ = 0; } + ; + +format : FORMAT WORD '=' FORMLIST + { if (strEQ($2,"stdout")) + make_form(stabent("STDOUT",TRUE),$4); + else if (strEQ($2,"stderr")) + make_form(stabent("STDERR",TRUE),$4); + else + make_form(stabent($2,TRUE),$4); + Safefree($2); $2 = Nullch; } + | FORMAT '=' FORMLIST + { make_form(stabent("STDOUT",TRUE),$3); } + ; + +subrout : SUB WORD block + { make_sub($2,$3); + cmdline = NOLINE; + if (savestack->ary_fill > $1) + restorelist($1); } + ; + +package : PACKAGE WORD ';' + { char tmpbuf[256]; + STAB *tmpstab; + + savehptr(&curstash); + saveitem(curstname); + str_set(curstname,$2); + sprintf(tmpbuf,"'_%s",$2); + tmpstab = stabent(tmpbuf,TRUE); + if (!stab_xhash(tmpstab)) + stab_xhash(tmpstab) = hnew(0); + curstash = stab_xhash(tmpstab); + if (!curstash->tbl_name) + curstash->tbl_name = savestr($2); + curstash->tbl_coeffsize = 0; + Safefree($2); $2 = Nullch; + cmdline = NOLINE; + expectterm = 2; + } + ; + +cexpr : ',' expr + { $$ = $2; } + ; + +expr : expr ',' sexpr + { $$ = make_op(O_COMMA, 2, $1, $3, Nullarg); } + | sexpr + ; + +csexpr : ',' sexpr + { $$ = $2; } + ; + +sexpr : sexpr '=' sexpr + { $1 = listish($1); + if ($1->arg_type == O_ASSIGN && $1->arg_len == 1) + $1->arg_type = O_ITEM; /* a local() */ + if ($1->arg_type == O_LIST) + $3 = listish($3); + $$ = l(make_op(O_ASSIGN, 2, $1, $3, Nullarg)); } + | sexpr POW '=' sexpr + { $$ = l(make_op(O_POW, 2, $1, $4, Nullarg)); } + | sexpr MULOP '=' sexpr + { $$ = l(make_op($2, 2, $1, $4, Nullarg)); } + | sexpr ADDOP '=' sexpr + { $$ = rcatmaybe(l(make_op($2, 2, $1, $4, Nullarg)));} + | sexpr LS '=' sexpr + { $$ = l(make_op(O_LEFT_SHIFT, 2, $1, $4, Nullarg)); } + | sexpr RS '=' sexpr + { $$ = l(make_op(O_RIGHT_SHIFT, 2, $1, $4, Nullarg)); } + | sexpr '&' '=' sexpr + { $$ = l(make_op(O_BIT_AND, 2, $1, $4, Nullarg)); } + | sexpr '^' '=' sexpr + { $$ = l(make_op(O_XOR, 2, $1, $4, Nullarg)); } + | sexpr '|' '=' sexpr + { $$ = l(make_op(O_BIT_OR, 2, $1, $4, Nullarg)); } + + + | sexpr POW sexpr + { $$ = make_op(O_POW, 2, $1, $3, Nullarg); } + | sexpr MULOP sexpr + { if ($2 == O_REPEAT) + $1 = listish($1); + $$ = make_op($2, 2, $1, $3, Nullarg); + if ($2 == O_REPEAT) { + if ($$[1].arg_type != A_EXPR || + $$[1].arg_ptr.arg_arg->arg_type != O_LIST) + $$[1].arg_flags &= ~AF_ARYOK; + } } + | sexpr ADDOP sexpr + { $$ = make_op($2, 2, $1, $3, Nullarg); } + | sexpr LS sexpr + { $$ = make_op(O_LEFT_SHIFT, 2, $1, $3, Nullarg); } + | sexpr RS sexpr + { $$ = make_op(O_RIGHT_SHIFT, 2, $1, $3, Nullarg); } + | sexpr RELOP sexpr + { $$ = make_op($2, 2, $1, $3, Nullarg); } + | sexpr EQOP sexpr + { $$ = make_op($2, 2, $1, $3, Nullarg); } + | sexpr '&' sexpr + { $$ = make_op(O_BIT_AND, 2, $1, $3, Nullarg); } + | sexpr '^' sexpr + { $$ = make_op(O_XOR, 2, $1, $3, Nullarg); } + | sexpr '|' sexpr + { $$ = make_op(O_BIT_OR, 2, $1, $3, Nullarg); } + | sexpr DOTDOT sexpr + { arg4 = Nullarg; + $$ = make_op(O_F_OR_R, 4, $1, $3, Nullarg); + $$[0].arg_flags |= $2; } + | sexpr ANDAND sexpr + { $$ = make_op(O_AND, 2, $1, $3, Nullarg); } + | sexpr OROR sexpr + { $$ = make_op(O_OR, 2, $1, $3, Nullarg); } + | sexpr '?' sexpr ':' sexpr + { $$ = make_op(O_COND_EXPR, 3, $1, $3, $5); } + | sexpr MATCH sexpr + { $$ = mod_match(O_MATCH, $1, $3); } + | sexpr NMATCH sexpr + { $$ = mod_match(O_NMATCH, $1, $3); } + | term + { $$ = $1; } + ; + +term : '-' term %prec UMINUS + { $$ = make_op(O_NEGATE, 1, $2, Nullarg, Nullarg); } + | '+' term %prec UMINUS + { $$ = $2; } + | '!' term + { $$ = make_op(O_NOT, 1, $2, Nullarg, Nullarg); } + | '~' term + { $$ = make_op(O_COMPLEMENT, 1, $2, Nullarg, Nullarg);} + | term INC + { $$ = addflags(1, AF_POST|AF_UP, + l(make_op(O_ITEM,1,$1,Nullarg,Nullarg))); } + | term DEC + { $$ = addflags(1, AF_POST, + l(make_op(O_ITEM,1,$1,Nullarg,Nullarg))); } + | INC term + { $$ = addflags(1, AF_PRE|AF_UP, + l(make_op(O_ITEM,1,$2,Nullarg,Nullarg))); } + | DEC term + { $$ = addflags(1, AF_PRE, + l(make_op(O_ITEM,1,$2,Nullarg,Nullarg))); } + | FILETEST WORD + { opargs[$1] = 0; /* force it special */ + $$ = make_op($1, 1, + stab2arg(A_STAB,stabent($2,TRUE)), + Nullarg, Nullarg); + Safefree($2); $2 = Nullch; + } + | FILETEST sexpr + { opargs[$1] = 1; + $$ = make_op($1, 1, $2, Nullarg, Nullarg); } + | FILETEST + { opargs[$1] = ($1 != O_FTTTY); + $$ = make_op($1, 1, + stab2arg(A_STAB, + $1 == O_FTTTY?stabent("STDIN",TRUE):defstab), + Nullarg, Nullarg); } + | LOCAL '(' expr crp + { $$ = l(localize(make_op(O_ASSIGN, 1, + localize(listish(make_list($3))), + Nullarg,Nullarg))); } + | '(' expr crp + { $$ = make_list($2); } + | '(' ')' + { $$ = make_list(Nullarg); } + | DO sexpr %prec FILETEST + { $$ = make_op(O_DOFILE,2,$2,Nullarg,Nullarg); + allstabs = TRUE;} + | DO block %prec '(' + { $$ = cmd_to_arg($2); } + | REG %prec '(' + { $$ = stab2arg(A_STAB,$1); } + | STAR %prec '(' + { $$ = stab2arg(A_STAR,$1); } + | REG '[' expr ']' %prec '(' + { $$ = make_op(O_AELEM, 2, + stab2arg(A_STAB,aadd($1)), $3, Nullarg); } + | HSH %prec '(' + { $$ = make_op(O_HASH, 1, + stab2arg(A_STAB,$1), + Nullarg, Nullarg); } + | ARY %prec '(' + { $$ = make_op(O_ARRAY, 1, + stab2arg(A_STAB,$1), + Nullarg, Nullarg); } + | REG '{' expr ';' '}' %prec '(' + { $$ = make_op(O_HELEM, 2, + stab2arg(A_STAB,hadd($1)), + jmaybe($3), + Nullarg); + expectterm = FALSE; } + | '(' expr crp '[' expr ']' %prec '(' + { $$ = make_op(O_LSLICE, 3, + Nullarg, + listish(make_list($5)), + listish(make_list($2))); } + | '(' ')' '[' expr ']' %prec '(' + { $$ = make_op(O_LSLICE, 3, + Nullarg, + listish(make_list($4)), + Nullarg); } + | ARY '[' expr ']' %prec '(' + { $$ = make_op(O_ASLICE, 2, + stab2arg(A_STAB,aadd($1)), + listish(make_list($3)), + Nullarg); } + | ARY '{' expr ';' '}' %prec '(' + { $$ = make_op(O_HSLICE, 2, + stab2arg(A_STAB,hadd($1)), + listish(make_list($3)), + Nullarg); + expectterm = FALSE; } + | DELETE REG '{' expr ';' '}' %prec '(' + { $$ = make_op(O_DELETE, 2, + stab2arg(A_STAB,hadd($2)), + jmaybe($4), + Nullarg); + expectterm = FALSE; } + | DELETE '(' REG '{' expr ';' '}' ')' %prec '(' + { $$ = make_op(O_DELETE, 2, + stab2arg(A_STAB,hadd($3)), + jmaybe($4), + Nullarg); + expectterm = FALSE; } + | ARYLEN %prec '(' + { $$ = stab2arg(A_ARYLEN,$1); } + | RSTRING %prec '(' + { $$ = $1; } + | PATTERN %prec '(' + { $$ = $1; } + | SUBST %prec '(' + { $$ = $1; } + | TRANS %prec '(' + { $$ = $1; } + | DO WORD '(' expr crp + { $$ = make_op((perldb ? O_DBSUBR : O_SUBR), 2, + stab2arg(A_WORD,stabent($2,MULTI)), + make_list($4), + Nullarg); Safefree($2); $2 = Nullch; + $$->arg_flags |= AF_DEPR; } + | AMPER WORD '(' expr crp + { $$ = make_op((perldb ? O_DBSUBR : O_SUBR), 2, + 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,MULTI)), + make_list(Nullarg), + Nullarg); + Safefree($2); $2 = Nullch; + $$->arg_flags |= AF_DEPR; } + | AMPER WORD '(' ')' + { $$ = make_op((perldb ? O_DBSUBR : O_SUBR), 2, + stab2arg(A_WORD,stabent($2,MULTI)), + make_list(Nullarg), + Nullarg); + Safefree($2); $2 = Nullch; + } + | AMPER WORD + { $$ = make_op((perldb ? O_DBSUBR : O_SUBR), 2, + stab2arg(A_WORD,stabent($2,MULTI)), + Nullarg, + Nullarg); + Safefree($2); $2 = Nullch; + } + | 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 crp + { $$ = make_op((perldb ? O_DBSUBR : O_SUBR), 2, + stab2arg(A_STAB,$2), + make_list($4), + Nullarg); } + | DO REG '(' ')' + { $$ = make_op((perldb ? O_DBSUBR : O_SUBR), 2, + stab2arg(A_STAB,$2), + make_list(Nullarg), + Nullarg); + $$->arg_flags |= AF_DEPR; } + | AMPER REG '(' ')' + { $$ = make_op((perldb ? O_DBSUBR : O_SUBR), 2, + stab2arg(A_STAB,$2), + make_list(Nullarg), + Nullarg); } + | AMPER REG + { $$ = make_op((perldb ? O_DBSUBR : O_SUBR), 2, + stab2arg(A_STAB,$2), + Nullarg, + Nullarg); } + | LOOPEX + { $$ = make_op($1,0,Nullarg,Nullarg,Nullarg); } + | LOOPEX WORD + { $$ = make_op($1,1,cval_to_arg($2), + 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 ')' + { arg4 = $6; + $$ = make_op(O_SSELECT, 4, $3, $4, $5); } + | OPEN WORD %prec '(' + { $$ = make_op(O_OPEN, 2, + stab2arg(A_WORD,stabent($2,TRUE)), + stab2arg(A_STAB,stabent($2,TRUE)), + Nullarg); + Safefree($2); $2 = Nullch; + } + | OPEN '(' WORD ')' + { $$ = make_op(O_OPEN, 2, + stab2arg(A_WORD,stabent($3,TRUE)), + stab2arg(A_STAB,stabent($3,TRUE)), + Nullarg); + Safefree($3); $3 = Nullch; + } + | OPEN '(' handle cexpr ')' + { $$ = make_op(O_OPEN, 2, + $3, + $4, Nullarg); } + | FILOP '(' handle ')' + { $$ = make_op($1, 1, + $3, + Nullarg, Nullarg); } + | FILOP WORD + { $$ = make_op($1, 1, + stab2arg(A_WORD,stabent($2,TRUE)), + Nullarg, Nullarg); + Safefree($2); $2 = Nullch; } + | FILOP REG + { $$ = make_op($1, 1, + stab2arg(A_STAB,$2), + Nullarg, Nullarg); } + | FILOP '(' ')' + { $$ = make_op($1, 1, + stab2arg(A_WORD,Nullstab), + Nullarg, Nullarg); } + | FILOP %prec '(' + { $$ = make_op($1, 0, + Nullarg, Nullarg, Nullarg); } + | FILOP2 '(' handle cexpr ')' + { $$ = make_op($1, 2, $3, $4, Nullarg); } + | FILOP3 '(' handle csexpr cexpr ')' + { $$ = make_op($1, 3, $3, $4, make_list($5)); } + | FILOP22 '(' handle ',' handle ')' + { $$ = make_op($1, 2, $3, $5, Nullarg); } + | FILOP4 '(' handle csexpr csexpr cexpr ')' + { arg4 = $6; $$ = make_op($1, 4, $3, $4, $5); } + | FILOP25 '(' handle ',' handle csexpr csexpr cexpr ')' + { arg4 = $7; arg5 = $8; + $$ = make_op($1, 5, $3, $5, $6); } + | PUSH '(' aryword ',' expr crp + { $$ = make_op($1, 2, + $3, + make_list($5), + Nullarg); } + | POP aryword %prec '(' + { $$ = make_op(O_POP, 1, $2, Nullarg, Nullarg); } + | POP '(' aryword ')' + { $$ = make_op(O_POP, 1, $3, Nullarg, Nullarg); } + | SHIFT aryword %prec '(' + { $$ = make_op(O_SHIFT, 1, $2, Nullarg, Nullarg); } + | SHIFT '(' aryword ')' + { $$ = make_op(O_SHIFT, 1, $3, Nullarg, Nullarg); } + | SHIFT %prec '(' + { $$ = make_op(O_SHIFT, 1, + stab2arg(A_STAB, + aadd(stabent(subline ? "_" : "ARGV", TRUE))), + Nullarg, Nullarg); } + | SPLIT %prec '(' + { static char p[]="/\\s+/"; + char *oldend = bufend; + ARG *oldarg = yylval.arg; + + bufend=p+5; + (void)scanpat(p); + bufend=oldend; + $$ = make_split(defstab,yylval.arg,Nullarg); + yylval.arg = oldarg; } + | SPLIT '(' sexpr csexpr csexpr ')' + { $$ = mod_match(O_MATCH, $4, + make_split(defstab,$3,$5));} + | SPLIT '(' sexpr csexpr ')' + { $$ = mod_match(O_MATCH, $4, + make_split(defstab,$3,Nullarg) ); } + | SPLIT '(' sexpr ')' + { $$ = mod_match(O_MATCH, + stab2arg(A_STAB,defstab), + make_split(defstab,$3,Nullarg) ); } + | FLIST2 '(' sexpr cexpr ')' + { $$ = make_op($1, 2, + $3, + listish(make_list($4)), + Nullarg); } + | FLIST '(' expr crp + { $$ = make_op($1, 1, + make_list($3), + Nullarg, + Nullarg); } + | LVALFUN sexpr %prec '(' + { $$ = l(make_op($1, 1, fixl($1,$2), + Nullarg, Nullarg)); } + | LVALFUN + { $$ = l(make_op($1, 1, + stab2arg(A_STAB,defstab), + Nullarg, Nullarg)); } + | FUNC0 + { $$ = make_op($1, 0, Nullarg, Nullarg, Nullarg); } + | FUNC0 '(' ')' + { $$ = make_op($1, 0, Nullarg, Nullarg, Nullarg); } + | FUNC1 '(' ')' + { $$ = make_op($1, 0, Nullarg, Nullarg, Nullarg); } + | FUNC1 '(' expr ')' + { $$ = make_op($1, 1, $3, Nullarg, Nullarg); } + | FUNC2 '(' sexpr cexpr ')' + { $$ = make_op($1, 2, $3, $4, Nullarg); + if ($1 == O_INDEX && $$[2].arg_type == A_SINGLE) + fbmcompile($$[2].arg_ptr.arg_str,0); } + | FUNC2x '(' sexpr csexpr ')' + { $$ = make_op($1, 2, $3, $4, Nullarg); + if ($1 == O_INDEX && $$[2].arg_type == A_SINGLE) + fbmcompile($$[2].arg_ptr.arg_str,0); } + | FUNC2x '(' sexpr csexpr cexpr ')' + { $$ = make_op($1, 3, $3, $4, $5); + if ($1 == O_INDEX && $$[2].arg_type == A_SINGLE) + fbmcompile($$[2].arg_ptr.arg_str,0); } + | FUNC3 '(' sexpr csexpr cexpr ')' + { $$ = make_op($1, 3, $3, $4, $5); } + | FUNC4 '(' sexpr csexpr csexpr cexpr ')' + { arg4 = $6; + $$ = make_op($1, 4, $3, $4, $5); } + | FUNC5 '(' sexpr csexpr csexpr csexpr cexpr ')' + { arg4 = $6; arg5 = $7; + $$ = make_op($1, 5, $3, $4, $5); } + | HSHFUN '(' hshword ')' + { $$ = make_op($1, 1, + $3, + Nullarg, + Nullarg); } + | HSHFUN hshword + { $$ = make_op($1, 1, + $2, + Nullarg, + Nullarg); } + | HSHFUN3 '(' hshword csexpr cexpr ')' + { $$ = make_op($1, 3, $3, $4, $5); } + | bareword + | listop + ; + +listop : LISTOP + { $$ = make_op($1,2, + stab2arg(A_WORD,Nullstab), + stab2arg(A_STAB,defstab), + Nullarg); } + | LISTOP expr + { $$ = make_op($1,2, + stab2arg(A_WORD,Nullstab), + maybelistish($1,make_list($2)), + Nullarg); } + | LISTOP WORD + { $$ = make_op($1,2, + stab2arg(A_WORD,stabent($2,TRUE)), + stab2arg(A_STAB,defstab), + Nullarg); + Safefree($2); $2 = Nullch; + } + | LISTOP WORD expr + { $$ = make_op($1,2, + stab2arg(A_WORD,stabent($2,TRUE)), + maybelistish($1,make_list($3)), + Nullarg); Safefree($2); $2 = Nullch; } + | LISTOP REG expr + { $$ = make_op($1,2, + 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 + { $$ = stab2arg(A_WORD,stabent($1,TRUE)); + Safefree($1); $1 = Nullch;} + | sexpr + ; + +aryword : WORD + { $$ = stab2arg(A_WORD,aadd(stabent($1,TRUE))); + Safefree($1); $1 = Nullch; } + | ARY + { $$ = stab2arg(A_STAB,$1); } + ; + +hshword : WORD + { $$ = stab2arg(A_WORD,hadd(stabent($1,TRUE))); + Safefree($1); $1 = Nullch; } + | HSH + { $$ = 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. + */ + +bareword: WORD + { char *s; + $$ = op_new(1); + $$->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++) ; + if (dowarn && !*s) + warn( + "\"%s\" may clash with future reserved word", + $1 ); + Safefree($1); $1 = Nullch; + } + ; +%% /* PROGRAM */ diff --git a/perly.y.rej b/perly.y.rej new file mode 100644 index 0000000..4f91fdd --- /dev/null +++ b/perly.y.rej @@ -0,0 +1,35 @@ +*************** +*** 1,4 **** +! /* $RCSfile: perly.y,v $$Revision: 4.0.1.5 $$Date: 1992/06/11 21:12:50 $ + * + * Copyright (c) 1991, Larry Wall + * +--- 1,4 ---- +! /* $RCSfile: perly.y,v $$Revision: 4.0.1.6 $$Date: 1993/02/05 19:41:15 $ + * + * Copyright (c) 1991, Larry Wall + * +*************** +*** 6,14 **** + * License or the Artistic License, as specified in the README file. + * + * $Log: perly.y,v $ +! * Revision 4.0.1.5 1992/06/11 21:12:50 lwall +! * patch34: expectterm incorrectly set to indicate start of program or block + * + * Revision 4.0.1.4 92/06/08 17:33:25 lwall + * patch20: one of the backdoors to expectterm was on the wrong reduction + * +--- 6,17 ---- + * License or the Artistic License, as specified in the README file. + * + * $Log: perly.y,v $ +! * Revision 4.0.1.6 1993/02/05 19:41:15 lwall +! * patch36: delete with parens dumped core + * ++ * Revision 4.0.1.5 92/06/11 21:12:50 lwall ++ * patch34: expectterm incorrectly set to indicate start of program or block ++ * + * Revision 4.0.1.4 92/06/08 17:33:25 lwall + * patch20: one of the backdoors to expectterm was on the wrong reduction + * diff --git a/stab.c b/stab.c index f8e6f07..c735837 100644 --- a/stab.c +++ b/stab.c @@ -318,9 +318,8 @@ STR *str; return (STRLEN)ofslen; case '\\': return (STRLEN)orslen; - default: - return str_len(stab_str(str)); } + return str_len(stab_str(str)); } void diff --git a/stab.c.orig b/stab.c.orig new file mode 100644 index 0000000..f8e6f07 --- /dev/null +++ b/stab.c.orig @@ -0,0 +1,1050 @@ +/* $RCSfile: stab.c,v $$Revision: 4.0.1.4 $$Date: 92/06/08 15:32:19 $ + * + * Copyright (c) 1991, Larry Wall + * + * You may distribute under the terms of either the GNU General Public + * License or the Artistic License, as specified in the README file. + * + * $Log: stab.c,v $ + * Revision 4.0.1.4 92/06/08 15:32:19 lwall + * patch20: fixed confusion between a *var's real name and its effective name + * patch20: the debugger now warns you on lines that can't set a breakpoint + * patch20: the debugger made perl forget the last pattern used by // + * patch20: paragraph mode now skips extra newlines automatically + * patch20: ($<,$>) = ... didn't work on some architectures + * + * 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 + * patch4: added $^F variable to specify maximum system fd, default 2 + * patch4: $` was busted inside s/// + * patch4: default top-of-form format is now FILEHANDLE_TOP + * patch4: length($`), length($&), length($') now optimized to avoid string copy + * patch4: $^D |= 1024 now does syntax tree dump at run-time + * + * Revision 4.0.1.1 91/04/12 09:10:24 lwall + * patch1: Configure now differentiates getgroups() type from getgid() type + * patch1: you may now use "die" and "caller" in a signal handler + * + * Revision 4.0 91/03/20 01:39:41 lwall + * 4.0 baseline. + * + */ + +#include "EXTERN.h" +#include "perl.h" + +#if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX) +#include +#endif + +static char *sig_name[] = { + SIG_NAME,0 +}; + +#ifdef VOIDSIG +#define handlertype void +#else +#define handlertype int +#endif + +static handlertype sighandler(); + +static int origalen = 0; + +STR * +stab_str(str) +STR *str; +{ + STAB *stab = str->str_u.str_stab; + register int paren; + register char *s; + register int i; + + if (str->str_rare) + return stab_val(stab); + + switch (*stab->str_magic->str_ptr) { + case '\004': /* ^D */ +#ifdef DEBUGGING + str_numset(stab_val(stab),(double)(debug & 32767)); +#endif + break; + case '\006': /* ^F */ + str_numset(stab_val(stab),(double)maxsysfd); + break; + case '\t': /* ^I */ + if (inplace) + str_set(stab_val(stab), inplace); + else + str_sset(stab_val(stab),&str_undef); + break; + case '\020': /* ^P */ + str_numset(stab_val(stab),(double)perldb); + break; + case '\024': /* ^T */ + str_numset(stab_val(stab),(double)basetime); + break; + case '\027': /* ^W */ + str_numset(stab_val(stab),(double)dowarn); + break; + case '1': case '2': case '3': case '4': + case '5': case '6': case '7': case '8': case '9': case '&': + if (curspat) { + paren = atoi(stab_ename(stab)); + getparen: + if (curspat->spat_regexp && + paren <= curspat->spat_regexp->nparens && + (s = curspat->spat_regexp->startp[paren]) ) { + i = curspat->spat_regexp->endp[paren] - s; + if (i >= 0) + str_nset(stab_val(stab),s,i); + else + str_sset(stab_val(stab),&str_undef); + } + else + str_sset(stab_val(stab),&str_undef); + } + break; + case '+': + if (curspat) { + paren = curspat->spat_regexp->lastparen; + goto getparen; + } + break; + case '`': + if (curspat) { + if (curspat->spat_regexp && + (s = curspat->spat_regexp->subbeg) ) { + i = curspat->spat_regexp->startp[0] - s; + if (i >= 0) + str_nset(stab_val(stab),s,i); + else + str_nset(stab_val(stab),"",0); + } + else + str_nset(stab_val(stab),"",0); + } + break; + case '\'': + if (curspat) { + if (curspat->spat_regexp && + (s = curspat->spat_regexp->endp[0]) ) { + str_nset(stab_val(stab),s, curspat->spat_regexp->subend - s); + } + else + str_nset(stab_val(stab),"",0); + } + break; + case '.': +#ifndef lint + if (last_in_stab && stab_io(last_in_stab)) { + str_numset(stab_val(stab),(double)stab_io(last_in_stab)->lines); + } +#endif + break; + case '?': + str_numset(stab_val(stab),(double)statusvalue); + break; + case '^': + s = stab_io(curoutstab)->top_name; + if (s) + str_set(stab_val(stab),s); + else { + str_set(stab_val(stab),stab_ename(curoutstab)); + str_cat(stab_val(stab),"_TOP"); + } + break; + case '~': + s = stab_io(curoutstab)->fmt_name; + if (!s) + s = stab_ename(curoutstab); + str_set(stab_val(stab),s); + break; +#ifndef lint + case '=': + str_numset(stab_val(stab),(double)stab_io(curoutstab)->page_len); + break; + case '-': + str_numset(stab_val(stab),(double)stab_io(curoutstab)->lines_left); + break; + case '%': + str_numset(stab_val(stab),(double)stab_io(curoutstab)->page); + break; +#endif + case ':': + break; + case '/': + break; + case '[': + str_numset(stab_val(stab),(double)arybase); + break; + case '|': + if (!stab_io(curoutstab)) + stab_io(curoutstab) = stio_new(); + str_numset(stab_val(stab), + (double)((stab_io(curoutstab)->flags & IOF_FLUSH) != 0) ); + break; + case ',': + str_nset(stab_val(stab),ofs,ofslen); + break; + case '\\': + str_nset(stab_val(stab),ors,orslen); + break; + case '#': + str_set(stab_val(stab),ofmt); + break; + case '!': + str_numset(stab_val(stab), (double)errno); + str_set(stab_val(stab), errno ? strerror(errno) : ""); + stab_val(stab)->str_nok = 1; /* what a wonderful hack! */ + break; + case '<': + str_numset(stab_val(stab),(double)uid); + break; + case '>': + str_numset(stab_val(stab),(double)euid); + break; + case '(': + s = buf; + (void)sprintf(s,"%d",(int)gid); + goto add_groups; + case ')': + s = buf; + (void)sprintf(s,"%d",(int)egid); + add_groups: + while (*s) s++; +#ifdef HAS_GETGROUPS +#ifndef NGROUPS +#define NGROUPS 32 +#endif + { + GROUPSTYPE gary[NGROUPS]; + + i = getgroups(NGROUPS,gary); + while (--i >= 0) { + (void)sprintf(s," %ld", (long)gary[i]); + while (*s) s++; + } + } +#endif + str_set(stab_val(stab),buf); + break; + case '*': + break; + case '0': + break; + default: + { + struct ufuncs *uf = (struct ufuncs *)str->str_ptr; + + if (uf && uf->uf_val) + (*uf->uf_val)(uf->uf_index, stab_val(stab)); + } + break; + } + return stab_val(stab); +} + +STRLEN +stab_len(str) +STR *str; +{ + STAB *stab = str->str_u.str_stab; + int paren; + int i; + char *s; + + if (str->str_rare) + return str_len(stab_val(stab)); + + switch (*stab->str_magic->str_ptr) { + case '1': case '2': case '3': case '4': + case '5': case '6': case '7': case '8': case '9': case '&': + if (curspat) { + paren = atoi(stab_ename(stab)); + getparen: + if (curspat->spat_regexp && + paren <= curspat->spat_regexp->nparens && + (s = curspat->spat_regexp->startp[paren]) ) { + i = curspat->spat_regexp->endp[paren] - s; + if (i >= 0) + return i; + else + return 0; + } + else + return 0; + } + break; + case '+': + if (curspat) { + paren = curspat->spat_regexp->lastparen; + goto getparen; + } + break; + case '`': + if (curspat) { + if (curspat->spat_regexp && + (s = curspat->spat_regexp->subbeg) ) { + i = curspat->spat_regexp->startp[0] - s; + if (i >= 0) + return i; + else + return 0; + } + else + return 0; + } + break; + case '\'': + if (curspat) { + if (curspat->spat_regexp && + (s = curspat->spat_regexp->endp[0]) ) { + return (STRLEN) (curspat->spat_regexp->subend - s); + } + else + return 0; + } + break; + case ',': + return (STRLEN)ofslen; + case '\\': + return (STRLEN)orslen; + default: + return str_len(stab_str(str)); + } +} + +void +stabset(mstr,str) +register STR *mstr; +STR *str; +{ + STAB *stab; + register char *s; + int i; + + switch (mstr->str_rare) { + case 'E': + my_setenv(mstr->str_ptr,str_get(str)); + /* And you'll never guess what the dog had */ + /* in its mouth... */ +#ifdef TAINT + if (strEQ(mstr->str_ptr,"PATH")) { + char *strend = str->str_ptr + str->str_cur; + + s = str->str_ptr; + while (s < strend) { + s = cpytill(tokenbuf,s,strend,':',&i); + s++; + if (*tokenbuf != '/' + || (stat(tokenbuf,&statbuf) && (statbuf.st_mode & 2)) ) + str->str_tainted = 2; + } + } +#endif + break; + 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); +#else + ; +#endif + else if (strEQ(s,"DEFAULT") || !*s) + (void)signal(i,SIG_DFL); + else { + (void)signal(i,sighandler); + if (!index(s,'\'')) { + sprintf(tokenbuf, "main'%s",s); + str_set(str,tokenbuf); + } + } + 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 + case 'L': + { + CMD *cmd; + + stab = mstr->str_u.str_stab; + i = str_true(str); + str = afetch(stab_xarray(stab),atoi(mstr->str_ptr), FALSE); + if (str->str_magic && (cmd = str->str_magic->str_u.str_cmd)) { + cmd->c_flags &= ~CF_OPTIMIZE; + cmd->c_flags |= i? CFT_D1 : CFT_D0; + } + else + warn("Can't break at that line\n"); + } + 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->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); + Newz(601,stbp, 1, STBP); + stab->str_ptr = stbp; + stab->str_len = stab->str_cur = sizeof(STBP); + stab->str_pok = 1; + strcpy(stab_magic(stab),"StB"); + stab_val(stab) = Str_new(70,0); + stab_line(stab) = curcmd->c_line; + stab_estab(stab) = stab; + } + else { + stab = stabent(s,TRUE); + if (!stab_xarray(stab)) + aadd(stab); + if (!stab_xhash(stab)) + hadd(stab); + if (!stab_io(stab)) + stab_io(stab) = stio_new(); + } + str_sset(str, (STR*) stab); + } + break; + case 's': { + struct lstring *lstr = (struct lstring*)str; + char *tmps; + + mstr->str_rare = 0; + str->str_magic = Nullstr; + tmps = str_get(str); + str_insert(mstr,lstr->lstr_offset,lstr->lstr_len, + tmps,str->str_cur); + } + break; + + case 'v': + do_vecset(mstr,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 + debug = (int)(str_gnum(str)) | 32768; + if (debug & 1024) + dump_all(); +#endif + break; + case '\006': /* ^F */ + maxsysfd = (int)str_gnum(str); + break; + case '\t': /* ^I */ + if (inplace) + Safefree(inplace); + if (str->str_pok || str->str_nok) + inplace = savestr(str_get(str)); + else + inplace = Nullch; + break; + case '\020': /* ^P */ + i = (int)str_gnum(str); + if (i != perldb) { + static SPAT *oldlastspat; + + if (perldb) + oldlastspat = lastspat; + else + lastspat = oldlastspat; + } + perldb = i; + break; + case '\024': /* ^T */ + basetime = (time_t)str_gnum(str); + break; + case '\027': /* ^W */ + dowarn = (bool)str_gnum(str); + break; + case '.': + if (localizing) + savesptr((STR**)&last_in_stab); + break; + case '^': + Safefree(stab_io(curoutstab)->top_name); + stab_io(curoutstab)->top_name = s = savestr(str_get(str)); + stab_io(curoutstab)->top_stab = stabent(s,TRUE); + break; + case '~': + Safefree(stab_io(curoutstab)->fmt_name); + stab_io(curoutstab)->fmt_name = s = savestr(str_get(str)); + stab_io(curoutstab)->fmt_stab = stabent(s,TRUE); + break; + case '=': + stab_io(curoutstab)->page_len = (long)str_gnum(str); + break; + case '-': + stab_io(curoutstab)->lines_left = (long)str_gnum(str); + if (stab_io(curoutstab)->lines_left < 0L) + stab_io(curoutstab)->lines_left = 0L; + break; + case '%': + stab_io(curoutstab)->page = (long)str_gnum(str); + break; + case '|': + if (!stab_io(curoutstab)) + stab_io(curoutstab) = stio_new(); + stab_io(curoutstab)->flags &= ~IOF_FLUSH; + if (str_gnum(str) != 0.0) { + stab_io(curoutstab)->flags |= IOF_FLUSH; + } + break; + case '*': + i = (int)str_gnum(str); + multiline = (i != 0); + break; + case '/': + if (str->str_pok) { + rs = str_get(str); + rslen = str->str_cur; + if (rspara = !rslen) { + rs = "\n\n"; + rslen = 2; + } + rschar = rs[rslen - 1]; + } + else { + rschar = 0777; /* fake a non-existent char */ + rslen = 1; + } + break; + case '\\': + if (ors) + Safefree(ors); + ors = savestr(str_get(str)); + orslen = str->str_cur; + break; + case ',': + if (ofs) + Safefree(ofs); + ofs = savestr(str_get(str)); + ofslen = str->str_cur; + break; + case '#': + if (ofmt) + Safefree(ofmt); + ofmt = savestr(str_get(str)); + break; + case '[': + arybase = (int)str_gnum(str); + break; + case '?': + statusvalue = U_S(str_gnum(str)); + break; + case '!': + errno = (int)str_gnum(str); /* will anyone ever use this? */ + break; + case '<': + uid = (int)str_gnum(str); + if (delaymagic) { + delaymagic |= DM_RUID; + break; /* don't do magic till later */ + } +#ifdef HAS_SETRUID + (void)setruid((UIDTYPE)uid); +#else +#ifdef HAS_SETREUID + (void)setreuid((UIDTYPE)uid, (UIDTYPE)-1); +#else + if (uid == euid) /* special case $< = $> */ + (void)setuid(uid); + else + fatal("setruid() not implemented"); +#endif +#endif + uid = (int)getuid(); + break; + case '>': + euid = (int)str_gnum(str); + if (delaymagic) { + delaymagic |= DM_EUID; + break; /* don't do magic till later */ + } +#ifdef HAS_SETEUID + (void)seteuid((UIDTYPE)euid); +#else +#ifdef HAS_SETREUID + (void)setreuid((UIDTYPE)-1, (UIDTYPE)euid); +#else + if (euid == uid) /* special case $> = $< */ + setuid(euid); + else + fatal("seteuid() not implemented"); +#endif +#endif + euid = (int)geteuid(); + break; + case '(': + gid = (int)str_gnum(str); + if (delaymagic) { + delaymagic |= DM_RGID; + break; /* don't do magic till later */ + } +#ifdef HAS_SETRGID + (void)setrgid((GIDTYPE)gid); +#else +#ifdef HAS_SETREGID + (void)setregid((GIDTYPE)gid, (GIDTYPE)-1); +#else + if (gid == egid) /* special case $( = $) */ + (void)setgid(gid); + else + fatal("setrgid() not implemented"); +#endif +#endif + gid = (int)getgid(); + break; + case ')': + egid = (int)str_gnum(str); + if (delaymagic) { + delaymagic |= DM_EGID; + break; /* don't do magic till later */ + } +#ifdef HAS_SETEGID + (void)setegid((GIDTYPE)egid); +#else +#ifdef HAS_SETREGID + (void)setregid((GIDTYPE)-1, (GIDTYPE)egid); +#else + if (egid == gid) /* special case $) = $( */ + (void)setgid(egid); + else + fatal("setegid() not implemented"); +#endif +#endif + egid = (int)getegid(); + break; + case ':': + chopset = str_get(str); + break; + case '0': + if (!origalen) { + s = origargv[0]; + s += strlen(s); + /* See if all the arguments are contiguous in memory */ + for (i = 1; i < origargc; i++) { + if (origargv[i] == s + 1) + s += strlen(++s); /* this one is ok too */ + } + if (origenviron[0] == s + 1) { /* can grab env area too? */ + my_setenv("NoNeSuCh", Nullch); + /* force copy of environment */ + for (i = 0; origenviron[i]; i++) + if (origenviron[i] == s + 1) + s += strlen(++s); + } + origalen = s - origargv[0]; + } + s = str_get(str); + i = str->str_cur; + if (i >= origalen) { + i = origalen; + str->str_cur = i; + str->str_ptr[i] = '\0'; + Copy(s, origargv[0], i, char); + } + else { + Copy(s, origargv[0], i, char); + s = origargv[0]+i; + *s++ = '\0'; + while (++i < origalen) + *s++ = ' '; + } + break; + default: + { + struct ufuncs *uf = (struct ufuncs *)str->str_magic->str_ptr; + + if (uf && uf->uf_set) + (*uf->uf_set)(uf->uf_index, str); + } + break; + } + break; + } +} + +int +whichsig(sig) +char *sig; +{ + register char **sigv; + + for (sigv = sig_name+1; *sigv; sigv++) + if (strEQ(sig,*sigv)) + return sigv - sig_name; +#ifdef SIGCLD + if (strEQ(sig,"CHLD")) + return SIGCLD; +#endif +#ifdef SIGCHLD + if (strEQ(sig,"CLD")) + return SIGCHLD; +#endif + return 0; +} + +static handlertype +sighandler(sig) +int sig; +{ + STAB *stab; + STR *str; + int oldsave = savestack->ary_fill; + int oldtmps_base = tmps_base; + register CSV *csv; + SUBR *sub; + +#ifdef OS2 /* or anybody else who requires SIG_ACK */ + signal(sig, SIG_ACK); +#endif + stab = stabent( + str_get(hfetch(stab_hash(sigstab),sig_name[sig],strlen(sig_name[sig]), + TRUE)), TRUE); + sub = stab_sub(stab); + if (!sub && *sig_name[sig] == 'C' && instr(sig_name[sig],"LD")) { + if (sig_name[sig][1] == 'H') + stab = stabent(str_get(hfetch(stab_hash(sigstab),"CLD",3,TRUE)), + TRUE); + else + stab = stabent(str_get(hfetch(stab_hash(sigstab),"CHLD",4,TRUE)), + TRUE); + sub = stab_sub(stab); /* gag */ + } + if (!sub) { + if (dowarn) + warn("SIG%s handler \"%s\" not defined.\n", + sig_name[sig], stab_ename(stab) ); + return; + } + /*SUPPRESS 701*/ + saveaptr(&stack); + str = Str_new(15, sizeof(CSV)); + str->str_state = SS_SCSV; + (void)apush(savestack,str); + csv = (CSV*)str->str_ptr; + csv->sub = sub; + csv->stab = stab; + csv->curcsv = curcsv; + csv->curcmd = curcmd; + csv->depth = sub->depth; + csv->wantarray = G_SCALAR; + csv->hasargs = TRUE; + csv->savearray = stab_xarray(defstab); + csv->argarray = stab_xarray(defstab) = stack = anew(defstab); + stack->ary_flags = 0; + curcsv = csv; + str = str_mortal(&str_undef); + str_set(str,sig_name[sig]); + (void)apush(stab_xarray(defstab),str); + sub->depth++; + if (sub->depth >= 2) { /* save temporaries on recursion? */ + if (sub->depth == 100 && dowarn) + warn("Deep recursion on subroutine \"%s\"",stab_ename(stab)); + savelist(sub->tosave->ary_array,sub->tosave->ary_fill); + } + + tmps_base = tmps_max; /* protect our mortal string */ + (void)cmd_exec(sub->cmd,G_SCALAR,0); /* so do it already */ + tmps_base = oldtmps_base; + + restorelist(oldsave); /* put everything back */ +} + +STAB * +aadd(stab) +register STAB *stab; +{ + if (!stab_xarray(stab)) + stab_xarray(stab) = anew(stab); + return stab; +} + +STAB * +hadd(stab) +register STAB *stab; +{ + if (!stab_xhash(stab)) + stab_xhash(stab) = hnew(COEFFSIZE); + return stab; +} + +STAB * +fstab(name) +char *name; +{ + char tmpbuf[1200]; + STAB *stab; + + sprintf(tmpbuf,"'_<%s", name); + stab = stabent(tmpbuf, TRUE); + str_set(stab_val(stab), name); + if (perldb) + (void)hadd(aadd(stab)); + return stab; +} + +STAB * +stabent(name,add) +register char *name; +int add; +{ + register STAB *stab; + register STBP *stbp; + int len; + register char *namend; + HASH *stash; + char *sawquote = Nullch; + char *prevquote = Nullch; + bool global = FALSE; + + if (isUPPER(*name)) { + if (*name > 'I') { + if (*name == 'S' && ( + strEQ(name, "SIG") || + strEQ(name, "STDIN") || + strEQ(name, "STDOUT") || + strEQ(name, "STDERR") )) + global = TRUE; + } + else if (*name > 'E') { + if (*name == 'I' && strEQ(name, "INC")) + global = TRUE; + } + else if (*name > 'A') { + if (*name == 'E' && strEQ(name, "ENV")) + global = TRUE; + } + else if (*name == 'A' && ( + strEQ(name, "ARGV") || + strEQ(name, "ARGVOUT") )) + global = TRUE; + } + for (namend = name; *namend; namend++) { + if (*namend == '\'' && namend[1]) + prevquote = sawquote, sawquote = namend; + } + if (sawquote == name && name[1]) { + stash = defstash; + sawquote = Nullch; + name++; + } + else if (!isALPHA(*name) || global) + stash = defstash; + else if ((CMD*)curcmd == &compiling) + stash = curstash; + else + stash = curcmd->c_stash; + if (sawquote) { + char tmpbuf[256]; + char *s, *d; + + *sawquote = '\0'; + /*SUPPRESS 560*/ + if (s = prevquote) { + strncpy(tmpbuf,name,s-name+1); + d = tmpbuf+(s-name+1); + *d++ = '_'; + strcpy(d,s+1); + } + else { + *tmpbuf = '_'; + strcpy(tmpbuf+1,name); + } + stab = stabent(tmpbuf,TRUE); + if (!(stash = stab_xhash(stab))) + stash = stab_xhash(stab) = hnew(0); + if (!stash->tbl_name) + stash->tbl_name = savestr(name); + name = sawquote+1; + *sawquote = '\''; + } + len = namend - name; + stab = (STAB*)hfetch(stash,name,len,add); + if (stab == (STAB*)&str_undef) + return Nullstab; + if (stab->str_pok) { + stab->str_pok |= SP_MULTI; + return stab; + } + else { + if (stab->str_len) + Safefree(stab->str_ptr); + Newz(602,stbp, 1, STBP); + stab->str_ptr = stbp; + stab->str_len = stab->str_cur = sizeof(STBP); + stab->str_pok = 1; + strcpy(stab_magic(stab),"StB"); + stab_val(stab) = Str_new(72,0); + stab_line(stab) = curcmd->c_line; + stab_estab(stab) = stab; + str_magic((STR*)stab, stab, '*', name, len); + stab_stash(stab) = stash; + 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; + } +} + +void +stab_fullname(str,stab) +STR *str; +STAB *stab; +{ + HASH *tb = stab_stash(stab); + + if (!tb) + return; + str_set(str,tb->tbl_name); + str_ncat(str,"'", 1); + str_scat(str,stab->str_magic); +} + +void +stab_efullname(str,stab) +STR *str; +STAB *stab; +{ + HASH *tb = stab_estash(stab); + + if (!tb) + return; + str_set(str,tb->tbl_name); + str_ncat(str,"'", 1); + str_scat(str,stab_estab(stab)->str_magic); +} + +STIO * +stio_new() +{ + STIO *stio; + + Newz(603,stio,1,STIO); + stio->page_len = 60; + return stio; +} + +void +stab_check(min,max) +int min; +register int max; +{ + register HENT *entry; + register int i; + register STAB *stab; + + for (i = min; i <= max; i++) { + for (entry = defstash->tbl_array[i]; entry; entry = entry->hent_next) { + stab = (STAB*)entry->hent_val; + if (stab->str_pok & SP_MULTI) + continue; + curcmd->c_line = stab_line(stab); + warn("Possible typo: \"%s\"", stab_name(stab)); + } + } +} + +static int gensym = 0; + +STAB * +genstab() +{ + (void)sprintf(tokenbuf,"_GEN_%d",gensym++); + return stabent(tokenbuf,TRUE); +} + +/* hopefully this is only called on local symbol table entries */ + +void +stab_clear(stab) +register STAB *stab; +{ + STIO *stio; + SUBR *sub; + + if (!stab || !stab->str_ptr) + return; + afree(stab_xarray(stab)); + stab_xarray(stab) = Null(ARRAY*); + (void)hfree(stab_xhash(stab), FALSE); + 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); + } + Safefree(stab->str_ptr); + stab->str_ptr = Null(STBP*); + stab->str_len = 0; + stab->str_cur = 0; +} + +#if defined(CRIPPLED_CC) && (defined(iAPX286) || defined(M_I286) || defined(I80286)) +#define MICROPORT +#endif + +#ifdef MICROPORT /* Microport 2.4 hack */ +ARRAY *stab_array(stab) +register STAB *stab; +{ + if (((STBP*)(stab->str_ptr))->stbp_array) + return ((STBP*)(stab->str_ptr))->stbp_array; + else + return ((STBP*)(aadd(stab)->str_ptr))->stbp_array; +} + +HASH *stab_hash(stab) +register STAB *stab; +{ + if (((STBP*)(stab->str_ptr))->stbp_hash) + return ((STBP*)(stab->str_ptr))->stbp_hash; + else + return ((STBP*)(hadd(stab)->str_ptr))->stbp_hash; +} +#endif /* Microport 2.4 hack */ diff --git a/stab.c.rej b/stab.c.rej new file mode 100644 index 0000000..af62598 --- /dev/null +++ b/stab.c.rej @@ -0,0 +1,43 @@ +*************** +*** 1,4 **** +! /* $RCSfile: stab.c,v $$Revision: 4.0.1.4 $$Date: 1992/06/08 15:32:19 $ + * + * Copyright (c) 1991, Larry Wall + * +--- 1,4 ---- +! /* $RCSfile: stab.c,v $$Revision: 4.0.1.5 $$Date: 1993/02/05 19:42:47 $ + * + * Copyright (c) 1991, Larry Wall + * +*************** +*** 6,18 **** + * License or the Artistic License, as specified in the README file. + * + * $Log: stab.c,v $ +! * Revision 4.0.1.4 1992/06/08 15:32:19 lwall + * patch20: fixed confusion between a *var's real name and its effective name + * patch20: the debugger now warns you on lines that can't set a breakpoint + * patch20: the debugger made perl forget the last pattern used by // + * patch20: paragraph mode now skips extra newlines automatically + * patch20: ($<,$>) = ... didn't work on some architectures +! * + * 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 +--- 6,21 ---- + * License or the Artistic License, as specified in the README file. + * + * $Log: stab.c,v $ +! * Revision 4.0.1.5 1993/02/05 19:42:47 lwall +! * patch36: length returned wrong value on certain semi-magical variables +! * +! * Revision 4.0.1.4 92/06/08 15:32:19 lwall + * patch20: fixed confusion between a *var's real name and its effective name + * patch20: the debugger now warns you on lines that can't set a breakpoint + * patch20: the debugger made perl forget the last pattern used by // + * patch20: paragraph mode now skips extra newlines automatically + * patch20: ($<,$>) = ... didn't work on some architectures +! * + * 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 diff --git a/str.c b/str.c index 4b597cc..8af06ad 100644 --- a/str.c +++ b/str.c @@ -863,11 +863,10 @@ screamer: bp = buf; while ((i = getc(fp)) != EOF && (*bp++ = i) != newline && bp < bpe) ; - *bp = '\0'; if (append) - str_cat(str, buf); + str_ncat(str, buf, bp - buf); else - str_set(str, buf); + str_nset(str, buf, bp - buf); if (i != EOF /* joy */ && (i != newline diff --git a/str.c.orig b/str.c.orig new file mode 100644 index 0000000..4b597cc --- /dev/null +++ b/str.c.orig @@ -0,0 +1,1594 @@ +/* $RCSfile: str.c,v $$Revision: 4.0.1.6 $$Date: 92/06/11 21:14:21 $ + * + * Copyright (c) 1991, Larry Wall + * + * You may distribute under the terms of either the GNU General Public + * License or the Artistic License, as specified in the README file. + * + * $Log: str.c,v $ + * Revision 4.0.1.6 92/06/11 21:14:21 lwall + * patch34: quotes containing subscripts containing variables didn't parse right + * + * Revision 4.0.1.5 92/06/08 15:40:43 lwall + * patch20: removed implicit int declarations on functions + * patch20: Perl now distinguishes overlapped copies from non-overlapped + * patch20: paragraph mode now skips extra newlines automatically + * patch20: fixed memory leak in doube-quote interpretation + * patch20: made /\$$foo/ look for literal '$foo' + * patch20: "$var{$foo'bar}" didn't scan subscript correctly + * patch20: a splice on non-existent array elements could dump core + * patch20: running taintperl explicitly now does checks even if $< == $> + * + * 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 + * + * Revision 4.0.1.2 91/06/07 11:58:13 lwall + * patch4: new copyright notice + * patch4: taint check on undefined string could cause core dump + * + * Revision 4.0.1.1 91/04/12 09:15:30 lwall + * patch1: fixed undefined environ problem + * patch1: substr($ENV{"PATH"},0,0) = "/foo:" didn't modify environment + * patch1: $foo .= could cause core dump for certain lengths of $foo + * + * Revision 4.0 91/03/20 01:39:55 lwall + * 4.0 baseline. + * + */ + +#include "EXTERN.h" +#include "perl.h" +#include "perly.h" + +static void ucase(); +static void lcase(); + +#ifndef str_get +char * +str_get(str) +STR *str; +{ +#ifdef TAINT + tainted |= str->str_tainted; +#endif + return str->str_pok ? str->str_ptr : str_2ptr(str); +} +#endif + +/* dlb ... guess we have a "crippled cc". + * dlb the following functions are usually macros. + */ +#ifndef str_true +int +str_true(Str) +STR *Str; +{ + if (Str->str_pok) { + if (*Str->str_ptr > '0' || + Str->str_cur > 1 || + (Str->str_cur && *Str->str_ptr != '0')) + return 1; + return 0; + } + if (Str->str_nok) + return (Str->str_u.str_nval != 0.0); + return 0; +} +#endif /* str_true */ + +#ifndef str_gnum +double str_gnum(Str) +STR *Str; +{ +#ifdef TAINT + tainted |= Str->str_tainted; +#endif /* TAINT*/ + if (Str->str_nok) + return Str->str_u.str_nval; + return str_2num(Str); +} +#endif /* str_gnum */ +/* dlb ... end of crutch */ + +char * +str_grow(str,newlen) +register STR *str; +#ifndef DOSISH +register int newlen; +#else +unsigned long newlen; +#endif +{ + register char *s = str->str_ptr; + +#ifdef MSDOS + if (newlen >= 0x10000) { + fprintf(stderr, "Allocation too large: %lx\n", newlen); + exit(1); + } +#endif /* MSDOS */ + if (str->str_state == SS_INCR) { /* data before str_ptr? */ + str->str_len += str->str_u.str_useful; + str->str_ptr -= str->str_u.str_useful; + str->str_u.str_useful = 0L; + Move(s, str->str_ptr, str->str_cur+1, char); + s = str->str_ptr; + str->str_state = SS_NORM; /* normal again */ + if (newlen > str->str_len) + newlen += 10 * (newlen - str->str_cur); /* avoid copy each time */ + } + if (newlen > str->str_len) { /* need more room? */ + if (str->str_len) + Renew(s,newlen,char); + else + New(703,s,newlen,char); + str->str_ptr = s; + str->str_len = newlen; + } + return s; +} + +void +str_numset(str,num) +register STR *str; +double num; +{ + if (str->str_pok) { + str->str_pok = 0; /* invalidate pointer */ + if (str->str_state == SS_INCR) + Str_Grow(str,0); + } + str->str_u.str_nval = num; + str->str_state = SS_NORM; + str->str_nok = 1; /* validate number */ +#ifdef TAINT + str->str_tainted = tainted; +#endif +} + +char * +str_2ptr(str) +register STR *str; +{ + register char *s; + int olderrno; + + if (!str) + return ""; + if (str->str_nok) { + STR_GROW(str, 30); + s = str->str_ptr; + olderrno = errno; /* some Xenix systems wipe out errno here */ +#if defined(scs) && defined(ns32000) + gcvt(str->str_u.str_nval,20,s); +#else +#ifdef apollo + if (str->str_u.str_nval == 0.0) + (void)strcpy(s,"0"); + else +#endif /*apollo*/ + (void)sprintf(s,"%.20g",str->str_u.str_nval); +#endif /*scs*/ + errno = olderrno; + while (*s) s++; +#ifdef hcx + if (s[-1] == '.') + s--; +#endif + } + else { + if (str == &str_undef) + return No; + if (dowarn) + warn("Use of uninitialized variable"); + STR_GROW(str, 30); + s = str->str_ptr; + } + *s = '\0'; + str->str_cur = s - str->str_ptr; + str->str_pok = 1; +#ifdef DEBUGGING + if (debug & 32) + fprintf(stderr,"0x%lx ptr(%s)\n",str,str->str_ptr); +#endif + return str->str_ptr; +} + +double +str_2num(str) +register STR *str; +{ + if (!str) + return 0.0; + if (str->str_state == SS_INCR) + Str_Grow(str,0); /* just force copy down */ + str->str_state = SS_NORM; + if (str->str_len && str->str_pok) + str->str_u.str_nval = atof(str->str_ptr); + else { + if (str == &str_undef) + return 0.0; + if (dowarn) + warn("Use of uninitialized variable"); + str->str_u.str_nval = 0.0; + } + str->str_nok = 1; +#ifdef DEBUGGING + if (debug & 32) + fprintf(stderr,"0x%lx num(%g)\n",str,str->str_u.str_nval); +#endif + return str->str_u.str_nval; +} + +/* Note: str_sset() should not be called with a source string that needs + * be reused, since it may destroy the source string if it is marked + * as temporary. + */ + +void +str_sset(dstr,sstr) +STR *dstr; +register STR *sstr; +{ +#ifdef TAINT + if (sstr) + tainted |= sstr->str_tainted; +#endif + if (sstr == dstr || dstr == &str_undef) + return; + if (!sstr) + dstr->str_pok = dstr->str_nok = 0; + else if (sstr->str_pok) { + + /* + * Check to see if we can just swipe the string. If so, it's a + * possible small lose on short strings, but a big win on long ones. + * It might even be a win on short strings if dstr->str_ptr + * has to be allocated and sstr->str_ptr has to be freed. + */ + + if (sstr->str_pok & SP_TEMP) { /* slated for free anyway? */ + if (dstr->str_ptr) { + if (dstr->str_state == SS_INCR) + dstr->str_ptr -= dstr->str_u.str_useful; + Safefree(dstr->str_ptr); + } + dstr->str_ptr = sstr->str_ptr; + dstr->str_len = sstr->str_len; + dstr->str_cur = sstr->str_cur; + dstr->str_state = sstr->str_state; + dstr->str_pok = sstr->str_pok & ~SP_TEMP; +#ifdef TAINT + dstr->str_tainted = sstr->str_tainted; +#endif + sstr->str_ptr = Nullch; + sstr->str_len = 0; + sstr->str_pok = 0; /* wipe out any weird flags */ + sstr->str_state = 0; /* so sstr frees uneventfully */ + } + else { /* have to copy actual string */ + if (dstr->str_ptr) { + if (dstr->str_state == SS_INCR) { + Str_Grow(dstr,0); + } + } + 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 { +#ifdef STRUCTCOPY + dstr->str_u = sstr->str_u; +#else + dstr->str_u.str_nval = sstr->str_u.str_nval; +#endif + if (dstr->str_cur == sizeof(STBP)) { + char *tmps = dstr->str_ptr; + + if (*tmps == 'S' && bcmp(tmps,"StB",4) == 0) { + if (dstr->str_magic && dstr->str_magic->str_rare == 'X') { + str_free(dstr->str_magic); + dstr->str_magic = Nullstr; + } + if (!dstr->str_magic) { + dstr->str_magic = str_smake(sstr->str_magic); + dstr->str_magic->str_rare = 'X'; + } + } + } + } + } + else if (sstr->str_nok) + str_numset(dstr,sstr->str_u.str_nval); + else { + if (dstr->str_state == SS_INCR) + Str_Grow(dstr,0); /* just force copy down */ + +#ifdef STRUCTCOPY + dstr->str_u = sstr->str_u; +#else + dstr->str_u.str_nval = sstr->str_u.str_nval; +#endif + dstr->str_pok = dstr->str_nok = 0; + } +} + +void +str_nset(str,ptr,len) +register STR *str; +register char *ptr; +register STRLEN len; +{ + if (str == &str_undef) + return; + STR_GROW(str, len + 1); + if (ptr) + Move(ptr,str->str_ptr,len,char); + str->str_cur = len; + *(str->str_ptr+str->str_cur) = '\0'; + str->str_nok = 0; /* invalidate number */ + str->str_pok = 1; /* validate pointer */ +#ifdef TAINT + str->str_tainted = tainted; +#endif +} + +void +str_set(str,ptr) +register STR *str; +register char *ptr; +{ + register STRLEN len; + + if (str == &str_undef) + return; + if (!ptr) + ptr = ""; + len = strlen(ptr); + STR_GROW(str, len + 1); + Move(ptr,str->str_ptr,len+1,char); + str->str_cur = len; + str->str_nok = 0; /* invalidate number */ + str->str_pok = 1; /* validate pointer */ +#ifdef TAINT + str->str_tainted = tainted; +#endif +} + +void +str_chop(str,ptr) /* like set but assuming ptr is in str */ +register STR *str; +register char *ptr; +{ + register STRLEN delta; + + if (!ptr || !(str->str_pok)) + return; + delta = ptr - str->str_ptr; + str->str_len -= delta; + str->str_cur -= delta; + str->str_ptr += delta; + if (str->str_state == SS_INCR) + str->str_u.str_useful += delta; + else { + str->str_u.str_useful = delta; + str->str_state = SS_INCR; + } + str->str_nok = 0; /* invalidate number */ + str->str_pok = 1; /* validate pointer (and unstudy str) */ +} + +void +str_ncat(str,ptr,len) +register STR *str; +register char *ptr; +register STRLEN len; +{ + if (str == &str_undef) + return; + if (!(str->str_pok)) + (void)str_2ptr(str); + STR_GROW(str, str->str_cur + len + 1); + Move(ptr,str->str_ptr+str->str_cur,len,char); + str->str_cur += len; + *(str->str_ptr+str->str_cur) = '\0'; + str->str_nok = 0; /* invalidate number */ + str->str_pok = 1; /* validate pointer */ +#ifdef TAINT + str->str_tainted |= tainted; +#endif +} + +void +str_scat(dstr,sstr) +STR *dstr; +register STR *sstr; +{ + if (!sstr) + return; +#ifdef TAINT + tainted |= sstr->str_tainted; +#endif + if (!(sstr->str_pok)) + (void)str_2ptr(sstr); + if (sstr) + str_ncat(dstr,sstr->str_ptr,sstr->str_cur); +} + +void +str_cat(str,ptr) +register STR *str; +register char *ptr; +{ + register STRLEN len; + + if (str == &str_undef) + return; + if (!ptr) + return; + if (!(str->str_pok)) + (void)str_2ptr(str); + len = strlen(ptr); + STR_GROW(str, str->str_cur + len + 1); + Move(ptr,str->str_ptr+str->str_cur,len+1,char); + str->str_cur += len; + str->str_nok = 0; /* invalidate number */ + str->str_pok = 1; /* validate pointer */ +#ifdef TAINT + str->str_tainted |= tainted; +#endif +} + +char * +str_append_till(str,from,fromend,delim,keeplist) +register STR *str; +register char *from; +register char *fromend; +register int delim; +char *keeplist; +{ + register char *to; + register STRLEN len; + + if (str == &str_undef) + return Nullch; + if (!from) + return Nullch; + len = fromend - from; + STR_GROW(str, str->str_cur + len + 1); + str->str_nok = 0; /* invalidate number */ + str->str_pok = 1; /* validate pointer */ + to = str->str_ptr+str->str_cur; + for (; from < fromend; from++,to++) { + if (*from == '\\' && from+1 < fromend && delim != '\\') { + if (!keeplist) { + if (from[1] == delim || from[1] == '\\') + from++; + else + *to++ = *from++; + } + else if (from[1] && index(keeplist,from[1])) + *to++ = *from++; + else + from++; + } + else if (*from == delim) + break; + *to = *from; + } + *to = '\0'; + str->str_cur = to - str->str_ptr; + return from; +} + +STR * +#ifdef LEAKTEST +str_new(x,len) +int x; +#else +str_new(len) +#endif +STRLEN len; +{ + register STR *str; + + if (freestrroot) { + str = freestrroot; + freestrroot = str->str_magic; + str->str_magic = Nullstr; + str->str_state = SS_NORM; + } + else { + Newz(700+x,str,1,STR); + } + if (len) + STR_GROW(str, len + 1); + return str; +} + +void +str_magic(str, stab, how, name, namlen) +register STR *str; +STAB *stab; +int how; +char *name; +STRLEN namlen; +{ + if (str == &str_undef || str->str_magic) + return; + str->str_magic = Str_new(75,namlen); + str = str->str_magic; + str->str_u.str_stab = stab; + str->str_rare = how; + if (name) + str_nset(str,name,namlen); +} + +void +str_insert(bigstr,offset,len,little,littlelen) +STR *bigstr; +STRLEN offset; +STRLEN len; +char *little; +STRLEN littlelen; +{ + register char *big; + register char *mid; + register char *midend; + register char *bigend; + register int i; + + if (bigstr == &str_undef) + return; + bigstr->str_nok = 0; + bigstr->str_pok = SP_VALID; /* disable possible screamer */ + + i = littlelen - len; + if (i > 0) { /* string might grow */ + STR_GROW(bigstr, bigstr->str_cur + i + 1); + big = bigstr->str_ptr; + mid = big + offset + len; + midend = bigend = big + bigstr->str_cur; + bigend += i; + *bigend = '\0'; + while (midend > mid) /* shove everything down */ + *--bigend = *--midend; + Move(little,big+offset,littlelen,char); + bigstr->str_cur += i; + STABSET(bigstr); + return; + } + else if (i == 0) { + Move(little,bigstr->str_ptr+offset,len,char); + STABSET(bigstr); + return; + } + + big = bigstr->str_ptr; + mid = big + offset; + midend = mid + len; + bigend = big + bigstr->str_cur; + + if (midend > bigend) + fatal("panic: str_insert"); + + if (mid - big > bigend - midend) { /* faster to shorten from end */ + if (littlelen) { + Move(little, mid, littlelen,char); + mid += littlelen; + } + i = bigend - midend; + if (i > 0) { + Move(midend, mid, i,char); + mid += i; + } + *mid = '\0'; + bigstr->str_cur = mid - big; + } + /*SUPPRESS 560*/ + else if (i = mid - big) { /* faster from front */ + midend -= littlelen; + mid = midend; + str_chop(bigstr,midend-i); + big += i; + while (i--) + *--midend = *--big; + if (littlelen) + Move(little, mid, littlelen,char); + } + else if (littlelen) { + midend -= littlelen; + str_chop(bigstr,midend); + Move(little,midend,littlelen,char); + } + else { + str_chop(bigstr,midend); + } + STABSET(bigstr); +} + +/* make str point to what nstr did */ + +void +str_replace(str,nstr) +register STR *str; +register STR *nstr; +{ + if (str == &str_undef) + return; + if (str->str_state == SS_INCR) + Str_Grow(str,0); /* just force copy down */ + if (nstr->str_state == SS_INCR) + Str_Grow(nstr,0); + if (str->str_ptr) + Safefree(str->str_ptr); + str->str_ptr = nstr->str_ptr; + str->str_len = nstr->str_len; + str->str_cur = nstr->str_cur; + str->str_pok = nstr->str_pok; + str->str_nok = nstr->str_nok; +#ifdef STRUCTCOPY + str->str_u = nstr->str_u; +#else + str->str_u.str_nval = nstr->str_u.str_nval; +#endif +#ifdef TAINT + str->str_tainted = nstr->str_tainted; +#endif + if (nstr->str_magic) + str_free(nstr->str_magic); + Safefree(nstr); +} + +void +str_free(str) +register STR *str; +{ + if (!str || str == &str_undef) + return; + if (str->str_state) { + if (str->str_state == SS_FREE) /* already freed */ + return; + if (str->str_state == SS_INCR && !(str->str_pok & 2)) { + str->str_ptr -= str->str_u.str_useful; + str->str_len += str->str_u.str_useful; + } + } + if (str->str_magic) + str_free(str->str_magic); + str->str_magic = freestrroot; +#ifdef LEAKTEST + if (str->str_len) { + Safefree(str->str_ptr); + str->str_ptr = Nullch; + } + if ((str->str_pok & SP_INTRP) && str->str_u.str_args) + arg_free(str->str_u.str_args); + Safefree(str); +#else /* LEAKTEST */ + if (str->str_len) { + if (str->str_len > 127) { /* next user not likely to want more */ + Safefree(str->str_ptr); /* so give it back to malloc */ + str->str_ptr = Nullch; + str->str_len = 0; + } + else + str->str_ptr[0] = '\0'; + } + if ((str->str_pok & SP_INTRP) && str->str_u.str_args) + arg_free(str->str_u.str_args); + str->str_cur = 0; + str->str_nok = 0; + str->str_pok = 0; + str->str_state = SS_FREE; +#ifdef TAINT + str->str_tainted = 0; +#endif + freestrroot = str; +#endif /* LEAKTEST */ +} + +STRLEN +str_len(str) +register STR *str; +{ + if (!str) + return 0; + if (!(str->str_pok)) + (void)str_2ptr(str); + if (str->str_ptr) + return str->str_cur; + else + return 0; +} + +int +str_eq(str1,str2) +register STR *str1; +register STR *str2; +{ + if (!str1 || str1 == &str_undef) + return (str2 == Nullstr || str2 == &str_undef || !str2->str_cur); + if (!str2 || str2 == &str_undef) + return !str1->str_cur; + + if (!str1->str_pok) + (void)str_2ptr(str1); + if (!str2->str_pok) + (void)str_2ptr(str2); + + if (str1->str_cur != str2->str_cur) + return 0; + + return !bcmp(str1->str_ptr, str2->str_ptr, str1->str_cur); +} + +int +str_cmp(str1,str2) +register STR *str1; +register STR *str2; +{ + int retval; + + if (!str1 || str1 == &str_undef) + return (str2 == Nullstr || str2 == &str_undef || !str2->str_cur)?0:-1; + if (!str2 || str2 == &str_undef) + return str1->str_cur != 0; + + if (!str1->str_pok) + (void)str_2ptr(str1); + if (!str2->str_pok) + (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) + return 0; + else + return 1; +} + +char * +str_gets(str,fp,append) +register STR *str; +register FILE *fp; +int append; +{ + register char *bp; /* we're going to steal some values */ + register int cnt; /* from the stdio struct and put EVERYTHING */ + register STDCHAR *ptr; /* in the innermost loop into registers */ + register int newline = rschar;/* (assuming >= 6 registers) */ + int i; + STRLEN bpx; + int shortbuffered; + + if (str == &str_undef) + return Nullch; + if (rspara) { /* have to do this both before and after */ + do { /* to make sure file boundaries work right */ + i = getc(fp); + if (i != '\n') { + ungetc(i,fp); + break; + } + } while (i != EOF); + } +#ifdef STDSTDIO /* Here is some breathtakingly efficient cheating */ + cnt = fp->_cnt; /* get count into register */ + str->str_nok = 0; /* invalidate number */ + str->str_pok = 1; /* validate pointer */ + 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; + } + else { + shortbuffered = 0; + STR_GROW(str, append+cnt+2);/* (remembering cnt can be -1) */ + } + } + else + shortbuffered = 0; + bp = str->str_ptr + append; /* move these two too to registers */ + ptr = fp->_ptr; + for (;;) { + screamer: + while (--cnt >= 0) { /* this */ /* eat */ + if ((*bp++ = *ptr++) == newline) /* really */ /* dust */ + goto thats_all_folks; /* screams */ /* sed :-) */ + } + + if (shortbuffered) { /* oh well, must extend */ + cnt = shortbuffered; + shortbuffered = 0; + bpx = bp - str->str_ptr; /* prepare for possible relocation */ + str->str_cur = bpx; + STR_GROW(str, str->str_len + append + cnt + 2); + bp = str->str_ptr + bpx; /* reconstitute our pointer */ + continue; + } + + fp->_cnt = cnt; /* deregisterize cnt and ptr */ + fp->_ptr = ptr; + i = _filbuf(fp); /* get more characters */ + cnt = fp->_cnt; + ptr = fp->_ptr; /* reregisterize cnt and ptr */ + + bpx = bp - str->str_ptr; /* prepare for possible relocation */ + str->str_cur = bpx; + STR_GROW(str, bpx + cnt + 2); + bp = str->str_ptr + bpx; /* reconstitute our pointer */ + + if (i == newline) { /* all done for now? */ + *bp++ = i; + goto thats_all_folks; + } + else if (i == EOF) /* all done for ever? */ + goto thats_really_all_folks; + *bp++ = i; /* now go back to screaming loop */ + } + +thats_all_folks: + if (rslen > 1 && (bp - str->str_ptr < rslen || bcmp(bp - rslen, rs, rslen))) + goto screamer; /* go back to the fray */ +thats_really_all_folks: + if (shortbuffered) + cnt += shortbuffered; + fp->_cnt = cnt; /* put these back or we're in trouble */ + fp->_ptr = ptr; + *bp = '\0'; + str->str_cur = bp - str->str_ptr; /* set length */ + +#else /* !STDSTDIO */ /* The big, slow, and stupid way */ + + { + static char buf[8192]; + char * bpe = buf + sizeof(buf) - 3; + +screamer: + bp = buf; + while ((i = getc(fp)) != EOF && (*bp++ = i) != newline && bp < bpe) ; + + *bp = '\0'; + if (append) + str_cat(str, buf); + else + str_set(str, buf); + if (i != EOF /* joy */ + && + (i != newline + || + (rslen > 1 + && + (str->str_cur < rslen + || + bcmp(str->str_ptr + str->str_cur - rslen, rs, rslen) + ) + ) + ) + ) + { + append = -1; + goto screamer; + } + } + +#endif /* STDSTDIO */ + + if (rspara) { + while (i != EOF) { + i = getc(fp); + if (i != '\n') { + ungetc(i,fp); + break; + } + } + } + return str->str_cur - append ? str->str_ptr : Nullch; +} + +ARG * +parselist(str) +STR *str; +{ + register CMD *cmd; + register ARG *arg; + CMD *oldcurcmd = curcmd; + int oldperldb = perldb; + int retval; + + perldb = 0; + str_sset(linestr,str); + in_eval++; + oldoldbufptr = oldbufptr = bufptr = str_get(linestr); + bufend = bufptr + linestr->str_cur; + if (++loop_ptr >= loop_max) { + loop_max += 128; + Renew(loop_stack, loop_max, struct loop); + } + loop_stack[loop_ptr].loop_label = "_EVAL_"; + loop_stack[loop_ptr].loop_sp = 0; +#ifdef DEBUGGING + if (debug & 4) { + deb("(Pushing label #%d _EVAL_)\n", loop_ptr); + } +#endif + if (setjmp(loop_stack[loop_ptr].loop_env)) { + in_eval--; + loop_ptr--; + perldb = oldperldb; + fatal("%s\n",stab_val(stabent("@",TRUE))->str_ptr); + } +#ifdef DEBUGGING + if (debug & 4) { + char *tmps = loop_stack[loop_ptr].loop_label; + deb("(Popping label #%d %s)\n",loop_ptr, + tmps ? tmps : "" ); + } +#endif + loop_ptr--; + error_count = 0; + curcmd = &compiling; + curcmd->c_line = oldcurcmd->c_line; + retval = yyparse(); + curcmd = oldcurcmd; + perldb = oldperldb; + in_eval--; + if (retval || error_count) + fatal("Invalid component in string or format"); + cmd = eval_root; + arg = cmd->c_expr; + if (cmd->c_type != C_EXPR || cmd->c_next || arg->arg_type != O_LIST) + fatal("panic: error in parselist %d %x %d", cmd->c_type, + cmd->c_next, arg ? arg->arg_type : -1); + cmd->c_expr = Nullarg; + cmd_free(cmd); + eval_root = Nullcmd; + return arg; +} + +void +intrpcompile(src) +STR *src; +{ + register char *s = str_get(src); + register char *send = s + src->str_cur; + register STR *str; + register char *t; + STR *toparse; + STRLEN len; + register int brackets; + register char *d; + STAB *stab; + char *checkpoint; + int sawcase = 0; + + toparse = Str_new(76,0); + str = Str_new(77,0); + + str_nset(str,"",0); + str_nset(toparse,"",0); + t = s; + while (s < send) { + if (*s == '\\' && s[1] && index("$@[{\\]}lLuUE",s[1])) { + str_ncat(str, t, s - t); + ++s; + if (isALPHA(*s)) { + str_ncat(str, "$c", 2); + sawcase = (*s != 'E'); + } + else { + if (*nointrp) { /* in a regular expression */ + if (*s == '@') /* always strip \@ */ /*SUPPRESS 530*/ + ; + else /* don't strip \\, \[, \{ etc. */ + str_ncat(str,s-1,1); + } + str_ncat(str, "$b", 2); + } + str_ncat(str, s, 1); + ++s; + t = s; + } + else if (*s == '$' && s+1 < send && *nointrp && index(nointrp,s[1])) { + str_ncat(str, t, s - t); + str_ncat(str, "$b", 2); + str_ncat(str, s, 2); + s += 2; + t = s; + } + else if ((*s == '@' || *s == '$') && s+1 < send) { + str_ncat(str,t,s-t); + t = s; + if (*s == '$' && s[1] == '#' && (isALPHA(s[2]) || s[2] == '_')) + s++; + s = scanident(s,send,tokenbuf); + if (*t == '@' && + (!(stab = stabent(tokenbuf,FALSE)) || + (*s == '{' ? !stab_xhash(stab) : !stab_xarray(stab)) )) { + str_ncat(str,"@",1); + s = ++t; + continue; /* grandfather @ from old scripts */ + } + str_ncat(str,"$a",2); + str_ncat(toparse,",",1); + if (t[1] != '{' && (*s == '[' || *s == '{' /* }} */ ) && + (stab = stabent(tokenbuf,FALSE)) && + ((*s == '[') ? (stab_xarray(stab) != 0) : (stab_xhash(stab) != 0)) ) { + brackets = 0; + checkpoint = s; + do { + switch (*s) { + case '[': + brackets++; + break; + case '{': + brackets++; + break; + case ']': + brackets--; + break; + case '}': + brackets--; + break; + case '$': + case '%': + case '@': + case '&': + case '*': + s = scanident(s,send,tokenbuf); + continue; + case '\'': + case '"': + /*SUPPRESS 68*/ + s = cpytill(tokenbuf,s+1,send,*s,&len); + if (s >= send) + fatal("Unterminated string"); + break; + } + s++; + } while (brackets > 0 && s < send); + if (s > send) + fatal("Unmatched brackets in string"); + if (*nointrp) { /* we're in a regular expression */ + d = checkpoint; + if (*d == '{' && s[-1] == '}') { /* maybe {n,m} */ + ++d; + if (isDIGIT(*d)) { /* matches /^{\d,?\d*}$/ */ + if (*++d == ',') + ++d; + while (isDIGIT(*d)) + d++; + if (d == s - 1) + s = checkpoint; /* Is {n,m}! Backoff! */ + } + } + else if (*d == '[' && s[-1] == ']') { /* char class? */ + int weight = 2; /* let's weigh the evidence */ + char seen[256]; + unsigned char un_char = 0, last_un_char; + + Zero(seen,256,char); + *--s = '\0'; + if (d[1] == '^') + weight += 150; + else if (d[1] == '$') + weight -= 3; + if (isDIGIT(d[1])) { + if (d[2]) { + if (isDIGIT(d[2]) && !d[3]) + weight -= 10; + } + else + weight -= 100; + } + for (d++; d < s; d++) { + last_un_char = un_char; + un_char = (unsigned char)*d; + switch (*d) { + case '&': + case '$': + weight -= seen[un_char] * 10; + if (isALNUM(d[1])) { + d = scanident(d,s,tokenbuf); + if (stabent(tokenbuf,FALSE)) + weight -= 100; + else + weight -= 10; + } + else if (*d == '$' && d[1] && + index("[#!%*<>()-=",d[1])) { + if (!d[2] || /*{*/ index("])} =",d[2])) + weight -= 10; + else + weight -= 1; + } + break; + case '\\': + un_char = 254; + if (d[1]) { + if (index("wds",d[1])) + weight += 100; + else if (seen['\''] || seen['"']) + weight += 1; + else if (index("rnftb",d[1])) + weight += 40; + else if (isDIGIT(d[1])) { + weight += 40; + while (d[1] && isDIGIT(d[1])) + d++; + } + } + else + weight += 100; + break; + case '-': + if (last_un_char < (unsigned char) d[1] + || d[1] == '\\') { + if (index("aA01! ",last_un_char)) + weight += 30; + if (index("zZ79~",d[1])) + weight += 30; + } + else + weight -= 1; + default: + if (isALPHA(*d) && d[1] && isALPHA(d[1])) { + bufptr = d; + if (yylex() != WORD) + weight -= 150; + d = bufptr; + } + if (un_char == last_un_char + 1) + weight += 5; + weight -= seen[un_char]; + break; + } + seen[un_char]++; + } +#ifdef DEBUGGING + if (debug & 512) + fprintf(stderr,"[%s] weight %d\n", + checkpoint+1,weight); +#endif + *s++ = ']'; + if (weight >= 0) /* probably a character class */ + s = checkpoint; + } + } + } + if (*t == '@') + str_ncat(toparse, "join($\",", 8); + if (t[1] == '{' && s[-1] == '}') { + str_ncat(toparse, t, 1); + str_ncat(toparse, t+2, s - t - 3); + } + else + str_ncat(toparse, t, s - t); + if (*t == '@') + str_ncat(toparse, ")", 1); + t = s; + } + else + s++; + } + str_ncat(str,t,s-t); + if (sawcase) + str_ncat(str, "$cE", 3); + if (toparse->str_ptr && *toparse->str_ptr == ',') { + *toparse->str_ptr = '('; + str_ncat(toparse,",$$);",5); + str->str_u.str_args = parselist(toparse); + str->str_u.str_args->arg_len--; /* ignore $$ reference */ + } + else + str->str_u.str_args = Nullarg; + str_free(toparse); + str->str_pok |= SP_INTRP; + str->str_nok = 0; + str_replace(src,str); +} + +STR * +interp(str,src,sp) +register STR *str; +STR *src; +int sp; +{ + register char *s; + register char *t; + register char *send; + register STR **elem; + int docase = 0; + int l = 0; + int u = 0; + int L = 0; + int U = 0; + + if (str == &str_undef) + return Nullstr; + if (!(src->str_pok & SP_INTRP)) { + int oldsave = savestack->ary_fill; + + (void)savehptr(&curstash); + curstash = curcmd->c_stash; /* so stabent knows right package */ + intrpcompile(src); + restorelist(oldsave); + } + s = src->str_ptr; /* assumed valid since str_pok set */ + t = s; + send = s + src->str_cur; + + if (src->str_u.str_args) { + (void)eval(src->str_u.str_args,G_ARRAY,sp); + /* Assuming we have correct # of args */ + elem = stack->ary_array + sp; + } + + str_nset(str,"",0); + while (s < send) { + if (*s == '$' && s+1 < send) { + if (s-t > 0) + str_ncat(str,t,s-t); + switch(*++s) { + default: + fatal("panic: unknown interp cookie\n"); + break; + case 'a': + str_scat(str,*++elem); + break; + case 'b': + str_ncat(str,++s,1); + break; + case 'c': + if (docase && str->str_cur >= docase) { + char *b = str->str_ptr + --docase; + + if (L) + lcase(b, str->str_ptr + str->str_cur); + else if (U) + ucase(b, str->str_ptr + str->str_cur); + + if (u) /* note that l & u are independent of L & U */ + ucase(b, b+1); + else if (l) + lcase(b, b+1); + l = u = 0; + } + docase = str->str_cur + 1; + switch (*++s) { + case 'u': + u = 1; + l = 0; + break; + case 'U': + U = 1; + L = 0; + break; + case 'l': + l = 1; + u = 0; + break; + case 'L': + L = 1; + U = 0; + break; + case 'E': + docase = L = U = l = u = 0; + break; + } + break; + } + t = ++s; + } + else + s++; + } + if (s-t > 0) + str_ncat(str,t,s-t); + return str; +} + +static void +ucase(s,send) +register char *s; +register char *send; +{ + while (s < send) { + if (isLOWER(*s)) + *s = toupper(*s); + s++; + } +} + +static void +lcase(s,send) +register char *s; +register char *send; +{ + while (s < send) { + if (isUPPER(*s)) + *s = tolower(*s); + s++; + } +} + +void +str_inc(str) +register STR *str; +{ + register char *d; + + if (!str || str == &str_undef) + return; + if (str->str_nok) { + str->str_u.str_nval += 1.0; + str->str_pok = 0; + return; + } + if (!str->str_pok || !*str->str_ptr) { + str->str_u.str_nval = 1.0; + str->str_nok = 1; + str->str_pok = 0; + return; + } + d = str->str_ptr; + 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 (++*d <= '9') + return; + *(d--) = '0'; + } + else { + ++*d; + if (isALPHA(*d)) + return; + *(d--) -= 'z' - 'a' + 1; + } + } + /* oh,oh, the number grew */ + STR_GROW(str, str->str_cur + 2); + str->str_cur++; + for (d = str->str_ptr + str->str_cur; d > str->str_ptr; d--) + *d = d[-1]; + if (isDIGIT(d[1])) + *d = '1'; + else + *d = d[1]; +} + +void +str_dec(str) +register STR *str; +{ + if (!str || str == &str_undef) + return; + if (str->str_nok) { + str->str_u.str_nval -= 1.0; + str->str_pok = 0; + return; + } + if (!str->str_pok) { + str->str_u.str_nval = -1.0; + str->str_nok = 1; + return; + } + str_numset(str,atof(str->str_ptr) - 1.0); +} + +/* Make a string that will exist for the duration of the expression + * evaluation. Actually, it may have to last longer than that, but + * hopefully cmd_exec won't free it until it has been assigned to a + * permanent location. */ + +static long tmps_size = -1; + +STR * +str_mortal(oldstr) +STR *oldstr; +{ + register STR *str = Str_new(78,0); + + str_sset(str,oldstr); + if (++tmps_max > tmps_size) { + tmps_size = tmps_max; + if (!(tmps_size & 127)) { + if (tmps_size) + Renew(tmps_list, tmps_size + 128, STR*); + else + New(702,tmps_list, 128, STR*); + } + } + tmps_list[tmps_max] = str; + if (str->str_pok) + str->str_pok |= SP_TEMP; + return str; +} + +/* same thing without the copying */ + +STR * +str_2mortal(str) +register STR *str; +{ + if (!str || str == &str_undef) + return str; + if (++tmps_max > tmps_size) { + tmps_size = tmps_max; + if (!(tmps_size & 127)) { + if (tmps_size) + Renew(tmps_list, tmps_size + 128, STR*); + else + New(704,tmps_list, 128, STR*); + } + } + tmps_list[tmps_max] = str; + if (str->str_pok) + str->str_pok |= SP_TEMP; + return str; +} + +STR * +str_make(s,len) +char *s; +STRLEN len; +{ + register STR *str = Str_new(79,0); + + if (!len) + len = strlen(s); + str_nset(str,s,len); + return str; +} + +STR * +str_nmake(n) +double n; +{ + register STR *str = Str_new(80,0); + + str_numset(str,n); + return str; +} + +/* make an exact duplicate of old */ + +STR * +str_smake(old) +register STR *old; +{ + register STR *new = Str_new(81,0); + + if (!old) + return Nullstr; + if (old->str_state == SS_FREE) { + warn("semi-panic: attempt to dup freed string"); + return Nullstr; + } + if (old->str_state == SS_INCR && !(old->str_pok & 2)) + Str_Grow(old,0); + if (new->str_ptr) + Safefree(new->str_ptr); + StructCopy(old,new,STR); + if (old->str_ptr) { + new->str_ptr = nsavestr(old->str_ptr,old->str_len); + new->str_pok &= ~SP_TEMP; + } + return new; +} + +void +str_reset(s,stash) +register char *s; +HASH *stash; +{ + register HENT *entry; + register STAB *stab; + register STR *str; + register int i; + register SPAT *spat; + register int max; + + if (!*s) { /* reset ?? searches */ + for (spat = stash->tbl_spatroot; + spat != Nullspat; + spat = spat->spat_next) { + spat->spat_flags &= ~SPAT_USED; + } + return; + } + + /* reset variables */ + + if (!stash->tbl_array) + return; + while (*s) { + i = *s; + if (s[1] == '-') { + s += 2; + } + max = *s++; + for ( ; i <= max; i++) { + for (entry = stash->tbl_array[i]; + entry; + entry = entry->hent_next) { + stab = (STAB*)entry->hent_val; + str = stab_val(stab); + str->str_cur = 0; + str->str_nok = 0; +#ifdef TAINT + str->str_tainted = tainted; +#endif + if (str->str_ptr != Nullch) + str->str_ptr[0] = '\0'; + if (stab_xarray(stab)) { + aclear(stab_xarray(stab)); + } + if (stab_xhash(stab)) { + hclear(stab_xhash(stab), FALSE); + if (stab == envstab) + environ[0] = Nullch; + } + } + } + } +} + +#ifdef TAINT +void +taintproper(s) +char *s; +{ +#ifdef DEBUGGING + if (debug & 2048) + fprintf(stderr,"%s %d %d %d\n",s,tainted,uid, euid); +#endif + if (tainted && (!euid || euid != uid || egid != gid || taintanyway)) { + if (!unsafe) + fatal("%s", s); + else if (dowarn) + warn("%s", s); + } +} + +void +taintenv() +{ + register STR *envstr; + + envstr = hfetch(stab_hash(envstab),"PATH",4,FALSE); + if (envstr == &str_undef || envstr->str_tainted) { + tainted = 1; + if (envstr->str_tainted == 2) + taintproper("Insecure directory in PATH"); + else + taintproper("Insecure PATH"); + } + envstr = hfetch(stab_hash(envstab),"IFS",3,FALSE); + if (envstr != &str_undef && envstr->str_tainted) { + tainted = 1; + taintproper("Insecure IFS"); + } +} +#endif /* TAINT */ diff --git a/str.c.rej b/str.c.rej new file mode 100644 index 0000000..e58d31c --- /dev/null +++ b/str.c.rej @@ -0,0 +1,35 @@ +*************** +*** 1,4 **** +! /* $RCSfile: str.c,v $$Revision: 4.0.1.6 $$Date: 1992/06/11 21:14:21 $ + * + * Copyright (c) 1991, Larry Wall + * +--- 1,4 ---- +! /* $RCSfile: str.c,v $$Revision: 4.0.1.7 $$Date: 1993/02/05 19:43:47 $ + * + * Copyright (c) 1991, Larry Wall + * +*************** +*** 6,14 **** + * License or the Artistic License, as specified in the README file. + * + * $Log: str.c,v $ +! * Revision 4.0.1.6 1992/06/11 21:14:21 lwall +! * patch34: quotes containing subscripts containing variables didn't parse right + * + * Revision 4.0.1.5 92/06/08 15:40:43 lwall + * patch20: removed implicit int declarations on functions + * patch20: Perl now distinguishes overlapped copies from non-overlapped +--- 6,17 ---- + * License or the Artistic License, as specified in the README file. + * + * $Log: str.c,v $ +! * Revision 4.0.1.7 1993/02/05 19:43:47 lwall +! * patch36: the non-std stdio input code wasn't null-proof + * ++ * Revision 4.0.1.6 92/06/11 21:14:21 lwall ++ * patch34: quotes containing subscripts containing variables didn't parse right ++ * + * Revision 4.0.1.5 92/06/08 15:40:43 lwall + * patch20: removed implicit int declarations on functions + * patch20: Perl now distinguishes overlapped copies from non-overlapped diff --git a/t/io/fs.t b/t/io/fs.t index 705523c..d298b29 100644 --- a/t/io/fs.t +++ b/t/io/fs.t @@ -13,7 +13,7 @@ chdir './tmp'; umask(022); -if (umask(0) == 022) {print "ok 1\n";} else {print "not ok 1\n";} +if ((umask(0)&0777) == 022) {print "ok 1\n";} else {print "not ok 1\n";} open(fh,'>x') || die "Can't create x"; close(fh); open(fh,'>a') || die "Can't create a"; diff --git a/t/io/fs.t.orig b/t/io/fs.t.orig new file mode 100644 index 0000000..705523c --- /dev/null +++ b/t/io/fs.t.orig @@ -0,0 +1,85 @@ +#!./perl + +# $Header: fs.t,v 4.0 91/03/20 01:50:55 lwall Locked $ + +print "1..22\n"; + +$wd = `pwd`; +chop($wd); + +`rm -f tmp 2>/dev/null; mkdir tmp 2>/dev/null`; +chdir './tmp'; +`/bin/rm -rf a b c x`; + +umask(022); + +if (umask(0) == 022) {print "ok 1\n";} else {print "not ok 1\n";} +open(fh,'>x') || die "Can't create x"; +close(fh); +open(fh,'>a') || die "Can't create a"; +close(fh); + +if (link('a','b')) {print "ok 2\n";} else {print "not ok 2\n";} + +if (link('b','c')) {print "ok 3\n";} else {print "not ok 3\n";} + +($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + $blksize,$blocks) = stat('c'); + +if ($nlink == 3) {print "ok 4\n";} else {print "not ok 4\n";} +if (($mode & 0777) == 0666) {print "ok 5\n";} else {print "not ok 5\n";} + +if ((chmod 0777,'a') == 1) {print "ok 6\n";} else {print "not ok 6\n";} + +($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + $blksize,$blocks) = stat('c'); +if (($mode & 0777) == 0777) {print "ok 7\n";} else {print "not ok 7\n";} + +if ((chmod 0700,'c','x') == 2) {print "ok 8\n";} else {print "not ok 8\n";} + +($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + $blksize,$blocks) = stat('c'); +if (($mode & 0777) == 0700) {print "ok 9\n";} else {print "not ok 9\n";} +($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + $blksize,$blocks) = stat('x'); +if (($mode & 0777) == 0700) {print "ok 10\n";} else {print "not ok 10\n";} + +if ((unlink 'b','x') == 2) {print "ok 11\n";} else {print "not ok 11\n";} +($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + $blksize,$blocks) = stat('b'); +if ($ino == 0) {print "ok 12\n";} else {print "not ok 12\n";} +($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + $blksize,$blocks) = stat('x'); +if ($ino == 0) {print "ok 13\n";} else {print "not ok 13\n";} + +if (rename('a','b')) {print "ok 14\n";} else {print "not ok 14\n";} +($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + $blksize,$blocks) = stat('a'); +if ($ino == 0) {print "ok 15\n";} else {print "not ok 15\n";} +$foo = (utime 500000000,500000001,'b'); +if ($foo == 1) {print "ok 16\n";} else {print "not ok 16 $foo\n";} +($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + $blksize,$blocks) = stat('b'); +if ($ino) {print "ok 17\n";} else {print "not ok 17\n";} +if (($atime == 500000000 && $mtime == 500000001) || $wd =~ m#/afs/#) + {print "ok 18\n";} +else + {print "not ok 18 $atime $mtime\n";} + +if ((unlink 'b') == 1) {print "ok 19\n";} else {print "not ok 19\n";} +($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + $blksize,$blocks) = stat('b'); +if ($ino == 0) {print "ok 20\n";} else {print "not ok 20\n";} +unlink 'c'; + +chdir $wd || die "Can't cd back to $wd"; + +unlink 'c'; +if (`ls -l perl 2>/dev/null` =~ /^l.*->/) { # we have symbolic links + if (symlink("TEST","c")) {print "ok 21\n";} else {print "not ok 21\n";} + $foo = `grep perl c`; + if ($foo) {print "ok 22\n";} else {print "not ok 22\n";} +} +else { + print "ok 21\nok 22\n"; +} diff --git a/t/io/fs.t.rej b/t/io/fs.t.rej new file mode 100644 index 0000000..e519af0 --- /dev/null +++ b/t/io/fs.t.rej @@ -0,0 +1,15 @@ +*************** +*** 1,6 **** + #!./perl + +! # $Header: fs.t,v 4.0 1991/03/20 01:50:55 lwall Locked $ + + print "1..22\n"; + +--- 1,6 ---- + #!./perl + +! # $RCSfile: fs.t,v $$Revision: 4.0.1.1 $$Date: 1993/02/05 19:44:34 $ + + print "1..22\n"; + diff --git a/toke.c b/toke.c index 8019756..6a40638 100644 --- a/toke.c +++ b/toke.c @@ -162,7 +162,7 @@ check_uni() { return; while (isSPACE(*last_uni)) last_uni++; - for (s = last_uni; isALNUM(*s); s++) ; + for (s = last_uni; isALNUM(*s) || *s == '-'; s++) ; ch = *s; *s = '\0'; warn("Warning: Use of \"%s\" without parens is ambiguous", last_uni); @@ -442,6 +442,7 @@ yylex() case '-': if (s[1] && isALPHA(s[1]) && !isALPHA(s[2])) { s++; + last_uni = oldbufptr; switch (*s++) { case 'r': FTST(O_FTEREAD); case 'w': FTST(O_FTEWRITE); @@ -2300,6 +2301,7 @@ int in_what; STR *tmpstr; STR *tmpstr2 = Nullstr; char *tmps; + char *start; bool dorange = FALSE; CLINE; @@ -2397,7 +2399,7 @@ int in_what; } s++; } - s = d = tmpstr->str_ptr; /* assuming shrinkage only */ + s = d = start = tmpstr->str_ptr; /* assuming shrinkage only */ while (s < send || dorange) { if (in_what & SCAN_TR) { if (dorange) { @@ -2415,10 +2417,11 @@ int in_what; max = d[1] & 0377; for (i = (*d & 0377); i <= max; i++) *d++ = i; + start = s; dorange = FALSE; continue; } - else if (*s == '-' && s+1 < send && d != tmpstr->str_ptr) { + else if (*s == '-' && s+1 < send && s != start) { dorange = TRUE; s++; } diff --git a/toke.c.orig b/toke.c.orig new file mode 100644 index 0000000..8019756 --- /dev/null +++ b/toke.c.orig @@ -0,0 +1,2754 @@ +/* $RCSfile: toke.c,v $$Revision: 4.0.1.8 $$Date: 92/06/23 12:33:45 $ + * + * Copyright (c) 1991, Larry Wall + * + * You may distribute under the terms of either the GNU General Public + * License or the Artistic License, as specified in the README file. + * + * $Log: toke.c,v $ + * Revision 4.0.1.8 92/06/23 12:33:45 lwall + * patch35: bad interaction between backslash and hyphen in tr/// + * + * Revision 4.0.1.7 92/06/11 21:16:30 lwall + * patch34: expectterm incorrectly set to indicate start of program or block + * + * Revision 4.0.1.6 92/06/08 16:03:49 lwall + * patch20: an EXPR may now start with a bareword + * patch20: print $fh EXPR can now expect term rather than operator in EXPR + * patch20: added ... as variant on .. + * patch20: new warning on spurious backslash + * patch20: new warning on missing $ for foreach variable + * patch20: "foo"x1024 now legal without space after x + * patch20: new warning on print accidentally used as function + * patch20: tr/stuff// wasn't working right + * patch20: 2. now eats the dot + * patch20: <@ARGV> now notices @ARGV + * patch20: tr/// now lets you say \- + * + * Revision 4.0.1.5 91/11/11 16:45:51 lwall + * patch19: default arg for shift was wrong after first subroutine definition + * + * 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 + * + * Revision 4.0.1.2 91/06/07 12:05:56 lwall + * patch4: new copyright notice + * patch4: debugger lost track of lines in eval + * patch4: //o and s///o now optimize themselves fully at runtime + * patch4: added global modifier for pattern matches + * + * Revision 4.0.1.1 91/04/12 09:18:18 lwall + * patch1: perl -de "print" wouldn't stop at the first statement + * + * Revision 4.0 91/03/20 01:42:14 lwall + * 4.0 baseline. + * + */ + +#include "EXTERN.h" +#include "perl.h" +#include "perly.h" + +static void set_csh(); + +#ifdef I_FCNTL +#include +#endif +#ifdef I_SYS_FILE +#include +#endif + +#ifdef f_next +#undef f_next +#endif + +/* which backslash sequences to keep in m// or s// */ + +static char *patleave = "\\.^$@dDwWsSbB+*?|()-nrtfeaxc0123456789[{]}"; + +char *reparse; /* if non-null, scanident found ${foo[$bar]} */ + +void checkcomma(); + +#ifdef CLINE +#undef CLINE +#endif +#define CLINE (cmdline = (curcmd->c_line < cmdline ? curcmd->c_line : cmdline)) + +#ifdef atarist +#define PERL_META(c) ((c) | 128) +#else +#define META(c) ((c) | 128) +#endif + +#define RETURN(retval) return (bufptr = s,(int)retval) +#define OPERATOR(retval) return (expectterm = TRUE,bufptr = s,(int)retval) +#define TERM(retval) return (CLINE, expectterm = FALSE,bufptr = s,(int)retval) +#define LOOPX(f) return(yylval.ival=f,expectterm = FALSE,bufptr = s,(int)LOOPEX) +#define FTST(f) return(yylval.ival=f,expectterm = TRUE,bufptr = s,(int)FILETEST) +#define FUN0(f) return(yylval.ival = f,expectterm = FALSE,bufptr = s,(int)FUNC0) +#define FUN1(f) return(yylval.ival = f,expectterm = FALSE,bufptr = s,(int)FUNC1) +#define FUN2(f) return(yylval.ival = f,expectterm = FALSE,bufptr = s,(int)FUNC2) +#define FUN2x(f) return(yylval.ival = f,expectterm = FALSE,bufptr = s,(int)FUNC2x) +#define FUN3(f) return(yylval.ival = f,expectterm = FALSE,bufptr = s,(int)FUNC3) +#define FUN4(f) return(yylval.ival = f,expectterm = FALSE,bufptr = s,(int)FUNC4) +#define FUN5(f) return(yylval.ival = f,expectterm = FALSE,bufptr = s,(int)FUNC5) +#define FL(f) return(yylval.ival=f,expectterm = FALSE,bufptr = s,(int)FLIST) +#define FL2(f) return(yylval.ival=f,expectterm = FALSE,bufptr = s,(int)FLIST2) +#define HFUN(f) return(yylval.ival=f,expectterm = TRUE,bufptr = s,(int)HSHFUN) +#define HFUN3(f) return(yylval.ival=f,expectterm = FALSE,bufptr = s,(int)HSHFUN3) +#define LFUN(f) return(yylval.ival=f,expectterm = TRUE,bufptr = s,(int)LVALFUN) +#define AOP(f) return(yylval.ival=f,expectterm = TRUE,bufptr = s,(int)ADDOP) +#define MOP(f) return(yylval.ival=f,expectterm = TRUE,bufptr = s,(int)MULOP) +#define EOP(f) return(yylval.ival=f,expectterm = TRUE,bufptr = s,(int)EQOP) +#define ROP(f) return(yylval.ival=f,expectterm = TRUE,bufptr = s,(int)RELOP) +#define FOP(f) return(yylval.ival=f,expectterm = FALSE,bufptr = s,(int)FILOP) +#define FOP2(f) return(yylval.ival=f,expectterm = FALSE,bufptr = s,(int)FILOP2) +#define FOP3(f) return(yylval.ival=f,expectterm = FALSE,bufptr = s,(int)FILOP3) +#define FOP4(f) return(yylval.ival=f,expectterm = FALSE,bufptr = s,(int)FILOP4) +#define FOP22(f) return(yylval.ival=f,expectterm = FALSE,bufptr = s,(int)FILOP22) +#define FOP25(f) return(yylval.ival=f,expectterm = FALSE,bufptr = s,(int)FILOP25) + +static char *last_uni; + +/* This bit of chicanery makes a unary function followed by + * a parenthesis into a function with one argument, highest precedence. + */ +#define UNI(f) return(yylval.ival = f, \ + expectterm = TRUE, \ + bufptr = s, \ + last_uni = oldbufptr, \ + (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) ) + +/* This does similarly for list operators, merely by pretending that the + * paren came before the listop rather than after. + */ +#ifdef atarist +#define LOP(f) return(CLINE, *s == '(' || (s = skipspace(s), *s == '(') ? \ + (*s = (char) PERL_META('('), bufptr = oldbufptr, '(') : \ + (yylval.ival=f,expectterm = TRUE,bufptr = s,(int)LISTOP)) +#else +#define LOP(f) return(CLINE, *s == '(' || (s = skipspace(s), *s == '(') ? \ + (*s = (char) META('('), bufptr = oldbufptr, '(') : \ + (yylval.ival=f,expectterm = TRUE,bufptr = s,(int)LISTOP)) +#endif +/* grandfather return to old style */ +#define OLDLOP(f) return(yylval.ival=f,expectterm = TRUE,bufptr = s,(int)LISTOP) + +char * +skipspace(s) +register char *s; +{ + while (s < bufend && isSPACE(*s)) + s++; + return s; +} + +void +check_uni() { + char *s; + char ch; + + if (oldoldbufptr != last_uni) + return; + while (isSPACE(*last_uni)) + last_uni++; + for (s = last_uni; isALNUM(*s); s++) ; + ch = *s; + *s = '\0'; + warn("Warning: Use of \"%s\" without parens is ambiguous", last_uni); + *s = ch; +} + +#ifdef CRIPPLED_CC + +#undef UNI +#undef LOP +#define UNI(f) return uni(f,s) +#define LOP(f) return lop(f,s) + +int +uni(f,s) +int f; +char *s; +{ + yylval.ival = f; + expectterm = TRUE; + bufptr = s; + last_uni = oldbufptr; + if (*s == '(') + return FUNC1; + s = skipspace(s); + if (*s == '(') + return FUNC1; + else + return UNIOP; +} + +int +lop(f,s) +int f; +char *s; +{ + CLINE; + if (*s != '(') + s = skipspace(s); + if (*s == '(') { +#ifdef atarist + *s = PERL_META('('); +#else + *s = META('('); +#endif + bufptr = oldbufptr; + return '('; + } + else { + yylval.ival=f; + expectterm = TRUE; + bufptr = s; + return LISTOP; + } +} + +#endif /* CRIPPLED_CC */ + +int +yylex() +{ + register char *s = bufptr; + register char *d; + register int tmp; + static bool in_format = FALSE; + static bool firstline = TRUE; + extern int yychar; /* last token */ + + oldoldbufptr = oldbufptr; + oldbufptr = s; + + retry: +#ifdef YYDEBUG + if (debug & 1) + if (index(s,'\n')) + fprintf(stderr,"Tokener at %s",s); + else + fprintf(stderr,"Tokener at %s\n",s); +#endif +#ifdef BADSWITCH + if (*s & 128) { + if ((*s & 127) == '(') { + *s++ = '('; + oldbufptr = s; + } + else if ((*s & 127) == '}') { + *s++ = '}'; + RETURN('}'); + } + else + warn("Unrecognized character \\%03o ignored", *s++ & 255); + goto retry; + } +#endif + switch (*s) { + default: + if ((*s & 127) == '(') { + *s++ = '('; + oldbufptr = s; + } + else if ((*s & 127) == '}') { + *s++ = '}'; + RETURN('}'); + } + else + warn("Unrecognized character \\%03o ignored", *s++ & 255); + goto retry; + case 4: + case 26: + goto fake_eof; /* emulate EOF on ^D or ^Z */ + case 0: + if (!rsfp) + RETURN(0); + if (s++ < bufend) + goto retry; /* ignore stray nulls */ + last_uni = 0; + if (firstline) { + firstline = FALSE; + if (minus_n || minus_p || perldb) { + str_set(linestr,""); + if (perldb) { + char *getenv(); + char *pdb = getenv("PERLDB"); + + str_cat(linestr, pdb ? pdb : "require 'perldb.pl'"); + str_cat(linestr, ";"); + } + if (minus_n || minus_p) { + str_cat(linestr,"line: while (<>) {"); + if (minus_l) + str_cat(linestr,"chop;"); + if (minus_a) + str_cat(linestr,"@F=split(' ');"); + } + oldoldbufptr = oldbufptr = s = str_get(linestr); + bufend = linestr->str_ptr + linestr->str_cur; + goto retry; + } + } + if (in_format) { + bufptr = bufend; + yylval.formval = load_format(); + in_format = FALSE; + oldoldbufptr = oldbufptr = s = str_get(linestr) + 1; + bufend = linestr->str_ptr + linestr->str_cur; + OPERATOR(FORMLIST); + } + curcmd->c_line++; +#ifdef CRYPTSCRIPT + cryptswitch(); +#endif /* CRYPTSCRIPT */ + do { + if ((s = str_gets(linestr, rsfp, 0)) == Nullch) { + fake_eof: + if (rsfp) { + if (preprocess) + (void)mypclose(rsfp); + else if ((FILE*)rsfp == stdin) + clearerr(stdin); + else + (void)fclose(rsfp); + rsfp = Nullfp; + } + if (minus_n || minus_p) { + str_set(linestr,minus_p ? ";}continue{print" : ""); + str_cat(linestr,";}"); + oldoldbufptr = oldbufptr = s = str_get(linestr); + bufend = linestr->str_ptr + linestr->str_cur; + minus_n = minus_p = 0; + goto retry; + } + oldoldbufptr = oldbufptr = s = str_get(linestr); + str_set(linestr,""); + RETURN(';'); /* not infinite loop because rsfp is NULL now */ + } + if (doextract && *linestr->str_ptr == '#') + doextract = FALSE; + } while (doextract); + oldoldbufptr = oldbufptr = bufptr = s; + if (perldb) { + STR *str = Str_new(85,0); + + str_sset(str,linestr); + astore(stab_xarray(curcmd->c_filestab),(int)curcmd->c_line,str); + } +#ifdef DEBUG + if (firstline) { + char *showinput(); + s = showinput(); + } +#endif + bufend = linestr->str_ptr + linestr->str_cur; + if (curcmd->c_line == 1) { + if (*s == '#' && s[1] == '!') { + if (!in_eval && !instr(s,"perl") && instr(origargv[0],"perl")) { + char **newargv; + char *cmd; + + s += 2; + if (*s == ' ') + s++; + cmd = s; + while (s < bufend && !isSPACE(*s)) + s++; + *s++ = '\0'; + while (s < bufend && isSPACE(*s)) + s++; + if (s < bufend) { + Newz(899,newargv,origargc+3,char*); + newargv[1] = s; + while (s < bufend && !isSPACE(*s)) + s++; + *s = '\0'; + Copy(origargv+1, newargv+2, origargc+1, char*); + } + else + newargv = origargv; + newargv[0] = cmd; + execv(cmd,newargv); + fatal("Can't exec %s", cmd); + } + } + else { + while (s < bufend && isSPACE(*s)) + s++; + if (*s == ':') /* for csh's that have to exec sh scripts */ + s++; + } + } + goto retry; + case ' ': case '\t': case '\f': case '\r': case 013: + s++; + goto retry; + case '#': + if (preprocess && s == str_get(linestr) && + 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++; + s[strlen(s)-1] = '\0'; /* wipe out newline */ + if (*s == '"') { + s++; + s[strlen(s)-1] = '\0'; /* wipe out trailing quote */ + } + if (*s) + curcmd->c_filestab = fstab(s); + else + curcmd->c_filestab = fstab(origfilename); + oldoldbufptr = oldbufptr = s = str_get(linestr); + } + /* FALL THROUGH */ + case '\n': + if (in_eval && !rsfp) { + d = bufend; + while (s < d && *s != '\n') + s++; + if (s < d) + s++; + if (in_format) { + bufptr = s; + yylval.formval = load_format(); + in_format = FALSE; + oldoldbufptr = oldbufptr = s = bufptr + 1; + TERM(FORMLIST); + } + curcmd->c_line++; + } + else { + *s = '\0'; + bufend = s; + } + goto retry; + case '-': + if (s[1] && isALPHA(s[1]) && !isALPHA(s[2])) { + s++; + switch (*s++) { + case 'r': FTST(O_FTEREAD); + case 'w': FTST(O_FTEWRITE); + case 'x': FTST(O_FTEEXEC); + case 'o': FTST(O_FTEOWNED); + case 'R': FTST(O_FTRREAD); + case 'W': FTST(O_FTRWRITE); + case 'X': FTST(O_FTREXEC); + case 'O': FTST(O_FTROWNED); + case 'e': FTST(O_FTIS); + case 'z': FTST(O_FTZERO); + case 's': FTST(O_FTSIZE); + case 'f': FTST(O_FTFILE); + case 'd': FTST(O_FTDIR); + case 'l': FTST(O_FTLINK); + case 'p': FTST(O_FTPIPE); + case 'S': FTST(O_FTSOCK); + case 'u': FTST(O_FTSUID); + case 'g': FTST(O_FTSGID); + case 'k': FTST(O_FTSVTX); + case 'b': FTST(O_FTBLK); + case 'c': FTST(O_FTCHR); + case 't': FTST(O_FTTTY); + case 'T': FTST(O_FTTEXT); + case 'B': FTST(O_FTBINARY); + case 'M': stabent("\024",TRUE); FTST(O_FTMTIME); + case 'A': stabent("\024",TRUE); FTST(O_FTATIME); + case 'C': stabent("\024",TRUE); FTST(O_FTCTIME); + default: + s -= 2; + break; + } + } + tmp = *s++; + if (*s == tmp) { + s++; + RETURN(DEC); + } + if (expectterm) { + if (isSPACE(*s) || !isSPACE(*bufptr)) + check_uni(); + OPERATOR('-'); + } + else + AOP(O_SUBTRACT); + case '+': + tmp = *s++; + if (*s == tmp) { + s++; + RETURN(INC); + } + if (expectterm) { + if (isSPACE(*s) || !isSPACE(*bufptr)) + check_uni(); + OPERATOR('+'); + } + else + AOP(O_ADD); + + case '*': + if (expectterm) { + check_uni(); + s = scanident(s,bufend,tokenbuf); + yylval.stabval = stabent(tokenbuf,TRUE); + TERM(STAR); + } + tmp = *s++; + if (*s == tmp) { + s++; + OPERATOR(POW); + } + MOP(O_MULTIPLY); + case '%': + if (expectterm) { + if (!isALPHA(s[1])) + check_uni(); + s = scanident(s,bufend,tokenbuf); + yylval.stabval = hadd(stabent(tokenbuf,TRUE)); + TERM(HSH); + } + s++; + MOP(O_MODULO); + + case '^': + case '~': + case '(': + case ',': + case ':': + case '[': + tmp = *s++; + OPERATOR(tmp); + case '{': + tmp = *s++; + yylval.ival = curcmd->c_line; + if (isSPACE(*s) || *s == '#') + cmdline = NOLINE; /* invalidate current command line number */ + expectterm = 2; + RETURN(tmp); + case ';': + if (curcmd->c_line < cmdline) + cmdline = curcmd->c_line; + tmp = *s++; + OPERATOR(tmp); + case ')': + case ']': + tmp = *s++; + TERM(tmp); + case '}': + *s |= 128; + RETURN(';'); + case '&': + s++; + tmp = *s++; + if (tmp == '&') + OPERATOR(ANDAND); + s--; + if (expectterm) { + d = bufend; + while (s < d && isSPACE(*s)) + s++; + if (isALPHA(*s) || *s == '_' || *s == '\'') + *(--s) = '\\'; /* force next ident to WORD */ + else + check_uni(); + OPERATOR(AMPER); + } + OPERATOR('&'); + case '|': + s++; + tmp = *s++; + if (tmp == '|') + OPERATOR(OROR); + s--; + OPERATOR('|'); + case '=': + s++; + tmp = *s++; + if (tmp == '=') + EOP(O_EQ); + if (tmp == '~') + OPERATOR(MATCH); + s--; + OPERATOR('='); + case '!': + s++; + tmp = *s++; + if (tmp == '=') + EOP(O_NE); + if (tmp == '~') + OPERATOR(NMATCH); + s--; + OPERATOR('!'); + case '<': + if (expectterm) { + if (s[1] != '<' && !index(s,'>')) + check_uni(); + s = scanstr(s, SCAN_DEF); + TERM(RSTRING); + } + s++; + tmp = *s++; + if (tmp == '<') + OPERATOR(LS); + if (tmp == '=') { + tmp = *s++; + if (tmp == '>') + EOP(O_NCMP); + s--; + ROP(O_LE); + } + s--; + ROP(O_LT); + case '>': + s++; + tmp = *s++; + if (tmp == '>') + OPERATOR(RS); + if (tmp == '=') + ROP(O_GE); + s--; + ROP(O_GT); + +#define SNARFWORD \ + d = tokenbuf; \ + while (isALNUM(*s) || *s == '\'') \ + *d++ = *s++; \ + while (d[-1] == '\'') \ + d--,s--; \ + *d = '\0'; \ + d = tokenbuf; + + case '$': + if (s[1] == '#' && (isALPHA(s[2]) || s[2] == '_')) { + s++; + s = scanident(s,bufend,tokenbuf); + yylval.stabval = aadd(stabent(tokenbuf,TRUE)); + TERM(ARYLEN); + } + d = s; + s = scanident(s,bufend,tokenbuf); + if (reparse) { /* turn ${foo[bar]} into ($foo[bar]) */ + do_reparse: + s[-1] = ')'; + s = d; + s[1] = s[0]; + s[0] = '('; + goto retry; + } + yylval.stabval = stabent(tokenbuf,TRUE); + expectterm = FALSE; + if (isSPACE(*s) && oldoldbufptr && oldoldbufptr < bufptr) { + s++; + while (isSPACE(*oldoldbufptr)) + oldoldbufptr++; + if (*oldoldbufptr == 'p' && strnEQ(oldoldbufptr,"print",5)) { + if (index("&*<%", *s) && isALPHA(s[1])) + expectterm = TRUE; /* e.g. print $fh &sub */ + else if (*s == '.' && isDIGIT(s[1])) + expectterm = TRUE; /* e.g. print $fh .3 */ + else if (index("/?-+", *s) && !isSPACE(s[1])) + expectterm = TRUE; /* e.g. print $fh -1 */ + } + } + RETURN(REG); + + case '@': + d = s; + s = scanident(s,bufend,tokenbuf); + if (reparse) + goto do_reparse; + yylval.stabval = aadd(stabent(tokenbuf,TRUE)); + TERM(ARY); + + case '/': /* may either be division or pattern */ + case '?': /* may either be conditional or pattern */ + if (expectterm) { + check_uni(); + s = scanpat(s); + TERM(PATTERN); + } + tmp = *s++; + if (tmp == '/') + MOP(O_DIVIDE); + OPERATOR(tmp); + + case '.': + if (!expectterm || !isDIGIT(s[1])) { + tmp = *s++; + if (*s == tmp) { + s++; + if (*s == tmp) { + s++; + yylval.ival = 0; + } + else + yylval.ival = AF_COMMON; + OPERATOR(DOTDOT); + } + if (expectterm) + check_uni(); + AOP(O_CONCAT); + } + /* FALL THROUGH */ + case '0': case '1': case '2': case '3': case '4': + case '5': case '6': case '7': case '8': case '9': + case '\'': case '"': case '`': + s = scanstr(s, SCAN_DEF); + TERM(RSTRING); + + case '\\': /* some magic to force next word to be a WORD */ + s++; /* used by do and sub to force a separate namespace */ + if (!isALPHA(*s) && *s != '_' && *s != '\'') { + warn("Spurious backslash ignored"); + goto retry; + } + /* FALL THROUGH */ + case '_': + SNARFWORD; + if (d[1] == '_') { + if (strEQ(d,"__LINE__") || strEQ(d,"__FILE__")) { + ARG *arg = op_new(1); + + yylval.arg = arg; + arg->arg_type = O_ITEM; + if (d[2] == 'L') + (void)sprintf(tokenbuf,"%ld",(long)curcmd->c_line); + else + strcpy(tokenbuf, stab_val(curcmd->c_filestab)->str_ptr); + arg[1].arg_type = A_SINGLE; + arg[1].arg_ptr.arg_str = str_make(tokenbuf,strlen(tokenbuf)); + TERM(RSTRING); + } + else if (strEQ(d,"__END__")) { + STAB *stab; + int fd; + + /*SUPPRESS 560*/ + if (!in_eval && (stab = stabent("DATA",FALSE))) { + stab->str_pok |= SP_MULTI; + if (!stab_io(stab)) + stab_io(stab) = stio_new(); + stab_io(stab)->ifp = rsfp; +#if defined(HAS_FCNTL) && defined(F_SETFD) + fd = fileno(rsfp); + fcntl(fd,F_SETFD,fd >= 3); +#endif + if (preprocess) + stab_io(stab)->type = '|'; + else if ((FILE*)rsfp == stdin) + stab_io(stab)->type = '-'; + else + stab_io(stab)->type = '<'; + rsfp = Nullfp; + } + goto fake_eof; + } + } + break; + case 'a': case 'A': + SNARFWORD; + if (strEQ(d,"alarm")) + UNI(O_ALARM); + if (strEQ(d,"accept")) + FOP22(O_ACCEPT); + if (strEQ(d,"atan2")) + FUN2(O_ATAN2); + break; + case 'b': case 'B': + SNARFWORD; + if (strEQ(d,"bind")) + FOP2(O_BIND); + if (strEQ(d,"binmode")) + FOP(O_BINMODE); + break; + case 'c': case 'C': + SNARFWORD; + if (strEQ(d,"chop")) + LFUN(O_CHOP); + if (strEQ(d,"continue")) + OPERATOR(CONTINUE); + if (strEQ(d,"chdir")) { + (void)stabent("ENV",TRUE); /* may use HOME */ + UNI(O_CHDIR); + } + if (strEQ(d,"close")) + FOP(O_CLOSE); + if (strEQ(d,"closedir")) + FOP(O_CLOSEDIR); + if (strEQ(d,"cmp")) + EOP(O_SCMP); + if (strEQ(d,"caller")) + UNI(O_CALLER); + if (strEQ(d,"crypt")) { +#ifdef FCRYPT + static int cryptseen = 0; + + if (!cryptseen++) + init_des(); +#endif + FUN2(O_CRYPT); + } + if (strEQ(d,"chmod")) + LOP(O_CHMOD); + if (strEQ(d,"chown")) + LOP(O_CHOWN); + if (strEQ(d,"connect")) + FOP2(O_CONNECT); + if (strEQ(d,"cos")) + UNI(O_COS); + if (strEQ(d,"chroot")) + UNI(O_CHROOT); + break; + case 'd': case 'D': + SNARFWORD; + if (strEQ(d,"do")) { + d = bufend; + while (s < d && isSPACE(*s)) + s++; + if (isALPHA(*s) || *s == '_') + *(--s) = '\\'; /* force next ident to WORD */ + OPERATOR(DO); + } + if (strEQ(d,"die")) + LOP(O_DIE); + if (strEQ(d,"defined")) + LFUN(O_DEFINED); + if (strEQ(d,"delete")) + OPERATOR(DELETE); + if (strEQ(d,"dbmopen")) + HFUN3(O_DBMOPEN); + if (strEQ(d,"dbmclose")) + HFUN(O_DBMCLOSE); + if (strEQ(d,"dump")) + LOOPX(O_DUMP); + break; + case 'e': case 'E': + SNARFWORD; + if (strEQ(d,"else")) + OPERATOR(ELSE); + if (strEQ(d,"elsif")) { + yylval.ival = curcmd->c_line; + OPERATOR(ELSIF); + } + if (strEQ(d,"eq") || strEQ(d,"EQ")) + EOP(O_SEQ); + if (strEQ(d,"exit")) + UNI(O_EXIT); + if (strEQ(d,"eval")) { + allstabs = TRUE; /* must initialize everything since */ + UNI(O_EVAL); /* we don't know what will be used */ + } + if (strEQ(d,"eof")) + FOP(O_EOF); + if (strEQ(d,"exp")) + UNI(O_EXP); + if (strEQ(d,"each")) + HFUN(O_EACH); + if (strEQ(d,"exec")) { + set_csh(); + LOP(O_EXEC_OP); + } + if (strEQ(d,"endhostent")) + FUN0(O_EHOSTENT); + if (strEQ(d,"endnetent")) + FUN0(O_ENETENT); + if (strEQ(d,"endservent")) + FUN0(O_ESERVENT); + if (strEQ(d,"endprotoent")) + FUN0(O_EPROTOENT); + if (strEQ(d,"endpwent")) + FUN0(O_EPWENT); + if (strEQ(d,"endgrent")) + FUN0(O_EGRENT); + break; + case 'f': case 'F': + SNARFWORD; + if (strEQ(d,"for") || strEQ(d,"foreach")) { + yylval.ival = curcmd->c_line; + while (s < bufend && isSPACE(*s)) + s++; + if (isALPHA(*s)) + fatal("Missing $ on loop variable"); + OPERATOR(FOR); + } + if (strEQ(d,"format")) { + d = bufend; + while (s < d && isSPACE(*s)) + s++; + if (isALPHA(*s) || *s == '_') + *(--s) = '\\'; /* force next ident to WORD */ + in_format = TRUE; + allstabs = TRUE; /* must initialize everything since */ + OPERATOR(FORMAT); /* we don't know what will be used */ + } + if (strEQ(d,"fork")) + FUN0(O_FORK); + if (strEQ(d,"fcntl")) + FOP3(O_FCNTL); + if (strEQ(d,"fileno")) + FOP(O_FILENO); + if (strEQ(d,"flock")) + FOP2(O_FLOCK); + break; + case 'g': case 'G': + SNARFWORD; + if (strEQ(d,"gt") || strEQ(d,"GT")) + ROP(O_SGT); + if (strEQ(d,"ge") || strEQ(d,"GE")) + ROP(O_SGE); + if (strEQ(d,"grep")) + FL2(O_GREP); + if (strEQ(d,"goto")) + LOOPX(O_GOTO); + if (strEQ(d,"gmtime")) + UNI(O_GMTIME); + if (strEQ(d,"getc")) + FOP(O_GETC); + if (strnEQ(d,"get",3)) { + d += 3; + if (*d == 'p') { + if (strEQ(d,"ppid")) + FUN0(O_GETPPID); + if (strEQ(d,"pgrp")) + UNI(O_GETPGRP); + if (strEQ(d,"priority")) + FUN2(O_GETPRIORITY); + if (strEQ(d,"protobyname")) + UNI(O_GPBYNAME); + if (strEQ(d,"protobynumber")) + FUN1(O_GPBYNUMBER); + if (strEQ(d,"protoent")) + FUN0(O_GPROTOENT); + if (strEQ(d,"pwent")) + FUN0(O_GPWENT); + if (strEQ(d,"pwnam")) + FUN1(O_GPWNAM); + if (strEQ(d,"pwuid")) + FUN1(O_GPWUID); + if (strEQ(d,"peername")) + FOP(O_GETPEERNAME); + } + else if (*d == 'h') { + if (strEQ(d,"hostbyname")) + UNI(O_GHBYNAME); + if (strEQ(d,"hostbyaddr")) + FUN2(O_GHBYADDR); + if (strEQ(d,"hostent")) + FUN0(O_GHOSTENT); + } + else if (*d == 'n') { + if (strEQ(d,"netbyname")) + UNI(O_GNBYNAME); + if (strEQ(d,"netbyaddr")) + FUN2(O_GNBYADDR); + if (strEQ(d,"netent")) + FUN0(O_GNETENT); + } + else if (*d == 's') { + if (strEQ(d,"servbyname")) + FUN2(O_GSBYNAME); + if (strEQ(d,"servbyport")) + FUN2(O_GSBYPORT); + if (strEQ(d,"servent")) + FUN0(O_GSERVENT); + if (strEQ(d,"sockname")) + FOP(O_GETSOCKNAME); + if (strEQ(d,"sockopt")) + FOP3(O_GSOCKOPT); + } + else if (*d == 'g') { + if (strEQ(d,"grent")) + FUN0(O_GGRENT); + if (strEQ(d,"grnam")) + FUN1(O_GGRNAM); + if (strEQ(d,"grgid")) + FUN1(O_GGRGID); + } + else if (*d == 'l') { + if (strEQ(d,"login")) + FUN0(O_GETLOGIN); + } + d -= 3; + } + break; + case 'h': case 'H': + SNARFWORD; + if (strEQ(d,"hex")) + UNI(O_HEX); + break; + case 'i': case 'I': + SNARFWORD; + if (strEQ(d,"if")) { + yylval.ival = curcmd->c_line; + OPERATOR(IF); + } + if (strEQ(d,"index")) + FUN2x(O_INDEX); + if (strEQ(d,"int")) + UNI(O_INT); + if (strEQ(d,"ioctl")) + FOP3(O_IOCTL); + break; + case 'j': case 'J': + SNARFWORD; + if (strEQ(d,"join")) + FL2(O_JOIN); + break; + case 'k': case 'K': + SNARFWORD; + if (strEQ(d,"keys")) + HFUN(O_KEYS); + if (strEQ(d,"kill")) + LOP(O_KILL); + break; + case 'l': case 'L': + SNARFWORD; + if (strEQ(d,"last")) + LOOPX(O_LAST); + if (strEQ(d,"local")) + OPERATOR(LOCAL); + if (strEQ(d,"length")) + UNI(O_LENGTH); + if (strEQ(d,"lt") || strEQ(d,"LT")) + ROP(O_SLT); + if (strEQ(d,"le") || strEQ(d,"LE")) + ROP(O_SLE); + if (strEQ(d,"localtime")) + UNI(O_LOCALTIME); + if (strEQ(d,"log")) + UNI(O_LOG); + if (strEQ(d,"link")) + FUN2(O_LINK); + if (strEQ(d,"listen")) + FOP2(O_LISTEN); + if (strEQ(d,"lstat")) + FOP(O_LSTAT); + break; + case 'm': case 'M': + if (s[1] == '\'') { + d = "m"; + s++; + } + else { + SNARFWORD; + } + if (strEQ(d,"m")) { + s = scanpat(s-1); + if (yylval.arg) + TERM(PATTERN); + else + RETURN(1); /* force error */ + } + switch (d[1]) { + case 'k': + if (strEQ(d,"mkdir")) + FUN2(O_MKDIR); + break; + case 's': + if (strEQ(d,"msgctl")) + FUN3(O_MSGCTL); + if (strEQ(d,"msgget")) + FUN2(O_MSGGET); + if (strEQ(d,"msgrcv")) + FUN5(O_MSGRCV); + if (strEQ(d,"msgsnd")) + FUN3(O_MSGSND); + break; + } + break; + case 'n': case 'N': + SNARFWORD; + if (strEQ(d,"next")) + LOOPX(O_NEXT); + if (strEQ(d,"ne") || strEQ(d,"NE")) + EOP(O_SNE); + break; + case 'o': case 'O': + SNARFWORD; + if (strEQ(d,"open")) + OPERATOR(OPEN); + if (strEQ(d,"ord")) + UNI(O_ORD); + if (strEQ(d,"oct")) + UNI(O_OCT); + if (strEQ(d,"opendir")) + FOP2(O_OPEN_DIR); + break; + case 'p': case 'P': + SNARFWORD; + if (strEQ(d,"print")) { + checkcomma(s,d,"filehandle"); + LOP(O_PRINT); + } + if (strEQ(d,"printf")) { + checkcomma(s,d,"filehandle"); + LOP(O_PRTF); + } + if (strEQ(d,"push")) { + yylval.ival = O_PUSH; + OPERATOR(PUSH); + } + if (strEQ(d,"pop")) + OPERATOR(POP); + if (strEQ(d,"pack")) + FL2(O_PACK); + if (strEQ(d,"package")) + OPERATOR(PACKAGE); + if (strEQ(d,"pipe")) + FOP22(O_PIPE_OP); + break; + case 'q': case 'Q': + SNARFWORD; + if (strEQ(d,"q")) { + s = scanstr(s-1, SCAN_DEF); + TERM(RSTRING); + } + if (strEQ(d,"qq")) { + s = scanstr(s-2, SCAN_DEF); + TERM(RSTRING); + } + if (strEQ(d,"qx")) { + s = scanstr(s-2, SCAN_DEF); + TERM(RSTRING); + } + break; + case 'r': case 'R': + SNARFWORD; + if (strEQ(d,"return")) + OLDLOP(O_RETURN); + if (strEQ(d,"require")) { + allstabs = TRUE; /* must initialize everything since */ + UNI(O_REQUIRE); /* we don't know what will be used */ + } + if (strEQ(d,"reset")) + UNI(O_RESET); + if (strEQ(d,"redo")) + LOOPX(O_REDO); + if (strEQ(d,"rename")) + FUN2(O_RENAME); + if (strEQ(d,"rand")) + UNI(O_RAND); + if (strEQ(d,"rmdir")) + UNI(O_RMDIR); + if (strEQ(d,"rindex")) + FUN2x(O_RINDEX); + if (strEQ(d,"read")) + FOP3(O_READ); + if (strEQ(d,"readdir")) + FOP(O_READDIR); + if (strEQ(d,"rewinddir")) + FOP(O_REWINDDIR); + if (strEQ(d,"recv")) + FOP4(O_RECV); + if (strEQ(d,"reverse")) + LOP(O_REVERSE); + if (strEQ(d,"readlink")) + UNI(O_READLINK); + break; + case 's': case 'S': + if (s[1] == '\'') { + d = "s"; + s++; + } + else { + SNARFWORD; + } + if (strEQ(d,"s")) { + s = scansubst(s); + if (yylval.arg) + TERM(SUBST); + else + RETURN(1); /* force error */ + } + switch (d[1]) { + case 'a': + case 'b': + break; + case 'c': + if (strEQ(d,"scalar")) + UNI(O_SCALAR); + break; + case 'd': + break; + case 'e': + if (strEQ(d,"select")) + OPERATOR(SSELECT); + if (strEQ(d,"seek")) + FOP3(O_SEEK); + if (strEQ(d,"semctl")) + FUN4(O_SEMCTL); + if (strEQ(d,"semget")) + FUN3(O_SEMGET); + if (strEQ(d,"semop")) + FUN2(O_SEMOP); + if (strEQ(d,"send")) + FOP3(O_SEND); + if (strEQ(d,"setpgrp")) + FUN2(O_SETPGRP); + if (strEQ(d,"setpriority")) + FUN3(O_SETPRIORITY); + if (strEQ(d,"sethostent")) + FUN1(O_SHOSTENT); + if (strEQ(d,"setnetent")) + FUN1(O_SNETENT); + if (strEQ(d,"setservent")) + FUN1(O_SSERVENT); + if (strEQ(d,"setprotoent")) + FUN1(O_SPROTOENT); + if (strEQ(d,"setpwent")) + FUN0(O_SPWENT); + if (strEQ(d,"setgrent")) + FUN0(O_SGRENT); + if (strEQ(d,"seekdir")) + FOP2(O_SEEKDIR); + if (strEQ(d,"setsockopt")) + FOP4(O_SSOCKOPT); + break; + case 'f': + case 'g': + break; + case 'h': + if (strEQ(d,"shift")) + TERM(SHIFT); + if (strEQ(d,"shmctl")) + FUN3(O_SHMCTL); + if (strEQ(d,"shmget")) + FUN3(O_SHMGET); + if (strEQ(d,"shmread")) + FUN4(O_SHMREAD); + if (strEQ(d,"shmwrite")) + FUN4(O_SHMWRITE); + if (strEQ(d,"shutdown")) + FOP2(O_SHUTDOWN); + break; + case 'i': + if (strEQ(d,"sin")) + UNI(O_SIN); + break; + case 'j': + case 'k': + break; + case 'l': + if (strEQ(d,"sleep")) + UNI(O_SLEEP); + break; + case 'm': + case 'n': + break; + case 'o': + if (strEQ(d,"socket")) + FOP4(O_SOCKET); + if (strEQ(d,"socketpair")) + FOP25(O_SOCKPAIR); + if (strEQ(d,"sort")) { + checkcomma(s,d,"subroutine name"); + d = bufend; + while (s < d && isSPACE(*s)) s++; + if (*s == ';' || *s == ')') /* probably a close */ + fatal("sort is now a reserved word"); + if (isALPHA(*s) || *s == '_') { + /*SUPPRESS 530*/ + for (d = s; isALNUM(*d); d++) ; + strncpy(tokenbuf,s,d-s); + tokenbuf[d-s] = '\0'; + if (strNE(tokenbuf,"keys") && + strNE(tokenbuf,"values") && + strNE(tokenbuf,"split") && + strNE(tokenbuf,"grep") && + strNE(tokenbuf,"readdir") && + strNE(tokenbuf,"unpack") && + strNE(tokenbuf,"do") && + strNE(tokenbuf,"eval") && + (d >= bufend || isSPACE(*d)) ) + *(--s) = '\\'; /* force next ident to WORD */ + } + LOP(O_SORT); + } + break; + case 'p': + if (strEQ(d,"split")) + TERM(SPLIT); + if (strEQ(d,"sprintf")) + FL(O_SPRINTF); + if (strEQ(d,"splice")) { + yylval.ival = O_SPLICE; + OPERATOR(PUSH); + } + break; + case 'q': + if (strEQ(d,"sqrt")) + UNI(O_SQRT); + break; + case 'r': + if (strEQ(d,"srand")) + UNI(O_SRAND); + break; + case 's': + break; + case 't': + if (strEQ(d,"stat")) + FOP(O_STAT); + if (strEQ(d,"study")) { + sawstudy++; + LFUN(O_STUDY); + } + break; + case 'u': + if (strEQ(d,"substr")) + FUN2x(O_SUBSTR); + if (strEQ(d,"sub")) { + yylval.ival = savestack->ary_fill; /* restore stuff on reduce */ + savelong(&subline); + saveitem(subname); + + subline = curcmd->c_line; + d = bufend; + while (s < d && isSPACE(*s)) + s++; + if (isALPHA(*s) || *s == '_' || *s == '\'') { + str_sset(subname,curstname); + str_ncat(subname,"'",1); + for (d = s+1; isALNUM(*d) || *d == '\''; d++) + /*SUPPRESS 530*/ + ; + if (d[-1] == '\'') + d--; + str_ncat(subname,s,d-s); + *(--s) = '\\'; /* force next ident to WORD */ + } + else + str_set(subname,"?"); + OPERATOR(SUB); + } + break; + case 'v': + case 'w': + case 'x': + break; + case 'y': + if (strEQ(d,"system")) { + set_csh(); + LOP(O_SYSTEM); + } + if (strEQ(d,"symlink")) + FUN2(O_SYMLINK); + if (strEQ(d,"syscall")) + LOP(O_SYSCALL); + if (strEQ(d,"sysread")) + FOP3(O_SYSREAD); + if (strEQ(d,"syswrite")) + FOP3(O_SYSWRITE); + break; + case 'z': + break; + } + break; + case 't': case 'T': + SNARFWORD; + if (strEQ(d,"tr")) { + s = scantrans(s); + if (yylval.arg) + TERM(TRANS); + else + RETURN(1); /* force error */ + } + if (strEQ(d,"tell")) + FOP(O_TELL); + if (strEQ(d,"telldir")) + FOP(O_TELLDIR); + if (strEQ(d,"time")) + FUN0(O_TIME); + if (strEQ(d,"times")) + FUN0(O_TMS); + if (strEQ(d,"truncate")) + FOP2(O_TRUNCATE); + break; + case 'u': case 'U': + SNARFWORD; + if (strEQ(d,"using")) + OPERATOR(USING); + if (strEQ(d,"until")) { + yylval.ival = curcmd->c_line; + OPERATOR(UNTIL); + } + if (strEQ(d,"unless")) { + yylval.ival = curcmd->c_line; + OPERATOR(UNLESS); + } + if (strEQ(d,"unlink")) + LOP(O_UNLINK); + if (strEQ(d,"undef")) + LFUN(O_UNDEF); + if (strEQ(d,"unpack")) + FUN2(O_UNPACK); + if (strEQ(d,"utime")) + LOP(O_UTIME); + if (strEQ(d,"umask")) + UNI(O_UMASK); + if (strEQ(d,"unshift")) { + yylval.ival = O_UNSHIFT; + OPERATOR(PUSH); + } + break; + case 'v': case 'V': + SNARFWORD; + if (strEQ(d,"values")) + HFUN(O_VALUES); + if (strEQ(d,"vec")) { + sawvec = TRUE; + FUN3(O_VEC); + } + break; + case 'w': case 'W': + SNARFWORD; + if (strEQ(d,"while")) { + yylval.ival = curcmd->c_line; + OPERATOR(WHILE); + } + if (strEQ(d,"warn")) + LOP(O_WARN); + if (strEQ(d,"wait")) + FUN0(O_WAIT); + if (strEQ(d,"waitpid")) + FUN2(O_WAITPID); + if (strEQ(d,"wantarray")) { + yylval.arg = op_new(1); + yylval.arg->arg_type = O_ITEM; + yylval.arg[1].arg_type = A_WANTARRAY; + TERM(RSTRING); + } + if (strEQ(d,"write")) + FOP(O_WRITE); + break; + case 'x': case 'X': + if (*s == 'x' && isDIGIT(s[1]) && !expectterm) { + s++; + MOP(O_REPEAT); + } + SNARFWORD; + if (strEQ(d,"x")) { + if (!expectterm) + MOP(O_REPEAT); + check_uni(); + } + break; + case 'y': case 'Y': + if (s[1] == '\'') { + d = "y"; + s++; + } + else { + SNARFWORD; + } + if (strEQ(d,"y")) { + s = scantrans(s); + TERM(TRANS); + } + break; + case 'z': case 'Z': + SNARFWORD; + break; + } + yylval.cval = savestr(d); + if (expectterm == 2) { /* special case: start of statement */ + while (isSPACE(*s)) s++; + if (*s == ':') { + s++; + CLINE; + OPERATOR(LABEL); + } + TERM(WORD); + } + expectterm = FALSE; + if (oldoldbufptr && oldoldbufptr < bufptr) { + while (isSPACE(*oldoldbufptr)) + oldoldbufptr++; + if (*oldoldbufptr == 'p' && strnEQ(oldoldbufptr,"print",5)) + expectterm = TRUE; + else if (*oldoldbufptr == 's' && strnEQ(oldoldbufptr,"sort",4)) + expectterm = TRUE; + } + return (CLINE, bufptr = s, (int)WORD); +} + +void +checkcomma(s,name,what) +register char *s; +char *name; +char *what; +{ + char *w; + + if (dowarn && *s == ' ' && s[1] == '(') { + w = index(s,')'); + if (w) + for (w++; *w && isSPACE(*w); w++) ; + if (!w || !*w || !index(";|}", *w)) /* an advisory hack only... */ + warn("%s (...) interpreted as function",name); + } + while (s < bufend && isSPACE(*s)) + s++; + if (*s == '(') + s++; + while (s < bufend && isSPACE(*s)) + s++; + if (isALPHA(*s) || *s == '_') { + w = s++; + while (isALNUM(*s)) + s++; + while (s < bufend && isSPACE(*s)) + s++; + if (*s == ',') { + *s = '\0'; + w = instr( + "tell eof times getlogin wait length shift umask getppid \ + cos exp int log rand sin sqrt ord wantarray", + w); + *s = ','; + if (w) + return; + fatal("No comma allowed after %s", what); + } + } +} + +char * +scanident(s,send,dest) +register char *s; +register char *send; +char *dest; +{ + register char *d; + int brackets = 0; + + reparse = Nullch; + s++; + d = dest; + if (isDIGIT(*s)) { + while (isDIGIT(*s)) + *d++ = *s++; + } + else { + while (isALNUM(*s) || *s == '\'') + *d++ = *s++; + } + while (d > dest+1 && d[-1] == '\'') + d--,s--; + *d = '\0'; + d = dest; + if (!*d) { + *d = *s++; + if (*d == '{' /* } */ ) { + d = dest; + brackets++; + while (s < send && brackets) { + if (!reparse && (d == dest || (*s && isALNUM(*s) ))) { + *d++ = *s++; + continue; + } + else if (!reparse) + reparse = s; + switch (*s++) { + /* { */ + case '}': + brackets--; + if (reparse && reparse == s - 1) + reparse = Nullch; + break; + case '{': /* } */ + brackets++; + break; + } + } + *d = '\0'; + d = dest; + } + else + d[1] = '\0'; + } + if (*d == '^' && (isUPPER(*s) || index("[\\]^_?", *s))) { +#ifdef DEBUGGING + if (*s == 'D') + debug |= 32768; +#endif + *d = *s++ ^ 64; + } + return s; +} + +void +scanconst(spat,string,len) +SPAT *spat; +char *string; +int len; +{ + register STR *tmpstr; + register char *t; + register char *d; + register char *e; + char *origstring = string; + static char *vert = "|"; + + if (ninstr(string, string+len, vert, vert+1)) + return; + if (*string == '^') + string++, len--; + tmpstr = Str_new(86,len); + str_nset(tmpstr,string,len); + t = str_get(tmpstr); + e = t + len; + tmpstr->str_u.str_useful = 100; + for (d=t; d < e; ) { + switch (*d) { + case '{': + 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("wWbB0123456789sSdDlLuUExc",d[1])) { + e = d; + break; + } + Move(d+1,d,e-d,char); + e--; + switch(*d) { + case 'n': + *d = '\n'; + break; + case 't': + *d = '\t'; + break; + case 'f': + *d = '\f'; + break; + case 'r': + *d = '\r'; + break; + case 'e': + *d = '\033'; + break; + case 'a': + *d = '\007'; + break; + } + /* FALL THROUGH */ + default: + defchar: + if (d[1] == '*' || (d[1] == '{' && d[2] == '0') || d[1] == '?') { + e = d; + break; + } + d++; + } + } + if (d == t) { + str_free(tmpstr); + return; + } + *d = '\0'; + tmpstr->str_cur = d - t; + if (d == t+len) + spat->spat_flags |= SPAT_ALL; + if (*origstring != '^') + spat->spat_flags |= SPAT_SCANFIRST; + spat->spat_short = tmpstr; + spat->spat_slen = d - t; +} + +char * +scanpat(s) +register char *s; +{ + register SPAT *spat; + register char *d; + register char *e; + int len; + SPAT savespat; + STR *str = Str_new(93,0); + char delim; + + Newz(801,spat,1,SPAT); + spat->spat_next = curstash->tbl_spatroot; /* link into spat list */ + curstash->tbl_spatroot = spat; + + switch (*s++) { + case 'm': + s++; + break; + case '/': + break; + case '?': + spat->spat_flags |= SPAT_ONCE; + break; + default: + fatal("panic: scanpat"); + } + s = str_append_till(str,s,bufend,s[-1],patleave); + if (s >= bufend) { + str_free(str); + yyerror("Search pattern not terminated"); + yylval.arg = Nullarg; + return s; + } + delim = *s++; + while (*s == 'i' || *s == 'o' || *s == 'g') { + if (*s == 'i') { + s++; + sawi = TRUE; + spat->spat_flags |= SPAT_FOLD; + } + if (*s == 'o') { + s++; + spat->spat_flags |= SPAT_KEEP; + } + if (*s == 'g') { + s++; + spat->spat_flags |= SPAT_GLOBAL; + } + } + len = str->str_cur; + e = str->str_ptr + len; + if (delim == '\'') + d = e; + else + d = str->str_ptr; + for (; d < e; d++) { + if (*d == '\\') + d++; + else if ((*d == '$' && d[1] && d[1] != '|' && d[1] != ')') || + (*d == '@')) { + register ARG *arg; + + spat->spat_runtime = arg = op_new(1); + 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); + (void)stabent(buf,TRUE); /* make sure it's created */ + for (; d < e; d++) { + if (*d == '\\') + d++; + else if (*d == '$' && d[1] && d[1] != '|' && d[1] != ')') { + d = scanident(d,bufend,buf); + (void)stabent(buf,TRUE); + } + else if (*d == '@') { + d = scanident(d,bufend,buf); + if (strEQ(buf,"ARGV") || strEQ(buf,"ENV") || + strEQ(buf,"SIG") || strEQ(buf,"INC")) + (void)stabent(buf,TRUE); + } + } + goto got_pat; /* skip compiling for now */ + } + } + if (spat->spat_flags & SPAT_FOLD) + StructCopy(spat, &savespat, SPAT); + scanconst(spat,str->str_ptr,len); + if ((spat->spat_flags & SPAT_ALL) && (spat->spat_flags & SPAT_SCANFIRST)) { + fbmcompile(spat->spat_short, spat->spat_flags & SPAT_FOLD); + spat->spat_regexp = regcomp(str->str_ptr,str->str_ptr+len, + spat->spat_flags & SPAT_FOLD); + /* Note that this regexp can still be used if someone says + * something like /a/ && s//b/; so we can't delete it. + */ + } + else { + if (spat->spat_flags & SPAT_FOLD) + StructCopy(&savespat, spat, SPAT); + if (spat->spat_short) + fbmcompile(spat->spat_short, spat->spat_flags & SPAT_FOLD); + spat->spat_regexp = regcomp(str->str_ptr,str->str_ptr+len, + spat->spat_flags & SPAT_FOLD); + hoistmust(spat); + } + got_pat: + str_free(str); + yylval.arg = make_match(O_MATCH,stab2arg(A_STAB,defstab),spat); + return s; +} + +char * +scansubst(start) +char *start; +{ + register char *s = start; + register SPAT *spat; + register char *d; + register char *e; + int len; + STR *str = Str_new(93,0); + char term = *s; + + if (term && (d = index("([{< )]}> )]}>",term))) + term = d[5]; + + Newz(802,spat,1,SPAT); + spat->spat_next = curstash->tbl_spatroot; /* link into spat list */ + curstash->tbl_spatroot = spat; + + s = str_append_till(str,s+1,bufend,term,patleave); + if (s >= bufend) { + str_free(str); + yyerror("Substitution pattern not terminated"); + yylval.arg = Nullarg; + return s; + } + len = str->str_cur; + e = str->str_ptr + len; + for (d = str->str_ptr; d < e; d++) { + if (*d == '\\') + d++; + else if ((*d == '$' && d[1] && d[1] != '|' && /*(*/ d[1] != ')') || + *d == '@' ) { + register ARG *arg; + + spat->spat_runtime = arg = op_new(1); + arg->arg_type = O_ITEM; + arg[1].arg_type = A_DOUBLE; + arg[1].arg_ptr.arg_str = str_smake(str); + 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,e,buf); + (void)stabent(buf,TRUE); + } + else if (*d == '@' && d[-1] != '\\') { + d = scanident(d,e,buf); + if (strEQ(buf,"ARGV") || strEQ(buf,"ENV") || + strEQ(buf,"SIG") || strEQ(buf,"INC")) + (void)stabent(buf,TRUE); + } + } + goto get_repl; /* skip compiling for now */ + } + } + scanconst(spat,str->str_ptr,len); +get_repl: + if (term != *start) + s++; + s = scanstr(s, SCAN_REPL); + if (s >= bufend) { + str_free(str); + yyerror("Substitution replacement not terminated"); + yylval.arg = Nullarg; + return s; + } + spat->spat_repl = yylval.arg; + if ((spat->spat_repl[1].arg_type & A_MASK) == A_SINGLE) + spat->spat_flags |= SPAT_CONST; + else if ((spat->spat_repl[1].arg_type & A_MASK) == A_DOUBLE) { + STR *tmpstr; + register char *t; + + spat->spat_flags |= SPAT_CONST; + tmpstr = spat->spat_repl[1].arg_ptr.arg_str; + e = tmpstr->str_ptr + tmpstr->str_cur; + for (t = tmpstr->str_ptr; t < e; t++) { + if (*t == '$' && t[1] && (index("`'&+0123456789",t[1]) || + (t[1] == '{' /*}*/ && isDIGIT(t[2])) )) + spat->spat_flags &= ~SPAT_CONST; + } + } + while (*s == 'g' || *s == 'i' || *s == 'e' || *s == 'o') { + int es = 0; + + if (*s == 'e') { + s++; + es++; + if ((spat->spat_repl[1].arg_type & A_MASK) == A_DOUBLE) + spat->spat_repl[1].arg_type = A_SINGLE; + spat->spat_repl = make_op( + (!es && spat->spat_repl[1].arg_type == A_SINGLE + ? O_EVALONCE + : O_EVAL), + 2, + spat->spat_repl, + Nullarg, + Nullarg); + spat->spat_flags &= ~SPAT_CONST; + } + if (*s == 'g') { + s++; + spat->spat_flags |= SPAT_GLOBAL; + } + if (*s == 'i') { + s++; + sawi = TRUE; + spat->spat_flags |= SPAT_FOLD; + if (!(spat->spat_flags & SPAT_SCANFIRST)) { + str_free(spat->spat_short); /* anchored opt doesn't do */ + spat->spat_short = Nullstr; /* case insensitive match */ + spat->spat_slen = 0; + } + } + if (*s == 'o') { + s++; + spat->spat_flags |= SPAT_KEEP; + } + } + if (spat->spat_short && (spat->spat_flags & SPAT_SCANFIRST)) + fbmcompile(spat->spat_short, spat->spat_flags & SPAT_FOLD); + if (!spat->spat_runtime) { + spat->spat_regexp = regcomp(str->str_ptr,str->str_ptr+len, + spat->spat_flags & SPAT_FOLD); + hoistmust(spat); + } + yylval.arg = make_match(O_SUBST,stab2arg(A_STAB,defstab),spat); + str_free(str); + return s; +} + +void +hoistmust(spat) +register SPAT *spat; +{ + if (!spat->spat_short && spat->spat_regexp->regstart && + (!spat->spat_regexp->regmust || spat->spat_regexp->reganch & ROPT_ANCH) + ) { + if (!(spat->spat_regexp->reganch & ROPT_ANCH)) + spat->spat_flags |= SPAT_SCANFIRST; + else if (spat->spat_flags & SPAT_FOLD) + return; + spat->spat_short = str_smake(spat->spat_regexp->regstart); + } + else if (spat->spat_regexp->regmust) {/* is there a better short-circuit? */ + if (spat->spat_short && + str_eq(spat->spat_short,spat->spat_regexp->regmust)) + { + if (spat->spat_flags & SPAT_SCANFIRST) { + str_free(spat->spat_short); + spat->spat_short = Nullstr; + } + else { + str_free(spat->spat_regexp->regmust); + spat->spat_regexp->regmust = Nullstr; + return; + } + } + if (!spat->spat_short || /* promote the better string */ + ((spat->spat_flags & SPAT_SCANFIRST) && + (spat->spat_short->str_cur < spat->spat_regexp->regmust->str_cur) )){ + str_free(spat->spat_short); /* ok if null */ + spat->spat_short = spat->spat_regexp->regmust; + spat->spat_regexp->regmust = Nullstr; + spat->spat_flags |= SPAT_SCANFIRST; + } + } +} + +char * +scantrans(start) +char *start; +{ + register char *s = start; + ARG *arg = + l(make_op(O_TRANS,2,stab2arg(A_STAB,defstab),Nullarg,Nullarg)); + STR *tstr; + STR *rstr; + register char *t; + register char *r; + register short *tbl; + register int i; + register int j; + int tlen, rlen; + int squash; + int delete; + int complement; + + New(803,tbl,256,short); + arg[2].arg_type = A_NULL; + arg[2].arg_ptr.arg_cval = (char*) tbl; + + s = scanstr(s, SCAN_TR); + if (s >= bufend) { + yyerror("Translation pattern not terminated"); + yylval.arg = Nullarg; + return s; + } + tstr = yylval.arg[1].arg_ptr.arg_str; + yylval.arg[1].arg_ptr.arg_str = Nullstr; + arg_free(yylval.arg); + t = tstr->str_ptr; + tlen = tstr->str_cur; + + if (s[-1] == *start) + s--; + + s = scanstr(s, SCAN_TR|SCAN_REPL); + if (s >= bufend) { + yyerror("Translation replacement not terminated"); + yylval.arg = Nullarg; + return s; + } + rstr = yylval.arg[1].arg_ptr.arg_str; + yylval.arg[1].arg_ptr.arg_str = Nullstr; + arg_free(yylval.arg); + r = rstr->str_ptr; + rlen = rstr->str_cur; + + complement = delete = squash = 0; + while (*s == 'c' || *s == 'd' || *s == 's') { + if (*s == 'c') + complement = 1; + else if (*s == 'd') + delete = 2; + else + squash = 1; + s++; + } + arg[2].arg_len = delete|squash; + yylval.arg = arg; + if (complement) { + Zero(tbl, 256, short); + for (i = 0; i < tlen; i++) + tbl[t[i] & 0377] = -1; + for (i = 0, j = 0; i < 256; i++) { + if (!tbl[i]) { + if (j >= rlen) { + if (delete) + tbl[i] = -2; + else if (rlen) + tbl[i] = r[j-1] & 0377; + else + tbl[i] = i; + } + else + tbl[i] = r[j++] & 0377; + } + } + } + else { + if (!rlen && !delete) { + r = t; rlen = tlen; + } + for (i = 0; i < 256; i++) + tbl[i] = -1; + for (i = 0, j = 0; i < tlen; i++,j++) { + if (j >= rlen) { + if (delete) { + if (tbl[t[i] & 0377] == -1) + tbl[t[i] & 0377] = -2; + continue; + } + --j; + } + if (tbl[t[i] & 0377] == -1) + tbl[t[i] & 0377] = r[j] & 0377; + } + } + str_free(tstr); + str_free(rstr); + return s; +} + +char * +scanstr(start, in_what) +char *start; +int in_what; +{ + register char *s = start; + register char term; + register char *d; + register ARG *arg; + register char *send; + register bool makesingle = FALSE; + register STAB *stab; + bool alwaysdollar = FALSE; + bool hereis = FALSE; + STR *herewas; + STR *str; + /* which backslash sequences to keep */ + char *leave = (in_what & SCAN_TR) + ? "\\$@nrtfbeacx0123456789-" + : "\\$@nrtfbeacx0123456789[{]}lLuUE"; + int len; + + arg = op_new(1); + yylval.arg = arg; + arg->arg_type = O_ITEM; + + switch (*s) { + default: /* a substitution replacement */ + arg[1].arg_type = A_DOUBLE; + makesingle = TRUE; /* maybe disable runtime scanning */ + term = *s; + if (term == '\'') + leave = Nullch; + goto snarf_it; + case '0': + { + unsigned long i; + int shift; + + arg[1].arg_type = A_SINGLE; + if (s[1] == 'x') { + shift = 4; + s += 2; + } + else if (s[1] == '.') + goto decimal; + else + shift = 3; + i = 0; + for (;;) { + switch (*s) { + default: + goto out; + case '_': + s++; + break; + case '8': case '9': + if (shift != 4) + yyerror("Illegal octal digit"); + /* FALL THROUGH */ + case '0': case '1': case '2': case '3': case '4': + case '5': case '6': case '7': + i <<= shift; + i += *s++ & 15; + break; + case 'a': case 'b': case 'c': case 'd': case 'e': case 'f': + case 'A': case 'B': case 'C': case 'D': case 'E': case 'F': + if (shift != 4) + goto out; + i <<= 4; + i += (*s++ & 7) + 9; + break; + } + } + out: + str = Str_new(92,0); + str_numset(str,(double)i); + if (str->str_ptr) { + Safefree(str->str_ptr); + str->str_ptr = Nullch; + str->str_len = str->str_cur = 0; + } + arg[1].arg_ptr.arg_str = str; + } + break; + case '1': case '2': case '3': case '4': case '5': + case '6': case '7': case '8': case '9': case '.': + decimal: + arg[1].arg_type = A_SINGLE; + d = tokenbuf; + while (isDIGIT(*s) || *s == '_') { + if (*s == '_') + s++; + else + *d++ = *s++; + } + if (*s == '.' && s[1] != '.') { + *d++ = *s++; + while (isDIGIT(*s) || *s == '_') { + if (*s == '_') + s++; + else + *d++ = *s++; + } + } + if (*s && index("eE",*s) && index("+-0123456789",s[1])) { + *d++ = *s++; + if (*s == '+' || *s == '-') + *d++ = *s++; + while (isDIGIT(*s)) + *d++ = *s++; + } + *d = '\0'; + str = Str_new(92,0); + str_numset(str,atof(tokenbuf)); + if (str->str_ptr) { + Safefree(str->str_ptr); + str->str_ptr = Nullch; + str->str_len = str->str_cur = 0; + } + arg[1].arg_ptr.arg_str = str; + break; + case '<': + if (in_what & (SCAN_REPL|SCAN_TR)) + goto do_double; + if (*++s == '<') { + hereis = TRUE; + d = tokenbuf; + if (!rsfp) + *d++ = '\n'; + if (*++s && index("`'\"",*s)) { + term = *s++; + s = cpytill(d,s,bufend,term,&len); + if (s < bufend) + s++; + d += len; + } + else { + if (*s == '\\') + s++, term = '\''; + else + term = '"'; + while (isALNUM(*s)) + *d++ = *s++; + } /* assuming tokenbuf won't clobber */ + *d++ = '\n'; + *d = '\0'; + len = d - tokenbuf; + d = "\n"; + if (rsfp || !(d=ninstr(s,bufend,d,d+1))) + herewas = str_make(s,bufend-s); + else + s--, herewas = str_make(s,d-s); + s += herewas->str_cur; + if (term == '\'') + goto do_single; + if (term == '`') + goto do_back; + goto do_double; + } + d = tokenbuf; + s = cpytill(d,s,bufend,'>',&len); + if (s < bufend) + s++; + else + fatal("Unterminated <> operator"); + + if (*d == '$') d++; + while (*d && (isALNUM(*d) || *d == '\'')) + d++; + if (d - tokenbuf != len) { + s = start; + term = *s; + arg[1].arg_type = A_GLOB; + set_csh(); + alwaysdollar = TRUE; /* treat $) and $| as variables */ + goto snarf_it; + } + else { + d = tokenbuf; + if (!len) + (void)strcpy(d,"ARGV"); + if (*d == '$') { + arg[1].arg_type = A_INDREAD; + arg[1].arg_ptr.arg_stab = stabent(d+1,TRUE); + } + else { + arg[1].arg_type = A_READ; + arg[1].arg_ptr.arg_stab = stabent(d,TRUE); + if (!stab_io(arg[1].arg_ptr.arg_stab)) + stab_io(arg[1].arg_ptr.arg_stab) = stio_new(); + if (strEQ(d,"ARGV")) { + (void)aadd(arg[1].arg_ptr.arg_stab); + stab_io(arg[1].arg_ptr.arg_stab)->flags |= + IOF_ARGV|IOF_START; + } + } + } + break; + + case 'q': + s++; + if (*s == 'q') { + s++; + goto do_double; + } + if (*s == 'x') { + s++; + goto do_back; + } + /* FALL THROUGH */ + case '\'': + do_single: + term = *s; + arg[1].arg_type = A_SINGLE; + leave = Nullch; + goto snarf_it; + + case '"': + do_double: + term = *s; + arg[1].arg_type = A_DOUBLE; + makesingle = TRUE; /* maybe disable runtime scanning */ + alwaysdollar = TRUE; /* treat $) and $| as variables */ + goto snarf_it; + case '`': + do_back: + term = *s; + arg[1].arg_type = A_BACKTICK; + set_csh(); + alwaysdollar = TRUE; /* treat $) and $| as variables */ + snarf_it: + { + STR *tmpstr; + STR *tmpstr2 = Nullstr; + char *tmps; + bool dorange = FALSE; + + CLINE; + multi_start = curcmd->c_line; + if (hereis) + multi_open = multi_close = '<'; + else { + multi_open = term; + if (term && (tmps = index("([{< )]}> )]}>",term))) + term = tmps[5]; + multi_close = term; + } + tmpstr = Str_new(87,80); + if (hereis) { + term = *tokenbuf; + if (!rsfp) { + d = s; + while (s < bufend && + (*s != term || bcmp(s,tokenbuf,len) != 0) ) { + if (*s++ == '\n') + curcmd->c_line++; + } + if (s >= bufend) { + curcmd->c_line = multi_start; + fatal("EOF in string"); + } + str_nset(tmpstr,d+1,s-d); + s += len - 1; + str_ncat(herewas,s,bufend-s); + str_replace(linestr,herewas); + oldoldbufptr = oldbufptr = bufptr = s = str_get(linestr); + bufend = linestr->str_ptr + linestr->str_cur; + hereis = FALSE; + } + else + str_nset(tmpstr,"",0); /* avoid "uninitialized" warning */ + } + else + s = str_append_till(tmpstr,s+1,bufend,term,leave); + while (s >= bufend) { /* multiple line string? */ + if (!rsfp || + !(oldoldbufptr = oldbufptr = s = str_gets(linestr, rsfp, 0))) { + curcmd->c_line = multi_start; + fatal("EOF in string"); + } + curcmd->c_line++; + if (perldb) { + STR *str = Str_new(88,0); + + str_sset(str,linestr); + astore(stab_xarray(curcmd->c_filestab), + (int)curcmd->c_line,str); + } + bufend = linestr->str_ptr + linestr->str_cur; + if (hereis) { + if (*s == term && bcmp(s,tokenbuf,len) == 0) { + s = bufend - 1; + *s = ' '; + str_scat(linestr,herewas); + bufend = linestr->str_ptr + linestr->str_cur; + } + else { + s = bufend; + str_scat(tmpstr,linestr); + } + } + else + s = str_append_till(tmpstr,s,bufend,term,leave); + } + multi_end = curcmd->c_line; + s++; + if (tmpstr->str_cur + 5 < tmpstr->str_len) { + tmpstr->str_len = tmpstr->str_cur + 1; + Renew(tmpstr->str_ptr, tmpstr->str_len, char); + } + if (arg[1].arg_type == A_SINGLE) { + arg[1].arg_ptr.arg_str = tmpstr; + break; + } + tmps = 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]) && + !alwaysdollar && s[1] != '0') + *s = '$'; /* grandfather \digit in subst */ + if ((*s == '$' || *s == '@') && s+1 < send && + (alwaysdollar || (s[1] != ')' && s[1] != '|'))) { + makesingle = FALSE; /* force interpretation */ + } + else if (*s == '\\' && s+1 < send) { + if (index("lLuUE",s[1])) + makesingle = FALSE; + s++; + } + s++; + } + s = d = tmpstr->str_ptr; /* assuming shrinkage only */ + while (s < send || dorange) { + if (in_what & SCAN_TR) { + if (dorange) { + int i; + int max; + if (!tmpstr2) { /* oops, have to grow */ + tmpstr2 = str_smake(tmpstr); + s = tmpstr2->str_ptr + (s - tmpstr->str_ptr); + send = tmpstr2->str_ptr + (send - tmpstr->str_ptr); + } + i = d - tmpstr->str_ptr; + STR_GROW(tmpstr, tmpstr->str_len + 256); + d = tmpstr->str_ptr + i; + d -= 2; + max = d[1] & 0377; + for (i = (*d & 0377); i <= max; i++) + *d++ = i; + dorange = FALSE; + continue; + } + else if (*s == '-' && s+1 < send && d != tmpstr->str_ptr) { + dorange = TRUE; + s++; + } + } + else { + 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") + || strEQ(tokenbuf,"SIG") + || strEQ(tokenbuf,"INC") ) + (void)stabent(tokenbuf,TRUE); /* add symbol */ + while (len--) + *d++ = *s++; + continue; + } + } + if (*s == '\\' && s+1 < send) { + s++; + switch (*s) { + case '-': + if (in_what & SCAN_TR) { + *d++ = *s++; + continue; + } + /* FALL THROUGH */ + default: + if (!makesingle && (!leave || (*s && index(leave,*s)))) + *d++ = '\\'; + *d++ = *s++; + continue; + case '0': case '1': case '2': case '3': + case '4': case '5': case '6': case '7': + *d++ = scanoct(s, 3, &len); + s += len; + continue; + case 'x': + *d++ = scanhex(++s, 2, &len); + s += len; + continue; + case 'c': + s++; + *d = *s++; + if (isLOWER(*d)) + *d = toupper(*d); + *d++ ^= 64; + continue; + case 'b': + *d++ = '\b'; + break; + case 'n': + *d++ = '\n'; + break; + case 'r': + *d++ = '\r'; + break; + case 'f': + *d++ = '\f'; + break; + case 't': + *d++ = '\t'; + break; + case 'e': + *d++ = '\033'; + break; + case 'a': + *d++ = '\007'; + break; + } + s++; + continue; + } + *d++ = *s++; + } + *d = '\0'; + + if (arg[1].arg_type == A_DOUBLE && makesingle) + arg[1].arg_type = A_SINGLE; /* now we can optimize on it */ + + tmpstr->str_cur = d - tmpstr->str_ptr; + if (arg[1].arg_type == A_GLOB) { + arg[1].arg_ptr.arg_stab = stab = genstab(); + stab_io(stab) = stio_new(); + str_sset(stab_val(stab), tmpstr); + } + else + arg[1].arg_ptr.arg_str = tmpstr; + s = tmps; + if (tmpstr2) + str_free(tmpstr2); + break; + } + } + if (hereis) + str_free(herewas); + return s; +} + +FCMD * +load_format() +{ + FCMD froot; + FCMD *flinebeg; + char *eol; + register FCMD *fprev = &froot; + register FCMD *fcmd; + register char *s; + register char *t; + register STR *str; + bool noblank; + bool repeater; + + Zero(&froot, 1, FCMD); + s = bufptr; + while (s < bufend || (rsfp && (s = str_gets(linestr,rsfp, 0)) != Nullch)) { + curcmd->c_line++; + if (in_eval && !rsfp) { + eol = index(s,'\n'); + if (!eol++) + eol = bufend; + } + else + eol = bufend = linestr->str_ptr + linestr->str_cur; + if (perldb) { + STR *tmpstr = Str_new(89,0); + + str_nset(tmpstr, s, eol-s); + 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; + return froot.f_next; + } + } + if (*s == '#') { + s = eol; + continue; + } + flinebeg = Nullfcmd; + noblank = FALSE; + repeater = FALSE; + while (s < eol) { + Newz(804,fcmd,1,FCMD); + fprev->f_next = fcmd; + fprev = fcmd; + for (t=s; t < eol && *t != '@' && *t != '^'; t++) { + if (*t == '~') { + noblank = TRUE; + *t = ' '; + if (t[1] == '~') { + repeater = TRUE; + t[1] = ' '; + } + } + } + fcmd->f_pre = nsavestr(s, t-s); + fcmd->f_presize = t-s; + s = t; + if (s >= eol) { + if (noblank) + fcmd->f_flags |= FC_NOBLANK; + if (repeater) + fcmd->f_flags |= FC_REPEAT; + break; + } + if (!flinebeg) + flinebeg = fcmd; /* start values here */ + if (*s++ == '^') + fcmd->f_flags |= FC_CHOP; /* for doing text filling */ + switch (*s) { + case '*': + fcmd->f_type = F_LINES; + *s = '\0'; + break; + case '<': + fcmd->f_type = F_LEFT; + while (*s == '<') + s++; + break; + case '>': + fcmd->f_type = F_RIGHT; + while (*s == '>') + s++; + break; + case '|': + fcmd->f_type = F_CENTER; + while (*s == '|') + s++; + break; + case '#': + case '.': + /* Catch the special case @... and handle it as a string + field. */ + if (*s == '.' && s[1] == '.') { + goto default_format; + } + fcmd->f_type = F_DECIMAL; + { + char *p; + + /* Read a format in the form @####.####, where either group + of ### may be empty, or the final .### may be missing. */ + while (*s == '#') + s++; + if (*s == '.') { + s++; + p = s; + while (*s == '#') + s++; + fcmd->f_decimals = s-p; + fcmd->f_flags |= FC_DP; + } else { + fcmd->f_decimals = 0; + } + } + break; + default: + default_format: + fcmd->f_type = F_LEFT; + break; + } + if (fcmd->f_flags & FC_CHOP && *s == '.') { + fcmd->f_flags |= FC_MORE; + while (*s == '.') + s++; + } + fcmd->f_size = s-t; + } + if (flinebeg) { + again: + if (s >= bufend && + (!rsfp || (s = str_gets(linestr, rsfp, 0)) == Nullch) ) + goto badform; + curcmd->c_line++; + if (in_eval && !rsfp) { + eol = index(s,'\n'); + if (!eol++) + eol = bufend; + } + else + eol = bufend = linestr->str_ptr + linestr->str_cur; + if (perldb) { + STR *tmpstr = Str_new(90,0); + + str_nset(tmpstr, s, eol-s); + astore(stab_xarray(curcmd->c_filestab), + (int)curcmd->c_line,tmpstr); + } + if (strnEQ(s,".\n",2)) { + bufptr = s; + yyerror("Missing values line"); + return froot.f_next; + } + if (*s == '#') { + s = eol; + goto again; + } + str = flinebeg->f_unparsed = Str_new(91,eol - s); + str->str_u.str_hash = curstash; + str_nset(str,"(",1); + flinebeg->f_line = curcmd->c_line; + eol[-1] = '\0'; + if (!flinebeg->f_next->f_type || index(s, ',')) { + eol[-1] = '\n'; + str_ncat(str, s, eol - s - 1); + str_ncat(str,",$$);",5); + s = eol; + } + else { + eol[-1] = '\n'; + while (s < eol && isSPACE(*s)) + s++; + t = s; + while (s < eol) { + switch (*s) { + case ' ': case '\t': case '\n': case ';': + str_ncat(str, t, s - t); + str_ncat(str, "," ,1); + while (s < eol && (isSPACE(*s) || *s == ';')) + s++; + t = s; + break; + case '$': + str_ncat(str, t, s - t); + t = s; + s = scanident(s,eol,tokenbuf); + str_ncat(str, t, s - t); + t = s; + if (s < eol && *s && index("$'\"",*s)) + str_ncat(str, ",", 1); + break; + case '"': case '\'': + str_ncat(str, t, s - t); + t = s; + s++; + while (s < eol && (*s != *t || s[-1] == '\\')) + s++; + if (s < eol) + s++; + str_ncat(str, t, s - t); + t = s; + if (s < eol && *s && index("$'\"",*s)) + str_ncat(str, ",", 1); + break; + default: + yyerror("Please use commas to separate fields"); + } + } + str_ncat(str,"$$);",4); + } + } + } + badform: + bufptr = str_get(linestr); + yyerror("Format not terminated"); + return froot.f_next; +} + +static void +set_csh() +{ +#ifdef CSH + if (!cshlen) + cshlen = strlen(cshname); +#endif +} diff --git a/toke.c.rej b/toke.c.rej new file mode 100644 index 0000000..14e76a2 --- /dev/null +++ b/toke.c.rej @@ -0,0 +1,36 @@ +*************** +*** 1,4 **** +! /* $RCSfile: toke.c,v $$Revision: 4.0.1.8 $$Date: 1992/06/23 12:33:45 $ + * + * Copyright (c) 1991, Larry Wall + * +--- 1,4 ---- +! /* $RCSfile: toke.c,v $$Revision: 4.0.1.9 $$Date: 1993/02/05 19:48:43 $ + * + * Copyright (c) 1991, Larry Wall + * +*************** +*** 6,14 **** + * License or the Artistic License, as specified in the README file. + * + * $Log: toke.c,v $ +! * Revision 4.0.1.8 1992/06/23 12:33:45 lwall +! * patch35: bad interaction between backslash and hyphen in tr/// + * + * Revision 4.0.1.7 92/06/11 21:16:30 lwall + * patch34: expectterm incorrectly set to indicate start of program or block + * +--- 6,18 ---- + * License or the Artistic License, as specified in the README file. + * + * $Log: toke.c,v $ +! * Revision 4.0.1.9 1993/02/05 19:48:43 lwall +! * patch36: now detects ambiguous use of filetest operators as well as unary +! * patch36: fixed ambiguity on - within tr/// + * ++ * Revision 4.0.1.8 92/06/23 12:33:45 lwall ++ * patch35: bad interaction between backslash and hyphen in tr/// ++ * + * Revision 4.0.1.7 92/06/11 21:16:30 lwall + * patch34: expectterm incorrectly set to indicate start of program or block + * diff --git a/x2p/find2perl.SH b/x2p/find2perl.SH index 7e49cd0..4a95de0 100644 --- a/x2p/find2perl.SH +++ b/x2p/find2perl.SH @@ -68,11 +68,11 @@ while (@ARGV) { die "Malformed -perm argument: $onum\n" unless $onum =~ /^-?[0-7]+$/; if ($onum =~ s/^-//) { $onum = '0' . sprintf("%o", oct($onum) & 017777); # s/b 07777 ? - $out .= &tab . "(\$mode & $onum) == $onum"; + $out .= &tab . "((\$mode & $onum) == $onum)"; } else { $onum = '0' . $onum unless $onum =~ /^0/; - $out .= &tab . "(\$mode & 0777) == $onum"; + $out .= &tab . "((\$mode & 0777) == $onum)"; } } elsif ($_ eq 'type') {