Newsgroups: comp.sources.misc From: lwall@netlabs.com (Larry Wall) Subject: v25i064: perl - The perl programming language, Patch15 Message-ID: <1991Nov13.214427.3782@sparky.imd.sterling.com> X-Md4-Signature: efbe162c35757d3f3864564e8f96ee1c Date: Wed, 13 Nov 1991 21:44:27 GMT Approved: kent@sparky.imd.sterling.com Submitted-by: lwall@netlabs.com (Larry Wall) Posting-number: Volume 25, Issue 64 Archive-name: perl/patch15 Environment: UNIX, MS-DOS, OS2 Patch-To: perl: Volume 18, Issue 19-54 System: perl version 4.0 Patch #: 15 Priority: MED-HIGH Subject: patch #11, continued Description: See patch #11. 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 15 Index: hash.c *** hash.c.old Tue Nov 5 19:26:22 1991 --- hash.c Tue Nov 5 19:26:23 1991 *************** *** 1,4 **** ! /* $RCSfile: hash.c,v $$Revision: 4.0.1.1 $$Date: 91/06/07 11:10:11 $ * * Copyright (c) 1991, Larry Wall * --- 1,4 ---- ! /* $RCSfile: hash.c,v $$Revision: 4.0.1.2 $$Date: 91/11/05 17:24:13 $ * * Copyright (c) 1991, Larry Wall * *************** *** 6,11 **** --- 6,14 ---- * License or the Artistic License, as specified in the README file. * * $Log: hash.c,v $ + * Revision 4.0.1.2 91/11/05 17:24:13 lwall + * patch11: saberized perl + * * Revision 4.0.1.1 91/06/07 11:10:11 lwall * patch4: new copyright notice * *************** *** 70,76 **** else maxi = tb->tbl_coeffsize; for (s=key, i=0, hash = 0; ! i < maxi; s++, i++, hash *= 5) { hash += *s * coeff[i]; } --- 73,79 ---- else maxi = tb->tbl_coeffsize; for (s=key, i=0, hash = 0; ! i < maxi; /*SUPPRESS 8*/ s++, i++, hash *= 5) { hash += *s * coeff[i]; } *************** *** 129,134 **** --- 132,138 ---- return FALSE; if (hash) + /*SUPPRESS 530*/ ; else if (!tb->tbl_coeffsize) hash = *key + 128 * key[1] + 128 * key[klen-1]; *************** *** 138,144 **** else maxi = tb->tbl_coeffsize; for (s=key, i=0, hash = 0; ! i < maxi; s++, i++, hash *= 5) { hash += *s * coeff[i]; } --- 142,148 ---- else maxi = tb->tbl_coeffsize; for (s=key, i=0, hash = 0; ! i < maxi; /*SUPPRESS 8*/ s++, i++, hash *= 5) { hash += *s * coeff[i]; } *************** *** 226,232 **** else maxi = tb->tbl_coeffsize; for (s=key, i=0, hash = 0; ! i < maxi; s++, i++, hash *= 5) { hash += *s * coeff[i]; } --- 230,236 ---- else maxi = tb->tbl_coeffsize; for (s=key, i=0, hash = 0; ! i < maxi; /*SUPPRESS 8*/ s++, i++, hash *= 5) { hash += *s * coeff[i]; } *************** *** 425,430 **** --- 429,435 ---- tb->tbl_dbm = 0; /* now clear just cache */ #endif (void)hiterinit(tb); + /*SUPPRESS 560*/ while (hent = hiternext(tb)) { /* concise but not very efficient */ hentfree(ohent); ohent = hent; Index: hash.h *** hash.h.old Tue Nov 5 19:26:24 1991 --- hash.h Tue Nov 5 19:26:25 1991 *************** *** 1,4 **** ! /* $RCSfile: hash.h,v $$Revision: 4.0.1.1 $$Date: 91/06/07 11:10:33 $ * * Copyright (c) 1991, Larry Wall * --- 1,4 ---- ! /* $RCSfile: hash.h,v $$Revision: 4.0.1.2 $$Date: 91/11/05 17:24:31 $ * * Copyright (c) 1991, Larry Wall * *************** *** 6,11 **** --- 6,14 ---- * License or the Artistic License, as specified in the README file. * * $Log: hash.h,v $ + * Revision 4.0.1.2 91/11/05 17:24:31 lwall + * patch11: random cleanup + * * Revision 4.0.1.1 91/06/07 11:10:33 lwall * patch4: new copyright notice * *************** *** 59,64 **** --- 62,68 ---- HASH *hnew(); void hclear(); void hentfree(); + void hfree(); int hiterinit(); HENT *hiternext(); char *hiterkey(); Index: hints/hp9000_800.sh *** hints/hp9000_800.sh.old Tue Nov 5 19:26:32 1991 --- hints/hp9000_800.sh Tue Nov 5 19:26:32 1991 *************** *** 0 **** --- 1 ---- + libswanted=`echo $libswanted | sed 's/malloc //'` Index: installperl *** installperl.old Tue Nov 5 19:26:46 1991 --- installperl Tue Nov 5 19:26:46 1991 *************** *** 6,12 **** shift; } ! @scripts = ('h2ph', 'x2p/s2p', 'x2p/find2perl'); @manpages = ('perl.man', 'h2ph.man', 'x2p/a2p.man', 'x2p/s2p.man'); $version = sprintf("%5.3f", $]); --- 6,14 ---- shift; } ! umask 022; ! ! @scripts = ('cppstdin', 'h2ph', 'c2ph', 'pstruct', 'x2p/s2p', 'x2p/find2perl'); @manpages = ('perl.man', 'h2ph.man', 'x2p/a2p.man', 'x2p/s2p.man'); $version = sprintf("%5.3f", $]); *************** *** 85,91 **** ($udev,$uino) = stat("/usr/bin"); if (-w _ && ($udev != $ddev || $uino != $dino) && !$nonono) { ! unlink "/usr/bin/perl"; eval 'symlink("$installbin/perl", "/usr/bin/perl")' || eval 'link("$installbin/perl", "/usr/bin/perl")' || &cmd("cp $installbin/perl /usr/bin"); --- 87,93 ---- ($udev,$uino) = stat("/usr/bin"); if (-w _ && ($udev != $ddev || $uino != $dino) && !$nonono) { ! &unlink("/usr/bin/perl"); eval 'symlink("$installbin/perl", "/usr/bin/perl")' || eval 'link("$installbin/perl", "/usr/bin/perl")' || &cmd("cp $installbin/perl /usr/bin"); *************** *** 100,115 **** s#.*/##; &chmod(0755, "$installscr/$_"); } - # Install library files. - - &makedir($installprivlib); - - ($pdev,$pino) = stat($installprivlib); - - if ($pdev != $ddev || $pino != $dino) { - &cmd("cd lib && cp *.pl $installprivlib"); - } - # Install man pages. if ($mansrc ne '') { --- 102,107 ---- *************** *** 133,138 **** --- 125,152 ---- } } } + + # Install library files. + + &makedir($installprivlib); + if (chdir "lib") { + + ($pdev,$pino) = stat($installprivlib); + ($ldev,$lino) = stat('.'); + + if ($pdev != $ldev || $pino != $lino) { + foreach $file (<*.pl>) { + &unlink("$installprivlib/$file"); + &cmd("cp $file $installprivlib"); + } + } + chdir ".." || die "Can't cd back to source directory: $!\n"; + } + else { + warn "Can't cd to lib to install lib files: $!\n"; + } + + &chmod(0755, "usub/mus"); print STDERR " Installation complete\n"; Index: malloc.c *** malloc.c.old Tue Nov 5 19:27:12 1991 --- malloc.c Tue Nov 5 19:27:12 1991 *************** *** 1,6 **** ! /* $RCSfile: malloc.c,v $$Revision: 4.0.1.2 $$Date: 91/06/07 11:20:45 $ * * $Log: malloc.c,v $ * Revision 4.0.1.2 91/06/07 11:20:45 lwall * patch4: many, many itty-bitty portability fixes * --- 1,9 ---- ! /* $RCSfile: malloc.c,v $$Revision: 4.0.1.3 $$Date: 91/11/05 17:57:40 $ * * $Log: malloc.c,v $ + * Revision 4.0.1.3 91/11/05 17:57:40 lwall + * patch11: safe malloc code now integrated into Perl's malloc when possible + * * Revision 4.0.1.2 91/06/07 11:20:45 lwall * patch4: many, many itty-bitty portability fixes * *************** *** 13,18 **** --- 16,22 ---- */ #ifndef lint + /*SUPPRESS 592*/ static char sccsid[] = "@(#)malloc.c 4.3 (Berkeley) 9/16/83"; #ifdef DEBUGGING *************** *** 110,115 **** --- 114,123 ---- #define ASSERT(p) #endif + #ifdef safemalloc + static int an = 0; + #endif + MALLOCPTRTYPE * malloc(nbytes) register unsigned nbytes; *************** *** 118,123 **** --- 126,148 ---- register int bucket = 0; register unsigned shiftr; + #ifdef safemalloc + #ifdef DEBUGGING + int size = nbytes; + #endif + + #ifdef MSDOS + if (nbytes > 0xffff) { + fprintf(stderr, "Allocation too large: %lx\n", nbytes); + exit(1); + } + #endif /* MSDOS */ + #ifdef DEBUGGING + if ((long)nbytes < 0) + fatal("panic: malloc"); + #endif + #endif /* safemalloc */ + /* * Convert amount of memory requested into * closest block size stored in hash buckets *************** *** 136,143 **** */ if (nextf[bucket] == NULL) morecore(bucket); ! if ((p = (union overhead *)nextf[bucket]) == NULL) return (NULL); /* remove from linked list */ #ifdef RCHECK if (*((int*)p) & (sizeof(union overhead) - 1)) --- 161,187 ---- */ if (nextf[bucket] == NULL) morecore(bucket); ! if ((p = (union overhead *)nextf[bucket]) == NULL) { ! #ifdef safemalloc ! fputs("Out of memory!\n", stderr); ! exit(1); ! #else return (NULL); + #endif + } + + #ifdef safemalloc + #ifdef DEBUGGING + # ifndef I286 + if (debug & 128) + fprintf(stderr,"0x%x: (%05d) malloc %d bytes\n",p+1,an++,size); + # else + if (debug & 128) + fprintf(stderr,"0x%lx: (%05d) malloc %d bytes\n",p+1,an++,size); + # endif + #endif + #endif /* safemalloc */ + /* remove from linked list */ #ifdef RCHECK if (*((int*)p) & (sizeof(union overhead) - 1)) *************** *** 240,245 **** --- 284,301 ---- register union overhead *op; char *cp = (char*)mp; + #ifdef safemalloc + #ifdef DEBUGGING + # ifndef I286 + if (debug & 128) + fprintf(stderr,"0x%x: (%05d) free\n",cp,an++); + # else + if (debug & 128) + fprintf(stderr,"0x%lx: (%05d) free\n",cp,an++); + # endif + #endif + #endif /* safemalloc */ + if (cp == NULL) return; op = (union overhead *)((caddr_t)cp - sizeof (union overhead)); *************** *** 292,297 **** --- 348,372 ---- int was_alloced = 0; char *cp = (char*)mp; + #ifdef safemalloc + #ifdef DEBUGGING + int size = nbytes; + #endif + + #ifdef MSDOS + if (nbytes > 0xffff) { + fprintf(stderr, "Reallocation too large: %lx\n", size); + exit(1); + } + #endif /* MSDOS */ + if (!cp) + fatal("Null realloc"); + #ifdef DEBUGGING + if ((long)nbytes < 0) + fatal("panic: realloc"); + #endif + #endif /* safemalloc */ + if (cp == NULL) return (malloc(nbytes)); op = (union overhead *)((caddr_t)cp - sizeof (union overhead)); *************** *** 336,349 **** *((u_int *)((caddr_t)op + nbytes - RSLOP)) = RMAGIC; } #endif ! return((MALLOCPTRTYPE*)cp); } ! if ((res = (char*)malloc(nbytes)) == NULL) ! return (NULL); ! if (cp != res) /* common optimization */ ! (void)bcopy(cp, res, (int)((nbytes < onb) ? nbytes : onb)); ! if (was_alloced) ! free(cp); return ((MALLOCPTRTYPE*)res); } --- 411,442 ---- *((u_int *)((caddr_t)op + nbytes - RSLOP)) = RMAGIC; } #endif ! res = cp; } ! else { ! if ((res = (char*)malloc(nbytes)) == NULL) ! return (NULL); ! if (cp != res) /* common optimization */ ! bcopy(cp, res, (int)(nbytes < onb ? nbytes : onb)); ! if (was_alloced) ! free(cp); ! } ! ! #ifdef safemalloc ! #ifdef DEBUGGING ! # ifndef I286 ! if (debug & 128) { ! fprintf(stderr,"0x%x: (%05d) rfree\n",res,an++); ! fprintf(stderr,"0x%x: (%05d) realloc %d bytes\n",res,an++,size); ! } ! # else ! if (debug & 128) { ! fprintf(stderr,"0x%lx: (%05d) rfree\n",res,an++); ! fprintf(stderr,"0x%lx: (%05d) realloc %d bytes\n",res,an++,size); ! } ! # endif ! #endif ! #endif /* safemalloc */ return ((MALLOCPTRTYPE*)res); } Index: hints/mpc.sh *** hints/mpc.sh.old Tue Nov 5 19:26:34 1991 --- hints/mpc.sh Tue Nov 5 19:26:34 1991 *************** *** 0 **** --- 1 ---- + ccflags="$ccflags -X18" Index: usub/mus *** usub/mus.old Tue Nov 5 19:28:22 1991 --- usub/mus Tue Nov 5 19:28:23 1991 *************** *** 64,74 **** if ($mode =~ /O/) { if ($what eq 'gnum') { push(@outies, "\t str_numset(st[$i], (double) $name);\n"); } else { push(@outies, "\t str_set(st[$i], (char*) $name);\n"); } - push(@callnames, "&$name"); } else { push(@callnames, $name); --- 64,75 ---- if ($mode =~ /O/) { if ($what eq 'gnum') { push(@outies, "\t str_numset(st[$i], (double) $name);\n"); + push(@callnames, "&$name"); } else { push(@outies, "\t str_set(st[$i], (char*) $name);\n"); + push(@callnames, "$name"); } } else { push(@callnames, $name); *************** *** 76,81 **** --- 77,87 ---- if ($mode =~ /I/) { print <c_filestab = fstab(origfilename); if (strEQ(origfilename,"-")) ! argv[0] = ""; if (preprocess) { str_cat(str,"-I"); str_cat(str,PRIVLIB); (void)sprintf(buf, "\ --- 322,347 ---- xfailed = savestr(tokenbuf); } if (!xfound) ! fatal("Can't execute %s", xfailed ? xfailed : scriptname ); if (xfailed) Safefree(xfailed); ! scriptname = savestr(xfound); } fdpid = anew(Nullstab); /* for remembering popen pids by fd */ pidstatus = hnew(COEFFSIZE);/* for remembering status of dead pids */ ! origfilename = savestr(scriptname); curcmd->c_filestab = fstab(origfilename); if (strEQ(origfilename,"-")) ! scriptname = ""; if (preprocess) { + char *cpp = CPPSTDIN; + + if (strEQ(cpp,"cppstdin")) + sprintf(tokenbuf, "%s/%s", SCRIPTDIR, cpp); + else + sprintf(tokenbuf, "%s", cpp); str_cat(str,"-I"); str_cat(str,PRIVLIB); (void)sprintf(buf, "\ *************** *** 329,336 **** -e '/^#[ ]*ifdef[ ]/b' \ -e '/^#[ ]*ifndef[ ]/b' \ -e '/^#[ ]*else/b' \ -e '/^#[ ]*endif/b' \ ! -e 's/^#.*//' \ %s | %s -C %s %s", #ifdef MSDOS "", --- 352,361 ---- -e '/^#[ ]*ifdef[ ]/b' \ -e '/^#[ ]*ifndef[ ]/b' \ -e '/^#[ ]*else/b' \ + -e '/^#[ ]*elif[ ]/b' \ + -e '/^#[ ]*undef[ ]/b' \ -e '/^#[ ]*endif/b' \ ! -e 's/^[ ]*#.*//' \ %s | %s -C %s %s", #ifdef MSDOS "", *************** *** 338,344 **** "/bin/", #endif (doextract ? "-e '1,/^#/d\n'" : ""), ! argv[0], CPPSTDIN, str_get(str), CPPMINUS); #ifdef DEBUGGING if (debug & 64) { fputs(buf,stderr); --- 363,369 ---- "/bin/", #endif (doextract ? "-e '1,/^#/d\n'" : ""), ! scriptname, tokenbuf, str_get(str), CPPMINUS); #ifdef DEBUGGING if (debug & 64) { fputs(buf,stderr); *************** *** 360,370 **** #endif /* IAMSUID */ rsfp = mypopen(buf,"r"); } ! else if (!*argv[0]) rsfp = stdin; else ! rsfp = fopen(argv[0],"r"); ! if (rsfp == Nullfp) { #ifdef DOSUID #ifndef IAMSUID /* in case script is not readable before setuid */ if (euid && stat(stab_val(curcmd->c_filestab)->str_ptr,&statbuf) >= 0 && --- 385,400 ---- #endif /* IAMSUID */ rsfp = mypopen(buf,"r"); } ! else if (!*scriptname) { ! #ifdef TAINT ! if (euid != uid || egid != gid) ! fatal("Can't take set-id script from stdin"); ! #endif rsfp = stdin; + } else ! rsfp = fopen(scriptname,"r"); ! if ((FILE*)rsfp == Nullfp) { #ifdef DOSUID #ifndef IAMSUID /* in case script is not readable before setuid */ if (euid && stat(stab_val(curcmd->c_filestab)->str_ptr,&statbuf) >= 0 && *************** *** 473,479 **** fatal("No #! line"); s = tokenbuf+2; if (*s == ' ') s++; ! while (!isspace(*s)) s++; if (strnNE(s-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */ fatal("Not a perl script"); while (*s == ' ' || *s == '\t') s++; --- 503,509 ---- fatal("No #! line"); s = tokenbuf+2; if (*s == ' ') s++; ! while (!isSPACE(*s)) s++; if (strnNE(s-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */ fatal("Not a perl script"); while (*s == ' ' || *s == '\t') s++; *************** *** 484,490 **** */ len = strlen(validarg); if (strEQ(validarg," PHOOEY ") || ! strnNE(s,validarg,len) || !isspace(s[len])) fatal("Args must match #! line"); #ifndef IAMSUID --- 514,520 ---- */ len = strlen(validarg); if (strEQ(validarg," PHOOEY ") || ! strnNE(s,validarg,len) || !isSPACE(s[len])) fatal("Args must match #! line"); #ifndef IAMSUID *************** *** 593,598 **** --- 623,629 ---- doextract = FALSE; if (s = instr(s,"perl -")) { s += 6; + /*SUPPRESS 530*/ while (s = moreswitches(s)) ; } if (cddir && chdir(cddir) < 0) *************** *** 872,881 **** /* this routine is in perl.c by virtue of being sort of an alternate main() */ int ! do_eval(str,optype,stash,gimme,arglast) STR *str; int optype; HASH *stash; int gimme; int *arglast; { --- 903,913 ---- /* this routine is in perl.c by virtue of being sort of an alternate main() */ int ! do_eval(str,optype,stash,savecmd,gimme,arglast) STR *str; int optype; HASH *stash; + int savecmd; int gimme; int *arglast; { *************** *** 891,896 **** --- 923,929 ---- SPAT * VOLATILE oldspat = curspat; SPAT * VOLATILE oldlspat = lastspat; static char *last_eval = Nullch; + static long last_elen = 0; static CMD *last_root = Nullcmd; VOLATILE int sp = arglast[0]; char *specfilename; *************** *** 996,1006 **** retval = yyparse(); retval |= error_count; } ! else if (last_root && *bufptr == *last_eval && strEQ(bufptr,last_eval)){ retval = 0; eval_root = last_root; /* no point in reparsing */ } ! else if (in_eval == 1) { if (last_root) { Safefree(last_eval); last_eval = Nullch; --- 1029,1040 ---- retval = yyparse(); retval |= error_count; } ! else if (last_root && last_elen == bufend - bufptr ! && *bufptr == *last_eval && !bcmp(bufptr,last_eval)){ retval = 0; eval_root = last_root; /* no point in reparsing */ } ! else if (in_eval == 1 && !savecmd) { if (last_root) { Safefree(last_eval); last_eval = Nullch; *************** *** 1007,1013 **** cmd_free(last_root); } last_root = Nullcmd; ! last_eval = savestr(bufptr); retval = yyparse(); retval |= error_count; if (!retval) --- 1041,1048 ---- cmd_free(last_root); } last_root = Nullcmd; ! last_elen = bufend - bufptr; ! last_eval = nsavestr(bufptr, last_elen); retval = yyparse(); retval |= error_count; if (!retval) *************** *** 1035,1041 **** #endif cmd_free(eval_root); #endif ! if (eval_root == last_root) last_root = Nullcmd; eval_root = myroot = Nullcmd; } --- 1070,1076 ---- #endif cmd_free(eval_root); #endif ! if ((CMD*)eval_root == last_root) last_root = Nullcmd; eval_root = myroot = Nullcmd; } *************** *** 1051,1057 **** for (i = arglast[0] + 1; i <= sp; i++) st[i] = str_mortal(st[i]); /* if we don't save result, free zaps it */ ! if (in_eval != 1 && myroot != last_root) cmd_free(myroot); } --- 1086,1094 ---- for (i = arglast[0] + 1; i <= sp; i++) st[i] = str_mortal(st[i]); /* if we don't save result, free zaps it */ ! if (savecmd) ! eval_root = myroot; ! else if (in_eval != 1 && myroot != last_root) cmd_free(myroot); } *************** *** 1091,1096 **** --- 1128,1195 ---- return sp; } + int + do_try(cmd,gimme,arglast) + CMD *cmd; + int gimme; + int *arglast; + { + STR **st = stack->ary_array; + + CMD * VOLATILE oldcurcmd = curcmd; + VOLATILE int oldtmps_base = tmps_base; + VOLATILE int oldsave = savestack->ary_fill; + SPAT * VOLATILE oldspat = curspat; + SPAT * VOLATILE oldlspat = lastspat; + VOLATILE int sp = arglast[0]; + + tmps_base = tmps_max; + str_set(stab_val(stabent("@",TRUE)),""); + in_eval++; + if (++loop_ptr >= loop_max) { + loop_max += 128; + Renew(loop_stack, loop_max, struct loop); + } + loop_stack[loop_ptr].loop_label = "_EVAL_"; + loop_stack[loop_ptr].loop_sp = sp; + #ifdef DEBUGGING + if (debug & 4) { + deb("(Pushing label #%d _EVAL_)\n", loop_ptr); + } + #endif + if (setjmp(loop_stack[loop_ptr].loop_env)) { + st = stack->ary_array; + sp = arglast[0]; + if (gimme != G_ARRAY) + st[++sp] = &str_undef; + } + else { + sp = cmd_exec(cmd,gimme,sp); + st = stack->ary_array; + /* for (i = arglast[0] + 1; i <= sp; i++) + st[i] = str_mortal(st[i]); not needed, I think */ + /* if we don't save result, free zaps it */ + } + + in_eval--; + #ifdef DEBUGGING + if (debug & 4) { + char *tmps = loop_stack[loop_ptr].loop_label; + deb("(Popping label #%d %s)\n",loop_ptr, + tmps ? tmps : "" ); + } + #endif + loop_ptr--; + tmps_base = oldtmps_base; + curspat = oldspat; + lastspat = oldlspat; + curcmd = oldcurcmd; + if (savestack->ary_fill > oldsave) /* let them use local() */ + restorelist(oldsave); + + return sp; + } + /* This routine handles any switches that can be given during run */ static char * *************** *** 1099,1105 **** { int numlen; - reswitch: switch (*s) { case '0': nrschar = scanoct(s, 4, &numlen); --- 1198,1203 ---- *************** *** 1141,1151 **** #else warn("Recompile perl with -DDEBUGGING to use -D switch\n"); #endif ! for (s++; isdigit(*s); s++) ; return s; case 'i': inplace = savestr(s+1); ! for (s = inplace; *s && !isspace(*s); s++) ; *s = '\0'; break; case 'I': --- 1239,1251 ---- #else warn("Recompile perl with -DDEBUGGING to use -D switch\n"); #endif ! /*SUPPRESS 530*/ ! for (s++; isDIGIT(*s); s++) ; return s; case 'i': inplace = savestr(s+1); ! /*SUPPRESS 530*/ ! for (s = inplace; *s && !isSPACE(*s); s++) ; *s = '\0'; break; case 'I': *************** *** 1162,1168 **** case 'l': minus_l = TRUE; s++; ! if (isdigit(*s)) { ors = savestr("\n"); orslen = 1; *ors = scanoct(s, 3 + (*s == '0'), &numlen); --- 1262,1268 ---- case 'l': minus_l = TRUE; s++; ! if (isDIGIT(*s)) { ors = savestr("\n"); orslen = 1; *ors = scanoct(s, 3 + (*s == '0'), &numlen); Index: perl.h *** perl.h.old Tue Nov 5 19:27:19 1991 --- perl.h Tue Nov 5 19:27:20 1991 *************** *** 1,4 **** ! /* $RCSfile: perl.h,v $$Revision: 4.0.1.3 $$Date: 91/06/10 01:25:10 $ * * Copyright (c) 1991, Larry Wall * --- 1,4 ---- ! /* $RCSfile: perl.h,v $$Revision: 4.0.1.4 $$Date: 91/11/05 18:06:10 $ * * Copyright (c) 1991, Larry Wall * *************** *** 6,11 **** --- 6,17 ---- * License or the Artistic License, as specified in the README file. * * $Log: perl.h,v $ + * Revision 4.0.1.4 91/11/05 18:06:10 lwall + * patch11: various portability fixes + * patch11: added support for dbz + * patch11: added some support for 64-bit integers + * patch11: hex() didn't understand leading 0x + * * Revision 4.0.1.3 91/06/10 01:25:10 lwall * patch10: certain pattern optimizations were botched * *************** *** 25,30 **** --- 31,53 ---- #define VOIDWANT 1 #include "config.h" + #ifdef MYMALLOC + # ifdef HIDEMYMALLOC + # define malloc Mymalloc + # define realloc Myremalloc + # define free Myfree + # endif + # define safemalloc malloc + # define saferealloc realloc + # define safefree free + #endif + + /* work around some libPW problems */ + #define fatal Myfatal + #ifdef DOINIT + char Error[1]; + #endif + #ifdef MSDOS /* This stuff now in the MS-DOS config.h file. */ #else /* !MSDOS */ *************** *** 197,202 **** --- 220,242 ---- #endif #endif + #ifdef WANT_DBZ + #include + #define SOME_DBM + #define dbm_fetch(db,dkey) fetch(dkey) + #define dbm_delete(db,dkey) fatal("dbz doesn't implement delete") + #define dbm_store(db,dkey,dcontent,flags) store(dkey,dcontent) + #define dbm_close(db) dbmclose() + #define dbm_firstkey(db) (fatal("dbz doesn't implement traversal"),fetch()) + #define nextkey() (fatal("dbz doesn't implement traversal"),fetch()) + #define dbm_nextkey(db) (fatal("dbz doesn't implement traversal"),fetch()) + #ifdef HAS_NDBM + #undef HAS_NDBM + #endif + #ifndef HAS_ODBM + #define HAS_ODBM + #endif + #else #ifdef HAS_GDBM #ifdef I_GDBM #include *************** *** 234,239 **** --- 274,280 ---- #endif /* HAS_ODBM */ #endif /* HAS_NDBM */ #endif /* HAS_GDBM */ + #endif /* WANT_DBZ */ #ifdef SOME_DBM EXT char *dbmkey; EXT int dbmlen; *************** *** 303,308 **** --- 344,353 ---- # endif #endif + #if S_ISBLK(060000) == 060000 + XXX Your sys/stat.h appears to be buggy. Please fix it. + #endif + #ifndef S_ISREG # define S_ISREG(m) ((m & S_IFMT) == S_IFREG) #endif *************** *** 377,382 **** --- 422,447 ---- #undef f_next #endif + #if defined(cray) || defined(gould) + # define SLOPPYDIVIDE + #endif + + #if defined(cray) || defined(convex) || BYTEORDER > 0xffff + # define QUAD + #endif + + #ifdef QUAD + # ifdef cray + # define quad int + # else + # ifdef convex + # define quad long long + # else + # define quad long + # endif + # endif + #endif + typedef unsigned int STRLEN; typedef struct arg ARG; *************** *** 631,637 **** EXT char **origenviron; extern char **environ; ! EXT line_t subline INIT(0); EXT STR *subname INIT(Nullstr); EXT int arybase INIT(0); --- 696,702 ---- EXT char **origenviron; extern char **environ; ! EXT long subline INIT(0); EXT STR *subname INIT(Nullstr); EXT int arybase INIT(0); *************** *** 676,682 **** EXT int lastspbase; EXT int lastsize; ! EXT char *hexdigit INIT("0123456789abcdef0123456789ABCDEF"); EXT char *origfilename; EXT FILE * VOLATILE rsfp; EXT char buf[1024]; --- 741,747 ---- EXT int lastspbase; EXT int lastsize; ! EXT char *hexdigit INIT("0123456789abcdef0123456789ABCDEFx"); EXT char *origfilename; EXT FILE * VOLATILE rsfp; EXT char buf[1024]; *************** *** 753,758 **** --- 818,824 ---- void free_arg(); STIO *stio_new(); void hoistmust(); + void scanconst(); EXT struct stat statbuf; EXT struct stat statcache; Index: perl.man *** perl.man.old Tue Nov 5 19:27:27 1991 --- perl.man Tue Nov 5 19:27:30 1991 *************** *** 1,7 **** .rn '' }` ! ''' $RCSfile: perl.man,v $$Revision: 4.0.1.3 $$Date: 91/06/10 01:26:02 $ ''' ''' $Log: perl.man,v $ ''' Revision 4.0.1.3 91/06/10 01:26:02 lwall ''' patch10: documented some newer features in addenda ''' --- 1,13 ---- .rn '' }` ! ''' $RCSfile: perl.man,v $$Revision: 4.0.1.4 $$Date: 91/11/05 18:11:05 $ ''' ''' $Log: perl.man,v $ + ''' Revision 4.0.1.4 91/11/05 18:11:05 lwall + ''' patch11: added sort {} LIST + ''' patch11: added eval {} + ''' patch11: documented meaning of scalar(%foo) + ''' patch11: sprintf() now supports any length of s field + ''' ''' Revision 4.0.1.3 91/06/10 01:26:02 lwall ''' patch10: documented some newer features in addenda ''' *************** *** 449,456 **** allows .I perl to do unsafe operations. ! Currently the only \*(L"unsafe\*(R" operation is the unlinking of directories while ! running as superuser. .TP 5 .B \-v prints the version and patchlevel of your --- 455,463 ---- allows .I perl to do unsafe operations. ! Currently the only \*(L"unsafe\*(R" operations are the unlinking of directories while ! running as superuser, and running setuid programs with fatal taint checks ! turned into warnings. .TP 5 .B \-v prints the version and patchlevel of your *************** *** 479,485 **** The .B \-x switch only controls the the disposal of leading garbage. ! The script must be terminated with __END__ if there is trailing garbage to be ignored (the script can process any or all of the trailing garbage via the DATA filehandle if desired). .Sh "Data Types and Objects" --- 486,492 ---- The .B \-x switch only controls the the disposal of leading garbage. ! The script must be terminated with _\|_END_\|_ if there is trailing garbage to be ignored (the script can process any or all of the trailing garbage via the DATA filehandle if desired). .Sh "Data Types and Objects" *************** *** 573,581 **** The following is always true: .nf ! @whatever == $#whatever \- $[ + 1; .fi .PP Multi-dimensional arrays are not directly supported, but see the discussion of the $; variable later for a means of emulating multiple subscripts with --- 580,593 ---- The following is always true: .nf ! scalar(@whatever) == $#whatever \- $[ + 1; .fi + If you evaluate an associative array in a scalar context, it returns + a value which is true if and only if the array contains any elements. + (If there are any elements, the value returned is a string consisting + of the number of used buckets and the number of allocated buckets, separated + by a slash.) .PP Multi-dimensional arrays are not directly supported, but see the discussion of the $; variable later for a means of emulating multiple subscripts with *************** *** 666,679 **** word by a space, since single quote is a valid character in an identifier (see Packages). .PP ! Two special literals are __LINE__ and __FILE__, which represent the current line number and filename at that point in your program. They may only be used as separate tokens; they will not be interpolated into strings. ! In addition, the token __END__ may be used to indicate the logical end of the script before the actual end of file. Any following text is ignored (but may be read via the DATA filehandle). ! The two control characters ^D and ^Z are synonyms for __END__. .PP A word that doesn't have any other interpretation in the grammar will be treated as if it had single quotes around it. --- 678,691 ---- word by a space, since single quote is a valid character in an identifier (see Packages). .PP ! Two special literals are _\|_LINE_\|_ and _\|_FILE_\|_, which represent the current line number and filename at that point in your program. They may only be used as separate tokens; they will not be interpolated into strings. ! In addition, the token _\|_END_\|_ may be used to indicate the logical end of the script before the actual end of file. Any following text is ignored (but may be read via the DATA filehandle). ! The two control characters ^D and ^Z are synonyms for _\|_END_\|_. .PP A word that doesn't have any other interpretation in the grammar will be treated as if it had single quotes around it. *************** *** 1844,1850 **** DBNAME is the name of the database (without the .dir or .pag extension). If the database does not exist, it is created with protection specified by MODE (as modified by the umask). ! If your system only supports the older dbm functions, you may only have one dbmopen in your program. If your system has neither dbm nor ndbm, calling dbmopen produces a fatal error. --- 1856,1862 ---- DBNAME is the name of the database (without the .dir or .pag extension). If the database does not exist, it is created with protection specified by MODE (as modified by the umask). ! If your system only supports the older dbm functions, you may perform only one dbmopen in your program. If your system has neither dbm nor ndbm, calling dbmopen produces a fatal error. *************** *** 1896,1902 **** unless defined($value = readlink $sym); eval '@foo = ()' if defined(@foo); die "No XYZ package defined" unless defined %_XYZ; ! sub foo { defined &bar ? &bar(@_) : die "No bar"; } .fi See also undef. --- 1908,1914 ---- unless defined($value = readlink $sym); eval '@foo = ()' if defined(@foo); die "No XYZ package defined" unless defined %_XYZ; ! sub foo { defined &$bar ? &$bar(@_) : die "No bar"; } .fi See also undef. *************** *** 1984,2001 **** If you pass arrays as part of LIST you may wish to pass the length of the array in front of each array. (See the section on subroutines later on.) - SUBROUTINE may be a scalar variable, in which case the variable contains - the name of the subroutine to execute. The parentheses are required to avoid confusion with the \*(L"do EXPR\*(R" form. .Sp ! As an alternate form, you may call a subroutine by prefixing the name with an ampersand: &foo(@args). If you aren't passing any arguments, you don't have to use parentheses. If you omit the parentheses, no @_ array is passed to the subroutine. The & form is also used to specify subroutines to the defined and undef ! operators. ! .Ip "do EXPR" 8 3 Uses the value of EXPR as a filename and executes the contents of the file as a .I perl --- 1996,2020 ---- If you pass arrays as part of LIST you may wish to pass the length of the array in front of each array. (See the section on subroutines later on.) The parentheses are required to avoid confusion with the \*(L"do EXPR\*(R" form. .Sp ! SUBROUTINE may also be a single scalar variable, in which case ! the name of the subroutine to execute is taken from the variable. ! .Sp ! As an alternate (and preferred) form, ! you may call a subroutine by prefixing the name with an ampersand: &foo(@args). If you aren't passing any arguments, you don't have to use parentheses. If you omit the parentheses, no @_ array is passed to the subroutine. The & form is also used to specify subroutines to the defined and undef ! operators: ! .nf ! ! if (defined &$var) { &$var($parm); undef &$var; } ! ! .fi ! :Ip "do EXPR" 8 3 Uses the value of EXPR as a filename and executes the contents of the file as a .I perl *************** *** 2128,2133 **** --- 2147,2153 ---- .fi .Ip "eval(EXPR)" 8 6 .Ip "eval EXPR" 8 6 + .Ip "eval BLOCK" 8 6 EXPR is parsed and executed as if it were a little .I perl program. *************** *** 2149,2154 **** --- 2169,2201 ---- (such as dbmopen or symlink) is implemented. It is also Perl's exception trapping mechanism, where the die operator is used to raise exceptions. + .Sp + If the code to be executed doesn't vary, you may use + the eval-BLOCK form to trap run-time errors without incurring + the penalty of recompiling each time. + The error, if any, is still returned in $@. + Evaluating a single-quoted string (as EXPR) has the same effect, except that + the eval-EXPR form reports syntax errors at run time via $@, whereas the + eval-BLOCK form reports syntax errors at compile time. The eval-EXPR form + is optimized to eval-BLOCK the first time it succeeds. (Since the replacement + side of a substitution is considered a single-quoted string when you + use the e modifier, the same optimization occurs there.) Examples: + .nf + + .ne 11 + # make divide-by-zero non-fatal + eval { $answer = $a / $b; }; warn $@ if $@; + + # optimized to same thing after first use + eval '$answer = $a / $b'; warn $@ if $@; + + # a compile-time error + eval { $answer = }; + + # a run-time error + eval '$answer ='; # sets $@ + + .fi .Ip "exec(LIST)" 8 8 .Ip "exec LIST" 8 6 If there is more than one argument in LIST, or if LIST is an array with *************** *** 3558,3565 **** .Ip "sleep EXPR" 8 .Ip "sleep" 8 Causes the script to sleep for EXPR seconds, or forever if no EXPR. ! May be interrupted by sending the process a SIGALARM. Returns the number of seconds actually slept. .Ip "socket(SOCKET,DOMAIN,TYPE,PROTOCOL)" 8 3 Opens a socket of the specified kind and attaches it to filehandle SOCKET. DOMAIN, TYPE and PROTOCOL are specified the same as for the system call --- 3605,3614 ---- .Ip "sleep EXPR" 8 .Ip "sleep" 8 Causes the script to sleep for EXPR seconds, or forever if no EXPR. ! May be interrupted by sending the process a SIGALRM. Returns the number of seconds actually slept. + You probably cannot mix alarm() and sleep() calls, since sleep() is + often implemented using alarm(). .Ip "socket(SOCKET,DOMAIN,TYPE,PROTOCOL)" 8 3 Opens a socket of the specified kind and attaches it to filehandle SOCKET. DOMAIN, TYPE and PROTOCOL are specified the same as for the system call *************** *** 3578,3602 **** .Ip "sort(SUBROUTINE LIST)" 8 9 .Ip "sort(LIST)" 8 .Ip "sort SUBROUTINE LIST" 8 .Ip "sort LIST" 8 Sorts the LIST and returns the sorted array value. Nonexistent values of arrays are stripped out. ! If SUBROUTINE is omitted, sorts in standard string comparison order. If SUBROUTINE is specified, gives the name of a subroutine that returns an integer less than, equal to, or greater than 0, depending on how the elements of the array are to be ordered. (The <=> and cmp operators are extremely useful in such routines.) In the interests of efficiency the normal calling code for subroutines is bypassed, with the following effects: the subroutine may not be a recursive subroutine, and the two elements to be compared are passed into the subroutine not via @_ but as $a and $b (see example below). They are passed by reference so don't modify $a and $b. ! SUBROUTINE may be a scalar variable name, in which case the value provides ! the name of the subroutine to use. Examples: .nf ! .ne 4 sub byage { $age{$a} <=> $age{$b}; # presuming integers } --- 3627,3677 ---- .Ip "sort(SUBROUTINE LIST)" 8 9 .Ip "sort(LIST)" 8 .Ip "sort SUBROUTINE LIST" 8 + .Ip "sort BLOCK LIST" 8 .Ip "sort LIST" 8 Sorts the LIST and returns the sorted array value. Nonexistent values of arrays are stripped out. ! If SUBROUTINE or BLOCK is omitted, sorts in standard string comparison order. If SUBROUTINE is specified, gives the name of a subroutine that returns an integer less than, equal to, or greater than 0, depending on how the elements of the array are to be ordered. (The <=> and cmp operators are extremely useful in such routines.) + SUBROUTINE may be a scalar variable name, in which case the value provides + the name of the subroutine to use. + In place of a SUBROUTINE name, you can provide a BLOCK as an anonymous, + in-line sort subroutine. + .Sp In the interests of efficiency the normal calling code for subroutines is bypassed, with the following effects: the subroutine may not be a recursive subroutine, and the two elements to be compared are passed into the subroutine not via @_ but as $a and $b (see example below). They are passed by reference so don't modify $a and $b. ! .Sp Examples: .nf ! .ne 2 ! # sort lexically ! @articles = sort @files; ! ! .ne 2 ! # same thing, but with explicit sort routine ! @articles = sort {$a cmp $b;} @files; ! ! .ne 2 ! # same thing in reversed order ! @articles = sort {$b cmp $a;} @files; ! ! .ne 2 ! # sort numerically ascending ! @articles = sort {$a <=> $b;} @files; ! ! .ne 2 ! # sort numerically descending ! @articles = sort {$b <=> $a;} @files; ! ! .ne 5 ! # sort using explicit subroutine name sub byage { $age{$a} <=> $age{$b}; # presuming integers } *************** *** 4175,4183 **** record, the page is advanced by writing a form feed, a special top-of-page format is used to format the new page header, and then the record is written. ! By default the top-of-page format is \*(L"top\*(R", but it ! may be set to the ! format of your choice by assigning the name to the $^ variable. The number of lines remaining on the current page is in variable $-, which can be set to 0 to force a new page. .Sp --- 4250,4259 ---- record, the page is advanced by writing a form feed, a special top-of-page format is used to format the new page header, and then the record is written. ! By default the top-of-page format is the name of the filehandle with ! \*(L"_TOP\*(R" appended, but it may be dynamicallly set to the ! format of your choice by assigning the name to the $^ variable while ! the filehandle is selected. The number of lines remaining on the current page is in variable $-, which can be set to 0 to force a new page. .Sp *************** *** 5574,5580 **** .fi .SH AUTHOR ! Larry Wall .br MS-DOS port by Diomidis Spinellis .SH FILES --- 5650,5656 ---- .fi .SH AUTHOR ! Larry Wall .br MS-DOS port by Diomidis Spinellis .SH FILES *************** *** 5775,5780 **** --- 5851,5859 ---- .fi .PP + The descriptions of alarm and sleep refer to signal SIGALARM. These + should refer to SIGALRM. + .PP The .B \-0 switch to set the initial value of $/ was added to Perl after the book *************** *** 5810,5815 **** --- 5889,5899 ---- to iterate through a string finding multiple matches. .PP All of the $^X variables are new except for $^T. + .PP + The default top-of-form format for FILEHANDLE is now FILEHANDLE_TOP rather + than top. + .PP + The eval {} and sort {} constructs were added in version 4.011. .SH BUGS .PP .I Perl *************** *** 5823,5831 **** .PP While none of the built-in data types have any arbitrary size limits (apart from memory size), there are still a few arbitrary limits: ! a given identifier may not be longer than 255 characters; ! sprintf is limited on many machines to 128 characters per field (unless the format ! specifier is exactly %s); and no component of your PATH may be longer than 255 if you use \-S. .PP .I Perl --- 5907,5913 ---- .PP While none of the built-in data types have any arbitrary size limits (apart from memory size), there are still a few arbitrary limits: ! a given identifier may not be longer than 255 characters, and no component of your PATH may be longer than 255 if you use \-S. .PP .I Perl *** End of Patch 15 *** exit 0 # Just in case... -- Kent Landfield INTERNET: kent@sparky.IMD.Sterling.COM Sterling Software, IMD UUCP: uunet!sparky!kent Phone: (402) 291-8300 FAX: (402) 291-4362 Please send comp.sources.misc-related mail to kent@uunet.uu.net.