perl 4.0 patch 15: patch #11, continued

See patch #11.

13 files changed, 465 insertions, 89 deletions

diff --git a/hash.c b/hash.c
index 52547ddcd7..72c17f17c2 100644
--- a/hash.c
+++ b/hash.c
@@ -1,4 +1,4 @@
-/* $RCSfile: hash.c,v $$Revision: 4.0.1.1 $$Date: 91/06/07 11:10:11 $
+/* $RCSfile: hash.c,v $$Revision: 4.0.1.2 $$Date: 91/11/05 17:24:13 $
  *
  *    Copyright (c) 1991, Larry Wall
  *
@@ -6,6 +6,9 @@
  *    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,7 +73,7 @@ int lval;
 	else
 	    maxi = tb->tbl_coeffsize;
 	for (s=key,		i=0,	hash = 0;
-			    i < maxi;
+			    i < maxi;			/*SUPPRESS 8*/
 	     s++,		i++,	hash *= 5) {
 	    hash += *s * coeff[i];
 	}
@@ -129,6 +132,7 @@ register int hash;
 	return FALSE;
 
     if (hash)
+	/*SUPPRESS 530*/
 	;
     else if (!tb->tbl_coeffsize)
 	hash = *key + 128 * key[1] + 128 * key[klen-1];
@@ -138,7 +142,7 @@ register int hash;
 	else
 	    maxi = tb->tbl_coeffsize;
 	for (s=key,		i=0,	hash = 0;
-			    i < maxi;
+			    i < maxi;			/*SUPPRESS 8*/
 	     s++,		i++,	hash *= 5) {
 	    hash += *s * coeff[i];
 	}
@@ -226,7 +230,7 @@ unsigned int klen;
 	else
 	    maxi = tb->tbl_coeffsize;
 	for (s=key,		i=0,	hash = 0;
-			    i < maxi;
+			    i < maxi;			/*SUPPRESS 8*/
 	     s++,		i++,	hash *= 5) {
 	    hash += *s * coeff[i];
 	}
@@ -425,6 +429,7 @@ int dodbm;
     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;
diff --git a/hash.h b/hash.h
index 837cc96e0e..3ebd6a633b 100644
--- a/hash.h
+++ b/hash.h
@@ -1,4 +1,4 @@
-/* $RCSfile: hash.h,v $$Revision: 4.0.1.1 $$Date: 91/06/07 11:10:33 $
+/* $RCSfile: hash.h,v $$Revision: 4.0.1.2 $$Date: 91/11/05 17:24:31 $
  *
  *    Copyright (c) 1991, Larry Wall
  *
@@ -6,6 +6,9 @@
  *    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,6 +62,7 @@ STR *hdelete();
 HASH *hnew();
 void hclear();
 void hentfree();
+void hfree();
 int hiterinit();
 HENT *hiternext();
 char *hiterkey();
diff --git a/hints/hp9000_800.sh b/hints/hp9000_800.sh
new file mode 100644
index 0000000000..c2c41d3a74
--- /dev/null
+++ b/hints/hp9000_800.sh
@@ -0,0 +1 @@
+libswanted=`echo $libswanted | sed 's/malloc //'`
diff --git a/hints/mpc.sh b/hints/mpc.sh
new file mode 100644
index 0000000000..da6fcc95b0
--- /dev/null
+++ b/hints/mpc.sh
@@ -0,0 +1 @@
+ccflags="$ccflags -X18"
diff --git a/hints/opus.sh b/hints/opus.sh
new file mode 100644
index 0000000000..da6fcc95b0
--- /dev/null
+++ b/hints/opus.sh
@@ -0,0 +1 @@
+ccflags="$ccflags -X18"
diff --git a/installperl b/installperl
index 633ff266a1..e05e75ce59 100644
--- a/installperl
+++ b/installperl
@@ -6,7 +6,9 @@ while (@ARGV) {
     shift;
 }
 
-@scripts = ('h2ph', 'x2p/s2p', 'x2p/find2perl');
+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,7 +87,7 @@ if ($bdev != $ddev || $bino != $dino) {
 ($udev,$uino) = stat("/usr/bin");
 
 if (-w _ && ($udev != $ddev || $uino != $dino) && !$nonono) {
-    unlink "/usr/bin/perl";
+    &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,16 +102,6 @@ for (@scripts) {
     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 '') {
@@ -134,6 +126,28 @@ if ($mansrc ne '') {
     }
 }
 
+# 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";
 
 exit 0;
diff --git a/lib/newgetopt.pl b/lib/newgetopt.pl
index 441213a538..8782428961 100644
--- a/lib/newgetopt.pl
+++ b/lib/newgetopt.pl
@@ -1,11 +1,11 @@
 # newgetopt.pl -- new options parsing
 
-# SCCS Status     : @(#)@ newgetopt.pl	1.7
+# SCCS Status     : @(#)@ newgetopt.pl	1.8
 # Author          : Johan Vromans
 # Created On      : Tue Sep 11 15:00:12 1990
 # Last Modified By: Johan Vromans
-# Last Modified On: Sun Oct 14 14:35:36 1990
-# Update Count    : 34
+# Last Modified On: Thu Sep 26 20:10:41 1991
+# Update Count    : 35
 # Status          : Okay
 
 # This package implements a new getopt function. This function adheres
@@ -139,6 +139,9 @@ sub main'NGetOpt {
 		print STDERR ("Option ", $opt, " requires an argument\n");
 		$error++;
 	    }
+	    if ( $mand eq ":" ) {
+		$arg = $type eq "s" ? "" : 0;
+	    }
 	    next;
 	}
 
diff --git a/malloc.c b/malloc.c
index 72a265ed6e..2a8b5516a1 100644
--- a/malloc.c
+++ b/malloc.c
@@ -1,6 +1,9 @@
-/* $RCSfile: malloc.c,v $$Revision: 4.0.1.2 $$Date: 91/06/07 11:20:45 $
+/* $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,6 +16,7 @@
  */
 
 #ifndef lint
+/*SUPPRESS 592*/
 static char sccsid[] = "@(#)malloc.c	4.3 (Berkeley) 9/16/83";
 
 #ifdef DEBUGGING
@@ -110,6 +114,10 @@ botch(s)
 #define	ASSERT(p)
 #endif
 
+#ifdef safemalloc
+static int an = 0;
+#endif
+
 MALLOCPTRTYPE *
 malloc(nbytes)
 	register unsigned nbytes;
@@ -118,6 +126,23 @@ malloc(nbytes)
   	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,8 +161,27 @@ malloc(nbytes)
 	 */
   	if (nextf[bucket] == NULL)    
   		morecore(bucket);
-  	if ((p = (union overhead *)nextf[bucket]) == NULL)
+  	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,6 +284,18 @@ free(mp)
 	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,6 +348,25 @@ realloc(mp, nbytes)
 	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,14 +411,32 @@ realloc(mp, nbytes)
 			*((u_int *)((caddr_t)op + nbytes - RSLOP)) = RMAGIC;
 		}
 #endif
-		return((MALLOCPTRTYPE*)cp);
+		res = 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);
+	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);
 }
 
diff --git a/patchlevel.h b/patchlevel.h
index f95be0eb07..69d9c2fd72 100644
--- a/patchlevel.h
+++ b/patchlevel.h
@@ -1 +1 @@
-#define PATCHLEVEL 14
+#define PATCHLEVEL 15
diff --git a/perl.c b/perl.c
index 664c8988d0..67b88ebb53 100644
--- a/perl.c
+++ b/perl.c
@@ -1,4 +1,4 @@
-char rcsid[] = "$RCSfile: perl.c,v $$Revision: 4.0.1.4 $$Date: 91/06/10 01:23:07 $\nPatch level: ###\n";
+char rcsid[] = "$RCSfile: perl.c,v $$Revision: 4.0.1.5 $$Date: 91/11/05 18:03:32 $\nPatch level: ###\n";
 /*
  *    Copyright (c) 1991, Larry Wall
  *
@@ -6,6 +6,15 @@ char rcsid[] = "$RCSfile: perl.c,v $$Revision: 4.0.1.4 $$Date: 91/06/10 01:23:07
  *    License or the Artistic License, as specified in the README file.
  *
  * $Log:	perl.c,v $
+ * Revision 4.0.1.5  91/11/05  18:03:32  lwall
+ * patch11: random cleanup
+ * patch11: $0 was being truncated at times
+ * patch11: cppstdin now installed outside of source directory
+ * patch11: -P didn't allow use of #elif or #undef
+ * patch11: prepared for ctype implementations that don't define isascii()
+ * patch11: added eval {}
+ * patch11: eval confused by string containing null
+ * 
  * Revision 4.0.1.4  91/06/10  01:23:07  lwall
  * patch10: perl -v printed incorrect copyright notice
  * 
@@ -26,6 +35,8 @@ char rcsid[] = "$RCSfile: perl.c,v $$Revision: 4.0.1.4 $$Date: 91/06/10 01:23:07
  * 
  */
 
+/*SUPPRESS 560*/
+
 #include "EXTERN.h"
 #include "perl.h"
 #include "perly.h"
@@ -64,6 +75,7 @@ register char **env;
 {
     register STR *str;
     register char *s;
+    char *scriptname;
     char *getenv();
     bool dosearch = FALSE;
 #ifdef DOSUID
@@ -193,6 +205,10 @@ setuid perl scripts securely.\n");
 	    s++;
 	    goto reswitch;
 	case 'S':
+#ifdef TAINT
+	    if (euid != uid || egid != gid)
+		fatal("No -S allowed in setuid scripts");
+#endif
 	    dosearch = TRUE;
 	    s++;
 	    goto reswitch;
@@ -212,10 +228,11 @@ setuid perl scripts securely.\n");
 	}
     }
   switch_end:
+    scriptname = argv[0];
     if (e_fp) {
 	(void)fclose(e_fp);
 	argc++,argv--;
-	argv[0] = e_tmpname;
+	scriptname = e_tmpname;
     }
 
 #ifdef MSDOS
@@ -259,17 +276,17 @@ setuid perl scripts securely.\n");
 
     /* open script */
 
-    if (argv[0] == Nullch)
+    if (scriptname == Nullch)
 #ifdef MSDOS
     {
 	if ( isatty(fileno(stdin)) )
 	  moreswitches("v");
-	argv[0] = "-";
+	scriptname = "-";
     }
 #else
-	argv[0] = "-";
+	scriptname = "-";
 #endif
-    if (dosearch && !index(argv[0], '/') && (s = getenv("PATH"))) {
+    if (dosearch && !index(scriptname, '/') && (s = getenv("PATH"))) {
 	char *xfound = Nullch, *xfailed = Nullch;
 	int len;
 
@@ -289,7 +306,7 @@ setuid perl scripts securely.\n");
 	    if (len && tokenbuf[len-1] != '\\')
 #endif
 		(void)strcat(tokenbuf+len,"/");
-	    (void)strcat(tokenbuf+len,argv[0]);
+	    (void)strcat(tokenbuf+len,scriptname);
 #ifdef DEBUGGING
 	    if (debug & 1)
 		fprintf(stderr,"Looking for %s\n",tokenbuf);
@@ -305,20 +322,26 @@ setuid perl scripts securely.\n");
 		xfailed = savestr(tokenbuf);
 	}
 	if (!xfound)
-	    fatal("Can't execute %s", xfailed ? xfailed : argv[0] );
+	    fatal("Can't execute %s", xfailed ? xfailed : scriptname );
 	if (xfailed)
 	    Safefree(xfailed);
-	argv[0] = savestr(xfound);
+	scriptname = savestr(xfound);
     }
 
     fdpid = anew(Nullstab);	/* for remembering popen pids by fd */
     pidstatus = hnew(COEFFSIZE);/* for remembering status of dead pids */
 
-    origfilename = savestr(argv[0]);
+    origfilename = savestr(scriptname);
     curcmd->c_filestab = fstab(origfilename);
     if (strEQ(origfilename,"-"))
-	argv[0] = "";
+	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,8 +352,10 @@ setuid perl scripts securely.\n");
  -e '/^#[ 	]*ifdef[ 	]/b' \
  -e '/^#[ 	]*ifndef[ 	]/b' \
  -e '/^#[ 	]*else/b' \
+ -e '/^#[ 	]*elif[ 	]/b' \
+ -e '/^#[ 	]*undef[ 	]/b' \
  -e '/^#[ 	]*endif/b' \
- -e 's/^#.*//' \
+ -e 's/^[ 	]*#.*//' \
  %s | %s -C %s %s",
 #ifdef MSDOS
 	  "",
@@ -338,7 +363,7 @@ setuid perl scripts securely.\n");
 	  "/bin/",
 #endif
 	  (doextract ? "-e '1,/^#/d\n'" : ""),
-	  argv[0], CPPSTDIN, str_get(str), CPPMINUS);
+	  scriptname, tokenbuf, str_get(str), CPPMINUS);
 #ifdef DEBUGGING
 	if (debug & 64) {
 	    fputs(buf,stderr);
@@ -360,11 +385,16 @@ setuid perl scripts securely.\n");
 #endif /* IAMSUID */
 	rsfp = mypopen(buf,"r");
     }
-    else if (!*argv[0])
+    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(argv[0],"r");
-    if (rsfp == Nullfp) {
+	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,7 +503,7 @@ setuid perl scripts securely.\n");
 	    fatal("No #! line");
 	s = tokenbuf+2;
 	if (*s == ' ') s++;
-	while (!isspace(*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,7 +514,7 @@ setuid perl scripts securely.\n");
 	 */
 	len = strlen(validarg);
 	if (strEQ(validarg," PHOOEY ") ||
-	    strnNE(s,validarg,len) || !isspace(s[len]))
+	    strnNE(s,validarg,len) || !isSPACE(s[len]))
 	    fatal("Args must match #! line");
 
 #ifndef IAMSUID
@@ -593,6 +623,7 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
 	    doextract = FALSE;
 	    if (s = instr(s,"perl -")) {
 		s += 6;
+		/*SUPPRESS 530*/
 		while (s = moreswitches(s)) ;
 	    }
 	    if (cddir && chdir(cddir) < 0)
@@ -872,10 +903,11 @@ STR *str;
 /* this routine is in perl.c by virtue of being sort of an alternate main() */
 
 int
-do_eval(str,optype,stash,gimme,arglast)
+do_eval(str,optype,stash,savecmd,gimme,arglast)
 STR *str;
 int optype;
 HASH *stash;
+int savecmd;
 int gimme;
 int *arglast;
 {
@@ -891,6 +923,7 @@ int *arglast;
     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,18 +1029,20 @@ int *arglast;
 	    retval = yyparse();
 	    retval |= error_count;
 	}
-	else if (last_root && *bufptr == *last_eval && strEQ(bufptr,last_eval)){
+	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) {
+	else if (in_eval == 1 && !savecmd) {
 	    if (last_root) {
 		Safefree(last_eval);
 		last_eval = Nullch;
 		cmd_free(last_root);
 	    }
 	    last_root = Nullcmd;
-	    last_eval = savestr(bufptr);
+	    last_elen = bufend - bufptr;
+	    last_eval = nsavestr(bufptr, last_elen);
 	    retval = yyparse();
 	    retval |= error_count;
 	    if (!retval)
@@ -1035,7 +1070,7 @@ int *arglast;
 #endif
 	    cmd_free(eval_root);
 #endif
-	    if (eval_root == last_root)
+	    if ((CMD*)eval_root == last_root)
 		last_root = Nullcmd;
 	    eval_root = myroot = Nullcmd;
 	}
@@ -1051,7 +1086,9 @@ int *arglast;
 	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)
+	if (savecmd)
+	    eval_root = myroot;
+	else if (in_eval != 1 && myroot != last_root)
 	    cmd_free(myroot);
     }
 
@@ -1091,6 +1128,68 @@ int *arglast;
     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,7 +1198,6 @@ char *s;
 {
     int numlen;
 
-  reswitch:
     switch (*s) {
     case '0':
 	nrschar = scanoct(s, 4, &numlen);
@@ -1141,11 +1239,13 @@ char *s;
 #else
 	warn("Recompile perl with -DDEBUGGING to use -D switch\n");
 #endif
-	for (s++; isdigit(*s); s++) ;
+	/*SUPPRESS 530*/
+	for (s++; isDIGIT(*s); s++) ;
 	return s;
     case 'i':
 	inplace = savestr(s+1);
-	for (s = inplace; *s && !isspace(*s); s++) ;
+	/*SUPPRESS 530*/
+	for (s = inplace; *s && !isSPACE(*s); s++) ;
 	*s = '\0';
 	break;
     case 'I':
@@ -1162,7 +1262,7 @@ char *s;
     case 'l':
 	minus_l = TRUE;
 	s++;
-	if (isdigit(*s)) {
+	if (isDIGIT(*s)) {
 	    ors = savestr("\n");
 	    orslen = 1;
 	    *ors = scanoct(s, 3 + (*s == '0'), &numlen);
diff --git a/perl.h b/perl.h
index 4ab86d9e8d..09edd0727c 100644
--- a/perl.h
+++ b/perl.h
@@ -1,4 +1,4 @@
-/* $RCSfile: perl.h,v $$Revision: 4.0.1.3 $$Date: 91/06/10 01:25:10 $
+/* $RCSfile: perl.h,v $$Revision: 4.0.1.4 $$Date: 91/11/05 18:06:10 $
  *
  *    Copyright (c) 1991, Larry Wall
  *
@@ -6,6 +6,12 @@
  *    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,6 +31,23 @@
 #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,6 +220,23 @@ extern char *sys_errlist[];
 #endif
 #endif
 
+#ifdef WANT_DBZ
+#include <dbz.h>
+#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 <gdbm.h>
@@ -234,6 +274,7 @@ extern char *sys_errlist[];
 #endif /* HAS_ODBM */
 #endif /* HAS_NDBM */
 #endif /* HAS_GDBM */
+#endif /* WANT_DBZ */
 #ifdef SOME_DBM
 EXT char *dbmkey;
 EXT int dbmlen;
@@ -303,6 +344,10 @@ EXT int dbmlen;
 #   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,6 +422,26 @@ EXT int dbmlen;
 #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,7 +696,7 @@ EXT int origargc;
 EXT char **origenviron;
 extern char **environ;
 
-EXT line_t subline INIT(0);
+EXT long subline INIT(0);
 EXT STR *subname INIT(Nullstr);
 EXT int arybase INIT(0);
 
@@ -676,7 +741,7 @@ EXT STR *DBsignal INIT(Nullstr);
 EXT int lastspbase;
 EXT int lastsize;
 
-EXT char *hexdigit INIT("0123456789abcdef0123456789ABCDEF");
+EXT char *hexdigit INIT("0123456789abcdef0123456789ABCDEFx");
 EXT char *origfilename;
 EXT FILE * VOLATILE rsfp;
 EXT char buf[1024];
@@ -753,6 +818,7 @@ STR *interp();
 void free_arg();
 STIO *stio_new();
 void hoistmust();
+void scanconst();
 
 EXT struct stat statbuf;
 EXT struct stat statcache;
diff --git a/perl.man b/perl.man
index f059208c1d..d3d6d5bedd 100644
--- a/perl.man
+++ b/perl.man
@@ -1,7 +1,13 @@
 .rn '' }`
-''' $RCSfile: perl.man,v $$Revision: 4.0.1.3 $$Date: 91/06/10 01:26:02 $
+''' $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,8 +455,9 @@ for a specific port of perl.
 allows
 .I perl
 to do unsafe operations.
-Currently the only \*(L"unsafe\*(R" operation is the unlinking of directories while
-running as superuser.
+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,7 +486,7 @@ before running the script.
 The
 .B \-x
 switch only controls the the disposal of leading garbage.
-The script must be terminated with __END__ if there is trailing 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,9 +580,14 @@ the array.
 The following is always true:
 .nf
 
-	@whatever == $#whatever \- $[ + 1;
+	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,14 +678,14 @@ Also note that a single quoted string must be separated from a preceding
 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
+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
+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__.
+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,7 +1856,7 @@ it looks like one).
 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
+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,7 +1908,7 @@ Examples:
 		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"; }
+	sub foo { defined &$bar ? &$bar(@_) : die "No bar"; }
 
 .fi
 See also undef.
@@ -1984,18 +1996,25 @@ exists.)
 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
+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.
-.Ip "do EXPR" 8 3
+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,6 +2147,7 @@ Examples:
 .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,6 +2169,33 @@ determining whether a particular feature
 (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,8 +3605,10 @@ If EXPR is omitted, returns sine of $_.
 .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.
+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,25 +3627,51 @@ Return true if successful.
 .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 is omitted, sorts in standard string comparison order.
+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.
-SUBROUTINE may be a scalar variable name, in which case the value provides
-the name of the subroutine to use.
+.Sp
 Examples:
 .nf
 
-.ne 4
+.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,9 +4250,10 @@ if there is insufficient room on the current page for the formatted
 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.
+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,7 +5650,7 @@ before doing anything else, just to keep people honest:
 
 .fi
 .SH AUTHOR
-Larry Wall <lwall@jpl-devvax.Jpl.Nasa.Gov>
+Larry Wall <lwall@netlabs.com>
 .br
 MS-DOS port by Diomidis Spinellis <dds@cc.ic.ac.uk>
 .SH FILES
@@ -5775,6 +5851,9 @@ very small files.  To do larger files, use
 
 .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,6 +5889,11 @@ There is now a g modifier on ordinary pattern matching that causes it
 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,9 +5907,7 @@ stream, so does
 .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);
+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
diff --git a/usub/mus b/usub/mus
index 3f772bd864..b1675fdc58 100644
--- a/usub/mus
+++ b/usub/mus
@@ -64,11 +64,12 @@ EOF
 	    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");
 		}
-		push(@callnames, "&$name");
 	    }
 	    else {
 		push(@callnames, $name);
@@ -78,6 +79,11 @@ EOF
 	    $type	$name =$x	$cast	str_$what(st[$i]);
 EOF
 	    }
+            elsif ($type =~ /char/) {
+            print <<EOF;
+	    char	${name}[133];
+EOF
+	    }
 	    else {
 		print <<EOF;
 	    $type	$name;