lwall@jpl-devvax.JPL.NASA.GOV (Larry Wall) (01/12/91)
System: perl version 3.0 Patch #: 43 Priority: Subject: patch #42, continued Description: See patch #42. 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: *** DO NOTHING--INSTALL ALL PATCHES UP THROUGH #44 FIRST *** 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: 42 1c1 < #define PATCHLEVEL 42 --- > #define PATCHLEVEL 43 Index: doio.c Prereq: 3.0.1.13 *** doio.c.old Fri Jan 11 18:40:30 1991 --- doio.c Fri Jan 11 18:40:38 1991 *************** *** 1,4 **** ! /* $Header: doio.c,v 3.0.1.13 90/11/10 01:17:37 lwall Locked $ * * Copyright (c) 1989, Larry Wall * --- 1,4 ---- ! /* $Header: doio.c,v 3.0.1.14 91/01/11 17:51:04 lwall Locked $ * * Copyright (c) 1989, Larry Wall * *************** *** 6,11 **** --- 6,18 ---- * 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,279 **** (void)fclose(fp); return FALSE; } ! result = (statbuf.st_mode & S_IFMT); ! #ifdef S_IFSOCK ! if (result == S_IFSOCK || result == 0) stio->type = 's'; /* in case a socket was passed in to us */ #endif } #if defined(FCNTL) && defined(F_SETFD) --- 277,287 ---- (void)fclose(fp); return FALSE; } ! 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,302 **** { register STR *str; char *oldname; ! int filemode,fileuid,filegid; while (alen(stab_xarray(stab)) >= 0) { str = ashift(stab_xarray(stab)); --- 304,314 ---- { register STR *str; char *oldname; ! int filedev; ! int fileino; ! int filemode; ! int fileuid; ! int filegid; while (alen(stab_xarray(stab)) >= 0) { str = ashift(stab_xarray(stab)); *************** *** 308,316 **** --- 320,342 ---- #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); *************** *** 317,325 **** #else str_cat(str,inplace); #endif #ifdef RENAME #ifndef MSDOS ! (void)rename(oldname,str->str_ptr); #else do_close(stab,FALSE); (void)unlink(str->str_ptr); --- 343,368 ---- #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 ! 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,334 **** #endif /* MSDOS */ #else (void)UNLINK(str->str_ptr); ! (void)link(oldname,str->str_ptr); (void)UNLINK(oldname); #endif } --- 371,383 ---- #endif /* MSDOS */ #else (void)UNLINK(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,350 **** 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"); defoutstab = argvoutstab; #ifdef FCHMOD (void)fchmod(fileno(stab_io(argvoutstab)->ifp),filemode); --- 393,400 ---- str_cat(str,oldname); errno = 0; /* in case sprintf set errno */ if (!do_open(argvoutstab,str->str_ptr,str->str_cur)) ! 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,369 **** return stab_io(stab)->ifp; } else ! fprintf(stderr,"Can't open %s\n",str_get(str)); str_free(str); } if (inplace) { --- 413,419 ---- return stab_io(stab)->ifp; } else ! fprintf(stderr,"Can't open %s: %s\n",str_get(str), strerror(errno)); str_free(str); } if (inplace) { *************** *** 440,446 **** if (stio->ifp) { if (stio->type == '|') { status = mypclose(stio->ifp); ! retval = (status >= 0); statusvalue = (unsigned short)status & 0xffff; } else if (stio->type == '-') --- 490,496 ---- if (stio->ifp) { if (stio->type == '|') { status = mypclose(stio->ifp); ! retval = (status == 0); statusvalue = (unsigned short)status & 0xffff; } else if (stio->type == '-') *************** *** 651,657 **** max = 0; } else { ! str_sset(statname,ary->ary_array[sp]); statstab = Nullstab; #ifdef LSTAT if (arg->arg_type == O_LSTAT) --- 701,707 ---- max = 0; } else { ! str_set(statname,str_get(ary->ary_array[sp])); statstab = Nullstab; #ifdef LSTAT if (arg->arg_type == O_LSTAT) *************** *** 968,978 **** } else { statstab = Nullstab; ! str_sset(statname,str); return (laststatval = stat(str_get(str),&statcache)); } } STR * do_fttext(arg,str) register ARG *arg; --- 1018,1045 ---- } else { statstab = Nullstab; ! 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,1030 **** } else { statstab = Nullstab; ! str_sset(statname,str); really_filename: i = open(str_get(str),0); if (i < 0) --- 1091,1097 ---- } else { statstab = Nullstab; ! str_set(statname,str_get(str)); really_filename: i = open(str_get(str),0); if (i < 0) *************** *** 2243,2253 **** } else { /* don't let root wipe out directories without -U */ #ifdef LSTAT ! if (lstat(s,&statbuf) < 0 || #else ! if (stat(s,&statbuf) < 0 || #endif - (statbuf.st_mode & S_IFMT) == S_IFDIR ) tot--; else { if (UNLINK(s)) --- 2310,2319 ---- } else { /* don't let root wipe out directories without -U */ #ifdef LSTAT ! if (lstat(s,&statbuf) < 0 || S_ISDIR(statbuf.st_mode)) #else ! if (stat(s,&statbuf) < 0 || S_ISDIR(statbuf.st_mode)) #endif tot--; else { if (UNLINK(s)) *************** *** 2298,2306 **** 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 ) return TRUE; } else --- 2364,2371 ---- register struct stat *statbufp; { if ((effective ? euid : uid) == 0) { /* root is special */ ! if (bit == S_IXUSR) { ! if (statbufp->st_mode & 0111 || S_ISDIR(statbufp->st_mode)) return TRUE; } else Index: dolist.c Prereq: 3.0.1.11 *** dolist.c.old Fri Jan 11 18:40:57 1991 --- dolist.c Fri Jan 11 18:41:03 1991 *************** *** 1,4 **** ! /* $Header: dolist.c,v 3.0.1.11 90/11/10 01:29:49 lwall Locked $ * * Copyright (c) 1989, Larry Wall * --- 1,4 ---- ! /* $Header: dolist.c,v 3.0.1.12 91/01/11 17:54:58 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: 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,554 **** --- 554,561 ---- 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,572 **** if (gimme != G_ARRAY) { /* arrange to do first one only */ for (patend = pat; !isalpha(*patend); patend++); ! if (*patend == 'a' || *patend == 'A' || *pat == '%') { patend++; while (isdigit(*patend) || *patend == '*') patend++; --- 573,579 ---- if (gimme != G_ARRAY) { /* arrange to do first one only */ for (patend = pat; !isalpha(*patend); patend++); ! if (index("aAbBhH", *patend) || *pat == '%') { patend++; while (isdigit(*patend) || *patend == '*') patend++; *************** *** 580,587 **** datumtype = *pat++; if (pat >= patend) len = 1; ! else if (*pat == '*') len = strend - strbeg; /* long enough */ else if (isdigit(*pat)) { len = *pat++ - '0'; while (isdigit(*pat)) --- 587,596 ---- datumtype = *pat++; if (pat >= patend) len = 1; ! else if (*pat == '*') { len = strend - strbeg; /* long enough */ + pat++; + } else if (isdigit(*pat)) { len = *pat++ - '0'; while (isdigit(*pat)) *************** *** 636,641 **** --- 645,716 ---- } (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,1267 **** --- 1335,1344 ---- 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,1286 **** --- 1358,1364 ---- curspat = oldspat; } restorelist(oldsave); + tmps_base = oldtmps_base; if (gimme != G_ARRAY) { str_numset(str,(double)(dst - arglast[1])); STABSET(str); *************** *** 1370,1375 **** --- 1448,1455 ---- if (*up = st[i]) { if (!(*up)->str_pok) (void)str_2ptr(*up); + else + (*up)->str_pok &= ~SP_TEMP; up++; } } *************** *** 1510,1516 **** for (;;) { if (!csv) return sp; ! if (csv->curcsv && csv->curcsv->sub == stab_sub(DBsub)) count++; if (!count--) break; --- 1590,1596 ---- for (;;) { if (!csv) return sp; ! if (DBsub && csv->curcsv && csv->curcsv->sub == stab_sub(DBsub)) count++; if (!count--) break; Index: eval.c Prereq: 3.0.1.10 *** eval.c.old Fri Jan 11 18:41:27 1991 --- eval.c Fri Jan 11 18:41:36 1991 *************** *** 1,4 **** ! /* $Header: eval.c,v 3.0.1.10 90/11/10 01:33:22 lwall Locked $ * * Copyright (c) 1989, Larry Wall * --- 1,4 ---- ! /* $Header: eval.c,v 3.0.1.11 91/01/11 17:58:30 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: 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,1416 **** --- 1413,1423 ---- 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,1494 **** break; #endif case O_WAITPID: ! #ifdef WAITPID #ifndef lint anum = (int)str_gnum(st[1]); optype = (int)str_gnum(st[2]); --- 1495,1501 ---- break; #endif case O_WAITPID: ! #ifdef WAIT #ifndef lint anum = (int)str_gnum(st[1]); optype = (int)str_gnum(st[2]); *************** *** 1703,1710 **** 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 ) (void)UNLINK(tmps2); if (!(anum = link(tmps,tmps2))) anum = UNLINK(tmps); --- 1710,1716 ---- if (same_dirent(tmps2, tmps)) /* can always rename to same name */ anum = 1; else { ! if (euid || stat(tmps2,&statbuf) < 0 || !S_ISDIR(statbuf.st_mode)) (void)UNLINK(tmps2); if (!(anum = link(tmps,tmps2))) anum = UNLINK(tmps); *************** *** 1955,1981 **** case O_FTRREAD: argtype = 0; ! anum = S_IREAD; goto check_perm; case O_FTRWRITE: argtype = 0; ! anum = S_IWRITE; goto check_perm; case O_FTREXEC: argtype = 0; ! anum = S_IEXEC; goto check_perm; case O_FTEREAD: argtype = 1; ! anum = S_IREAD; goto check_perm; case O_FTEWRITE: argtype = 1; ! anum = S_IWRITE; goto check_perm; case O_FTEEXEC: argtype = 1; ! anum = S_IEXEC; check_perm: if (mystat(arg,st[1]) < 0) goto say_undef; --- 1961,1987 ---- case O_FTRREAD: argtype = 0; ! anum = S_IRUSR; goto check_perm; case O_FTRWRITE: argtype = 0; ! anum = S_IWUSR; goto check_perm; case O_FTREXEC: argtype = 0; ! anum = S_IXUSR; goto check_perm; case O_FTEREAD: argtype = 1; ! anum = S_IRUSR; goto check_perm; case O_FTEWRITE: argtype = 1; ! anum = S_IWUSR; goto check_perm; case O_FTEEXEC: argtype = 1; ! anum = S_IXUSR; check_perm: if (mystat(arg,st[1]) < 0) goto say_undef; *************** *** 2023,2071 **** goto donumset; case O_FTSOCK: ! #ifdef S_IFSOCK ! anum = S_IFSOCK; ! goto check_file_type; ! #else goto say_no; - #endif case O_FTCHR: ! anum = S_IFCHR; ! goto check_file_type; case O_FTBLK: ! #ifdef S_IFBLK ! anum = S_IFBLK; ! goto check_file_type; ! #else goto say_no; - #endif case O_FTFILE: ! anum = S_IFREG; ! goto check_file_type; 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 ) goto say_yes; goto say_no; case O_FTPIPE: ! #ifdef S_IFIFO ! anum = S_IFIFO; ! goto check_file_type; ! #else 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) goto say_undef; ! if ((statcache.st_mode & S_IFMT) == S_IFLNK ) goto say_yes; - #endif goto say_no; case O_SYMLINK: #ifdef SYMLINK --- 2029,2074 ---- goto donumset; case O_FTSOCK: ! if (mystat(arg,st[1]) < 0) ! goto say_undef; ! if (S_ISSOCK(statcache.st_mode)) ! goto say_yes; goto say_no; case O_FTCHR: ! if (mystat(arg,st[1]) < 0) ! goto say_undef; ! if (S_ISCHR(statcache.st_mode)) ! goto say_yes; ! goto say_no; case O_FTBLK: ! if (mystat(arg,st[1]) < 0) ! goto say_undef; ! if (S_ISBLK(statcache.st_mode)) ! goto say_yes; goto say_no; case O_FTFILE: ! if (mystat(arg,st[1]) < 0) ! goto say_undef; ! if (S_ISREG(statcache.st_mode)) ! goto say_yes; ! goto say_no; case O_FTDIR: if (mystat(arg,st[1]) < 0) goto say_undef; ! if (S_ISDIR(statcache.st_mode)) goto say_yes; goto say_no; case O_FTPIPE: ! if (mystat(arg,st[1]) < 0) ! goto say_undef; ! if (S_ISFIFO(statcache.st_mode)) ! goto say_yes; goto say_no; case O_FTLINK: ! if (mylstat(arg,st[1]) < 0) goto say_undef; ! if (S_ISLNK(statcache.st_mode)) goto say_yes; goto say_no; case O_SYMLINK: #ifdef SYMLINK Index: evalargs.xc Prereq: 3.0.1.8 *** evalargs.xc.old Fri Jan 11 18:41:47 1991 --- evalargs.xc Fri Jan 11 18:41:49 1991 *************** *** 2,10 **** * kit sizes from getting too big. */ ! /* $Header: evalargs.xc,v 3.0.1.8 90/11/10 01:35:49 lwall Locked $ * * $Log: evalargs.xc,v $ * Revision 3.0.1.8 90/11/10 01:35:49 lwall * patch38: array slurps are now faster and take less memory * --- 2,13 ---- * kit sizes from getting too big. */ ! /* $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,363 **** --- 361,369 ---- } 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; *************** *** 414,419 **** --- 420,433 ---- } 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; Index: lib/flush.pl *** lib/flush.pl.old Fri Jan 11 18:42:22 1991 --- lib/flush.pl Fri Jan 11 18:42:23 1991 *************** *** 20,22 **** --- 20,23 ---- select($old); } + 1; Index: form.c Prereq: 3.0.1.3 *** form.c.old Fri Jan 11 18:41:55 1991 --- form.c Fri Jan 11 18:41:56 1991 *************** *** 1,4 **** ! /* $Header: form.c,v 3.0.1.3 90/10/15 17:26:24 lwall Locked $ * * Copyright (c) 1989, Larry Wall * --- 1,4 ---- ! /* $Header: form.c,v 3.0.1.4 91/01/11 18:04:07 lwall Locked $ * * Copyright (c) 1989, Larry Wall * *************** *** 6,11 **** --- 6,15 ---- * 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,287 **** str = stack->ary_array[sp+1]; s = str_get(str); size = str_len(str); ! CHKLEN(size); ! orec->o_lines += countlines(s); (void)bcopy(s,d,size); d += size; linebeg = fcmd->f_next; break; case F_DECIMAL: { --- 282,295 ---- str = stack->ary_array[sp+1]; s = str_get(str); size = str_len(str); ! 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,294 **** --- 297,304 ---- (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,306 **** 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 { --- 309,314 ---- *************** *** 315,326 **** *d++ = '\0'; } ! countlines(s) register char *s; { register int count = 0; ! while (*s) { if (*s++ == '\n') count++; } --- 323,335 ---- *d++ = '\0'; } ! countlines(s,size) register char *s; + register int size; { register int count = 0; ! while (size--) { if (*s++ == '\n') count++; } Index: installperl *** installperl.old Fri Jan 11 18:42:00 1991 --- installperl Fri Jan 11 18:42:02 1991 *************** *** 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 (<CONFIG>) { + 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; + } + } Index: malloc.c Prereq: 3.0.1.4 *** malloc.c.old Fri Jan 11 18:42:55 1991 --- malloc.c Fri Jan 11 18:42:57 1991 *************** *** 1,6 **** ! /* $Header: malloc.c,v 3.0.1.4 90/11/13 15:23:45 lwall Locked $ * * $Log: malloc.c,v $ * Revision 3.0.1.4 90/11/13 15:23:45 lwall * patch41: added hp malloc union overhead strut (that sounds very blue collar) * --- 1,9 ---- ! /* $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,66 **** */ union overhead { union overhead *ov_next; /* when free */ ! #if defined(mips) || defined(sparc) || defined(luna88k) || defined(hp9000s800) ! double strut; /* alignment problems */ #endif struct { u_char ovu_magic; /* magic number */ --- 62,69 ---- */ union overhead { union overhead *ov_next; /* when free */ ! #if ALIGNBYTES > 4 ! double strut; /* alignment problems */ #endif struct { u_char ovu_magic; /* magic number */ Index: t/op.dbm Prereq: 3.0.1.1 *** t/op.dbm.old Fri Jan 11 18:46:31 1991 --- t/op.dbm Fri Jan 11 18:46:32 1991 *************** *** 1,6 **** #!./perl ! # $Header: op.dbm,v 3.0.1.1 90/03/27 16:25:57 lwall Locked $ if (!-r '/usr/include/dbm.h' && !-r '/usr/include/ndbm.h') { print "1..0\n"; --- 1,6 ---- #!./perl ! # $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,15 **** print "1..10\n"; ! unlink 'Op.dbmx.dir', 'Op.dbmx.pag'; 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, --- 9,15 ---- print "1..10\n"; ! unlink <Op.dbmx.*>; 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, Index: t/op.mkdir Prereq: 3.0.1.3 *** t/op.mkdir.old Fri Jan 11 18:46:36 1991 --- t/op.mkdir Fri Jan 11 18:46:37 1991 *************** *** 1,6 **** #!./perl ! # $Header: op.mkdir,v 3.0.1.3 90/03/12 17:03:57 lwall Locked $ print "1..7\n"; --- 1,6 ---- #!./perl ! # $Header: op.mkdir,v 3.0.1.4 91/01/11 18:30:00 lwall Locked $ print "1..7\n"; *************** *** 8,14 **** 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 (-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"); --- 8,14 ---- print (mkdir('blurfl',0777) ? "ok 1\n" : "not ok 1\n"); print (mkdir('blurfl',0777) ? "not ok 2\n" : "ok 2\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"); Index: perl.h Prereq: 3.0.1.10 *** perl.h.old Fri Jan 11 18:43:07 1991 --- perl.h Fri Jan 11 18:43:11 1991 *************** *** 1,4 **** ! /* $Header: perl.h,v 3.0.1.10 90/11/10 01:44:13 lwall Locked $ * * Copyright (c) 1989, Larry Wall * --- 1,4 ---- ! /* $Header: perl.h,v 3.0.1.11 91/01/11 18:10:57 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: 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 * *************** *** 286,291 **** --- 289,386 ---- # define DIRENT direct # endif # 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; Index: perl.y Prereq: 3.0.1.9 *** perl.y.old Fri Jan 11 18:43:20 1991 --- perl.y Fri Jan 11 18:43:24 1991 *************** *** 1,4 **** ! /* $Header: perl.y,v 3.0.1.9 90/10/15 18:01:45 lwall Locked $ * * Copyright (c) 1989, Larry Wall * --- 1,4 ---- ! /* $Header: perl.y,v 3.0.1.10 91/01/11 18:14:28 lwall Locked $ * * Copyright (c) 1989, Larry Wall * *************** *** 6,11 **** --- 6,15 ---- * 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,355 **** saveitem(curstname); str_set(curstname,$2); sprintf(tmpbuf,"'_%s",$2); ! tmpstab = hadd(stabent(tmpbuf,TRUE)); curstash = stab_xhash(tmpstab); if (!curstash->tbl_name) curstash->tbl_name = savestr($2); --- 353,361 ---- saveitem(curstname); str_set(curstname,$2); sprintf(tmpbuf,"'_%s",$2); ! 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,671 **** 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); } | SPLIT '(' sexpr csexpr csexpr ')' { $$ = mod_match(O_MATCH, $4, make_split(defstab,$3,$5));} --- 670,684 ---- aadd(stabent(subline ? "_" : "ARGV", TRUE))), Nullarg, Nullarg); } | SPLIT %prec '(' ! { 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));} *** End of Patch 43 ***