From: Larry Wall Date: Fri, 11 Jan 1991 05:46:37 +0000 (+0000) Subject: perl 3.0 patch #43 patch #42, continued X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=c623bd54707a8bf975b272e17e7c3b3342b31eb0;p=p5sagit%2Fp5-mst-13.2.git perl 3.0 patch #43 patch #42, continued See patch #42. --- diff --git a/doio.c b/doio.c index 7895213..34d4f70 100644 --- a/doio.c +++ b/doio.c @@ -1,4 +1,4 @@ -/* $Header: doio.c,v 3.0.1.13 90/11/10 01:17:37 lwall Locked $ +/* $Header: doio.c,v 3.0.1.14 91/01/11 17:51:04 lwall Locked $ * * Copyright (c) 1989, Larry Wall * @@ -6,6 +6,13 @@ * as specified in the README file that comes with the perl 3.0 kit. * * $Log: doio.c,v $ + * Revision 3.0.1.14 91/01/11 17:51:04 lwall + * patch42: ANSIfied the stat mode checking + * patch42: the -i switch is now much more robust and informative + * patch42: close on a pipe didn't return failure correctly + * patch42: stat on temp values could wipe them out prematurely, i.e. grep(-d,<*>) + * patch42: -l didn't work right with _ + * * Revision 3.0.1.13 90/11/10 01:17:37 lwall * patch38: -e _ was wrong if last stat failed * patch38: more msdos/os2 upgrades @@ -270,10 +277,11 @@ int len; (void)fclose(fp); return FALSE; } - result = (statbuf.st_mode & S_IFMT); -#ifdef S_IFSOCK - if (result == S_IFSOCK || result == 0) + if (S_ISSOCK(statbuf.st_mode)) stio->type = 's'; /* in case a socket was passed in to us */ +#ifdef S_IFMT + else if (!(statbuf.st_mode & S_IFMT)) + stio->type = 's'; /* some OS's return 0 on fstat()ed socket */ #endif } #if defined(FCNTL) && defined(F_SETFD) @@ -296,7 +304,11 @@ register STAB *stab; { register STR *str; char *oldname; - int filemode,fileuid,filegid; + int filedev; + int fileino; + int filemode; + int fileuid; + int filegid; while (alen(stab_xarray(stab)) >= 0) { str = ashift(stab_xarray(stab)); @@ -308,18 +320,49 @@ register STAB *stab; #ifdef TAINT taintproper("Insecure dependency in inplace open"); #endif + if (strEQ(oldname,"-")) { + str_free(str); + defoutstab = stabent("STDOUT",TRUE); + return stab_io(stab)->ifp; + } + filedev = statbuf.st_dev; + fileino = statbuf.st_ino; filemode = statbuf.st_mode; fileuid = statbuf.st_uid; filegid = statbuf.st_gid; + if (!S_ISREG(filemode)) { + warn("Can't do inplace edit: %s is not a regular file", + oldname ); + do_close(stab,FALSE); + str_free(str); + continue; + } if (*inplace) { #ifdef SUFFIX add_suffix(str,inplace); #else str_cat(str,inplace); #endif +#ifndef FLEXFILENAMES + if (stat(str->str_ptr,&statbuf) >= 0 + && statbuf.st_dev == filedev + && statbuf.st_ino == fileino ) { + warn("Can't do inplace edit: %s > 14 characters", + str->str_ptr ); + do_close(stab,FALSE); + str_free(str); + continue; + } +#endif #ifdef RENAME #ifndef MSDOS - (void)rename(oldname,str->str_ptr); + if (rename(oldname,str->str_ptr) < 0) { + warn("Can't rename %s to %s: %s, skipping file", + oldname, str->str_ptr, strerror(errno) ); + do_close(stab,FALSE); + str_free(str); + continue; + } #else do_close(stab,FALSE); (void)unlink(str->str_ptr); @@ -328,7 +371,13 @@ register STAB *stab; #endif /* MSDOS */ #else (void)UNLINK(str->str_ptr); - (void)link(oldname,str->str_ptr); + if (link(oldname,str->str_ptr) < 0) { + warn("Can't rename %s to %s: %s, skipping file", + oldname, str->str_ptr, strerror(errno) ); + do_close(stab,FALSE); + str_free(str); + continue; + } (void)UNLINK(oldname); #endif } @@ -344,7 +393,8 @@ register STAB *stab; str_cat(str,oldname); errno = 0; /* in case sprintf set errno */ if (!do_open(argvoutstab,str->str_ptr,str->str_cur)) - fatal("Can't do inplace edit"); + warn("Can't do inplace edit on %s: %s", + oldname, strerror(errno) ); defoutstab = argvoutstab; #ifdef FCHMOD (void)fchmod(fileno(stab_io(argvoutstab)->ifp),filemode); @@ -363,7 +413,7 @@ register STAB *stab; return stab_io(stab)->ifp; } else - fprintf(stderr,"Can't open %s\n",str_get(str)); + fprintf(stderr,"Can't open %s: %s\n",str_get(str), strerror(errno)); str_free(str); } if (inplace) { @@ -440,7 +490,7 @@ bool explicit; if (stio->ifp) { if (stio->type == '|') { status = mypclose(stio->ifp); - retval = (status >= 0); + retval = (status == 0); statusvalue = (unsigned short)status & 0xffff; } else if (stio->type == '-') @@ -651,7 +701,7 @@ int *arglast; max = 0; } else { - str_sset(statname,ary->ary_array[sp]); + str_set(statname,str_get(ary->ary_array[sp])); statstab = Nullstab; #ifdef LSTAT if (arg->arg_type == O_LSTAT) @@ -968,11 +1018,28 @@ STR *str; } else { statstab = Nullstab; - str_sset(statname,str); + str_set(statname,str_get(str)); return (laststatval = stat(str_get(str),&statcache)); } } +int +mylstat(arg,str) +ARG *arg; +STR *str; +{ + if (arg[1].arg_type & A_DONT) + fatal("You must supply explicit filename with -l"); + + statstab = Nullstab; + str_set(statname,str_get(str)); +#ifdef LSTAT + return (laststatval = lstat(str_get(str),&statcache)); +#else + return (laststatval = stat(str_get(str),&statcache)); +#endif +} + STR * do_fttext(arg,str) register ARG *arg; @@ -1024,7 +1091,7 @@ STR *str; } else { statstab = Nullstab; - str_sset(statname,str); + str_set(statname,str_get(str)); really_filename: i = open(str_get(str),0); if (i < 0) @@ -2243,11 +2310,10 @@ int *arglast; } else { /* don't let root wipe out directories without -U */ #ifdef LSTAT - if (lstat(s,&statbuf) < 0 || + if (lstat(s,&statbuf) < 0 || S_ISDIR(statbuf.st_mode)) #else - if (stat(s,&statbuf) < 0 || + if (stat(s,&statbuf) < 0 || S_ISDIR(statbuf.st_mode)) #endif - (statbuf.st_mode & S_IFMT) == S_IFDIR ) tot--; else { if (UNLINK(s)) @@ -2298,9 +2364,8 @@ int effective; register struct stat *statbufp; { if ((effective ? euid : uid) == 0) { /* root is special */ - if (bit == S_IEXEC) { - if (statbufp->st_mode & 0111 || - (statbufp->st_mode & S_IFMT) == S_IFDIR ) + if (bit == S_IXUSR) { + if (statbufp->st_mode & 0111 || S_ISDIR(statbufp->st_mode)) return TRUE; } else diff --git a/dolist.c b/dolist.c index c2822e3..1e9b3e7 100644 --- a/dolist.c +++ b/dolist.c @@ -1,4 +1,4 @@ -/* $Header: dolist.c,v 3.0.1.11 90/11/10 01:29:49 lwall Locked $ +/* $Header: dolist.c,v 3.0.1.12 91/01/11 17:54:58 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: dolist.c,v $ + * Revision 3.0.1.12 91/01/11 17:54:58 lwall + * patch42: added binary and hex pack/unpack options + * patch42: sort subroutines didn't allow copying $a or $b to other variables. + * patch42: caller() coredumped when called outside the debugger. + * * Revision 3.0.1.11 90/11/10 01:29:49 lwall * patch38: temp string values are now copied less often * patch38: sort parameters are now in the right package @@ -549,6 +554,8 @@ int *arglast; register char *patend = pat + st[sp]->str_cur; int datumtype; register int len; + register int bits; + static char hexchar[] = "0123456789abcdef"; /* These must not be in registers: */ short ashort; @@ -566,7 +573,7 @@ int *arglast; if (gimme != G_ARRAY) { /* arrange to do first one only */ for (patend = pat; !isalpha(*patend); patend++); - if (*patend == 'a' || *patend == 'A' || *pat == '%') { + if (index("aAbBhH", *patend) || *pat == '%') { patend++; while (isdigit(*patend) || *patend == '*') patend++; @@ -580,8 +587,10 @@ int *arglast; datumtype = *pat++; if (pat >= patend) len = 1; - else if (*pat == '*') + else if (*pat == '*') { len = strend - strbeg; /* long enough */ + pat++; + } else if (isdigit(*pat)) { len = *pat++ - '0'; while (isdigit(*pat)) @@ -636,6 +645,72 @@ int *arglast; } (void)astore(stack, ++sp, str_2static(str)); break; + case 'B': + case 'b': + if (pat[-1] == '*' || len > (strend - s) * 8) + len = (strend - s) * 8; + str = Str_new(35, len + 1); + str->str_cur = len; + str->str_pok = 1; + aptr = pat; /* borrow register */ + pat = str->str_ptr; + if (datumtype == 'b') { + aint = len; + for (len = 0; len < aint; len++) { + if (len & 7) + bits >>= 1; + else + bits = *s++; + *pat++ = '0' + (bits & 1); + } + } + else { + aint = len; + for (len = 0; len < aint; len++) { + if (len & 7) + bits <<= 1; + else + bits = *s++; + *pat++ = '0' + ((bits & 128) != 0); + } + } + *pat = '\0'; + pat = aptr; /* unborrow register */ + (void)astore(stack, ++sp, str_2static(str)); + break; + case 'H': + case 'h': + if (pat[-1] == '*' || len > (strend - s) * 2) + len = (strend - s) * 2; + str = Str_new(35, len); + str->str_cur = len; + str->str_pok = 1; + aptr = pat; /* borrow register */ + pat = str->str_ptr; + if (datumtype == 'h') { + aint = len; + for (len = 0; len < aint; len++) { + if (len & 1) + bits >>= 4; + else + bits = *s++; + *pat++ = hexchar[bits & 15]; + } + } + else { + aint = len; + for (len = 0; len < aint; len++) { + if (len & 1) + bits <<= 4; + else + bits = *s++; + *pat++ = hexchar[(bits >> 4) & 15]; + } + } + *pat = '\0'; + pat = aptr; /* unborrow register */ + (void)astore(stack, ++sp, str_2static(str)); + break; case 'c': if (len > strend - s) len = strend - s; @@ -1260,8 +1335,10 @@ int *arglast; register int i = sp - arglast[1]; int oldsave = savestack->ary_fill; SPAT *oldspat = curspat; + int oldtmps_base = tmps_base; savesptr(&stab_val(defstab)); + tmps_base = tmps_max; if ((arg[1].arg_type & A_MASK) != A_EXPR) { arg[1].arg_type &= A_MASK; dehoist(arg,1); @@ -1281,6 +1358,7 @@ int *arglast; curspat = oldspat; } restorelist(oldsave); + tmps_base = oldtmps_base; if (gimme != G_ARRAY) { str_numset(str,(double)(dst - arglast[1])); STABSET(str); @@ -1370,6 +1448,8 @@ int *arglast; if (*up = st[i]) { if (!(*up)->str_pok) (void)str_2ptr(*up); + else + (*up)->str_pok &= ~SP_TEMP; up++; } } @@ -1510,7 +1590,7 @@ int *arglast; for (;;) { if (!csv) return sp; - if (csv->curcsv && csv->curcsv->sub == stab_sub(DBsub)) + if (DBsub && csv->curcsv && csv->curcsv->sub == stab_sub(DBsub)) count++; if (!count--) break; diff --git a/eval.c b/eval.c index a2de82f..ae0edbf 100644 --- a/eval.c +++ b/eval.c @@ -1,4 +1,4 @@ -/* $Header: eval.c,v 3.0.1.10 90/11/10 01:33:22 lwall Locked $ +/* $Header: eval.c,v 3.0.1.11 91/01/11 17:58:30 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: eval.c,v $ + * Revision 3.0.1.11 91/01/11 17:58:30 lwall + * patch42: ANSIfied the stat mode checking + * patch42: perl -D14 crashed on .. + * patch42: waitpid() emulation was useless because of #ifdef WAITPID + * * Revision 3.0.1.10 90/11/10 01:33:22 lwall * patch38: random cleanup * patch38: couldn't return from sort routine @@ -1408,9 +1413,11 @@ register int sp; stab = arg[1].arg_ptr.arg_stab = aadd(genstab()); ary = stab_array(stab); afill(ary,maxarg - 1); + anum = maxarg; st += arglast[0]+1; while (maxarg-- > 0) ary->ary_array[maxarg] = str_smake(st[maxarg]); + st -= arglast[0]+1; goto array_return; } arg->arg_type = optype = O_RANGE; @@ -1488,7 +1495,7 @@ register int sp; break; #endif case O_WAITPID: -#ifdef WAITPID +#ifdef WAIT #ifndef lint anum = (int)str_gnum(st[1]); optype = (int)str_gnum(st[2]); @@ -1703,8 +1710,7 @@ register int sp; if (same_dirent(tmps2, tmps)) /* can always rename to same name */ anum = 1; else { - if (euid || stat(tmps2,&statbuf) < 0 || - (statbuf.st_mode & S_IFMT) != S_IFDIR ) + if (euid || stat(tmps2,&statbuf) < 0 || !S_ISDIR(statbuf.st_mode)) (void)UNLINK(tmps2); if (!(anum = link(tmps,tmps2))) anum = UNLINK(tmps); @@ -1955,27 +1961,27 @@ register int sp; case O_FTRREAD: argtype = 0; - anum = S_IREAD; + anum = S_IRUSR; goto check_perm; case O_FTRWRITE: argtype = 0; - anum = S_IWRITE; + anum = S_IWUSR; goto check_perm; case O_FTREXEC: argtype = 0; - anum = S_IEXEC; + anum = S_IXUSR; goto check_perm; case O_FTEREAD: argtype = 1; - anum = S_IREAD; + anum = S_IRUSR; goto check_perm; case O_FTEWRITE: argtype = 1; - anum = S_IWRITE; + anum = S_IWUSR; goto check_perm; case O_FTEEXEC: argtype = 1; - anum = S_IEXEC; + anum = S_IXUSR; check_perm: if (mystat(arg,st[1]) < 0) goto say_undef; @@ -2023,49 +2029,46 @@ register int sp; goto donumset; case O_FTSOCK: -#ifdef S_IFSOCK - anum = S_IFSOCK; - goto check_file_type; -#else + if (mystat(arg,st[1]) < 0) + goto say_undef; + if (S_ISSOCK(statcache.st_mode)) + goto say_yes; goto say_no; -#endif case O_FTCHR: - anum = S_IFCHR; - goto check_file_type; + if (mystat(arg,st[1]) < 0) + goto say_undef; + if (S_ISCHR(statcache.st_mode)) + goto say_yes; + goto say_no; case O_FTBLK: -#ifdef S_IFBLK - anum = S_IFBLK; - goto check_file_type; -#else + if (mystat(arg,st[1]) < 0) + goto say_undef; + if (S_ISBLK(statcache.st_mode)) + goto say_yes; goto say_no; -#endif case O_FTFILE: - anum = S_IFREG; - goto check_file_type; + if (mystat(arg,st[1]) < 0) + goto say_undef; + if (S_ISREG(statcache.st_mode)) + goto say_yes; + goto say_no; case O_FTDIR: - anum = S_IFDIR; - check_file_type: if (mystat(arg,st[1]) < 0) goto say_undef; - if ((statcache.st_mode & S_IFMT) == anum ) + if (S_ISDIR(statcache.st_mode)) goto say_yes; goto say_no; case O_FTPIPE: -#ifdef S_IFIFO - anum = S_IFIFO; - goto check_file_type; -#else + if (mystat(arg,st[1]) < 0) + goto say_undef; + if (S_ISFIFO(statcache.st_mode)) + goto say_yes; goto say_no; -#endif case O_FTLINK: - if (arg[1].arg_type & A_DONT) - fatal("You must supply explicit filename with -l"); -#ifdef LSTAT - if (lstat(str_get(st[1]),&statcache) < 0) + if (mylstat(arg,st[1]) < 0) goto say_undef; - if ((statcache.st_mode & S_IFMT) == S_IFLNK ) + if (S_ISLNK(statcache.st_mode)) goto say_yes; -#endif goto say_no; case O_SYMLINK: #ifdef SYMLINK diff --git a/evalargs.xc b/evalargs.xc index d6aad79..2c98a02 100644 --- a/evalargs.xc +++ b/evalargs.xc @@ -2,9 +2,12 @@ * kit sizes from getting too big. */ -/* $Header: evalargs.xc,v 3.0.1.8 90/11/10 01:35:49 lwall Locked $ +/* $Header: evalargs.xc,v 3.0.1.9 91/01/11 18:00:18 lwall Locked $ * * $Log: evalargs.xc,v $ + * Revision 3.0.1.9 91/01/11 18:00:18 lwall + * patch42: <> input to individual array elements was suboptimal + * * Revision 3.0.1.8 90/11/10 01:35:49 lwall * patch38: array slurps are now faster and take less memory * @@ -358,6 +361,9 @@ } if (!fp && dowarn) warn("Read on closed filehandle <%s>",stab_name(last_in_stab)); + when = str->str_len; /* remember if already alloced */ + if (!when) + Str_Grow(str,80); /* try short-buffering it */ keepgoing: if (!fp) st[sp] = &str_undef; @@ -415,6 +421,14 @@ str = Str_new(58,80); goto keepgoing; } + else if (!when && str->str_len - str->str_cur > 80) { + /* try to reclaim a bit of scalar space on 1st alloc */ + if (str->str_cur < 60) + str->str_len = 80; + else + str->str_len = str->str_cur+40; /* allow some slop */ + Renew(str->str_ptr, str->str_len, char); + } } record_separator = old_record_separator; #ifdef DEBUGGING diff --git a/form.c b/form.c index 2b0553f..2b91d43 100644 --- a/form.c +++ b/form.c @@ -1,4 +1,4 @@ -/* $Header: form.c,v 3.0.1.3 90/10/15 17:26:24 lwall Locked $ +/* $Header: form.c,v 3.0.1.4 91/01/11 18:04:07 lwall Locked $ * * Copyright (c) 1989, Larry Wall * @@ -6,6 +6,10 @@ * as specified in the README file that comes with the perl 3.0 kit. * * $Log: form.c,v $ + * Revision 3.0.1.4 91/01/11 18:04:07 lwall + * patch42: the @* format counted lines wrong + * patch42: the @* format didn't handle lines with nulls or without newline + * * Revision 3.0.1.3 90/10/15 17:26:24 lwall * patch29: added @###.## fields to format * @@ -278,10 +282,14 @@ int sp; str = stack->ary_array[sp+1]; s = str_get(str); size = str_len(str); - CHKLEN(size); - orec->o_lines += countlines(s); + CHKLEN(size+1); + orec->o_lines += countlines(s,size) - 1; (void)bcopy(s,d,size); d += size; + if (size && s[size-1] != '\n') { + *d++ = '\n'; + orec->o_lines++; + } linebeg = fcmd->f_next; break; case F_DECIMAL: { @@ -289,6 +297,8 @@ int sp; (void)eval(fcmd->f_expr,G_SCALAR,sp); str = stack->ary_array[sp+1]; + size = fcmd->f_size; + CHKLEN(size); /* If the field is marked with ^ and the value is undefined, blank it out. */ if ((fcmd->f_flags & FC_CHOP) && !str->str_pok && !str->str_nok) { @@ -299,8 +309,6 @@ int sp; break; } value = str_gnum(str); - size = fcmd->f_size; - CHKLEN(size); if (fcmd->f_flags & FC_DP) { sprintf(d, "%#*.*f", size, fcmd->f_decimals, value); } else { @@ -315,12 +323,13 @@ int sp; *d++ = '\0'; } -countlines(s) +countlines(s,size) register char *s; +register int size; { register int count = 0; - while (*s) { + while (size--) { if (*s++ == '\n') count++; } diff --git a/installperl b/installperl new file mode 100644 index 0000000..12c314d --- /dev/null +++ b/installperl @@ -0,0 +1,162 @@ +#!./perl + +while (@ARGV) { + $nonono = 1 if $ARGV[0] eq '-n'; + $versiononly = 1 if $ARGV[0] eq '-v'; + shift; +} + +@scripts = 'h2ph'; +@manpages = ('perl.man', 'h2ph.man'); + +# Read in the config file. + +open(CONFIG, "config.sh") || die "You haven't run Configure yet!\n"; +while () { + if (s/^(\w+=)/\$$1/) { + $accum =~ s/'undef'/undef/g; + eval $accum; + $accum = ''; + } + $accum .= $_; +} + +# Do some quick sanity checks. + +if ($d_dosuid && $>) { die "You must run as root to install suidperl\n"; } + + $bin || die "No bin directory in config.sh\n"; +-d $bin || die "$bin is not a directory\n"; +-w $bin || die "$bin is not writable by you\n"; + +-x 'perl' || die "perl isn't executable!\n"; +-x 'taintperl' || die "taintperl isn't executable!\n"; +-x 'suidperl' || die "suidperl isn't executable!\n" if $d_dosuid; + +-x 't/TEST' || die "You've never run 'make test'!\n"; + +# First we install the version-numbered executables. + +$ver = sprintf("%5.3f", $]); + +&unlink("$bin/perl$ver"); +&cmd("cp perl $bin/perl$ver"); + +&unlink("$bin/tperl$ver"); +&cmd("cp taintperl $bin/tperl$ver"); +&chmod(0755, "$bin/tperl$ver"); # force non-suid for security + +&unlink("$bin/sperl$ver"); +if ($d_dosuid) { + &cmd("cp suidperl $bin/sperl$ver"); + &chmod(04711, "$bin/sperl$ver"); +} + +exit 0 if $versiononly; + +# Make links to ordinary names if bin directory isn't current directory. + +($bdev,$bino) = stat($bin); +($ddev,$dino) = stat('.'); + +if ($bdev != $ddev || $bino != $dino) { + &unlink("$bin/perl", "$bin/taintperl", "$bin/suidperl"); + &link("$bin/perl$ver", "$bin/perl"); + &link("$bin/tperl$ver", "$bin/taintperl"); + &link("$bin/sperl$ver", "$bin/suidperl") if $d_dosuid; +} + +# Make some enemies in the name of standardization. :-) + +($udev,$uino) = stat("/usr/bin"); + +if (($udev != $ddev || $uino != $dino) && !$nonono) { + unlink "/usr/bin/perl"; + eval 'symlink("$bin/perl", "/usr/bin/perl")' || + eval 'link("$bin/perl", "/usr/bin/perl")' || + &cmd("cp $bin/perl /usr/bin"); +} + +# Install scripts. + +&makedir($scriptdir); + +for (@scripts) { + &chmod(0755, $_); + &cmd("cp $_ $scriptdir"); +} + +# Install library files. + +&makedir($privlib); + +($pdev,$pino) = stat($privlib); + +if ($pdev != $ddev || $pino != $dino) { + &cmd("cd lib && cp *.pl $privlib"); +} + +# Install man pages. + +&makedir($mansrc); + +($mdev,$mino) = stat($mansrc); +if ($mdev != $ddev || $mino != $dino) { + for (@manpages) { + ($new = $_) =~ s/man$/$manext/; + &cmd("cp $_ $mansrc/$new"); + } +} + +print STDERR " Installation complete\n"; + +exit 0; + +############################################################################### + +sub unlink { + local(@names) = @_; + + foreach $name (@names) { + next unless -e $name; + print STDERR " unlink $name\n"; + unlink($name) || warn "Couldn't unlink $name: $!\n" unless $nonono; + } +} + +sub cmd { + local($cmd) = @_; + print STDERR " $cmd\n"; + unless ($nonono) { + system $cmd; + warn "Command failed!!!\n" if $?; + } +} + +sub link { + local($from,$to) = @_; + + print STDERR " ln $from $to\n"; + link($from,$to) || warn "Couldn't link $from to $to: $!\n" unless $nonono; +} + +sub chmod { + local($mode,$name) = @_; + + printf STDERR " chmod %o %s\n", $mode, $name; + chmod($mode,$name) || warn "Couldn't chmod $mode $name: $!\n" + unless $nonono; +} + +sub makedir { + local($dir) = @_; + unless (-d $dir) { + local($shortdir) = $dir; + + $shortdir =~ s#(.*)/.*#$1#; + &makedir($shortdir); + + print STDERR " mkdir $dir\n"; + mkdir($dir, 0777) || warn "Couldn't create $dir: $!\n" unless $nonono; + } +} diff --git a/lib/flush.pl b/lib/flush.pl index 1d22819..55002b9 100644 --- a/lib/flush.pl +++ b/lib/flush.pl @@ -20,3 +20,4 @@ sub printflush { select($old); } +1; diff --git a/malloc.c b/malloc.c index 6ad48b9..3ed5536 100644 --- a/malloc.c +++ b/malloc.c @@ -1,6 +1,9 @@ -/* $Header: malloc.c,v 3.0.1.4 90/11/13 15:23:45 lwall Locked $ +/* $Header: malloc.c,v 3.0.1.5 91/01/11 18:09:52 lwall Locked $ * * $Log: malloc.c,v $ + * Revision 3.0.1.5 91/01/11 18:09:52 lwall + * patch42: Configure now checks alignment requirements + * * Revision 3.0.1.4 90/11/13 15:23:45 lwall * patch41: added hp malloc union overhead strut (that sounds very blue collar) * @@ -59,8 +62,8 @@ static findbucket(), morecore(); */ union overhead { union overhead *ov_next; /* when free */ -#if defined(mips) || defined(sparc) || defined(luna88k) || defined(hp9000s800) - double strut; /* alignment problems */ +#if ALIGNBYTES > 4 + double strut; /* alignment problems */ #endif struct { u_char ovu_magic; /* magic number */ diff --git a/patchlevel.h b/patchlevel.h index f037018..64b1306 100644 --- a/patchlevel.h +++ b/patchlevel.h @@ -1 +1 @@ -#define PATCHLEVEL 42 +#define PATCHLEVEL 43 diff --git a/perl.h b/perl.h index c911e2b..ca773cb 100644 --- a/perl.h +++ b/perl.h @@ -1,4 +1,4 @@ -/* $Header: perl.h,v 3.0.1.10 90/11/10 01:44:13 lwall Locked $ +/* $Header: perl.h,v 3.0.1.11 91/01/11 18:10:57 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: perl.h,v $ + * Revision 3.0.1.11 91/01/11 18:10:57 lwall + * patch42: ANSIfied the stat mode checking + * * Revision 3.0.1.10 90/11/10 01:44:13 lwall * patch38: more msdos/os2 upgrades * @@ -288,6 +291,98 @@ EXT int dbmlen; # endif #endif +/* + * The following gobbledygook brought to you on behalf of __STDC__. + * (I could just use #ifndef __STDC__, but this is more bulletproof + * in the face of half-implementations.) + */ + +#ifndef S_IFMT +# ifdef _S_IFMT +# define S_IFMT _S_IFMT +# else +# define S_IFMT 0170000 +# endif +#endif + +#ifndef S_ISDIR +# define S_ISDIR(m) ((m & S_IFMT) == S_IFDIR) +#endif + +#ifndef S_ISCHR +# define S_ISCHR(m) ((m & S_IFMT) == S_IFCHR) +#endif + +#ifndef S_ISBLK +# define S_ISBLK(m) ((m & S_IFMT) == S_IFBLK) +#endif + +#ifndef S_ISREG +# define S_ISREG(m) ((m & S_IFMT) == S_IFREG) +#endif + +#ifndef S_ISFIFO +# define S_ISFIFO(m) ((m & S_IFMT) == S_IFIFO) +#endif + +#ifndef S_ISLNK +# ifdef _S_ISLNK +# define S_ISLNK(m) _S_ISLNK(m) +# else +# ifdef _S_IFLNK +# define S_ISLNK(m) ((m & S_IFMT) == _S_IFLNK) +# else +# ifdef S_IFLNK +# define S_ISLNK(m) ((m & S_IFMT) == S_IFLNK) +# else +# define S_ISLNK(m) (0) +# endif +# endif +# endif +#endif + +#ifndef S_ISSOCK +# ifdef _S_ISSOCK +# define S_ISSOCK(m) _S_ISSOCK(m) +# else +# ifdef _S_IFSOCK +# define S_ISSOCK(m) ((m & S_IFMT) == _S_IFSOCK) +# else +# ifdef S_IFSOCK +# define S_ISSOCK(m) ((m & S_IFMT) == S_IFSOCK) +# else +# define S_ISSOCK(m) (0) +# endif +# endif +# endif +#endif + +#ifndef S_IRUSR +# ifdef S_IREAD +# define S_IRUSR S_IREAD +# define S_IWUSR S_IWRITE +# define S_IXUSR S_IEXEC +# else +# define S_IRUSR 0400 +# define S_IWUSR 0200 +# define S_IXUSR 0100 +# endif +# define S_IRGRP (S_IRUSR>>3) +# define S_IWGRP (S_IWUSR>>3) +# define S_IXGRP (S_IXUSR>>3) +# define S_IROTH (S_IRUSR>>6) +# define S_IWOTH (S_IWUSR>>6) +# define S_IXOTH (S_IXUSR>>6) +#endif + +#ifndef S_ISUID +# define S_ISUID 04000 +#endif + +#ifndef S_ISGID +# define S_ISGID 02000 +#endif + typedef unsigned int STRLEN; typedef struct arg ARG; diff --git a/perl.y b/perl.y index c8394be..5c5b4a4 100644 --- a/perl.y +++ b/perl.y @@ -1,4 +1,4 @@ -/* $Header: perl.y,v 3.0.1.9 90/10/15 18:01:45 lwall Locked $ +/* $Header: perl.y,v 3.0.1.10 91/01/11 18:14:28 lwall Locked $ * * Copyright (c) 1989, Larry Wall * @@ -6,6 +6,10 @@ * as specified in the README file that comes with the perl 3.0 kit. * * $Log: perl.y,v $ + * Revision 3.0.1.10 91/01/11 18:14:28 lwall + * patch42: package didn't create symbol tables that could be reset + * patch42: split with no arguments could wipe out next operator + * * Revision 3.0.1.9 90/10/15 18:01:45 lwall * patch29: added SysV IPC * patch29: package behavior is now more consistent @@ -349,7 +353,9 @@ package : PACKAGE WORD ';' saveitem(curstname); str_set(curstname,$2); sprintf(tmpbuf,"'_%s",$2); - tmpstab = hadd(stabent(tmpbuf,TRUE)); + tmpstab = stabent(tmpbuf,TRUE); + if (!stab_xhash(tmpstab)) + stab_xhash(tmpstab) = hnew(0); curstash = stab_xhash(tmpstab); if (!curstash->tbl_name) curstash->tbl_name = savestr($2); @@ -664,8 +670,15 @@ term : '-' term %prec UMINUS aadd(stabent(subline ? "_" : "ARGV", TRUE))), Nullarg, Nullarg); } | SPLIT %prec '(' -{static char p[]="/\\s+/";char*o=bufend;bufend=p+5;(void)scanpat(p);bufend=o; - $$ = make_split(defstab,yylval.arg,Nullarg); } + { static char p[]="/\\s+/"; + char *oldend = bufend; + int oldarg = yylval.arg; + + bufend=p+5; + (void)scanpat(p); + bufend=oldend; + $$ = make_split(defstab,yylval.arg,Nullarg); + yylval.arg = oldarg; } | SPLIT '(' sexpr csexpr csexpr ')' { $$ = mod_match(O_MATCH, $4, make_split(defstab,$3,$5));} diff --git a/t/op.dbm b/t/op.dbm index 1f80715..15a6f75 100644 --- a/t/op.dbm +++ b/t/op.dbm @@ -1,6 +1,6 @@ #!./perl -# $Header: op.dbm,v 3.0.1.1 90/03/27 16:25:57 lwall Locked $ +# $Header: op.dbm,v 3.0.1.2 91/01/11 18:29:12 lwall Locked $ if (!-r '/usr/include/dbm.h' && !-r '/usr/include/ndbm.h') { print "1..0\n"; @@ -9,7 +9,7 @@ if (!-r '/usr/include/dbm.h' && !-r '/usr/include/ndbm.h') { print "1..10\n"; -unlink 'Op.dbmx.dir', 'Op.dbmx.pag'; +unlink ; umask(0); print (dbmopen(h,'Op.dbmx',0640) ? "ok 1\n" : "not ok 1\n"); ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, diff --git a/t/op.mkdir b/t/op.mkdir index 01dc6ca..dba5a88 100644 --- a/t/op.mkdir +++ b/t/op.mkdir @@ -1,6 +1,6 @@ #!./perl -# $Header: op.mkdir,v 3.0.1.3 90/03/12 17:03:57 lwall Locked $ +# $Header: op.mkdir,v 3.0.1.4 91/01/11 18:30:00 lwall Locked $ print "1..7\n"; @@ -8,7 +8,7 @@ print "1..7\n"; print (mkdir('blurfl',0777) ? "ok 1\n" : "not ok 1\n"); print (mkdir('blurfl',0777) ? "not ok 2\n" : "ok 2\n"); -print ($! =~ /exists/ ? "ok 3\n" : "not ok 3\n"); +print ($! =~ /exist/ ? "ok 3\n" : "not ok 3\n"); print (-d 'blurfl' ? "ok 4\n" : "not ok 4\n"); print (rmdir('blurfl') ? "ok 5\n" : "not ok 5\n"); print (rmdir('blurfl') ? "not ok 6\n" : "ok 6\n");