diff options
| -rw-r--r-- | doarg.c | 235 | ||||
| -rw-r--r-- | patchlevel.h | 2 | ||||
| -rw-r--r-- | perly.c | 160 | ||||
| -rw-r--r-- | usersub.c | 10 | ||||
| -rw-r--r-- | util.c | 119 | ||||
| -rw-r--r-- | x2p/util.c | 35 | ||||
| -rw-r--r-- | x2p/walk.c | 7 |
7 files changed, 330 insertions, 238 deletions
@@ -1,4 +1,4 @@ -/* $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 * @@ -6,6 +6,14 @@ * 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 @@ -59,7 +67,7 @@ extern unsigned char fold[]; -int wantarray; +extern char **environ; #ifdef BUGGY_MSC #pragma function(memcmp) @@ -320,15 +328,17 @@ nope: 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) @@ -338,12 +348,36 @@ register ARG *arg; 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; @@ -713,10 +747,14 @@ register STR **sarg; 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'; @@ -801,11 +839,12 @@ int *arglast; 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; @@ -819,115 +858,60 @@ int *arglast; } 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; } @@ -992,12 +976,31 @@ int *arglast; 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) @@ -1010,6 +1013,10 @@ int *arglast; 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 @@ -1023,7 +1030,7 @@ int *arglast; *(relem++) = str; } else { - str_nset(str, "", 0); + str_sset(str, &str_undef); if (gimme == G_ARRAY) { i = ++lastrelem - firstrelem; relem++; /* tacky, I suppose */ @@ -1207,7 +1214,15 @@ int *arglast; } 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) { diff --git a/patchlevel.h b/patchlevel.h index 68fcfefec9..d248b3566e 100644 --- a/patchlevel.h +++ b/patchlevel.h @@ -1 +1 @@ -#define PATCHLEVEL 35 +#define PATCHLEVEL 36 @@ -1,4 +1,4 @@ -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 * @@ -6,6 +6,15 @@ char rcsid[] = "$Header: perly.c,v 3.0.1.7 90/08/13 22:22:22 lwall Locked $\nPat * 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 * @@ -45,7 +54,11 @@ char rcsid[] = "$Header: perly.c,v 3.0.1.7 90/08/13 22:22:22 lwall Locked $\nPat #include "EXTERN.h" #include "perl.h" #include "perly.h" +#ifdef MSDOS +#include "patchlev.h" +#else #include "patchlevel.h" +#endif #ifdef IAMSUID #ifndef DOSUID @@ -113,6 +126,7 @@ setuid perl scripts securely.\n"); 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++) { @@ -274,17 +288,18 @@ setuid perl scripts securely.\n"); 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' \ @@ -294,6 +309,11 @@ setuid perl scripts securely.\n"); -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; @@ -318,7 +338,7 @@ setuid perl scripts securely.\n"); 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 */ @@ -327,7 +347,7 @@ setuid perl scripts securely.\n"); #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 */ @@ -359,7 +379,7 @@ setuid perl scripts securely.\n"); #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; @@ -373,7 +393,7 @@ setuid perl scripts securely.\n"); * 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 @@ -386,8 +406,8 @@ setuid perl scripts securely.\n"); 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); @@ -397,7 +417,8 @@ setuid perl scripts securely.\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, - 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"); @@ -555,15 +576,22 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\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; } @@ -611,7 +639,7 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n"); (void)hadd(sigstab); } - magicalize("!#?^~=-%0123456789.+&*()<>,\\/[|`':"); + magicalize("!#?^~=-%0123456789.+&*()<>,\\/[|`':\024"); userinit(); /* in case linked C routines want magical variables */ amperstab = stabent("&",allstabs); @@ -620,6 +648,8 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n"); 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)) @@ -662,13 +692,6 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n"); 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(); @@ -702,7 +725,7 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n"); 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++) { @@ -721,6 +744,11 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n"); 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 */ @@ -785,15 +813,16 @@ int *arglast; 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) { @@ -801,9 +830,11 @@ int *arglast; 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 */ @@ -815,35 +846,39 @@ int *arglast; 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); @@ -855,6 +890,7 @@ int *arglast; } if (gimme != G_ARRAY) st[++sp] = &str_undef; + perldb = oldperldb; return sp; } curcmd->c_line = 0; @@ -879,8 +915,10 @@ int *arglast; } 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 */ @@ -893,6 +931,7 @@ int *arglast; last_eval = savestr(bufptr); last_root = Nullcmd; retval = yyparse(); + retval |= error_count; if (!retval) last_root = eval_root; } @@ -900,7 +939,8 @@ int *arglast; 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) @@ -909,8 +949,6 @@ int *arglast; if (rsfp) { fclose(rsfp); rsfp = 0; - if (optype == O_REQUIRE) - fatal("%s", str_get(stab_val(stabent("@",TRUE)))); } } else { @@ -921,30 +959,40 @@ int *arglast; /* 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; } @@ -1017,15 +1065,23 @@ char *s; 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; @@ -1,10 +1,13 @@ -/* $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 * @@ -96,9 +99,8 @@ VOID (*func)(); } 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"); } @@ -1,4 +1,4 @@ -/* $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 * @@ -6,6 +6,11 @@ * 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 @@ -437,7 +442,7 @@ int iflag; 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 @@ -479,7 +484,7 @@ int iflag; 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]]; @@ -559,7 +564,7 @@ STR *littlestr; 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 @@ -592,7 +597,7 @@ STR *littlestr; } } else { - while (s < bigend) { + if (s < bigend) { top2: if (tmp = table[*s]) { #ifdef POINTERRIGOR @@ -777,7 +782,8 @@ long a1, a2, a3, a4; 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 && @@ -874,7 +880,8 @@ va_list args; 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 && @@ -1229,6 +1236,7 @@ char *mode; 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 @@ -1240,9 +1248,8 @@ char *mode; 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); } @@ -1298,36 +1305,77 @@ FILE *ptr; #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 */ @@ -1335,21 +1383,16 @@ pidgone(pid,status) 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 diff --git a/x2p/util.c b/x2p/util.c index 27b08b0862..07f19a3715 100644 --- a/x2p/util.c +++ b/x2p/util.c @@ -1,4 +1,4 @@ -/* $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 * @@ -6,6 +6,9 @@ * 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 * @@ -103,36 +106,6 @@ register int len; 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 * diff --git a/x2p/walk.c b/x2p/walk.c index ce164530b4..555e13c1a3 100644 --- a/x2p/walk.c +++ b/x2p/walk.c @@ -1,4 +1,4 @@ -/* $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 * @@ -6,6 +6,9 @@ * 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 @@ -694,7 +697,7 @@ sub Pick {\n\ 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); |