lwall@jpl-devvax.JPL.NASA.GOV (Larry Wall) (10/17/90)
System: perl version 3.0 Patch #: 36 Priority: HIGH Subject: patch #29, continued Description: See patch #29. Fix: From rn, say "| patch -p -N -d DIR", where DIR is your perl source directory. Outside of rn, say "cd DIR; patch -p -N <thisarticle". If you don't have the patch program, apply the following by hand, or get patch (version 2.0, latest patchlevel). After patching: Configure -d make depend make make test make install If patch indicates that patchlevel is the wrong version, you may need to apply one or more previous patches, or the patch may already have been applied. See the patchlevel.h file to find out what has or has not been applied. In any event, don't continue with the patch. If you are missing previous patches they can be obtained from me: Larry Wall lwall@jpl-devvax.jpl.nasa.gov If you send a mail message of the following form it will greatly speed processing: Subject: Command @SH mailpatch PATH perl 3.0 LIST ^ note the c where PATH is a return path FROM ME TO YOU either in Internet notation, or in bang notation from some well-known host, and LIST is the number of one or more patches you need, separated by spaces, commas, and/or hyphens. Saying 35- says everything from 35 to the end. You can also get the patches via anonymous FTP from jpl-devvax.jpl.nasa.gov (128.149.1.143). Index: patchlevel.h Prereq: 35 1c1 < #define PATCHLEVEL 35 --- > #define PATCHLEVEL 36 Index: usersub.c Prereq: 3.0.1.1 *** usersub.c.old Tue Oct 16 12:05:26 1990 --- usersub.c Tue Oct 16 12:05:28 1990 *************** *** 1,4 **** ! /* $Header: usersub.c,v 3.0.1.1 90/08/09 05:40:45 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 --- 1,4 ---- ! /* $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 *************** *** 5,10 **** --- 5,13 ---- * 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,104 **** } close(p[1]); fclose(fil); ! str = afetch(pidstatary,p[0],TRUE); ! str_numset(str,(double)pipepid); ! str->str_cur = 0; return fdopen(p[0], "r"); } --- 99,106 ---- } close(p[1]); fclose(fil); ! str = afetch(fdpid,p[0],TRUE); ! str->str_u.str_useful = pipepid; return fdopen(p[0], "r"); } Index: util.c Prereq: 3.0.1.7 *** util.c.old Tue Oct 16 12:05:53 1990 --- util.c Tue Oct 16 12:05:59 1990 *************** *** 1,4 **** ! /* $Header: util.c,v 3.0.1.7 90/08/13 22:40:26 lwall Locked $ * * Copyright (c) 1989, Larry Wall * --- 1,4 ---- ! /* $Header: util.c,v 3.0.1.8 90/10/16 11:26:57 lwall Locked $ * * Copyright (c) 1989, Larry Wall * *************** *** 6,11 **** --- 6,16 ---- * 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,443 **** register int i; register int len = str->str_cur; int rarest = 0; ! int frequency = 256; Str_Grow(str,len+258); #ifndef lint --- 442,448 ---- register int i; register int len = str->str_cur; int rarest = 0; ! unsigned int frequency = 256; Str_Grow(str,len+258); #ifndef lint *************** *** 479,485 **** s = Null(unsigned char*); #endif if (iflag) { ! register int tmp, foldtmp; str->str_pok |= SP_CASEFOLD; for (i = 0; i < len; i++) { tmp=freq[s[i]]; --- 484,490 ---- s = Null(unsigned char*); #endif if (iflag) { ! register unsigned int tmp, foldtmp; str->str_pok |= SP_CASEFOLD; for (i = 0; i < len; i++) { tmp=freq[s[i]]; *************** *** 559,565 **** s = big + littlelen; oldlittle = little = table - 2; if (littlestr->str_pok & SP_CASEFOLD) { /* case insensitive? */ ! while (s < bigend) { top1: if (tmp = table[*s]) { #ifdef POINTERRIGOR --- 564,570 ---- s = big + littlelen; oldlittle = little = table - 2; if (littlestr->str_pok & SP_CASEFOLD) { /* case insensitive? */ ! if (s < bigend) { top1: if (tmp = table[*s]) { #ifdef POINTERRIGOR *************** *** 592,598 **** } } else { ! while (s < bigend) { top2: if (tmp = table[*s]) { #ifdef POINTERRIGOR --- 597,603 ---- } } else { ! if (s < bigend) { top2: if (tmp = table[*s]) { #ifdef POINTERRIGOR *************** *** 777,783 **** s += strlen(s); if (s[-1] != '\n') { if (curcmd->c_line) { ! (void)sprintf(s," at %s line %ld", filename, (long)curcmd->c_line); s += strlen(s); } if (last_in_stab && --- 782,789 ---- s += strlen(s); if (s[-1] != '\n') { if (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,880 **** s += strlen(s); if (s[-1] != '\n') { if (curcmd->c_line) { ! (void)sprintf(s," at %s line %ld", filename, (long)curcmd->c_line); s += strlen(s); } if (last_in_stab && --- 880,887 ---- s += strlen(s); if (s[-1] != '\n') { if (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,1234 **** --- 1236,1242 ---- 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,1248 **** close(p[this]); p[this] = p[that]; } ! str = afetch(pidstatary,p[this],TRUE); ! str_numset(str,(double)pid); ! str->str_cur = 0; forkprocess = pid; return fdopen(p[this], mode); } --- 1248,1255 ---- close(p[this]); p[this] = p[that]; } ! str = afetch(fdpid,p[this],TRUE); ! str->str_u.str_useful = pid; forkprocess = pid; return fdopen(p[this], mode); } *************** *** 1298,1333 **** #endif int status; STR *str; ! register int pid; ! str = afetch(pidstatary,fileno(ptr),TRUE); fclose(ptr); ! pid = (int)str_gnum(str); ! if (!pid) ! return -1; hstat = signal(SIGHUP, SIG_IGN); istat = signal(SIGINT, SIG_IGN); qstat = signal(SIGQUIT, SIG_IGN); #ifdef WAIT4 ! if (wait4(pid,&status,0,Null(struct rusage *)) < 0) ! status = -1; #else ! if (pid < 0) /* already exited? */ ! status = str->str_cur; else { int result; ! while ((result = wait(&status)) != pid && result >= 0) ! pidgone(result,status); if (result < 0) ! status = -1; } #endif ! signal(SIGHUP, hstat); ! signal(SIGINT, istat); ! signal(SIGQUIT, qstat); ! str_numset(str,0.0); ! return(status); } #endif /* !MSDOS */ --- 1305,1381 ---- #endif int status; STR *str; ! int pid; ! str = afetch(fdpid,fileno(ptr),TRUE); ! astore(fdpid,fileno(ptr),Nullstr); fclose(ptr); ! 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 ! return wait4(pid,statusp,flags,Null(struct rusage *)); #else ! #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(statusp)) != pid && pid > 0 && result >= 0) ! pidgone(result,*statusp); if (result < 0) ! *statusp = -1; } #endif ! #endif ! return result; } #endif /* !MSDOS */ *************** *** 1335,1355 **** int pid; int status; { ! #ifdef WAIT4 ! return; #else - register int count; register STR *str; ! 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; ! } ! } #endif } #ifndef MEMCMP --- 1383,1398 ---- int pid; int status; { ! #if defined(WAIT4) || defined(WAITPID) #else register STR *str; + char spid[16]; ! sprintf(spid, "%d", pid); ! str = hfetch(pidstatus,pid,strlen(pid),TRUE); ! str->str_u.str_useful = status; #endif + return; } #ifndef MEMCMP Index: x2p/util.c Prereq: 3.0 *** x2p/util.c.old Tue Oct 16 12:06:48 1990 --- x2p/util.c Tue Oct 16 12:06:50 1990 *************** *** 1,4 **** ! /* $Header: util.c,v 3.0 89/10/18 15:35:35 lwall Locked $ * * Copyright (c) 1989, Larry Wall * --- 1,4 ---- ! /* $Header: util.c,v 3.0.1.1 90/10/16 11:34:06 lwall Locked $ * * Copyright (c) 1989, Larry Wall * *************** *** 6,11 **** --- 6,14 ---- * 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 * *************** *** 102,137 **** *dest = '\0'; 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 */ --- 105,110 ---- Index: x2p/walk.c Prereq: 3.0.1.5 *** x2p/walk.c.old Tue Oct 16 12:07:11 1990 --- x2p/walk.c Tue Oct 16 12:07:21 1990 *************** *** 1,4 **** ! /* $Header: walk.c,v 3.0.1.5 90/08/09 05:55:01 lwall Locked $ * * Copyright (c) 1989, Larry Wall * --- 1,4 ---- ! /* $Header: walk.c,v 3.0.1.6 90/10/16 11:35:51 lwall Locked $ * * Copyright (c) 1989, Larry Wall * *************** *** 6,11 **** --- 6,14 ---- * 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,700 **** i = fstr->str_ptr[1] & 127; if (index("*+?.[]()|^$\\",i)) sprintf(tokenbuf,"/\\%c/",i); ! else if (i = ' ') sprintf(tokenbuf,"' '"); else sprintf(tokenbuf,"/%c/",i); --- 697,703 ---- i = fstr->str_ptr[1] & 127; if (index("*+?.[]()|^$\\",i)) sprintf(tokenbuf,"/\\%c/",i); ! else if (i == ' ') sprintf(tokenbuf,"' '"); else sprintf(tokenbuf,"/%c/",i); Index: perly.c Prereq: 3.0.1.7 *** perly.c.old Tue Oct 16 12:01:09 1990 --- perly.c Tue Oct 16 12:01:17 1990 *************** *** 1,4 **** ! char rcsid[] = "$Header: perly.c,v 3.0.1.7 90/08/13 22:22:22 lwall Locked $\nPatch level: ###\n"; /* * Copyright (c) 1989, Larry Wall * --- 1,4 ---- ! 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,11 **** --- 6,20 ---- * 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,51 **** --- 54,64 ---- #include "EXTERN.h" #include "perl.h" #include "perly.h" + #ifdef MSDOS + #include "patchlev.h" + #else #include "patchlevel.h" + #endif #ifdef IAMSUID #ifndef DOSUID *************** *** 113,118 **** --- 126,132 ---- 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,290 **** argv[0] = savestr(xfound); } ! pidstatary = anew(Nullstab); /* for remembering popen pids, status */ origfilename = savestr(argv[0]); ! filename = origfilename; ! if (strEQ(filename,"-")) argv[0] = ""; if (preprocess) { str_cat(str,"-I"); str_cat(str,PRIVLIB); (void)sprintf(buf, "\ ! /bin/sed %s -e '/^[^#]/b' \ -e '/^#[ ]*include[ ]/b' \ -e '/^#[ ]*define[ ]/b' \ -e '/^#[ ]*if[ ]/b' \ --- 288,305 ---- argv[0] = savestr(xfound); } ! fdpid = anew(Nullstab); /* for remembering popen pids by fd */ ! pidstatus = hnew(Nullstab); /* for remembering status of dead pids */ origfilename = savestr(argv[0]); ! curcmd->c_filestab = fstab(origfilename); ! if (strEQ(origfilename,"-")) argv[0] = ""; if (preprocess) { str_cat(str,"-I"); str_cat(str,PRIVLIB); (void)sprintf(buf, "\ ! %ssed %s -e '/^[^#]/b' \ -e '/^#[ ]*include[ ]/b' \ -e '/^#[ ]*define[ ]/b' \ -e '/^#[ ]*if[ ]/b' \ *************** *** 294,299 **** --- 309,319 ---- -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,324 **** if (rsfp == Nullfp) { #ifdef DOSUID #ifndef IAMSUID /* in case script is not readable before setuid */ ! if (euid && stat(filename,&statbuf) >= 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) { (void)sprintf(buf, "%s/%s", BIN, "suidperl"); execv(buf, origargv); /* try again */ --- 338,344 ---- if (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/%s", BIN, "suidperl"); execv(buf, origargv); /* try again */ *************** *** 327,333 **** #endif #endif fatal("Can't open perl script \"%s\": %s\n", ! filename, strerror(errno)); } str_free(str); /* free -I directories */ --- 347,353 ---- #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 */ *************** *** 359,365 **** #ifdef DOSUID if (fstat(fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */ ! fatal("Can't stat script \"%s\"",filename); if (statbuf.st_mode & (S_ISUID|S_ISGID)) { int len; --- 379,385 ---- #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; *************** *** 373,379 **** * 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 */ fatal("Permission denied"); #else /* If we can swap euid and uid, then we can determine access rights --- 393,399 ---- * 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 *************** *** 386,393 **** 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 (tmpstatbuf.st_dev != statbuf.st_dev || tmpstatbuf.st_ino != statbuf.st_ino) { (void)fclose(rsfp); --- 406,413 ---- 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); *************** *** 397,403 **** (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); (void)mypclose(rsfp); } fatal("Permission denied\n"); --- 417,424 ---- (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"); *************** *** 555,569 **** debstash = hnew(0); stab_xhash(stabent("_DB",TRUE)) = debstash; curstash = debstash; ! lineary = stab_xarray(aadd((tmpstab = stabent("line",TRUE)))); tmpstab->str_pok |= SP_MULTI; subname = str_make("main",4); DBstab = stabent("DB",TRUE); DBstab->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; curstash = defstash; } --- 576,597 ---- 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; 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,617 **** (void)hadd(sigstab); } ! magicalize("!#?^~=-%0123456789.+&*()<>,\\/[|`':"); userinit(); /* in case linked C routines want magical variables */ amperstab = stabent("&",allstabs); --- 639,645 ---- (void)hadd(sigstab); } ! magicalize("!#?^~=-%0123456789.+&*()<>,\\/[|`':\024"); userinit(); /* in case linked C routines want magical variables */ amperstab = stabent("&",allstabs); *************** *** 620,625 **** --- 648,655 ---- 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,674 **** 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(); --- 692,697 ---- *************** *** 702,708 **** if (envstab = stabent("ENV",allstabs)) { envstab->str_pok |= SP_MULTI; (void)hadd(envstab); ! hclear(stab_hash(envstab)); if (env != environ) environ[0] = Nullch; for (; *env; env++) { --- 725,731 ---- 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++) { *************** *** 721,726 **** --- 744,754 ---- 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,799 **** 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; SPAT * VOLATILE oldspat = curspat; static char *last_eval = Nullch; static CMD *last_root = Nullcmd; VOLATILE int sp = arglast[0]; char *specfilename; tmps_base = tmps_max; if (curstash != stash) { --- 813,828 ---- CMD *myroot; 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; 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,809 **** curstash = stash; } str_set(stab_val(stabent("@",TRUE)),""); curcmd = &compiling; if (optype == O_EVAL) { /* normal eval */ ! filename = "(eval)"; curcmd->c_line = 1; str_sset(linestr,str); str_cat(linestr,";"); /* be kind to them */ --- 830,840 ---- 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,";"); /* be kind to them */ *************** *** 815,836 **** last_root = Nullcmd; } specfilename = str_get(str); - filename = savestr(specfilename); /* can't free this easily */ str_set(linestr,""); ! if (optype == O_REQUIRE && hfetch(stab_hash(incstab), specfilename, strlen(specfilename), 0)) { ! filename = oldfile; tmps_base = oldtmps_base; st[++sp] = &str_yes; return sp; } ! else if (*filename == '/') ! rsfp = fopen(filename,"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); rsfp = fopen(buf,"r"); if (rsfp) { char *s = buf; --- 846,868 ---- 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 (index("/.", *tmpfilename)) ! 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; *************** *** 837,849 **** if (*s == '.' && s[1] == '/') s += 2; ! filename = savestr(s); break; } } } if (!rsfp) { ! filename = oldfile; tmps_base = oldtmps_base; if (optype == O_REQUIRE) { sprintf(tokenbuf,"Can't locate %s in @INC", specfilename); --- 869,884 ---- if (*s == '.' && s[1] == '/') s += 2; ! Safefree(tmpfilename); ! tmpfilename = savestr(s); break; } } } + curcmd->c_filestab = fstab(tmpfilename); + Safefree(tmpfilename); if (!rsfp) { ! curcmd = oldcurcmd; tmps_base = oldtmps_base; if (optype == O_REQUIRE) { sprintf(tokenbuf,"Can't locate %s in @INC", specfilename); *************** *** 855,860 **** --- 890,896 ---- } if (gimme != G_ARRAY) st[++sp] = &str_undef; + perldb = oldperldb; return sp; } curcmd->c_line = 0; *************** *** 879,886 **** } else { error_count = 0; ! if (rsfp) retval = yyparse(); else if (last_root && *bufptr == *last_eval && strEQ(bufptr,last_eval)){ retval = 0; eval_root = last_root; /* no point in reparsing */ --- 915,924 ---- } else { error_count = 0; ! 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,898 **** --- 931,937 ---- last_eval = savestr(bufptr); last_root = Nullcmd; retval = yyparse(); + retval |= error_count; if (!retval) last_root = eval_root; } *************** *** 900,906 **** 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) --- 939,946 ---- retval = yyparse(); } myroot = eval_root; /* in case cmd_exec does another eval! */ ! ! if (retval) { st = stack->ary_array; sp = arglast[0]; if (gimme != G_ARRAY) *************** *** 909,916 **** if (rsfp) { fclose(rsfp); rsfp = 0; - if (optype == O_REQUIRE) - fatal("%s", str_get(stab_val(stabent("@",TRUE)))); } } else { --- 949,954 ---- *************** *** 921,950 **** /* 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); - } } 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--; - filename = oldfile; - curcmd = oldcurcmd; tmps_base = oldtmps_base; curspat = oldspat; if (savestack->ary_fill > oldsave) /* let them use local() */ restorelist(oldsave); return sp; } --- 959,998 ---- /* if we don't save result, free zaps it */ 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; 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,1031 **** --- 1065,1087 ---- 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; Index: doarg.c Prereq: 3.0.1.7 *** doarg.c.old Tue Oct 16 11:48:22 1990 --- doarg.c Tue Oct 16 11:48:37 1990 *************** *** 1,4 **** ! /* $Header: doarg.c,v 3.0.1.7 90/08/13 22:14:15 lwall Locked $ * * Copyright (c) 1989, Larry Wall * --- 1,4 ---- ! /* $Header: doarg.c,v 3.0.1.8 90/10/15 16:04:04 lwall Locked $ * * Copyright (c) 1989, Larry Wall * *************** *** 6,11 **** --- 6,19 ---- * 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,65 **** extern unsigned char fold[]; ! int wantarray; #ifdef BUGGY_MSC #pragma function(memcmp) --- 67,73 ---- extern unsigned char fold[]; ! extern char **environ; #ifdef BUGGY_MSC #pragma function(memcmp) *************** *** 320,334 **** int do_trans(str,arg) STR *str; ! register ARG *arg; { ! register char *tbl; register char *s; register int matches = 0; register int ch; register char *send; ! tbl = arg[2].arg_ptr.arg_cval; s = str_get(str); send = s + str->str_cur; if (!tbl || !s) --- 328,344 ---- 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) *************** *** 338,350 **** deb("2.TBL\n"); } #endif ! while (s < send) { ! if (ch = tbl[*s & 0377]) { ! matches++; ! *s = ch; } - s++; } STABSET(str); return matches; } --- 348,384 ---- 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; } *************** *** 713,722 **** 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 */ xs = tokenbuf; xlen = strlen(tokenbuf); } if (strEQ(t-2,"%s")) { /* some printfs fail on >128 chars */ *buf = '\0'; --- 747,760 ---- xlen = (*sarg)->str_cur; if (*xs == 'S' && xs[1] == 't' && xs[2] == 'B' && xlen == sizeof(STBP) && strlen(xs) < xlen) { ! 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,811 **** register int sp = arglast[1]; register int items = arglast[2] - sp; register SUBR *sub; ! ARRAY *savearray; 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; --- 839,850 ---- register int sp = arglast[1]; register int items = arglast[2] - sp; register SUBR *sub; ! 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; *************** *** 819,840 **** } 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]); } - savelong(&sub->depth); sub->depth++; if (sub->depth >= 2) { /* save temporaries on recursion? */ if (sub->depth == 100 && dowarn) --- 858,902 ---- } if (!stab) fatal("Undefined subroutine called"); ! 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"); ! } ! else { ! if (!(sub = stab_sub(stab))) { ! STR *tmpstr = arg[0].arg_ptr.arg_str; ! ! stab_fullname(tmpstr, stab); ! fatal("Undefined subroutine \"%s\" called",tmpstr->str_ptr); ! } ! } ! 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; } sub->depth++; if (sub->depth >= 2) { /* save temporaries on recursion? */ if (sub->depth == 100 && dowarn) *************** *** 841,933 **** 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 (tmpstr) - stab = stabent(str_get(tmpstr),TRUE); - else - stab = Nullstab; - } - 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]); - } - 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; } --- 903,917 ---- warn("Deep recursion on subroutine \"%s\"",stab_name(stab)); savelist(sub->tosave->ary_array,sub->tosave->ary_fill); } tmps_base = tmps_max; 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_static(st[items]); ! /* in case restore wipes old str */ ! restorelist(oldsave); return sp; } *************** *** 992,1003 **** else if (str->str_state == SS_HASH) { char *tmps; STR *tmpstr; if (makelocal) hash = savehash(str->str_u.str_stab); else { hash = stab_hash(str->str_u.str_stab); ! hclear(hash); } while (relem < lastrelem) { /* gobble up all the rest */ if (*relem) --- 976,1006 ---- 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) *************** *** 1010,1015 **** --- 1013,1022 ---- 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,1029 **** *(relem++) = str; } else { ! str_nset(str, "", 0); if (gimme == G_ARRAY) { i = ++lastrelem - firstrelem; relem++; /* tacky, I suppose */ --- 1030,1036 ---- *(relem++) = str; } else { ! str_sset(str, &str_undef); if (gimme == G_ARRAY) { i = ++lastrelem - firstrelem; relem++; /* tacky, I suppose */ *************** *** 1207,1213 **** } else if (type == O_HASH || type == O_LHASH) { stab = arg[1].arg_ptr.arg_stab; ! (void)hfree(stab_xhash(stab)); stab_xhash(stab) = Null(HASH*); } else if (type == O_SUBR || type == O_DBSUBR) { --- 1214,1228 ---- } 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) { *** End of Patch 36 ***