Nullarg,mycompblock));
saw_return = FALSE;
cmd->c_flags |= CF_TERM;
+ cmd->c_head = cmd;
}
sub->cmd = cmd;
if (perldb) {
/* 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;
}
shouldsave = TRUE;
break;
}
- if (willsave)
+ if (willsave && arg->arg_ptr.arg_str)
(void)apush(tosave,arg->arg_ptr.arg_str);
return shouldsave;
}
--- /dev/null
+/* $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 (<channel>)" 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;
+}
+
--- /dev/null
+***************
+*** 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()
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*/
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) {
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 {
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 */
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);
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);
--- /dev/null
+/* $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 <signal.h>
+#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
+}
+
+
--- /dev/null
+***************
+*** 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
CMD mycmd;
STR *str;
char *chophere;
+ int blank = TRUE;
mycmd.c_type = C_NULL;
orec->o_lines = 0;
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;
}
else
linebeg = fcmd->f_next;
+ blank = TRUE;
}
*d++ = *s++;
}
while (size && *s && *s != '\n') {
if (*s == '\t')
*s = ' ';
+ else if (*s != ' ')
+ blank = FALSE;
size--;
if (*s && index(chopset,(*d++ = *s++)))
chophere = s;
while (size && *s && *s != '\n') {
if (*s == '\t')
*s = ' ';
+ else if (*s != ' ')
+ blank = FALSE;
size--;
if (*s && index(chopset,*s++))
chophere = s;
while (size && *s && *s != '\n') {
if (*s == '\t')
*s = ' ';
+ else if (*s != ' ')
+ blank = FALSE;
size--;
if (*s && index(chopset,*s++))
chophere = s;
}
break;
}
+ blank = FALSE;
value = str_gnum(str);
if (fcmd->f_flags & FC_DP) {
sprintf(d, "%#*.*f", size, fcmd->f_decimals, value);
--- /dev/null
+/* $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;
+}
--- /dev/null
+***************
+*** 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
--- /dev/null
+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
--- /dev/null
+d_vfork='undef'
+d_wait4='undef'
+i_dirent='undef'
+i_sys_dir='define'
# 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/;
$_;
}
$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;
$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;
}
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 '';
}
$MIN = 60 * $SEC;
$HR = 60 * $MIN;
$DAYS = 24 * $HR;
+ $YearFix = ((gmtime(946684800))[5] == 100) ? 100 : 0;
}
sub timegm {
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);
-#define PATCHLEVEL 35
+#define PATCHLEVEL 36
#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);
eval_root = myroot;
else if (in_eval != 1 && myroot != last_root)
cmd_free(myroot);
+ if (eval_root == myroot)
+ eval_root = Nullcmd;
}
perldb = oldperldb;
--- /dev/null
+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
+}
+
--- /dev/null
+***************
+*** 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()
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;
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
--- /dev/null
+/* $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 <stdio.h>
+#include <ctype.h>
+#include <setjmp.h>
+#ifndef MSDOS
+#ifdef PARAM_NEEDS_TYPES
+#include <sys/types.h>
+#endif
+#include <sys/param.h>
+#endif
+#ifdef STANDARD_C
+/* Use all the "standard" definitions */
+#include <stdlib.h>
+#include <string.h>
+#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 <sys/types.h>
+#endif
+#endif
+
+#ifdef I_NETINET_IN
+#include <netinet/in.h>
+#endif
+
+#include <sys/stat.h>
+#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 <time.h>
+#endif
+
+#ifdef I_SYS_TIME
+# ifdef SYSTIMEKERNEL
+# define KERNEL
+# endif
+# include <sys/time.h>
+# ifdef SYSTIMEKERNEL
+# undef KERNEL
+# endif
+#endif
+
+#ifndef MSDOS
+#include <sys/times.h>
+#endif
+
+#if defined(HAS_STRERROR) && (!defined(HAS_MKDIR) || !defined(HAS_RMDIR))
+#undef HAS_STRERROR
+#endif
+
+#include <errno.h>
+#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 <sys/ioctl.h>
+#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 <dbz.h>
+#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 <gdbm.h>
+#endif
+#define SOME_DBM
+#ifdef HAS_NDBM
+#undef HAS_NDBM
+#endif
+#ifdef HAS_ODBM
+#undef HAS_ODBM
+#endif
+#else
+#ifdef HAS_NDBM
+#include <ndbm.h>
+#define SOME_DBM
+#ifdef HAS_ODBM
+#undef HAS_ODBM
+#endif
+#else
+#ifdef HAS_ODBM
+#ifdef NULL
+#undef NULL /* suppress redefinition message */
+#endif
+#include <dbm.h>
+#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 <dirent.h>
+# define DIRENT dirent
+#else
+# ifdef I_SYS_NDIR
+# include <sys/ndir.h>
+# define DIRENT direct
+# else
+# ifdef I_SYS_DIR
+# ifdef hp9000s500
+# include <ndir.h> /* may be wrong in the future */
+# else
+# include <sys/dir.h>
+# 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
--- /dev/null
+***************
+*** 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
| DELETE '(' REG '{' expr ';' '}' ')' %prec '('
{ $$ = make_op(O_DELETE, 2,
stab2arg(A_STAB,hadd($3)),
- jmaybe($4),
+ jmaybe($5),
Nullarg);
expectterm = FALSE; }
| ARYLEN %prec '('
--- /dev/null
+/* $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 <ival> '{' ')'
+
+%token <cval> WORD LABEL
+%token <ival> APPEND OPEN SSELECT LOOPEX DOTDOT
+%token <ival> USING FORMAT DO SHIFT PUSH POP LVALFUN
+%token <ival> WHILE UNTIL IF UNLESS ELSE ELSIF CONTINUE SPLIT FLIST
+%token <ival> FOR FILOP FILOP2 FILOP3 FILOP4 FILOP22 FILOP25
+%token <ival> FUNC0 FUNC1 FUNC2 FUNC2x FUNC3 FUNC4 FUNC5 HSHFUN HSHFUN3
+%token <ival> FLIST2 SUB FILETEST LOCAL DELETE
+%token <ival> RELOP EQOP MULOP ADDOP PACKAGE AMPER
+%token <formval> FORMLIST
+%token <stabval> REG ARYLEN ARY HSH STAR
+%token <arg> SUBST PATTERN
+%token <arg> RSTRING TRANS
+
+%type <ival> prog decl format remember crp
+%type <cmdval> block lineseq line loop cond sideff nexpr else
+%type <arg> expr sexpr cexpr csexpr term handle aryword hshword
+%type <arg> texpr listop bareword
+%type <cval> label
+%type <compval> compblock
+
+%nonassoc <ival> LISTOP
+%left ','
+%right '='
+%right '?' ':'
+%nonassoc DOTDOT
+%left OROR
+%left ANDAND
+%left '|' '^'
+%left '&'
+%nonassoc EQOP
+%nonassoc RELOP
+%nonassoc <ival> 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 */
--- /dev/null
+***************
+*** 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
+ *
return (STRLEN)ofslen;
case '\\':
return (STRLEN)orslen;
- default:
- return str_len(stab_str(str));
}
+ return str_len(stab_str(str));
}
void
--- /dev/null
+/* $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 <signal.h>
+#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 */
--- /dev/null
+***************
+*** 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
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
--- /dev/null
+/* $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 .= <BAR> could overrun malloced memory
+ * patch11: \$ didn't always make it through double-quoter to regexp routines
+ * patch11: prepared for ctype implementations that don't define isascii()
+ *
+ * Revision 4.0.1.3 91/06/10 01:27:54 lwall
+ * patch10: $) and $| incorrectly handled in run-time patterns
+ *
+ * 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 .= <BAR> 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 */
--- /dev/null
+***************
+*** 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
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";
--- /dev/null
+#!./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";
+}
--- /dev/null
+***************
+*** 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";
+
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);
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);
STR *tmpstr;
STR *tmpstr2 = Nullstr;
char *tmps;
+ char *start;
bool dorange = FALSE;
CLINE;
}
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) {
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++;
}
--- /dev/null
+/* $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 <fcntl.h>
+#endif
+#ifdef I_SYS_FILE
+#include <sys/file.h>
+#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
+}
--- /dev/null
+***************
+*** 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
+ *
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') {
projects / p5sagit/p5-mst-13.2.git / commitdiff