-/* $Header: eval.c,v 4.0 91/03/20 01:16:48 lwall Locked $
+/* $RCSfile: eval.c,v $$Revision: 4.0.1.3 $$Date: 91/11/05 17:15:21 $
*
- * Copyright (c) 1989, Larry Wall
+ * Copyright (c) 1991, Larry Wall
*
- * You may distribute under the terms of the GNU General Public License
- * as specified in the README file that comes with the perl 3.0 kit.
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
*
* $Log: eval.c,v $
+ * Revision 4.0.1.3 91/11/05 17:15:21 lwall
+ * patch11: prepared for ctype implementations that don't define isascii()
+ * patch11: various portability fixes
+ * patch11: added sort {} LIST
+ * patch11: added eval {}
+ * patch11: sysread() in socket was substituting recv()
+ * patch11: a last statement outside any block caused occasional core dumps
+ * patch11: missing arguments caused core dump in -D8 code
+ * patch11: eval 'stuff' now optimized to eval {stuff}
+ *
+ * Revision 4.0.1.2 91/06/07 11:07:23 lwall
+ * patch4: new copyright notice
+ * patch4: length($`), length($&), length($') now optimized to avoid string copy
+ * patch4: assignment wasn't correctly de-tainting the assigned variable.
+ * patch4: default top-of-form format is now FILEHANDLE_TOP
+ * patch4: added $^P variable to control calling of perldb routines
+ * patch4: taintchecks could improperly modify parent in vfork()
+ * patch4: many, many itty-bitty portability fixes
+ *
+ * Revision 4.0.1.1 91/04/11 17:43:48 lwall
+ * patch1: fixed failed fork to return undef as documented
+ * patch1: reduced maximum branch distance in eval.c
+ *
* Revision 4.0 91/03/20 01:16:48 lwall
* 4.0 baseline.
*
}
#endif
break;
+ case A_LENSTAB:
+ str_numset(str, (double)STAB_LEN(argptr.arg_stab));
+ st[++sp] = str;
+#ifdef DEBUGGING
+ if (debug & 8) {
+ (void)sprintf(buf,"LENSTAB $%s",stab_name(argptr.arg_stab));
+ tmps = buf;
+ }
+#endif
+ break;
case A_LEXPR:
#ifdef DEBUGGING
if (debug & 8) {
if (fp) {
if (gimme == G_SCALAR) {
while (str_gets(str,fp,str->str_cur) != Nullch)
+ /*SUPPRESS 530*/
;
}
else {
else
str->str_cur++;
for (tmps = str->str_ptr; *tmps; tmps++)
- if (!isalpha(*tmps) && !isdigit(*tmps) &&
+ if (!isALPHA(*tmps) && !isDIGIT(*tmps) &&
index("$&*(){}[]'\";\\|?<>~`",*tmps))
break;
if (*tmps && stat(str->str_ptr,&statbuf) < 0)
goto array_return;
case O_SASSIGN:
sassign:
+#ifdef TAINT
+ if (tainted && !st[2]->str_tainted)
+ tainted = 0;
+#endif
STR_SSET(str, st[2]);
STABSET(str);
break;
case O_DIVIDE:
if ((value = str_gnum(st[2])) == 0.0)
fatal("Illegal division by zero");
-#ifdef cray
+#ifdef SLOPPYDIVIDE
/* insure that 20./5. == 4. */
{
double x;
value = -str_gnum(st[1]);
goto donumset;
case O_NOT:
+#ifdef NOTNOT
+ { char xxx = str_true(st[1]); value = (double) !xxx; }
+#else
value = (double) !str_true(st[1]);
+#endif
goto donumset;
case O_COMPLEMENT:
if (!sawvec || st[1]->str_nok) {
break;
}
format(&outrec,form,sp);
- do_write(&outrec,stab_io(stab),sp);
+ do_write(&outrec,stab,sp);
if (stab_io(stab)->flags & IOF_FLUSH)
(void)fflush(fp);
str_set(str, Yes);
else if (stab_hash(tmpstab)->tbl_dbm)
str_magic(str, tmpstab, 'D', tmps, anum);
#endif
- else if (perldb && tmpstab == DBline)
+ else if (tmpstab == DBline)
str_magic(str, tmpstab, 'L', tmps, anum);
break;
case O_LSLICE:
case O_SUBSTR:
anum = ((int)str_gnum(st[2])) - arybase; /* anum=where to start*/
tmps = str_get(st[1]); /* force conversion to string */
+ /*SUPPRESS 560*/
if (argtype = (str == st[1]))
str = arg->arg_ptr.arg_str;
if (anum < 0)
}
break;
case O_PACK:
+ /*SUPPRESS 701*/
(void)do_pack(str,arglast);
break;
case O_GREP:
st = stack->ary_array + arglast[0]; /* maybe realloced */
goto array_return;
case O_SORT:
- if ((arg[1].arg_type & A_MASK) == A_WORD)
- stab = arg[1].arg_ptr.arg_stab;
- else
- stab = stabent(str_get(st[1]),TRUE);
- sp = do_sort(str,stab,
+ sp = do_sort(str,arg,
gimme,arglast);
goto array_return;
case O_REVERSE:
goto badsock;
#endif
STR_GROW(st[2], anum+maxarg+1), (tmps = str_get(st[2])); /* sneaky */
+ if (optype == O_SYSREAD) {
+ anum = read(fileno(stab_io(stab)->ifp), tmps+maxarg, anum);
+ }
+ else
#ifdef HAS_SOCKET
if (stab_io(stab)->type == 's') {
argtype = sizeof buf;
}
else
#endif
- if (optype == O_SYSREAD) {
- anum = read(fileno(stab_io(stab)->ifp), tmps+maxarg, anum);
- }
- else
anum = fread(tmps+maxarg, 1, anum, stab_io(stab)->ifp);
if (anum < 0)
goto say_undef;
case O_REDO:
case O_NEXT:
case O_LAST:
+ tmps = Nullch;
if (maxarg > 0) {
tmps = str_get(arg[1].arg_ptr.arg_str);
dopop:
case O_FORK:
#ifdef HAS_FORK
anum = fork();
+ if (anum < 0)
+ goto say_undef;
if (!anum) {
+ /*SUPPRESS 560*/
if (tmpstab = stabent("$",allstabs))
str_numset(STAB_STR(tmpstab),(double)getpid());
- hclear(pidstatus); /* no kids, so don't wait for 'em */
+ hclear(pidstatus, FALSE); /* no kids, so don't wait for 'em */
}
value = (double)anum;
goto donumset;
else if (arglast[2] - arglast[1] != 1)
value = (double)do_aexec(Nullstr,arglast);
else {
+#ifdef TAINT
+ taintenv();
+ tainted |= st[2]->str_tainted;
+ taintproper("Insecure dependency in exec");
+#endif
value = (double)do_exec(str_get(str_mortal(st[2])));
}
goto donumset;
tmps = str_get(stab_val(defstab));
else
tmps = str_get(st[1]);
- while (*tmps && isascii(*tmps) && (isspace(*tmps) || *tmps == '0'))
+ while (*tmps && (isSPACE(*tmps) || *tmps == '0'))
tmps++;
if (*tmps == 'x')
value = (double)scanhex(++tmps, 99, &argtype);
else
value = (double)scanoct(tmps, 99, &argtype);
goto donumset;
+
+/* These common exits are hidden here in the middle of the switches for the
+ benefit of those machines with limited branch addressing. Sigh. */
+
+array_return:
+#ifdef DEBUGGING
+ if (debug) {
+ dlevel--;
+ if (debug & 8) {
+ anum = sp - arglast[0];
+ switch (anum) {
+ case 0:
+ deb("%s RETURNS ()\n",opname[optype]);
+ break;
+ case 1:
+ deb("%s RETURNS (\"%s\")\n",opname[optype],
+ st[1] ? str_get(st[1]) : "");
+ break;
+ default:
+ tmps = st[1] ? str_get(st[1]) : "";
+ deb("%s RETURNS %d ARGS (\"%s\",%s\"%s\")\n",opname[optype],
+ anum,tmps,anum==2?"":"...,",
+ st[anum] ? str_get(st[anum]) : "");
+ break;
+ }
+ }
+ }
+#endif
+ return sp;
+
+say_yes:
+ str = &str_yes;
+ goto normal_return;
+
+say_no:
+ str = &str_no;
+ goto normal_return;
+
+say_undef:
+ str = &str_undef;
+ goto normal_return;
+
+say_zero:
+ value = 0.0;
+ /* FALL THROUGH */
+
+donumset:
+ str_numset(str,value);
+ STABSET(str);
+ st[1] = str;
+#ifdef DEBUGGING
+ if (debug) {
+ dlevel--;
+ if (debug & 8)
+ deb("%s RETURNS \"%f\"\n",opname[optype],value);
+ }
+#endif
+ return arglast[0] + 1;
#ifdef SMALLSWITCHES
}
else
anum = 0;
else
anum = (int)str_gnum(st[1]);
+#ifdef _POSIX_SOURCE
+ if (anum != 0)
+ fatal("POSIX getpgrp can't take an argument");
+ value = (double)getpgrp();
+#else
value = (double)getpgrp(anum);
+#endif
goto donumset;
#else
fatal("The getpgrp() function is unimplemented on this machine");
value = (double)(ary->ary_fill + 1);
goto donumset;
+ case O_TRY:
+ sp = do_try(arg[1].arg_ptr.arg_cmd,
+ gimme,arglast);
+ goto array_return;
+
+ case O_EVALONCE:
+ sp = do_eval(st[1], O_EVAL, curcmd->c_stash, TRUE,
+ gimme,arglast);
+ if (eval_root) {
+ str_free(arg[1].arg_ptr.arg_str);
+ arg[1].arg_ptr.arg_cmd = eval_root;
+ arg[1].arg_type = (A_CMD|A_DONT);
+ arg[0].arg_type = O_TRY;
+ }
+ goto array_return;
+
case O_REQUIRE:
case O_DOFILE:
case O_EVAL:
tainted |= tmpstr->str_tainted;
taintproper("Insecure dependency in eval");
#endif
- sp = do_eval(tmpstr, optype, curcmd->c_stash,
+ sp = do_eval(tmpstr, optype, curcmd->c_stash, FALSE,
gimme,arglast);
goto array_return;
stab = stabent(tmps = str_get(st[1]),FALSE);
if (stab && stab_io(stab) && stab_io(stab)->ifp)
anum = fileno(stab_io(stab)->ifp);
- else if (isdigit(*tmps))
+ else if (isDIGIT(*tmps))
anum = atoi(tmps);
else
goto say_undef;
fatal("Unsupported function getlogin");
#endif
break;
- case O_OPENDIR:
+ case O_OPEN_DIR:
case O_READDIR:
case O_TELLDIR:
case O_SEEKDIR:
}
#endif
return arglast[0] + 1;
-
-array_return:
-#ifdef DEBUGGING
- if (debug) {
- dlevel--;
- if (debug & 8) {
- anum = sp - arglast[0];
- switch (anum) {
- case 0:
- deb("%s RETURNS ()\n",opname[optype]);
- break;
- case 1:
- deb("%s RETURNS (\"%s\")\n",opname[optype],str_get(st[1]));
- break;
- default:
- tmps = str_get(st[1]);
- deb("%s RETURNS %d ARGS (\"%s\",%s\"%s\")\n",opname[optype],
- anum,tmps,anum==2?"":"...,",str_get(st[anum]));
- break;
- }
- }
- }
-#endif
- return sp;
-
-say_yes:
- str = &str_yes;
- goto normal_return;
-
-say_no:
- str = &str_no;
- goto normal_return;
-
-say_undef:
- str = &str_undef;
- goto normal_return;
-
-say_zero:
- value = 0.0;
- /* FALL THROUGH */
-
-donumset:
- str_numset(str,value);
- STABSET(str);
- st[1] = str;
-#ifdef DEBUGGING
- if (debug) {
- dlevel--;
- if (debug & 8)
- deb("%s RETURNS \"%f\"\n",opname[optype],value);
- }
-#endif
- return arglast[0] + 1;
}
https://perl5.git.perl.org / perl5.git / blobdiff