Xref: utzoo comp.sources.bugs:2784 comp.lang.perl:3535 Path: utzoo!utgpu!news-server.csri.toronto.edu!cs.utexas.edu!swrinde!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 #43 Summary: This is an official patch for perl 3.0. Please apply it. Message-ID: <11028@jpl-devvax.JPL.NASA.GOV> Date: 12 Jan 91 08:40:58 GMT Organization: Jet Propulsion Laboratory, Pasadena, CA Lines: 1488 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 #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 () { + 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 ; 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 ***