Xref: utzoo comp.sources.bugs:2607 comp.lang.perl:2598 Path: utzoo!utgpu!news-server.csri.toronto.edu!cs.utexas.edu!usc!elroy.jpl.nasa.gov!jpl-devvax!lwall From: lwall@jpl-devvax.JPL.NASA.GOV (Larry Wall) Newsgroups: comp.sources.bugs,comp.lang.perl Subject: perl 3.0 patch #36 Summary: This is an official patch for perl 3.0. Please apply it. Message-ID: <10007@jpl-devvax.JPL.NASA.GOV> Date: 17 Oct 90 16:55:54 GMT Organization: Jet Propulsion Laboratory, Pasadena, CA Lines: 1644 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 #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 ***