See patch #29.
-/* $Header: doarg.c,v 3.0.1.7 90/08/13 22:14:15 lwall Locked $
+/* $Header: doarg.c,v 3.0.1.8 90/10/15 16:04:04 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.8 90/10/15 16:04:04 lwall
+ * patch29: @ENV = () now works
+ * patch29: added caller
+ * patch29: tr/// now understands c, d and s options, and handles nulls right
+ * patch29: *foo now prints as *package'foo
+ * patch29: added caller
+ * patch29: local() without initialization now creates undefined values
+ *
* Revision 3.0.1.7 90/08/13 22:14:15 lwall
* patch28: the NSIG hack didn't work on Xenix
* patch28: defined(@array) and defined(%array) didn't work right
extern unsigned char fold[];
-int wantarray;
+extern char **environ;
#ifdef BUGGY_MSC
#pragma function(memcmp)
int
do_trans(str,arg)
STR *str;
-register ARG *arg;
+ARG *arg;
{
- register char *tbl;
+ 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 = arg[2].arg_ptr.arg_cval;
+ tbl = (short*) arg[2].arg_ptr.arg_cval;
s = str_get(str);
send = s + str->str_cur;
if (!tbl || !s)
deb("2.TBL\n");
}
#endif
- while (s < send) {
- if (ch = tbl[*s & 0377]) {
- matches++;
- *s = ch;
+ 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++;
}
- s++;
+ matches += send - d; /* account for disappeared chars */
+ *d = '\0';
+ str->str_cur = d - str->str_ptr;
}
STABSET(str);
return matches;
xlen = (*sarg)->str_cur;
if (*xs == 'S' && xs[1] == 't' && xs[2] == 'B'
&& xlen == sizeof(STBP) && strlen(xs) < xlen) {
- xs = stab_name(((STAB*)(*sarg))); /* a stab value! */
- sprintf(tokenbuf,"*%s",xs); /* reformat to non-binary */
+ STR *tmpstr = Str_new(24,0);
+
+ stab_fullname(tmpstr, ((STAB*)(*sarg))); /* a stab value! */
+ sprintf(tokenbuf,"*%s",tmpstr->str_ptr);
+ /* reformat to non-binary */
xs = tokenbuf;
xlen = strlen(tokenbuf);
+ str_free(tmpstr);
}
if (strEQ(t-2,"%s")) { /* some printfs fail on >128 chars */
*buf = '\0';
register int sp = arglast[1];
register int items = arglast[2] - sp;
register SUBR *sub;
- ARRAY *savearray;
+ STR *str;
STAB *stab;
- char *oldfile = filename;
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;
}
if (!stab)
fatal("Undefined subroutine called");
- saveint(&wantarray);
- wantarray = gimme;
- sub = stab_sub(stab);
- if (!sub)
- fatal("Undefined subroutine \"%s\" called", stab_name(stab));
- if (sub->usersub) {
- st[sp] = arg->arg_ptr.arg_str;
- if ((arg[2].arg_type & A_MASK) == A_NULL)
- items = 0;
- return sub->usersub(sub->userindex,sp,items);
- }
- if ((arg[2].arg_type & A_MASK) != A_NULL) {
- savearray = stab_xarray(defstab);
- stab_xarray(defstab) = afake(defstab, items, &st[sp+1]);
+ if (arg->arg_type == O_DBSUBR) {
+ str = stab_val(DBsub);
+ saveitem(str);
+ stab_fullname(str,stab);
+ sub = stab_sub(DBsub);
+ if (!sub)
+ fatal("No DBsub routine");
}
- savelong(&sub->depth);
- sub->depth++;
- if (sub->depth >= 2) { /* save temporaries on recursion? */
- if (sub->depth == 100 && dowarn)
- warn("Deep recursion on subroutine \"%s\"",stab_name(stab));
- savelist(sub->tosave->ary_array,sub->tosave->ary_fill);
- }
- filename = sub->filename;
- tmps_base = tmps_max;
- sp = cmd_exec(sub->cmd,gimme,--sp); /* so do it already */
- st = stack->ary_array;
-
- if ((arg[2].arg_type & A_MASK) != A_NULL) {
- afree(stab_xarray(defstab)); /* put back old $_[] */
- stab_xarray(defstab) = savearray;
- }
- filename = oldfile;
- tmps_base = oldtmps_base;
- if (savestack->ary_fill > oldsave) {
- for (items = arglast[0] + 1; items <= sp; items++)
- st[items] = str_static(st[items]);
- /* in case restore wipes old str */
- restorelist(oldsave);
- }
- return sp;
-}
-
-int
-do_dbsubr(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;
- ARRAY *savearray;
- STR *str;
- STAB *stab;
- char *oldfile = filename;
- int oldsave = savestack->ary_fill;
- int oldtmps_base = tmps_base;
-
- if ((arg[1].arg_type & A_MASK) == A_WORD)
- stab = arg[1].arg_ptr.arg_stab;
else {
- STR *tmpstr = stab_val(arg[1].arg_ptr.arg_stab);
+ if (!(sub = stab_sub(stab))) {
+ STR *tmpstr = arg[0].arg_ptr.arg_str;
- if (tmpstr)
- stab = stabent(str_get(tmpstr),TRUE);
- else
- stab = Nullstab;
+ stab_fullname(tmpstr, stab);
+ fatal("Undefined subroutine \"%s\" called",tmpstr->str_ptr);
+ }
}
- if (!stab)
- fatal("Undefined subroutine called");
- saveint(&wantarray);
- wantarray = gimme;
-/* begin differences */
- str = stab_val(DBsub);
- saveitem(str);
- str_set(str,stab_name(stab));
- sub = stab_sub(DBsub);
- if (!sub)
- fatal("No DBsub routine");
-/* end differences */
- if ((arg[2].arg_type & A_MASK) != A_NULL) {
- savearray = stab_xarray(defstab);
- stab_xarray(defstab) = afake(defstab, items, &st[sp+1]);
+ 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;
+ if (sub->usersub) {
+ st[sp] = arg->arg_ptr.arg_str;
+ if (!hasargs)
+ items = 0;
+ return (*sub->usersub)(sub->userindex,sp,items);
+ }
+ if (hasargs) {
+ csv->savearray = stab_xarray(defstab);
+ csv->argarray = afake(defstab, items, &st[sp+1]);
+ stab_xarray(defstab) = csv->argarray;
}
- savelong(&sub->depth);
sub->depth++;
if (sub->depth >= 2) { /* save temporaries on recursion? */
if (sub->depth == 100 && dowarn)
warn("Deep recursion on subroutine \"%s\"",stab_name(stab));
savelist(sub->tosave->ary_array,sub->tosave->ary_fill);
}
- filename = sub->filename;
tmps_base = tmps_max;
sp = cmd_exec(sub->cmd,gimme, --sp); /* so do it already */
st = stack->ary_array;
- if ((arg[2].arg_type & A_MASK) != A_NULL) {
- afree(stab_xarray(defstab)); /* put back old $_[] */
- stab_xarray(defstab) = savearray;
- }
- filename = oldfile;
tmps_base = oldtmps_base;
- if (savestack->ary_fill > oldsave) {
- for (items = arglast[0] + 1; items <= sp; items++)
- st[items] = str_static(st[items]);
- /* in case restore wipes old str */
- restorelist(oldsave);
- }
+ for (items = arglast[0] + 1; items <= sp; items++)
+ st[items] = str_static(st[items]);
+ /* in case restore wipes old str */
+ restorelist(oldsave);
return sp;
}
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);
- hclear(hash);
+ 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_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
*(relem++) = str;
}
else {
- str_nset(str, "", 0);
+ str_sset(str, &str_undef);
if (gimme == G_ARRAY) {
i = ++lastrelem - firstrelem;
relem++; /* tacky, I suppose */
}
else if (type == O_HASH || type == O_LHASH) {
stab = arg[1].arg_ptr.arg_stab;
- (void)hfree(stab_xhash(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) {
-#define PATCHLEVEL 35
+#define PATCHLEVEL 36
-char rcsid[] = "$Header: perly.c,v 3.0.1.7 90/08/13 22:22:22 lwall Locked $\nPatch level: ###\n";
+char rcsid[] = "$Header: perly.c,v 3.0.1.8 90/10/16 10:14:20 lwall Locked $\nPatch level: ###\n";
/*
* Copyright (c) 1989, Larry Wall
*
* as specified in the README file that comes with the perl 3.0 kit.
*
* $Log: perly.c,v $
+ * Revision 3.0.1.8 90/10/16 10:14:20 lwall
+ * patch29: *foo now prints as *package'foo
+ * patch29: added waitpid
+ * patch29: the debugger now understands packages and evals
+ * patch29: added -M, -A and -C
+ * patch29: -w sometimes printed spurious warnings about ARGV and ENV
+ * patch29: require "./foo" didn't work right
+ * patch29: require error messages referred to wrong file
+ *
* Revision 3.0.1.7 90/08/13 22:22:22 lwall
* patch28: defined(@array) and defined(%array) didn't work right
*
#include "EXTERN.h"
#include "perl.h"
#include "perly.h"
+#ifdef MSDOS
+#include "patchlev.h"
+#else
#include "patchlevel.h"
+#endif
#ifdef IAMSUID
#ifndef DOSUID
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++) {
argv[0] = savestr(xfound);
}
- pidstatary = anew(Nullstab); /* for remembering popen pids, status */
+ fdpid = anew(Nullstab); /* for remembering popen pids by fd */
+ pidstatus = hnew(Nullstab); /* for remembering status of dead pids */
origfilename = savestr(argv[0]);
- filename = origfilename;
- if (strEQ(filename,"-"))
+ curcmd->c_filestab = fstab(origfilename);
+ if (strEQ(origfilename,"-"))
argv[0] = "";
if (preprocess) {
str_cat(str,"-I");
str_cat(str,PRIVLIB);
(void)sprintf(buf, "\
-/bin/sed %s -e '/^[^#]/b' \
+%ssed %s -e '/^[^#]/b' \
-e '/^#[ ]*include[ ]/b' \
-e '/^#[ ]*define[ ]/b' \
-e '/^#[ ]*if[ ]/b' \
-e '/^#[ ]*endif/b' \
-e 's/^#.*//' \
%s | %s -C %s %s",
+#ifdef MSDOS
+ "",
+#else
+ "/bin/",
+#endif
(doextract ? "-e '1,/^#/d\n'" : ""),
argv[0], CPPSTDIN, str_get(str), CPPMINUS);
doextract = FALSE;
if (rsfp == Nullfp) {
#ifdef DOSUID
#ifndef IAMSUID /* in case script is not readable before setuid */
- if (euid && stat(filename,&statbuf) >= 0 &&
+ if (euid && stat(stab_val(curcmd->c_filestab)->str_ptr,&statbuf) >= 0 &&
statbuf.st_mode & (S_ISUID|S_ISGID)) {
(void)sprintf(buf, "%s/%s", BIN, "suidperl");
execv(buf, origargv); /* try again */
#endif
#endif
fatal("Can't open perl script \"%s\": %s\n",
- filename, strerror(errno));
+ stab_val(curcmd->c_filestab)->str_ptr, strerror(errno));
}
str_free(str); /* free -I directories */
#ifdef DOSUID
if (fstat(fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
- fatal("Can't stat script \"%s\"",filename);
+ fatal("Can't stat script \"%s\"",origfilename);
if (statbuf.st_mode & (S_ISUID|S_ISGID)) {
int len;
* But I don't think it's too important. The manual lies when
* it says access() is useful in setuid programs.
*/
- if (access(filename,1)) /* as a double check */
+ 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
if (setreuid(euid,uid) < 0 || getuid() != euid || geteuid() != uid)
fatal("Can't swap uid and euid"); /* really paranoid */
- if (stat(filename,&tmpstatbuf) < 0) /* testing full pathname here */
- fatal("Permission denied");
+ 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);
(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,
- filename, statbuf.st_uid, statbuf.st_gid);
+ stab_val(curcmd->c_filestab)->str_ptr,
+ statbuf.st_uid, statbuf.st_gid);
(void)mypclose(rsfp);
}
fatal("Permission denied\n");
debstash = hnew(0);
stab_xhash(stabent("_DB",TRUE)) = debstash;
curstash = debstash;
- lineary = stab_xarray(aadd((tmpstab = stabent("line",TRUE))));
+ dbargs = stab_xarray(aadd((tmpstab = stabent("args",TRUE))));
tmpstab->str_pok |= SP_MULTI;
+ dbargs->ary_flags = 0;
subname = str_make("main",4);
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;
}
(void)hadd(sigstab);
}
- magicalize("!#?^~=-%0123456789.+&*()<>,\\/[|`':");
+ magicalize("!#?^~=-%0123456789.+&*()<>,\\/[|`':\024");
userinit(); /* in case linked C routines want magical variables */
amperstab = stabent("&",allstabs);
sawampersand = (amperstab || leftstab || rightstab);
if (tmpstab = stabent(":",allstabs))
str_set(STAB_STR(tmpstab),chopset);
+ if (tmpstab = stabent("\024",allstabs))
+ time(&basetime);
/* these aren't necessarily magical */
if (tmpstab = stabent(";",allstabs))
statname = Str_new(66,0); /* last filename we did stat on */
- perldb = FALSE; /* don't try to instrument evals */
-
- if (dowarn) {
- stab_check('A','Z');
- stab_check('a','z');
- }
-
if (do_undump)
abort();
if (envstab = stabent("ENV",allstabs)) {
envstab->str_pok |= SP_MULTI;
(void)hadd(envstab);
- hclear(stab_hash(envstab));
+ hclear(stab_hash(envstab), FALSE);
if (env != environ)
environ[0] = Nullch;
for (; *env; env++) {
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 */
CMD *myroot;
ARRAY *ar;
int i;
- char * VOLATILE oldfile = filename;
CMD * VOLATILE oldcurcmd = curcmd;
VOLATILE int oldtmps_base = tmps_base;
VOLATILE int oldsave = savestack->ary_fill;
+ VOLATILE int oldperldb = perldb;
SPAT * VOLATILE oldspat = curspat;
static char *last_eval = Nullch;
static CMD *last_root = Nullcmd;
VOLATILE int sp = arglast[0];
char *specfilename;
+ char *tmpfilename;
tmps_base = tmps_max;
if (curstash != stash) {
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 */
- filename = "(eval)";
+ curcmd->c_filestab = fstab("(eval)");
curcmd->c_line = 1;
str_sset(linestr,str);
str_cat(linestr,";"); /* be kind to them */
last_root = Nullcmd;
}
specfilename = str_get(str);
- filename = savestr(specfilename); /* can't free this easily */
str_set(linestr,"");
- if (optype == O_REQUIRE &&
+ if (optype == O_REQUIRE && &str_undef !=
hfetch(stab_hash(incstab), specfilename, strlen(specfilename), 0)) {
- filename = oldfile;
+ curcmd = oldcurcmd;
tmps_base = oldtmps_base;
st[++sp] = &str_yes;
+ perldb = oldperldb;
return sp;
}
- else if (*filename == '/')
- rsfp = fopen(filename,"r");
+ tmpfilename = savestr(specfilename);
+ if (index("/.", *tmpfilename))
+ rsfp = fopen(tmpfilename,"r");
else {
ar = stab_array(incstab);
- Safefree(filename);
for (i = 0; i <= ar->ary_fill; i++) {
- (void)sprintf(buf,"%s/%s",str_get(afetch(ar,i,TRUE)),filename);
+ (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;
- filename = savestr(s);
+ Safefree(tmpfilename);
+ tmpfilename = savestr(s);
break;
}
}
}
+ curcmd->c_filestab = fstab(tmpfilename);
+ Safefree(tmpfilename);
if (!rsfp) {
- filename = oldfile;
+ curcmd = oldcurcmd;
tmps_base = oldtmps_base;
if (optype == O_REQUIRE) {
sprintf(tokenbuf,"Can't locate %s in @INC", specfilename);
}
if (gimme != G_ARRAY)
st[++sp] = &str_undef;
+ perldb = oldperldb;
return sp;
}
curcmd->c_line = 0;
}
else {
error_count = 0;
- if (rsfp)
+ if (rsfp) {
retval = yyparse();
+ retval |= error_count;
+ }
else if (last_root && *bufptr == *last_eval && strEQ(bufptr,last_eval)){
retval = 0;
eval_root = last_root; /* no point in reparsing */
last_eval = savestr(bufptr);
last_root = Nullcmd;
retval = yyparse();
+ retval |= error_count;
if (!retval)
last_root = eval_root;
}
retval = yyparse();
}
myroot = eval_root; /* in case cmd_exec does another eval! */
- if (retval || error_count) {
+
+ if (retval) {
st = stack->ary_array;
sp = arglast[0];
if (gimme != G_ARRAY)
if (rsfp) {
fclose(rsfp);
rsfp = 0;
- if (optype == O_REQUIRE)
- fatal("%s", str_get(stab_val(stabent("@",TRUE))));
}
}
else {
/* if we don't save result, free zaps it */
if (in_eval != 1 && myroot != last_root)
cmd_free(myroot);
- if (optype != O_EVAL) {
- if (gimme == G_SCALAR ? str_true(st[sp]) : sp > arglast[0]) {
- (void)hstore(stab_hash(incstab), specfilename,
- strlen(specfilename), str_make(filename,0), 0 );
- }
- else if (optype == O_REQUIRE)
- fatal("%s did not return a true value", specfilename);
- }
}
+
+ 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 : "" );
- }
+ if (debug & 4) {
+ char *tmps = loop_stack[loop_ptr].loop_label;
+ deb("(Popping label #%d %s)\n",loop_ptr,
+ tmps ? tmps : "" );
+ }
#endif
loop_ptr--;
- filename = oldfile;
- curcmd = oldcurcmd;
tmps_base = oldtmps_base;
curspat = oldspat;
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;
}
s++;
return s;
case 'v':
+ fputs("\nThis is perl, version 3.0\n\n",stdout);
fputs(rcsid,stdout);
fputs("\nCopyright (c) 1989, 1990, 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, Raymond Chen, Kai Uwe Rommel\n",
+ stdout);
+#endif
#endif
fputs("\n\
Perl may be copied only under the terms of the GNU General Public License,\n\
a copy of which can be found with the Perl 3.0 distribution kit.\n",stdout);
+#ifdef MSDOS
+ usage(origargv[0]);
+#endif
exit(0);
case 'w':
dowarn = TRUE;
-/* $Header: usersub.c,v 3.0.1.1 90/08/09 05:40:45 lwall Locked $
+/* $Header: usersub.c,v 3.0.1.2 90/10/16 11:22:04 lwall Locked $
*
* This file contains stubs for routines that the user may define to
* set up glue routines for C libraries or to decrypt encrypted scripts
* for execution.
*
* $Log: usersub.c,v $
+ * Revision 3.0.1.2 90/10/16 11:22:04 lwall
+ * patch29: added waitpid
+ *
* Revision 3.0.1.1 90/08/09 05:40:45 lwall
* patch19: Initial revision
*
}
close(p[1]);
fclose(fil);
- str = afetch(pidstatary,p[0],TRUE);
- str_numset(str,(double)pipepid);
- str->str_cur = 0;
+ str = afetch(fdpid,p[0],TRUE);
+ str->str_u.str_useful = pipepid;
return fdopen(p[0], "r");
}
-/* $Header: util.c,v 3.0.1.7 90/08/13 22:40:26 lwall Locked $
+/* $Header: util.c,v 3.0.1.8 90/10/16 11:26:57 lwall Locked $
*
* Copyright (c) 1989, Larry Wall
*
* as specified in the README file that comes with the perl 3.0 kit.
*
* $Log: util.c,v $
+ * Revision 3.0.1.8 90/10/16 11:26:57 lwall
+ * patch29: added waitpid
+ * patch29: various portability fixes
+ * patch29: scripts now run at almost full speed under the debugger
+ *
* Revision 3.0.1.7 90/08/13 22:40:26 lwall
* patch28: the NSIG hack didn't work right on Xenix
* patch28: rename was busted on systems without rename system call
register int i;
register int len = str->str_cur;
int rarest = 0;
- int frequency = 256;
+ unsigned int frequency = 256;
Str_Grow(str,len+258);
#ifndef lint
s = Null(unsigned char*);
#endif
if (iflag) {
- register int tmp, foldtmp;
+ register unsigned int tmp, foldtmp;
str->str_pok |= SP_CASEFOLD;
for (i = 0; i < len; i++) {
tmp=freq[s[i]];
s = big + littlelen;
oldlittle = little = table - 2;
if (littlestr->str_pok & SP_CASEFOLD) { /* case insensitive? */
- while (s < bigend) {
+ if (s < bigend) {
top1:
if (tmp = table[*s]) {
#ifdef POINTERRIGOR
}
}
else {
- while (s < bigend) {
+ if (s < bigend) {
top2:
if (tmp = table[*s]) {
#ifdef POINTERRIGOR
s += strlen(s);
if (s[-1] != '\n') {
if (curcmd->c_line) {
- (void)sprintf(s," at %s line %ld", filename, (long)curcmd->c_line);
+ (void)sprintf(s," at %s line %ld",
+ stab_val(curcmd->c_filestab)->str_ptr, (long)curcmd->c_line);
s += strlen(s);
}
if (last_in_stab &&
s += strlen(s);
if (s[-1] != '\n') {
if (curcmd->c_line) {
- (void)sprintf(s," at %s line %ld", filename, (long)curcmd->c_line);
+ (void)sprintf(s," at %s line %ld",
+ stab_val(curcmd->c_filestab)->str_ptr, (long)curcmd->c_line);
s += strlen(s);
}
if (last_in_stab &&
if (tmpstab = stabent("$",allstabs))
str_numset(STAB_STR(tmpstab),(double)getpid());
forkprocess = 0;
+ hclear(pidstatus); /* we have no children */
return Nullfp;
#undef THIS
#undef THAT
close(p[this]);
p[this] = p[that];
}
- str = afetch(pidstatary,p[this],TRUE);
- str_numset(str,(double)pid);
- str->str_cur = 0;
+ str = afetch(fdpid,p[this],TRUE);
+ str->str_u.str_useful = pid;
forkprocess = pid;
return fdopen(p[this], mode);
}
#endif
int status;
STR *str;
- register int pid;
+ int pid;
- str = afetch(pidstatary,fileno(ptr),TRUE);
+ str = afetch(fdpid,fileno(ptr),TRUE);
+ astore(fdpid,fileno(ptr),Nullstr);
fclose(ptr);
- pid = (int)str_gnum(str);
- if (!pid)
- return -1;
+ pid = (int)str->str_u.str_useful;
hstat = signal(SIGHUP, SIG_IGN);
istat = signal(SIGINT, SIG_IGN);
qstat = signal(SIGQUIT, SIG_IGN);
+ pid = wait4pid(pid, &status, 0);
+ signal(SIGHUP, hstat);
+ signal(SIGINT, istat);
+ signal(SIGQUIT, qstat);
+ return(pid < 0 ? pid : status);
+}
+
+int
+wait4pid(pid,statusp,flags)
+int pid;
+int *statusp;
+int flags;
+{
+ int result;
+ STR *str;
+ char spid[16];
+
+ if (!pid)
+ return -1;
#ifdef WAIT4
- if (wait4(pid,&status,0,Null(struct rusage *)) < 0)
- status = -1;
+ return wait4(pid,statusp,flags,Null(struct rusage *));
#else
- if (pid < 0) /* already exited? */
- status = str->str_cur;
+#ifdef WAITPID
+ return waitpid(pid,statusp,flags);
+#else
+ if (pid > 0) {
+ sprintf(spid, "%d", pid);
+ str = hfetch(pidstatus,spid,strlen(pid),FALSE);
+ if (str != &str_undef) {
+ *statusp = (int)str->str_u.str_useful;
+ hdelete(pidstatus,spid,strlen(pid));
+ return pid;
+ }
+ }
+ else {
+ HENT *entry;
+
+ hiterinit(pidstatus);
+ if (entry = hiternext(pidstatus)) {
+ pid = atoi(hiterkey(entry,statusp));
+ str = hiterval(entry);
+ *statusp = (int)str->str_u.str_useful;
+ sprintf(spid, "%d", pid);
+ hdelete(pidstatus,spid,strlen(pid));
+ return pid;
+ }
+ }
+ if (flags)
+ fatal("Can't do waitpid with flags");
else {
int result;
+ register int count;
+ register STR *str;
- while ((result = wait(&status)) != pid && result >= 0)
- pidgone(result,status);
+ while ((result = wait(statusp)) != pid && pid > 0 && result >= 0)
+ pidgone(result,*statusp);
if (result < 0)
- status = -1;
+ *statusp = -1;
}
#endif
- signal(SIGHUP, hstat);
- signal(SIGINT, istat);
- signal(SIGQUIT, qstat);
- str_numset(str,0.0);
- return(status);
+#endif
+ return result;
}
#endif /* !MSDOS */
int pid;
int status;
{
-#ifdef WAIT4
- return;
+#if defined(WAIT4) || defined(WAITPID)
#else
- register int count;
register STR *str;
+ char spid[16];
- for (count = pidstatary->ary_fill; count >= 0; --count) {
- if ((str = afetch(pidstatary,count,FALSE)) &&
- ((int)str->str_u.str_nval) == pid) {
- str_numset(str, -str->str_u.str_nval);
- str->str_cur = status;
- return;
- }
- }
+ sprintf(spid, "%d", pid);
+ str = hfetch(pidstatus,pid,strlen(pid),TRUE);
+ str->str_u.str_useful = status;
#endif
+ return;
}
#ifndef MEMCMP
-/* $Header: util.c,v 3.0 89/10/18 15:35:35 lwall Locked $
+/* $Header: util.c,v 3.0.1.1 90/10/16 11:34:06 lwall Locked $
*
* Copyright (c) 1989, Larry Wall
*
* as specified in the README file that comes with the perl 3.0 kit.
*
* $Log: util.c,v $
+ * Revision 3.0.1.1 90/10/16 11:34:06 lwall
+ * patch29: removed #ifdef undef
+ *
* Revision 3.0 89/10/18 15:35:35 lwall
* 3.0 baseline
*
return to;
}
-#ifdef undef
-/* safe version of string concatenate, with \n deletion and space padding */
-
-char *
-safecat(to,from,len)
-char *to;
-register char *from;
-register int len;
-{
- register char *dest = to;
-
- len--; /* leave room for null */
- if (*dest) {
- while (len && *dest++) len--;
- if (len) {
- len--;
- *(dest-1) = ' ';
- }
- }
- if (from != Nullch)
- while (len && (*dest++ = *from++)) len--;
- if (len)
- dest--;
- if (*(dest-1) == '\n')
- dest--;
- *dest = '\0';
- return to;
-}
-#endif
-
/* copy a string up to some (non-backslashed) delimiter, if any */
char *
-/* $Header: walk.c,v 3.0.1.5 90/08/09 05:55:01 lwall Locked $
+/* $Header: walk.c,v 3.0.1.6 90/10/16 11:35:51 lwall Locked $
*
* Copyright (c) 1989, Larry Wall
*
* as specified in the README file that comes with the perl 3.0 kit.
*
* $Log: walk.c,v $
+ * Revision 3.0.1.6 90/10/16 11:35:51 lwall
+ * patch29: a2p mistranslated certain weird field separators
+ *
* Revision 3.0.1.5 90/08/09 05:55:01 lwall
* patch19: a2p emited local($_) without a semicolon
* patch19: a2p didn't make explicit split on whitespace skip leading whitespace
i = fstr->str_ptr[1] & 127;
if (index("*+?.[]()|^$\\",i))
sprintf(tokenbuf,"/\\%c/",i);
- else if (i = ' ')
+ else if (i == ' ')
sprintf(tokenbuf,"' '");
else
sprintf(tokenbuf,"/%c/",i);
projects / p5sagit/p5-mst-13.2.git / commitdiff