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 -&n
https://perl5.git.perl.org / perl5.git / commitdiff