See patch #9.
-/* $Header: cmd.c,v 3.0.1.4 89/12/21 19:17:41 lwall Locked $
+/* $Header: cmd.c,v 3.0.1.5 90/02/28 16:38:31 lwall Locked $
*
* Copyright (c) 1989, Larry Wall
*
* as specified in the README file that comes with the perl 3.0 kit.
*
* $Log: cmd.c,v $
+ * Revision 3.0.1.5 90/02/28 16:38:31 lwall
+ * patch9: volatilized some more variables for super-optimizing compilers
+ * patch9: nested foreach loops didn't reset inner loop on next to outer loop
+ * patch9: returned values were read from obsolete stack
+ * patch9: added sanity check on longjmp() return value
+ * patch9: substitutions that almost always succeed can corrupt label stack
+ * patch9: subs which return by both mechanisms can clobber local return data
+ *
* Revision 3.0.1.4 89/12/21 19:17:41 lwall
* patch7: arranged for certain registers to be restored after longjmp()
* patch7: made nested or recursive foreach work right
int
cmd_exec(cmdparm,gimme,sp)
CMD *VOLATILE cmdparm;
-int gimme;
-int sp;
+VOLATILE int gimme;
+VOLATILE int sp;
{
register CMD *cmd = cmdparm;
SPAT *VOLATILE oldspat;
+ VOLATILE int firstsave = savestack->ary_fill;
VOLATILE int oldsave;
VOLATILE int aryoptsave;
#ifdef DEBUGGING
cmdparm = cmd;
#endif
if (match = setjmp(loop_stack[loop_ptr].loop_env)) {
-#ifdef JMPCLOBBER
st = stack->ary_array; /* possibly reallocated */
+#ifdef JMPCLOBBER
cmd = cmdparm;
cmdflags = cmd->c_flags|CF_ONCE;
#endif
+ if (savestack->ary_fill > oldsave)
+ restorelist(oldsave);
switch (match) {
+ default:
+ fatal("longjmp returned bad value (%d)",match);
case O_LAST: /* not done unless go_to found */
go_to = Nullch;
if (lastretstr) {
olddlevel = dlevel;
#endif
curspat = oldspat;
- if (savestack->ary_fill > oldsave)
- restorelist(oldsave);
goto next_cmd;
case O_NEXT: /* not done unless go_to found */
go_to = Nullch;
}
}
if (--cmd->c_short->str_u.str_useful < 0) {
- cmdflags &= ~CF_OPTIMIZE;
+ cmdflags &= ~(CF_OPTIMIZE|CF_ONCE);
cmdflags |= CFT_EVAL; /* never try this optimization again */
cmd->c_flags = cmdflags;
}
savesptr(&stab_val(cmd->c_stab));
savelong(&cmd->c_short->str_u.str_useful);
}
- else
+ else {
ar = stab_xarray(cmd->c_expr[1].arg_ptr.arg_stab);
+ if (cmd->c_type != C_WHILE && savestack->ary_fill > firstsave)
+ restorelist(firstsave);
+ }
if (match >= ar->ary_fill) { /* we're in LAST, probably */
retstr = &str_undef;
cmdparm = cmd;
#endif
if (match = setjmp(loop_stack[loop_ptr].loop_env)) {
-#ifdef JMPCLOBBER
st = stack->ary_array; /* possibly reallocated */
+#ifdef JMPCLOBBER
cmd = cmdparm;
cmdflags = cmd->c_flags|CF_ONCE;
go_to = goto_targ;
#endif
+ if (savestack->ary_fill > oldsave)
+ restorelist(oldsave);
switch (match) {
+ default:
+ fatal("longjmp returned bad value (%d)",match);
case O_LAST:
if (lastretstr) {
retstr = lastretstr;
retstr = st[newsp];
}
curspat = oldspat;
- if (savestack->ary_fill > oldsave)
- restorelist(oldsave);
goto next_cmd;
case O_NEXT:
#ifdef JMPCLOBBER
}
finish_while:
curspat = oldspat;
- if (savestack->ary_fill > oldsave)
+ if (savestack->ary_fill > oldsave) {
+ if (cmdflags & CF_TERM) {
+ for (match = sp + 1; match <= newsp; match++)
+ st[match] = str_static(st[match]);
+ retstr = st[newsp];
+ }
restorelist(oldsave);
+ }
#ifdef DEBUGGING
dlevel = olddlevel - 1;
#endif
}
#endif
loop_ptr--;
- if ((cmdflags & CF_OPTIMIZE) == CFT_ARRAY)
+ if ((cmdflags & CF_OPTIMIZE) == CFT_ARRAY &&
+ savestack->ary_fill > aryoptsave)
restorelist(aryoptsave);
}
cmd = cmd->c_next;
-/* $Header: cmd.h,v 3.0.1.1 89/10/26 23:05:43 lwall Locked $
+/* $Header: cmd.h,v 3.0.1.2 90/02/28 16:39:36 lwall Locked $
*
* Copyright (c) 1989, Larry Wall
*
* as specified in the README file that comes with the perl 3.0 kit.
*
* $Log: cmd.h,v $
+ * Revision 3.0.1.2 90/02/28 16:39:36 lwall
+ * patch9: volatilized some more variables for super-optimizing compilers
+ *
* Revision 3.0.1.1 89/10/26 23:05:43 lwall
* patch1: unless was broken when run under the debugger
*
struct scmd scmd; /* switch command */
} ucmd;
short c_slen; /* len of c_short, if not null */
- short c_flags; /* optimization flags--see above */
+ VOLATILE short c_flags; /* optimization flags--see above */
char *c_file; /* file the following line # is from */
line_t c_line; /* line # of this command */
char c_type; /* what this command does */
#define Nullcmd Null(CMD*)
-EXT CMD *main_root INIT(Nullcmd);
-EXT CMD *eval_root INIT(Nullcmd);
+EXT CMD * VOLATILE main_root INIT(Nullcmd);
+EXT CMD * VOLATILE eval_root INIT(Nullcmd);
struct compcmd {
CMD *comp_true;
*/
#$d_voidsig VOIDSIG /**/
+/* HASVOLATILE:
+ * This symbol, if defined, indicates that this C compiler knows about
+ * the volatile declaration.
+ */
+#$d_volatile HASVOLATILE /**/
+
/* VPRINTF:
* This symbol, if defined, indicates that the vprintf routine is available
* to printf with a pointer to an argument list. If unavailable, you
/* I_UTIME:
* This symbol, if defined, indicates to the C program that it should
- * include utime.h (a DG/UX thingie).
+ * include utime.h.
*/
#$i_utime I_UTIME /**/
-/* $Header: cons.c,v 3.0.1.3 89/12/21 19:20:25 lwall Locked $
+/* $Header: cons.c,v 3.0.1.4 90/02/28 16:44:00 lwall Locked $
*
* Copyright (c) 1989, Larry Wall
*
* as specified in the README file that comes with the perl 3.0 kit.
*
* $Log: cons.c,v $
+ * Revision 3.0.1.4 90/02/28 16:44:00 lwall
+ * patch9: subs which return by both mechanisms can clobber local return data
+ * patch9: changed internal SUB label to _SUB_
+ * patch9: line numbers were bogus during certain portions of foreach evaluation
+ *
* Revision 3.0.1.3 89/12/21 19:20:25 lwall
* patch7: made nested or recursive foreach work right
*
mycompblock.comp_true = cmd;
mycompblock.comp_alt = Nullcmd;
- cmd = add_label(savestr("SUB"),make_ccmd(C_BLOCK,Nullarg,mycompblock));
+ cmd = add_label(savestr("_SUB_"),make_ccmd(C_BLOCK,Nullarg,mycompblock));
saw_return = FALSE;
+ if (perldb)
+ cmd->c_next->c_flags |= CF_TERM;
+ else
+ cmd->c_flags |= CF_TERM;
}
sub->cmd = cmd;
stab_sub(stab) = sub;
cmd->c_expr = cond;
if (cond)
cmd->c_flags |= CF_COND;
- if (cmdline != NOLINE) {
+ if (cmdline == NOLINE)
+ cmd->c_line = line;
+ else {
cmd->c_line = cmdline;
cmdline = NOLINE;
}
cmd->ucmd.ccmd.cc_alt = cblock.comp_alt;
if (arg)
cmd->c_flags |= CF_COND;
- if (cmdline != NOLINE) {
+ if (cmdline == NOLINE)
+ cmd->c_line = line;
+ else {
cmd->c_line = cmdline;
cmdline = NOLINE;
}
cmd->ucmd.ccmd.cc_alt = cblock.comp_alt;
if (arg)
cmd->c_flags |= CF_COND;
- if (cmdline != NOLINE) {
+ if (cmdline == NOLINE)
+ cmd->c_line = line;
+ else {
cmd->c_line = cmdline;
cmdline = NOLINE;
}
-/* $Header: consarg.c,v 3.0.1.2 89/11/17 15:11:34 lwall Locked $
+/* $Header: consarg.c,v 3.0.1.3 90/02/28 16:47:54 lwall Locked $
*
* Copyright (c) 1989, Larry Wall
*
* as specified in the README file that comes with the perl 3.0 kit.
*
* $Log: consarg.c,v $
+ * Revision 3.0.1.3 90/02/28 16:47:54 lwall
+ * patch9: the x operator is now up to 10 times faster
+ * patch9: @_ clobbered by ($foo,$bar) = split
+ *
* Revision 3.0.1.2 89/11/17 15:11:34 lwall
* patch5: defined $foo{'bar'} should not create element
*
break;
case O_REPEAT:
i = (int)str_gnum(s2);
+ tmps = str_get(s1);
str_nset(str,"",0);
- while (i-- > 0)
- str_scat(str,s1);
+ STR_GROW(str, i * s1->str_cur + 1);
+ repeatcpy(str->str_ptr, tmps, s1->str_cur, i);
+ str->str_cur = i * s1->str_cur;
+ str->str_ptr[str->str_cur] = '\0';
break;
case O_MULTIPLY:
value = str_gnum(s1);
arg2 = arg[2].arg_ptr.arg_arg;
if (arg2->arg_type == O_SPLIT) { /* use split's builtin =?*/
spat = arg2[2].arg_ptr.arg_spat;
- if (spat->spat_repl[1].arg_ptr.arg_stab == defstab &&
+ if (!(spat->spat_flags & SPAT_ONCE) &&
nothing_in_common(arg1,spat->spat_repl)) {
spat->spat_repl[1].arg_ptr.arg_stab =
arg1[1].arg_ptr.arg_stab;
+ spat->spat_flags |= SPAT_ONCE;
arg_free(arg1); /* recursive */
free_arg(arg); /* non-recursive */
return arg2; /* split has builtin assign */
-/* $Header: doarg.c,v 3.0.1.2 89/12/21 19:52:15 lwall Locked $
+/* $Header: doarg.c,v 3.0.1.3 90/02/28 16:56:58 lwall Locked $
*
* Copyright (c) 1989, Larry Wall
*
* as specified in the README file that comes with the perl 3.0 kit.
*
* $Log: doarg.c,v $
+ * Revision 3.0.1.3 90/02/28 16:56:58 lwall
+ * patch9: split now can split into more than 10000 elements
+ * patch9: sped up pack and unpack
+ * patch9: pack of unsigned ints and longs blew up some places
+ * patch9: sun3 can't cast negative float to unsigned int or long
+ * patch9: local($.) didn't work
+ * patch9: grep(s/foo/bar/, @abc = @xyz) modified @xyz rather than @abc
+ * patch9: syscall returned stack size rather than value of system call
+ *
* Revision 3.0.1.2 89/12/21 19:52:15 lwall
* patch7: a pattern wouldn't match a null string before the first character
* patch7: certain patterns didn't match correctly at end of string
register char *d;
int clen;
int iters = 0;
+ int maxiters = (strend - s) + 10;
register int i;
bool once;
char *orig;
/* NOTREACHED */
}
do {
- if (iters++ > 10000)
+ if (iters++ > maxiters)
fatal("Substitution loop");
m = spat->spat_regexp->startp[0];
if (i = m - s) {
curspat = spat;
lastspat = spat;
do {
- if (iters++ > 10000)
+ if (iters++ > maxiters)
fatal("Substitution loop");
if (spat->spat_regexp->subbase
&& spat->spat_regexp->subbase != orig) {
char achar;
short ashort;
int aint;
+ unsigned int auint;
long along;
+ unsigned long aulong;
char *aptr;
items = arglast[2] - sp;
#define NEXTFROM (items-- > 0 ? *st++ : &str_no)
datumtype = *pat++;
if (isdigit(*pat)) {
- len = atoi(pat);
+ len = *pat++ - '0';
while (isdigit(*pat))
- pat++;
+ len = (len * 10) + (*pat++ - '0');
}
else
len = 1;
}
break;
case 'I':
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ auint = (unsigned int)str_gnum(fromstr);
+ str_ncat(str,(char*)&auint,sizeof(unsigned int));
+ }
+ break;
case 'i':
while (len-- > 0) {
fromstr = NEXTFROM;
}
break;
case 'L':
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ aulong = (unsigned long)str_gnum(fromstr);
+ str_ncat(str,(char*)&aulong,sizeof(unsigned long));
+ }
+ break;
case 'l':
while (len-- > 0) {
fromstr = NEXTFROM;
register char *send;
char *xs;
int xlen;
+ double value;
str_set(str,"");
len--; /* don't count pattern string */
case 'x': case 'o': case 'u':
ch = *(++t);
*t = '\0';
+ value = str_gnum(*(sarg++));
+#if defined(sun) && !defined(sparc)
+ if (value < 0.0) { /* sigh */
+ if (dolong)
+ (void)sprintf(buf,s,(long)value);
+ else
+ (void)sprintf(buf,s,(int)value);
+ }
+ else
+#endif
if (dolong)
- (void)sprintf(buf,s,(unsigned long)str_gnum(*(sarg++)));
+ (void)sprintf(buf,s,(unsigned long)value);
else
- (void)sprintf(buf,s,(unsigned int)str_gnum(*(sarg++)));
+ (void)sprintf(buf,s,(unsigned int)value);
s = t;
*(t--) = ch;
break;
int i;
makelocal = (arg->arg_flags & AF_LOCAL);
+ localizing = makelocal;
delaymagic = DM_DELAY; /* catch simultaneous items */
/* If there's a common identifier on both sides we have to take
while (relem <= lastrelem) { /* gobble up all the rest */
str = Str_new(28,0);
if (*relem)
- str_sset(str,*(relem++));
- else
- relem++;
+ str_sset(str,*relem);
+ *(relem++) = str;
(void)astore(ary,i++,str);
}
}
tmps = str_get(str);
tmpstr = Str_new(29,0);
if (*relem)
- str_sset(tmpstr,*(relem++)); /* value */
- else
- relem++;
+ str_sset(tmpstr,*relem); /* value */
+ *(relem++) = tmpstr;
(void)hstore(hash,tmps,str->str_cur,tmpstr,0);
}
}
else {
if (makelocal)
saveitem(str);
- if (relem <= lastrelem)
- str_sset(str, *(relem++));
- else
+ if (relem <= lastrelem) {
+ str_sset(str, *relem);
+ *(relem++) = str;
+ }
+ else {
str_nset(str, "", 0);
+ 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);
}
}
#endif
}
delaymagic = 0;
+ localizing = FALSE;
if (gimme == G_ARRAY) {
i = lastrelem - firstrelem + 1;
if (ary || hash)
arg[7]);
break;
}
- st[sp] = str_static(&str_undef);
- str_numset(st[sp], (double)retval);
- return sp;
+ return retval;
#else
fatal("syscall() unimplemented");
#endif
-/* $Header: doio.c,v 3.0.1.4 89/12/21 19:55:10 lwall Locked $
+/* $Header: doio.c,v 3.0.1.5 90/02/28 17:01:36 lwall Locked $
*
* Copyright (c) 1989, Larry Wall
*
* as specified in the README file that comes with the perl 3.0 kit.
*
* $Log: doio.c,v $
+ * Revision 3.0.1.5 90/02/28 17:01:36 lwall
+ * patch9: open(FOO,"$filename\0") will now protect trailing spaces in filename
+ * patch9: removed obsolete checks to avoid opening block devices
+ * patch9: removed references to acusec and modusec that some utime.h's have
+ * patch9: added pipe function
+ *
* Revision 3.0.1.4 89/12/21 19:55:10 lwall
* patch7: select now works on big-endian machines
* patch7: errno may now be a macro with an lvalue
#endif
bool
-do_open(stab,name)
+do_open(stab,name,len)
STAB *stab;
register char *name;
+int len;
{
FILE *fp;
- int len = strlen(name);
register STIO *stio = stab_io(stab);
char *myname = savestr(name);
int result;
return FALSE;
}
result = (statbuf.st_mode & S_IFMT);
- if (result != S_IFREG &&
-#ifdef S_IFSOCK
- result != S_IFSOCK &&
-#endif
-#ifdef S_IFFIFO
- result != S_IFFIFO &&
-#endif
-#ifdef S_IFIFO
- result != S_IFIFO &&
-#endif
- result != 0 && /* socket? */
- result != S_IFCHR) {
- (void)fclose(fp);
- return FALSE;
- }
#ifdef S_IFSOCK
if (result == S_IFSOCK || result == 0)
stio->type = 's'; /* in case a socket was passed in to us */
str_sset(stab_val(stab),str);
STABSET(stab_val(stab));
oldname = str_get(stab_val(stab));
- if (do_open(stab,oldname)) {
+ if (do_open(stab,oldname,stab_val(stab)->str_cur)) {
if (inplace) {
#ifdef TAINT
taintproper("Insecure dependency in inplace open");
str_nset(str,">",1);
str_cat(str,oldname);
errno = 0; /* in case sprintf set errno */
- if (!do_open(argvoutstab,str->str_ptr))
+ if (!do_open(argvoutstab,str->str_ptr,str->str_cur))
fatal("Can't do inplace edit");
defoutstab = argvoutstab;
#ifdef FCHMOD
return Nullfp;
}
+void
+do_pipe(str, rstab, wstab)
+STR *str;
+STAB *rstab;
+STAB *wstab;
+{
+ register STIO *rstio;
+ register STIO *wstio;
+ int fd[2];
+
+ if (!rstab)
+ goto badexit;
+ if (!wstab)
+ goto badexit;
+
+ rstio = stab_io(rstab);
+ wstio = stab_io(wstab);
+
+ if (!rstio)
+ rstio = stab_io(rstab) = stio_new();
+ else if (rstio->ifp)
+ do_close(rstab,FALSE);
+ if (!wstio)
+ wstio = stab_io(wstab) = stio_new();
+ else if (wstio->ifp)
+ do_close(wstab,FALSE);
+
+ if (pipe(fd) < 0)
+ goto badexit;
+ rstio->ifp = fdopen(fd[0], "r");
+ wstio->ofp = fdopen(fd[1], "w");
+ wstio->ifp = wstio->ofp;
+ rstio->type = '<';
+ wstio->type = '>';
+
+ str_sset(str,&str_yes);
+ return;
+
+badexit:
+ str_sset(str,&str_undef);
+ return;
+}
+
bool
do_close(stab,explicit)
STAB *stab;
} utbuf;
#endif
+ Zero(&utbuf, sizeof utbuf, char);
utbuf.actime = (long)str_gnum(st[++sp]); /* time accessed */
utbuf.modtime = (long)str_gnum(st[++sp]); /* time modified */
-#ifdef I_UTIME
- utbuf.acusec = 0; /* hopefully I_UTIME implies these */
- utbuf.modusec = 0;
-#endif
items -= 2;
#ifndef lint
tot = items;
-/* $Header: dolist.c,v 3.0.1.4 89/12/21 19:58:46 lwall Locked $
+/* $Header: dolist.c,v 3.0.1.5 90/02/28 17:09:44 lwall Locked $
*
* Copyright (c) 1989, Larry Wall
*
* as specified in the README file that comes with the perl 3.0 kit.
*
* $Log: dolist.c,v $
+ * Revision 3.0.1.5 90/02/28 17:09:44 lwall
+ * patch9: split now can split into more than 10000 elements
+ * patch9: @_ clobbered by ($foo,$bar) = split
+ * patch9: sped up pack and unpack
+ * patch9: unpack of single item now works in a scalar context
+ * patch9: slices ignored value of $[
+ * patch9: grep now returns number of items matched in scalar context
+ * patch9: grep iterations no longer in the regexp context of previous iteration
+ *
* Revision 3.0.1.4 89/12/21 19:58:46 lwall
* patch7: grep(1,@array) didn't work
* patch7: /$pat/; //; wrongly freed runtime pattern twice
register STR *dstr;
register char *m;
int iters = 0;
+ int maxiters = (strend - s) + 10;
int i;
char *orig;
int origlimit = limit;
}
#endif
ary = stab_xarray(spat->spat_repl[1].arg_ptr.arg_stab);
- if (ary && ((ary->ary_flags & ARF_REAL) || gimme != G_ARRAY)) {
+ if (ary && (gimme != G_ARRAY || (spat->spat_flags & SPAT_ONCE))) {
realarray = 1;
if (!(ary->ary_flags & ARF_REAL)) {
ary->ary_flags |= ARF_REAL;
s++;
}
if (!limit)
- limit = 10001;
+ limit = maxiters + 2;
if (spat->spat_short) {
i = spat->spat_short->str_cur;
if (i == 1) {
}
}
else {
+ maxiters += (strend - s) * spat->spat_regexp->nparens;
while (s < strend && --limit &&
regexec(spat->spat_regexp, s, strend, orig, 1, Nullstr, TRUE) ) {
if (spat->spat_regexp->subbase
iters = sp + 1;
else
iters = sp - arglast[0];
- if (iters > 9999)
+ if (iters > maxiters)
fatal("Split loop");
if (s < strend || origlimit) { /* keep field after final delim? */
if (realarray)
unsigned long aulong;
char *aptr;
- if (gimme != G_ARRAY) {
- str_sset(str,&str_undef);
- STABSET(str);
- st[sp] = str;
- return sp;
+ if (gimme != G_ARRAY) { /* arrange to do first one only */
+ patend = pat+1;
+ if (*pat == 'a' || *pat == 'A') {
+ while (isdigit(*patend))
+ patend++;
+ }
}
sp--;
while (pat < patend) {
datumtype = *pat++;
if (isdigit(*pat)) {
- len = atoi(pat);
+ len = *pat++ - '0';
while (isdigit(*pat))
- pat++;
+ len = (len * 10) + (*pat++ - '0');
}
else
len = 1;
if (numarray) {
while (sp < max) {
if (st[++sp]) {
- st[sp-1] = afetch(stab_array(stab),(int)str_gnum(st[sp]),
- lval);
+ st[sp-1] = afetch(stab_array(stab),
+ ((int)str_gnum(st[sp])) - arybase, lval);
}
else
st[sp-1] = &str_undef;
else {
if (numarray) {
if (st[max])
- st[sp] = afetch(stab_array(stab),(int)str_gnum(st[max]), lval);
+ st[sp] = afetch(stab_array(stab),
+ ((int)str_gnum(st[max])) - arybase, lval);
else
st[sp] = &str_undef;
}
register int sp = arglast[2];
register int i = sp - arglast[1];
int oldsave = savestack->ary_fill;
+ SPAT *oldspat = curspat;
savesptr(&stab_val(defstab));
if ((arg[1].arg_type & A_MASK) != A_EXPR) {
if (str_true(st[sp+1]))
st[dst++] = st[src];
src++;
+ curspat = oldspat;
}
restorelist(oldsave);
if (gimme != G_ARRAY) {
- str_sset(str,&str_undef);
+ str_numset(str,(double)(dst - arglast[1]));
STABSET(str);
st[arglast[0]+1] = str;
return arglast[0]+1;
-/* $Header: eval.c,v 3.0.1.3 89/12/21 20:03:05 lwall Locked $
+/* $Header: eval.c,v 3.0.1.4 90/02/28 17:36:59 lwall Locked $
*
* Copyright (c) 1989, Larry Wall
*
* as specified in the README file that comes with the perl 3.0 kit.
*
* $Log: eval.c,v $
+ * Revision 3.0.1.4 90/02/28 17:36:59 lwall
+ * patch9: added pipe function
+ * patch9: a return in scalar context wouldn't return array
+ * patch9: !~ now always returns scalar even in array context
+ * patch9: some machines can't cast float to long with high bit set
+ * patch9: piped opens returned undef in child
+ * patch9: @array in scalar context now returns length of array
+ * patch9: chdir; coredumped
+ * patch9: wait no longer ignores signals
+ * patch9: mkdir now handles odd versions of /bin/mkdir
+ * patch9: -l FILEHANDLE now disallowed
+ *
* Revision 3.0.1.3 89/12/21 20:03:05 lwall
* patch7: errno may now be a macro with an lvalue
* patch7: ANSI strerror() is now supported
static STIO *stio;
static struct lstring *lstr;
static char old_record_separator;
+extern int wantarray;
double sin(), cos(), atan2(), pow();
STR_SSET(str,st[1]);
anum = (int)str_gnum(st[2]);
if (anum >= 1) {
- tmpstr = Str_new(50,0);
+ tmpstr = Str_new(50, 0);
str_sset(tmpstr,str);
- while (--anum > 0)
- str_scat(str,tmpstr);
+ tmps = str_get(tmpstr); /* force to be string */
+ STR_GROW(str, (anum * str->str_cur) + 1);
+ repeatcpy(str->str_ptr, tmps, tmpstr->str_cur, anum);
+ str->str_cur *= anum; str->str_ptr[str->str_cur] = '\0';
}
else
str_sset(str,&str_no);
break;
case O_NMATCH:
sp = do_match(str,arg,
- gimme,arglast);
- if (gimme == G_ARRAY)
- goto array_return;
+ G_SCALAR,arglast);
str_sset(str, str_true(str) ? &str_no : &str_yes);
STABSET(str);
break;
value = str_gnum(st[1]);
anum = (int)str_gnum(st[2]);
#ifndef lint
- value = (double)(((long)value) << anum);
+ value = (double)(((unsigned long)value) << anum);
#endif
goto donumset;
case O_RIGHT_SHIFT:
value = str_gnum(st[1]);
anum = (int)str_gnum(st[2]);
#ifndef lint
- value = (double)(((long)value) >> anum);
+ value = (double)(((unsigned long)value) >> anum);
#endif
goto donumset;
case O_LT:
if (!sawvec || st[1]->str_nok || st[2]->str_nok) {
value = str_gnum(st[1]);
#ifndef lint
- value = (double)(((long)value) & (long)str_gnum(st[2]));
+ value = (double)(((unsigned long)value) &
+ (unsigned long)str_gnum(st[2]));
#endif
goto donumset;
}
if (!sawvec || st[1]->str_nok || st[2]->str_nok) {
value = str_gnum(st[1]);
#ifndef lint
- value = (double)(((long)value) ^ (long)str_gnum(st[2]));
+ value = (double)(((unsigned long)value) ^
+ (unsigned long)str_gnum(st[2]));
#endif
goto donumset;
}
if (!sawvec || st[1]->str_nok || st[2]->str_nok) {
value = str_gnum(st[1]);
#ifndef lint
- value = (double)(((long)value) | (long)str_gnum(st[2]));
+ value = (double)(((unsigned long)value) |
+ (unsigned long)str_gnum(st[2]));
#endif
goto donumset;
}
goto donumset;
case O_COMPLEMENT:
#ifndef lint
- value = (double) ~(long)str_gnum(st[1]);
+ value = (double) ~(unsigned long)str_gnum(st[1]);
#endif
goto donumset;
case O_SELECT:
stab = arg[1].arg_ptr.arg_stab;
else
stab = stabent(str_get(st[1]),TRUE);
- if (do_open(stab,str_get(st[2]))) {
+ tmps = str_get(st[2]);
+ if (do_open(stab,tmps,st[2]->str_cur)) {
value = (double)forkprocess;
stab_io(stab)->lines = 0;
goto donumset;
}
+ else if (forkprocess == 0) /* we are a new child */
+ goto say_zero;
else
goto say_undef;
break;
sp += maxarg;
goto array_return;
}
- else
- str = afetch(ary,maxarg - 1,FALSE);
- break;
+ else {
+ value = (double)maxarg;
+ goto donumset;
+ }
case O_AELEM:
anum = ((int)str_gnum(st[2])) - arybase;
str = afetch(stab_array(arg[1].arg_ptr.arg_stab),anum,FALSE);
goto donumset;
case O_CHDIR:
if (maxarg < 1)
- tmps = str_get(stab_val(defstab));
+ tmps = Nullch;
else
tmps = str_get(st[1]);
if (!tmps || !*tmps) {
STABSET(str);
break;
case O_RETURN:
- tmps = "SUB"; /* just fake up a "last SUB" */
+ tmps = "_SUB_"; /* just fake up a "last _SUB_" */
optype = O_LAST;
- if (gimme == G_ARRAY) {
+ if (wantarray == G_ARRAY) {
lastretstr = Nullstr;
lastspbase = arglast[1];
lastsize = arglast[2] - arglast[1];
goto donumset;
case O_WAIT:
#ifndef lint
- ihand = signal(SIGINT, SIG_IGN);
- qhand = signal(SIGQUIT, SIG_IGN);
+ /* ihand = signal(SIGINT, SIG_IGN); */
+ /* qhand = signal(SIGQUIT, SIG_IGN); */
anum = wait(&argflags);
if (anum > 0)
pidgone(anum,argflags);
value = (double)anum;
#else
- ihand = qhand = 0;
+ /* ihand = qhand = 0; */
#endif
- (void)signal(SIGINT, ihand);
- (void)signal(SIGQUIT, qhand);
+ /* (void)signal(SIGINT, ihand); */
+ /* (void)signal(SIGQUIT, qhand); */
statusvalue = (unsigned short)argflags;
goto donumset;
case O_SYSTEM:
errno = EEXIST;
else if (instr(buf,"non-exist"))
errno = ENOENT;
+ else if (instr(buf,"does not exist"))
+ errno = ENOENT;
else if (instr(buf,"not empty"))
errno = EBUSY;
else if (instr(buf,"cannot access"))
stab = arg[1].arg_ptr.arg_stab;
else
stab = stabent(str_get(st[1]),TRUE);
- argtype = (int)str_gnum(st[2]);
+ argtype = (unsigned int)str_gnum(st[2]);
#ifdef TAINT
taintproper("Insecure dependency in ioctl");
#endif
goto say_no;
#endif
case O_FTLINK:
+ if (arg[1].arg_type & A_DONT)
+ fatal("You must supply explicit filename with -l");
#ifdef LSTAT
if (lstat(str_get(st[1]),&statcache) < 0)
goto say_undef;
case O_SYSCALL:
value = (double)do_syscall(arglast);
goto donumset;
+ case O_PIPE:
+ if ((arg[1].arg_type & A_MASK) == A_WORD)
+ stab = arg[1].arg_ptr.arg_stab;
+ else
+ stab = stabent(str_get(st[1]),TRUE);
+ if ((arg[2].arg_type & A_MASK) == A_WORD)
+ stab2 = arg[2].arg_ptr.arg_stab;
+ else
+ stab2 = stabent(str_get(st[2]),TRUE);
+ do_pipe(str,stab,stab2);
+ STABSET(str);
+ break;
}
normal_return:
#ifdef DEBUGGING
if (debug) {
dlevel--;
- if (debug & 8)
- deb("%s RETURNS ARRAY OF %d ARGS\n",opname[optype],sp - arglast[0]);
+ 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:
+ deb("%s RETURNS %d ARGS (\"%s\",%s\"%s\"\n",opname[optype],anum,
+ str_get(st[1]),anum==2?"":"...,",str_get(st[anum]));
+ break;
+ }
+ }
}
#endif
return sp;
local ($prompt) = shift (@_);
local ($c, $cmp, $l, $r, $ret, $return, $test);
@_cmp_lst = sort @_;
+ local($[) = 0;
system 'stty raw -echo';
loop: {
print $prompt, $return;
-#define PATCHLEVEL 9
+#define PATCHLEVEL 10
#!./perl
-# $Header: base.term,v 3.0 89/10/18 15:24:34 lwall Locked $
+# $Header: base.term,v 3.0.1.1 90/02/28 18:31:56 lwall Locked $
print "1..6\n";
# check <> pseudoliteral
open(try, "/dev/null") || (die "Can't open /dev/null.");
-if (<try> eq '') {print "ok 5\n";} else {print "not ok 5\n";}
+if (<try> eq '') {
+ print "ok 5\n";
+}
+else {
+ print "not ok 5\n";
+ die "/dev/null IS NOT A CHARACTER SPECIAL FILE!!!!\n" unless -c '/dev/null';
+}
open(try, "../Makefile") || (die "Can't open ../Makefile.");
if (<try> ne '') {print "ok 6\n";} else {print "not ok 6\n";}
projects / p5sagit/p5-mst-13.2.git / commitdiff