perl 4.0 patch 8: patch #4, continued

See patch #4.

20 files changed, 496 insertions, 195 deletions

diff --git a/hints/sco_2_3_0.sh b/hints/sco_2_3_0.sh
index bf593b0f3e..146363ab3d 100644
--- a/hints/sco_2_3_0.sh
+++ b/hints/sco_2_3_0.sh
@@ -1,2 +1,2 @@
-yacc='/usr/bin/yacc -m25000'
+yacc='/usr/bin/yacc -Sm25000'
 i_dirent=undef
diff --git a/hints/sco_2_3_1.sh b/hints/sco_2_3_1.sh
index bf593b0f3e..146363ab3d 100644
--- a/hints/sco_2_3_1.sh
+++ b/hints/sco_2_3_1.sh
@@ -1,2 +1,2 @@
-yacc='/usr/bin/yacc -m25000'
+yacc='/usr/bin/yacc -Sm25000'
 i_dirent=undef
diff --git a/hints/sco_2_3_2.sh b/hints/sco_2_3_2.sh
index acd8e34a05..54540e4aa0 100644
--- a/hints/sco_2_3_2.sh
+++ b/hints/sco_2_3_2.sh
@@ -1,2 +1,2 @@
-yacc='/usr/bin/yacc -m25000'
+yacc='/usr/bin/yacc -Sm25000'
 libswanted=`echo $libswanted | sed 's/ x / /'`
diff --git a/hints/sco_2_3_3.sh b/hints/sco_2_3_3.sh
index acd8e34a05..d1db39f8af 100644
--- a/hints/sco_2_3_3.sh
+++ b/hints/sco_2_3_3.sh
@@ -1,2 +1,4 @@
-yacc='/usr/bin/yacc -m25000'
+yacc='/usr/bin/yacc -Sm25000'
 libswanted=`echo $libswanted | sed 's/ x / /'`
+echo "NOTE: you may have problems due to a spurious semicolon on the strerror()"
+echo "macro definition in /usr/include/string.h.  If so, delete the semicolon."
diff --git a/hints/sco_3.sh b/hints/sco_3.sh
index 015de91dd2..a151fe0eed 100644
--- a/hints/sco_3.sh
+++ b/hints/sco_3.sh
@@ -1,3 +1,4 @@
 yacc='/usr/bin/yacc -Sm11000'
 libswanted=`echo $libswanted | sed 's/ x / /'`
 i_varargs=undef
+ccflags="$ccflags -U M_XENIX"
diff --git a/hints/sgi.sh b/hints/sgi.sh
index da5ff639d3..b7db156461 100644
--- a/hints/sgi.sh
+++ b/hints/sgi.sh
@@ -1,7 +1,6 @@
-optimize='-O0'
+optimize='-O1'
 usemymalloc='y'
 mallocsrc='malloc.c'
 mallocobj='malloc.o'
-ccflags="$ccflags -Uf_next"
 d_voidsig=define
 d_vfork=undef
diff --git a/lib/perldb.pl b/lib/perldb.pl
index d7f05bfc82..8d1605426c 100644
--- a/lib/perldb.pl
+++ b/lib/perldb.pl
@@ -1,6 +1,6 @@
 package DB;
 
-$header = '$Header: perldb.pl,v 4.0 91/03/20 01:25:50 lwall Locked $';
+$header = '$RCSfile: perldb.pl,v $$Revision: 4.0.1.1 $$Date: 91/06/07 11:17:44 $';
 #
 # This file is automatically included if you do perl -d.
 # It's probably not useful to include this yourself.
@@ -10,6 +10,10 @@ $header = '$Header: perldb.pl,v 4.0 91/03/20 01:25:50 lwall Locked $';
 # have a breakpoint.  It also inserts a do 'perldb.pl' before the first line.
 #
 # $Log:	perldb.pl,v $
+# Revision 4.0.1.1  91/06/07  11:17:44  lwall
+# patch4: added $^P variable to control calling of perldb routines
+# patch4: debugger sometimes listed wrong number of lines for a statement
+# 
 # Revision 4.0  91/03/20  01:25:50  lwall
 # 4.0 baseline.
 # 
@@ -61,6 +65,7 @@ sub DB {
     ($package, $filename, $line) = caller;
     $usercontext = '($@, $!, $[, $,, $/, $\) = @saved;' .
 	"package $package;";		# this won't let them modify, alas
+    local($^P) = 0;			# don't debug our own evals
     local(*dbline) = "_<$filename";
     $max = $#dbline;
     if (($stop,$action) = split(/\0/,$dbline{$line})) {
@@ -76,7 +81,7 @@ sub DB {
 	print OUT "$package'" unless $sub =~ /'/;
 	print OUT "$sub($filename:$line):\t",$dbline[$line];
 	for ($i = $line + 1; $i <= $max && $dbline[$i] == 0; ++$i) {
-	    last if $dbline[$i] =~ /^\s*(}|#|\n)/;
+	    last if $dbline[$i] =~ /^\s*(;|}|#|\n)/;
 	    print OUT "$sub($filename:$i):\t",$dbline[$i];
 	}
     }
diff --git a/lib/shellwords.pl b/lib/shellwords.pl
new file mode 100644
index 0000000000..168991fa3f
--- /dev/null
+++ b/lib/shellwords.pl
@@ -0,0 +1,42 @@
+#; shellwords.pl
+#;
+#; Usage:
+#;	require 'shellwords.pl';
+#;	@words = &shellwords($line);
+#;	or
+#;	@words = &shellwords(@lines);
+#;	or
+#;	@words = &shellwords;		# defaults to $_ (and clobbers it)
+
+sub shellwords {
+    package shellwords;
+    local($_) = join('', @_) if @_;
+    local(@words,$snippet,$field);
+
+    s/^\s+//;
+    while ($_ ne '') {
+	$field = '';
+	for (;;) {
+	    if (s/^"(([^"\\]+|\\[\\"])*)"//) {
+		($snippet = $1) =~ s#\\(.)#$1#g;
+	    }
+	    elsif (s/^'(([^'\\]+|\\[\\'])*)'//) {
+		($snippet = $1) =~ s#\\(.)#$1#g;
+	    }
+	    elsif (s/^\\(.)//) {
+		$snippet = $1;
+	    }
+	    elsif (s/^([^\s\\'"]+)//) {
+		$snippet = $1;
+	    }
+	    else {
+		s/^\s+//;
+		last;
+	    }
+	    $field .= $snippet;
+	}
+	push(@words, $field);
+    }
+    @words;
+}
+1;
diff --git a/msdos/popen.c b/msdos/popen.c
index 96e68558cc..c55c1364d9 100644
--- a/msdos/popen.c
+++ b/msdos/popen.c
@@ -1,11 +1,14 @@
-/* $Header: popen.c,v 4.0 91/03/20 01:34:50 lwall Locked $
+/* $RCSfile: popen.c,v $$Revision: 4.0.1.1 $$Date: 91/06/07 11:22:52 $
  *
  *    (C) Copyright 1988, 1990 Diomidis Spinellis.
  *
- *    You may distribute under the terms of the GNU General Public License
- *    as specified in the README file that comes with the perl 3.0 kit.
+ *    You may distribute under the terms of either the GNU General Public
+ *    License or the Artistic License, as specified in the README file.
  *
  * $Log:	popen.c,v $
+ * Revision 4.0.1.1  91/06/07  11:22:52  lwall
+ * patch4: new copyright notice
+ * 
  * Revision 4.0  91/03/20  01:34:50  lwall
  * 4.0 baseline.
  * 
diff --git a/patchlevel.h b/patchlevel.h
index e19cd94440..a6997a9a35 100644
--- a/patchlevel.h
+++ b/patchlevel.h
@@ -1 +1 @@
-#define PATCHLEVEL 7
+#define PATCHLEVEL 8
diff --git a/perly.fixer b/perly.fixer
index 33d1c5cd1a..f3b0e6a90a 100644
--- a/perly.fixer
+++ b/perly.fixer
@@ -2,6 +2,9 @@
 
 #  Hacks to make it work with Interactive's SysVr3 Version 2.2
 #   doughera@lafvax.lafayette.edu (Andy Dougherty)   3/23/91
+#
+# Additional information to make the BSD section work with SunOS 4.0.2
+#   tdinger@East.Sun.COM (Tom Dinger)	4/15/1991
 
 input=$1
 output=$2
@@ -10,11 +13,12 @@ tmp=/tmp/f$$
 plan="unknown"
 
 #  Test for BSD 4.3 version.
+#  Also tests for the SunOS 4.0.2 version
 egrep 'YYSTYPE[ 	]*yyv\[ *YYMAXDEPTH *\];
 short[  ]*yys\[ *YYMAXDEPTH *\] *;
 yyps *= *&yys\[ *-1 *\];
 yypv *= *&yyv\[ *-1 *\];
-if *\( *\+\+yyps *> *&yys\[ *YYMAXDEPTH *\] *\)' $input >$tmp
+if *\( *\+\+yyps *>=* *&yys\[ *YYMAXDEPTH *\] *\)' $input >$tmp
 
 set `wc -l $tmp`
 if test "$1" = "5"; then
@@ -36,7 +40,10 @@ if *\( *\+\+yy_ps *>= *&yys\[ *YYMAXDEPTH *\] *\)' $input >$tmp
 fi
 
 case "$plan" in
-    #######################################################
+    ##################################################################
+    # The SunOS 4.0.2 version has the comparison fixed already.
+    # Also added are out of memory checks (makes porting the generated
+    # code easier) For most systems, it can't hurt. -- TD
     "bsd43")
 	echo "Patching perly.c to allow dynamic yacc stack allocation"
 	echo "Assuming bsd4.3 yaccpar"
@@ -55,13 +62,17 @@ short *maxyyps;
 \	if (!yyv) {\
 \	    yyv = (YYSTYPE*) malloc(yymaxdepth * sizeof(YYSTYPE));\
 \	    yys = (short*) malloc(yymaxdepth * sizeof(short));\
+\	    if ( !yyv || !yys ) {\
+\		yyerror( "out of memory" );\
+\		return(1);\
+\	    }\
 \	    maxyyps = &yys[yymaxdepth];\
 \	}\
 \	yyps = &yys[-1];\
 \	yypv = &yyv[-1];
 
 
-/if *( *\+\+yyps *> *&yys\[ *YYMAXDEPTH *\] *)/c\
+/if *( *\+\+yyps *>=* *&yys\[ *YYMAXDEPTH *\] *)/c\
 \		if( ++yyps >= maxyyps ) {\
 \		    int tv = yypv - yyv;\
 \		    int ts = yyps - yys;\
@@ -71,6 +82,10 @@ short *maxyyps;
 \		      yymaxdepth*sizeof(YYSTYPE));\
 \		    yys = (short*)realloc((char*)yys,\
 \		      yymaxdepth*sizeof(short));\
+\		    if ( !yyv || !yys ) {\
+\			yyerror( "yacc stack overflow" );\
+\			return(1);\
+\		    }\
 \		    yyps = yys + ts;\
 \		    yypv = yyv + tv;\
 \		    maxyyps = &yys[yymaxdepth];\
diff --git a/perly.y b/perly.y
index affb41b2e9..4032e10b1d 100644
--- a/perly.y
+++ b/perly.y
@@ -1,11 +1,14 @@
-/* $Header: perly.y,v 4.0 91/03/20 01:38:40 lwall Locked $
+/* $RCSfile: perly.y,v $$Revision: 4.0.1.1 $$Date: 91/06/07 11:42:34 $
  *
- *    Copyright (c) 1989, Larry Wall
+ *    Copyright (c) 1991, Larry Wall
  *
- *    You may distribute under the terms of the GNU General Public License
- *    as specified in the README file that comes with the perl 3.0 kit.
+ *    You may distribute under the terms of either the GNU General Public
+ *    License or the Artistic License, as specified in the README file.
  *
  * $Log:	perly.y,v $
+ * Revision 4.0.1.1  91/06/07  11:42:34  lwall
+ * patch4: new copyright notice
+ * 
  * Revision 4.0  91/03/20  01:38:40  lwall
  * 4.0 baseline.
  * 
@@ -788,5 +791,5 @@ bareword:	WORD
 				  "\"%s\" may clash with future reserved word",
 				  $1 );
 			}
-
+		;
 %% /* PROGRAM */
diff --git a/regcomp.c b/regcomp.c
index f11c602b55..92e43a3c58 100644
--- a/regcomp.c
+++ b/regcomp.c
@@ -7,9 +7,14 @@
  * blame Henry for some of the lack of readability.
  */
 
-/* $RCSfile: regcomp.c,v $$Revision: 4.0.1.1 $$Date: 91/04/12 09:04:45 $
+/* $RCSfile: regcomp.c,v $$Revision: 4.0.1.2 $$Date: 91/06/07 11:48:24 $
  *
  * $Log:	regcomp.c,v $
+ * Revision 4.0.1.2  91/06/07  11:48:24  lwall
+ * patch4: new copyright notice
+ * patch4: /(x+) \1/ incorrectly optimized to not match "xxx xx"
+ * patch4: // wouldn't use previous pattern if it started with a null character
+ * 
  * Revision 4.0.1.1  91/04/12  09:04:45  lwall
  * patch1: random cleanup in cpp namespace
  * 
@@ -41,10 +46,11 @@
  *
  ****    Alterations to Henry's code are...
  ****
- ****    Copyright (c) 1989, Larry Wall
+ ****    Copyright (c) 1991, Larry Wall
  ****
- ****    You may distribute under the terms of the GNU General Public License
- ****    as specified in the README file that comes with the perl 3.0 kit.
+ ****    You may distribute under the terms of either the GNU General Public
+ ****    License or the Artistic License, as specified in the README file.
+
  *
  * Beware that some of this code is subtly aware of the way operator
  * precedence is structured in regular expressions.  Serious changes in
@@ -95,6 +101,7 @@ static char *regcode;		/* Code-emit pointer; &regdummy = don't. */
 static long regsize;		/* Code size. */
 static int regfold;
 static int regsawbracket;	/* Did we do {d,d} trick? */
+static int regsawback;		/* Did we see \1, ...? */
 
 /*
  * Forward declarations for regcomp()'s friends.
@@ -146,6 +153,7 @@ int fold;
 	extern char *safemalloc();
 	extern char *savestr();
 	int sawplus = 0;
+	int sawopen = 0;
 
 	if (exp == NULL)
 		fatal("NULL regexp argument");
@@ -156,6 +164,7 @@ int fold;
 	regxend = xend;
 	regprecomp = nsavestr(exp,xend-exp);
 	regsawbracket = 0;
+	regsawback = 0;
 	regnpar = 1;
 	regsize = 0L;
 	regcode = &regdummy;
@@ -178,8 +187,9 @@ int fold;
 	/* Second pass: emit code. */
 	if (regsawbracket)
 	    bcopy(regprecomp,exp,xend-exp);
+	r->prelen = xend-exp;
 	r->precomp = regprecomp;
-	r->subbase = NULL;
+	r->subbeg = r->subbase = NULL;
 	regparse = exp;
 	regnpar = 1;
 	regcode = r->program;
@@ -198,18 +208,19 @@ int fold;
 		scan = NEXTOPER(scan);
 
 		first = scan;
-		while (OP(first) == OPEN ||
+		while ((OP(first) == OPEN && (sawopen = 1)) ||
 		    (OP(first) == BRANCH && OP(regnext(first)) != BRANCH) ||
 		    (OP(first) == PLUS) ||
 		    (OP(first) == CURLY && ARG1(first) > 0) ) {
 			if (OP(first) == PLUS)
-			    sawplus = 2;
+			    sawplus = 1;
 			else
 			    first += regarglen[OP(first)];
 			first = NEXTOPER(first);
 		}
 
 		/* Starting-point info. */
+	    again:
 		if (OP(first) == EXACTLY) {
 			r->regstart =
 			    str_make(OPERAND(first)+1,*OPERAND(first));
@@ -221,9 +232,13 @@ int fold;
 		else if (OP(first) == BOUND || OP(first) == NBOUND)
 			r->regstclass = first;
 		else if (OP(first) == BOL ||
-		    (OP(first) == STAR && OP(NEXTOPER(first)) == ANY) )
-			r->reganch = 1;		/* kinda turn .* into ^.* */
-		r->reganch |= sawplus;
+		    (OP(first) == STAR && OP(NEXTOPER(first)) == ANY) ) {
+			r->reganch = ROPT_ANCH;	/* kinda turn .* into ^.* */
+			first = NEXTOPER(first);
+		    	goto again;
+		}
+		if (sawplus && (!sawopen || !regsawback))
+		    r->reganch |= ROPT_SKIP;	/* x+ must match 1st of run */
 
 #ifdef DEBUGGING
 		if (debug & 512)
@@ -741,6 +756,7 @@ int *flagp;
 			    if (num > 9 && num >= regnpar)
 				goto defchar;
 			    else {
+				regsawback = 1;
 				ret = reganode(REF, num);
 				while (isascii(*regparse) && isdigit(*regparse))
 				    regparse++;
@@ -1272,9 +1288,9 @@ regexp *r;
 		fprintf(stderr,"start `%s' ", r->regstart->str_ptr);
 	if (r->regstclass)
 		fprintf(stderr,"stclass `%s' ", regprop(r->regstclass));
-	if (r->reganch & 1)
+	if (r->reganch & ROPT_ANCH)
 		fprintf(stderr,"anchored ");
-	if (r->reganch & 2)
+	if (r->reganch & ROPT_SKIP)
 		fprintf(stderr,"plus ");
 	if (r->regmust != NULL)
 		fprintf(stderr,"must have \"%s\" back %d ", r->regmust->str_ptr,
diff --git a/regcomp.h b/regcomp.h
index 21ad4f9355..8d0d1faf6e 100644
--- a/regcomp.h
+++ b/regcomp.h
@@ -1,6 +1,9 @@
-/* $Header: regcomp.h,v 4.0 91/03/20 01:39:09 lwall Locked $
+/* $RCSfile: regcomp.h,v $$Revision: 4.0.1.1 $$Date: 91/06/07 11:49:40 $
  *
  * $Log:	regcomp.h,v $
+ * Revision 4.0.1.1  91/06/07  11:49:40  lwall
+ * patch4: no change
+ * 
  * Revision 4.0  91/03/20  01:39:09  lwall
  * 4.0 baseline.
  * 
diff --git a/regexec.c b/regexec.c
index 7db8e3d3ba..bb63eda2e6 100644
--- a/regexec.c
+++ b/regexec.c
@@ -7,9 +7,13 @@
  * blame Henry for some of the lack of readability.
  */
 
-/* $RCSfile: regexec.c,v $$Revision: 4.0.1.1 $$Date: 91/04/12 09:07:39 $
+/* $RCSfile: regexec.c,v $$Revision: 4.0.1.2 $$Date: 91/06/07 11:50:33 $
  *
  * $Log:	regexec.c,v $
+ * Revision 4.0.1.2  91/06/07  11:50:33  lwall
+ * patch4: new copyright notice
+ * patch4: // wouldn't use previous pattern if it started with a null character
+ * 
  * Revision 4.0.1.1  91/04/12  09:07:39  lwall
  * patch1: regexec only allocated space for 9 subexpresssions
  * 
@@ -40,10 +44,10 @@
  *
  ****    Alterations to Henry's code are...
  ****
- ****    Copyright (c) 1989, Larry Wall
+ ****    Copyright (c) 1991, Larry Wall
  ****
- ****    You may distribute under the terms of the GNU General Public License
- ****    as specified in the README file that comes with the perl 3.0 kit.
+ ****    You may distribute under the terms of either the GNU General Public
+ ****    License or the Artistic License, as specified in the README file.
  *
  * Beware that some of this code is subtly aware of the way operator
  * precedence is structured in regular expressions.  Serious changes in
@@ -151,7 +155,8 @@ int safebase;	/* no need to remember string in subbase */
 	/* If there is a "must appear" string, look for it. */
 	s = string;
 	if (prog->regmust != Nullstr &&
-	    (!(prog->reganch & 1) || (multiline && prog->regback >= 0)) ) {
+	    (!(prog->reganch & ROPT_ANCH)
+	     || (multiline && prog->regback >= 0)) ) {
 		if (stringarg == strbeg && screamer) {
 			if (screamfirst[prog->regmust->str_rare] >= 0)
 				s = screaminstr(screamer,prog->regmust);
@@ -213,7 +218,7 @@ int safebase;	/* no need to remember string in subbase */
 
 	/* Simplest case:  anchored match need be tried only once. */
 	/*  [unless multiline is set] */
-	if (prog->reganch & 1) {
+	if (prog->reganch & ROPT_ANCH) {
 		if (regtry(prog, string))
 			goto got_it;
 		else if (multiline) {
@@ -235,7 +240,7 @@ int safebase;	/* no need to remember string in subbase */
 
 	/* Messy cases:  unanchored match. */
 	if (prog->regstart) {
-		if (prog->reganch & 2) {	/* we have /x+whatever/ */
+		if (prog->reganch & ROPT_SKIP) {  /* we have /x+whatever/ */
 		    /* it must be a one character string */
 		    i = prog->regstart->str_ptr[0];
 		    while (s < strend) {
@@ -275,7 +280,7 @@ int safebase;	/* no need to remember string in subbase */
 		goto phooey;
 	}
 	if (c = prog->regstclass) {
-		int doevery = (prog->reganch & 2) == 0;
+		int doevery = (prog->reganch & ROPT_SKIP) == 0;
 
 		if (minlen)
 		    dontbother = minlen - 1;
@@ -445,7 +450,7 @@ int safebase;	/* no need to remember string in subbase */
 		    s = nsavestr(strbeg,i);	/* so $digit will work later */
 		    if (prog->subbase)
 			    Safefree(prog->subbase);
-		    prog->subbase = s;
+		    prog->subbeg = prog->subbase = s;
 		    prog->subend = s+i;
 		}
 		else
diff --git a/regexp.h b/regexp.h
index 600e630ee7..573187488e 100644
--- a/regexp.h
+++ b/regexp.h
@@ -5,9 +5,14 @@
  * not the System V one.
  */
 
-/* $Header: regexp.h,v 4.0 91/03/20 01:39:23 lwall Locked $
+/* $RCSfile: regexp.h,v $$Revision: 4.0.1.1 $$Date: 91/06/07 11:51:18 $
  *
  * $Log:	regexp.h,v $
+ * Revision 4.0.1.1  91/06/07  11:51:18  lwall
+ * patch4: new copyright notice
+ * patch4: // wouldn't use previous pattern if it started with a null character
+ * patch4: $` was busted inside s///
+ * 
  * Revision 4.0  91/03/20  01:39:23  lwall
  * 4.0 baseline.
  * 
@@ -20,8 +25,10 @@ typedef struct regexp {
 	char *regstclass;
 	STR *regmust;		/* Internal use only. */
 	int regback;		/* Can regmust locate first try? */
+	int prelen;		/* length of precomp */
 	char *precomp;		/* pre-compilation regular expression */
 	char *subbase;		/* saved string so \digit works forever */
+	char *subbeg;		/* same, but not responsible for allocation */
 	char *subend;		/* end of subbase */
 	char reganch;		/* Internal use only. */
 	char do_folding;	/* do case-insensitive match? */
@@ -30,5 +37,8 @@ typedef struct regexp {
 	char program[1];	/* Unwarranted chumminess with compiler. */
 } regexp;
 
+#define ROPT_ANCH 1
+#define ROPT_SKIP 2
+
 regexp *regcomp();
 int regexec();
diff --git a/spat.h b/spat.h
index 4c03c6edef..6c1551e0d1 100644
--- a/spat.h
+++ b/spat.h
@@ -1,11 +1,15 @@
-/* $Header: spat.h,v 4.0 91/03/20 01:39:36 lwall Locked $
+/* $RCSfile: spat.h,v $$Revision: 4.0.1.1 $$Date: 91/06/07 11:51:59 $
  *
- *    Copyright (c) 1989, Larry Wall
+ *    Copyright (c) 1991, Larry Wall
  *
- *    You may distribute under the terms of the GNU General Public License
- *    as specified in the README file that comes with the perl 3.0 kit.
+ *    You may distribute under the terms of either the GNU General Public
+ *    License or the Artistic License, as specified in the README file.
  *
  * $Log:	spat.h,v $
+ * Revision 4.0.1.1  91/06/07  11:51:59  lwall
+ * patch4: new copyright notice
+ * patch4: added global modifier for pattern matches
+ * 
  * Revision 4.0  91/03/20  01:39:36  lwall
  * 4.0 baseline.
  * 
@@ -17,7 +21,7 @@ struct scanpat {
     ARG		*spat_repl;		/* replacement string for subst */
     ARG		*spat_runtime;		/* compile pattern at runtime */
     STR		*spat_short;		/* for a fast bypass of execute() */
-    bool	spat_flags;
+    short	spat_flags;
     char	spat_slen;
 };
 
@@ -29,6 +33,7 @@ struct scanpat {
 #define SPAT_FOLD 32			/* case insensitivity */
 #define SPAT_CONST 64			/* subst replacement is constant */
 #define SPAT_KEEP 128			/* keep 1st runtime pattern forever */
+#define SPAT_GLOBAL 256			/* pattern had a g modifier */
 
 EXT SPAT *curspat;		/* what to do \ interps from */
 EXT SPAT *lastspat;		/* what to use in place of null pattern */
diff --git a/stab.c b/stab.c
index 7819793b80..b8e76d43b7 100644
--- a/stab.c
+++ b/stab.c
@@ -1,11 +1,20 @@
-/* $RCSfile: stab.c,v $$Revision: 4.0.1.1 $$Date: 91/04/12 09:10:24 $
+/* $RCSfile: stab.c,v $$Revision: 4.0.1.2 $$Date: 91/06/07 11:55:53 $
  *
- *    Copyright (c) 1989, Larry Wall
+ *    Copyright (c) 1991, Larry Wall
  *
- *    You may distribute under the terms of the GNU General Public License
- *    as specified in the README file that comes with the perl 3.0 kit.
+ *    You may distribute under the terms of either the GNU General Public
+ *    License or the Artistic License, as specified in the README file.
  *
  * $Log:	stab.c,v $
+ * Revision 4.0.1.2  91/06/07  11:55:53  lwall
+ * patch4: new copyright notice
+ * patch4: added $^P variable to control calling of perldb routines
+ * patch4: added $^F variable to specify maximum system fd, default 2
+ * patch4: $` was busted inside s///
+ * patch4: default top-of-form format is now FILEHANDLE_TOP
+ * patch4: length($`), length($&), length($') now optimized to avoid string copy
+ * patch4: $^D |= 1024 now does syntax tree dump at run-time
+ * 
  * Revision 4.0.1.1  91/04/12  09:10:24  lwall
  * patch1: Configure now differentiates getgroups() type from getgid() type
  * patch1: you may now use "die" and "caller" in a signal handler
@@ -54,12 +63,18 @@ STR *str;
 	str_numset(stab_val(stab),(double)(debug & 32767));
 #endif
 	break;
+    case '\006':		/* ^F */
+	str_numset(stab_val(stab),(double)maxsysfd);
+	break;
     case '\t':			/* ^I */
 	if (inplace)
 	    str_set(stab_val(stab), inplace);
 	else
 	    str_sset(stab_val(stab),&str_undef);
 	break;
+    case '\020':		/* ^P */
+	str_numset(stab_val(stab),(double)perldb);
+	break;
     case '\024':		/* ^T */
 	str_numset(stab_val(stab),(double)basetime);
 	break;
@@ -93,7 +108,7 @@ STR *str;
     case '`':
 	if (curspat) {
 	    if (curspat->spat_regexp &&
-	      (s = curspat->spat_regexp->subbase) ) {
+	      (s = curspat->spat_regexp->subbeg) ) {
 		i = curspat->spat_regexp->startp[0] - s;
 		if (i >= 0)
 		    str_nset(stab_val(stab),s,i);
@@ -126,10 +141,17 @@ STR *str;
 	break;
     case '^':
 	s = stab_io(curoutstab)->top_name;
-	str_set(stab_val(stab),s);
+	if (s)
+	    str_set(stab_val(stab),s);
+	else {
+	    str_set(stab_val(stab),stab_name(curoutstab));
+	    str_cat(stab_val(stab),"_TOP");
+	}
 	break;
     case '~':
 	s = stab_io(curoutstab)->fmt_name;
+	if (!s)
+	    s = stab_name(curoutstab);
 	str_set(stab_val(stab),s);
 	break;
 #ifndef lint
@@ -215,6 +237,76 @@ STR *str;
     return stab_val(stab);
 }
 
+STRLEN
+stab_len(str)
+STR *str;
+{
+    STAB *stab = str->str_u.str_stab;
+    int paren;
+    int i;
+    char *s;
+
+    if (str->str_rare)
+	return stab_val(stab)->str_cur;
+
+    switch (*stab->str_magic->str_ptr) {
+    case '1': case '2': case '3': case '4':
+    case '5': case '6': case '7': case '8': case '9': case '&':
+	if (curspat) {
+	    paren = atoi(stab_name(stab));
+	  getparen:
+	    if (curspat->spat_regexp &&
+	      paren <= curspat->spat_regexp->nparens &&
+	      (s = curspat->spat_regexp->startp[paren]) ) {
+		i = curspat->spat_regexp->endp[paren] - s;
+		if (i >= 0)
+		    return i;
+		else
+		    return 0;
+	    }
+	    else
+		return 0;
+	}
+	break;
+    case '+':
+	if (curspat) {
+	    paren = curspat->spat_regexp->lastparen;
+	    goto getparen;
+	}
+	break;
+    case '`':
+	if (curspat) {
+	    if (curspat->spat_regexp &&
+	      (s = curspat->spat_regexp->subbeg) ) {
+		i = curspat->spat_regexp->startp[0] - s;
+		if (i >= 0)
+		    return i;
+		else
+		    return 0;
+	    }
+	    else
+		return 0;
+	}
+	break;
+    case '\'':
+	if (curspat) {
+	    if (curspat->spat_regexp &&
+	      (s = curspat->spat_regexp->endp[0]) ) {
+		return (STRLEN) (curspat->spat_regexp->subend - s);
+	    }
+	    else
+		return 0;
+	}
+	break;
+    case ',':
+	return (STRLEN)ofslen;
+    case '\\':
+	return (STRLEN)orslen;
+    default:
+	return stab_str(str)->str_cur;
+    }
+}
+
 stabset(mstr,str)
 register STR *mstr;
 STR *str;
@@ -334,8 +426,13 @@ STR *str;
 	case '\004':	/* ^D */
 #ifdef DEBUGGING
 	    debug = (int)(str_gnum(str)) | 32768;
+	    if (debug & 1024)
+		dump_all();
 #endif
 	    break;
+	case '\006':	/* ^F */
+	    maxsysfd = (int)str_gnum(str);
+	    break;
 	case '\t':	/* ^I */
 	    if (inplace)
 		Safefree(inplace);
@@ -344,6 +441,9 @@ STR *str;
 	    else
 		inplace = Nullch;
 	    break;
+	case '\020':	/* ^P */
+	    perldb = (int)str_gnum(str);
+	    break;
 	case '\024':	/* ^T */
 	    basetime = (long)str_gnum(str);
 	    break;
@@ -430,12 +530,12 @@ STR *str;
 	    break;
 	case '<':
 	    uid = (int)str_gnum(str);
-#ifdef HAS_SETREUID
+#if defined(HAS_SETREUID) || !defined(HAS_SETRUID)
 	    if (delaymagic) {
 		delaymagic |= DM_REUID;
 		break;				/* don't do magic till later */
 	    }
-#endif /* HAS_SETREUID */
+#endif /* HAS_SETREUID or not HASSETRUID */
 #ifdef HAS_SETRUID
 	    if (setruid((UIDTYPE)uid) < 0)
 		uid = (int)getuid();
@@ -453,12 +553,12 @@ STR *str;
 	    break;
 	case '>':
 	    euid = (int)str_gnum(str);
-#ifdef HAS_SETREUID
+#if defined(HAS_SETREUID) || !defined(HAS_SETEUID)
 	    if (delaymagic) {
 		delaymagic |= DM_REUID;
 		break;				/* don't do magic till later */
 	    }
-#endif /* HAS_SETREUID */
+#endif /* HAS_SETREUID or not HAS_SETEUID */
 #ifdef HAS_SETEUID
 	    if (seteuid((UIDTYPE)euid) < 0)
 		euid = (int)geteuid();
@@ -476,12 +576,12 @@ STR *str;
 	    break;
 	case '(':
 	    gid = (int)str_gnum(str);
-#ifdef HAS_SETREGID
+#if defined(HAS_SETREGID) || !defined(HAS_SETRGID)
 	    if (delaymagic) {
 		delaymagic |= DM_REGID;
 		break;				/* don't do magic till later */
 	    }
-#endif /* HAS_SETREGID */
+#endif /* HAS_SETREGID or not HAS_SETRGID */
 #ifdef HAS_SETRGID
 	    (void)setrgid((GIDTYPE)gid);
 #else
@@ -494,12 +594,12 @@ STR *str;
 	    break;
 	case ')':
 	    egid = (int)str_gnum(str);
-#ifdef HAS_SETREGID
+#if defined(HAS_SETREGID) || !defined(HAS_SETEGID)
 	    if (delaymagic) {
 		delaymagic |= DM_REGID;
 		break;				/* don't do magic till later */
 	    }
-#endif /* HAS_SETREGID */
+#endif /* HAS_SETREGID or not HAS_SETEGID */
 #ifdef HAS_SETEGID
 	    (void)setegid((GIDTYPE)egid);
 #else
diff --git a/x2p/s2p.SH b/x2p/s2p.SH
index c059481a18..818d36211b 100644
--- a/x2p/s2p.SH
+++ b/x2p/s2p.SH
@@ -29,9 +29,12 @@ $spitshell >s2p <<!GROK!THIS!
 : In the following dollars and backticks do not need the extra backslash.
 $spitshell >>s2p <<'!NO!SUBS!'
 
-# $Header: s2p.SH,v 4.0 91/03/20 01:57:59 lwall Locked $
+# $RCSfile: s2p.SH,v $$Revision: 4.0.1.1 $$Date: 91/06/07 12:19:18 $
 #
 # $Log:	s2p.SH,v $
+# Revision 4.0.1.1  91/06/07  12:19:18  lwall
+# patch4: s2p now handles embedded newlines better and optimizes common idioms
+# 
 # Revision 4.0  91/03/20  01:57:59  lwall
 # 4.0 baseline.
 # 
@@ -66,33 +69,43 @@ unless ($debug) {
 }
 
 if (!$assumen && !$assumep) {
-    print BODY <<'EOT';
-while ($ARGV[0] =~ /^-/) {
-    $_ = shift;
-  last if /^--/;
-    if (/^-n/) {
-	$nflag++;
-	next;
-    }
-    die "I don't recognize this switch: $_\\n";
-}
-
+    print BODY &q(<<'EOT');
+:	while ($ARGV[0] =~ /^-/) {
+:	    $_ = shift;
+:	  last if /^--/;
+:	    if (/^-n/) {
+:		$nflag++;
+:		next;
+:	    }
+:	    die "I don't recognize this switch: $_\\n";
+:	}
+:	
 EOT
 }
 
-print BODY <<'EOT';
-
-#ifdef PRINTIT
-#ifdef ASSUMEP
-$printit++;
-#else
-$printit++ unless $nflag;
-#endif
-#endif
-LINE: while (<>) {
+print BODY &q(<<'EOT');
+:	#ifdef PRINTIT
+:	#ifdef ASSUMEP
+:	$printit++;
+:	#else
+:	$printit++ unless $nflag;
+:	#endif
+:	#endif
+:	<><>
+:	$\ = "\n";		# automatically add newline on print
+:	<><>
+:	#ifdef TOPLABEL
+:	LINE:
+:	while (chop($_ = <>)) {
+:	#else
+:	LINE:
+:	while (<>) {
+:	    chop;
+:	#endif
 EOT
 
-LINE: while (<>) {
+LINE:
+while (<>) {
 
     # Wipe out surrounding whitespace.
 
@@ -105,6 +118,10 @@ LINE: while (<>) {
 	$label = &make_label($_);
 	if ($. == 1) {
 	    $toplabel = $label;
+	    if (/^(top|(re)?start|redo|begin(ning)|again|input)$/i) {
+		$_ = <>;
+		redo LINE; # Never referenced, so delete it if not a comment.
+	    }
 	}
 	$_ = "$label:";
 	if ($lastlinewaslabel++) {
@@ -127,6 +144,7 @@ LINE: while (<>) {
     $addr2 = '';
     if (s/^([0-9]+)//) {
 	$addr1 = "$1";
+	$addr1 = "\$. == $addr1" unless /^,/;
     }
     elsif (s/^\$//) {
 	$addr1 = 'eof()';
@@ -213,35 +231,39 @@ if ($lastlinewaslabel++) {
     $indent -= 4;
 }
 
-print BODY "}\n";
 if ($appendseen || $tseen || !$assumen) {
     $printit++ if $dseen || (!$assumen && !$assumep);
-    print BODY <<'EOT';
-
-continue {
-#ifdef PRINTIT
-#ifdef DSEEN
-#ifdef ASSUMEP
-    print if $printit++;
-#else
-    if ($printit)
-	{ print; }
-    else
-	{ $printit++ unless $nflag; }
-#endif
-#else
-    print if $printit;
-#endif
-#else
-    print;
-#endif
-#ifdef TSEEN
-    $tflag = '';
-#endif
-#ifdef APPENDSEEN
-    if ($atext) { print $atext; $atext = ''; }
-#endif
-}
+    print BODY &q(<<'EOT');
+:	#ifdef SAWNEXT
+:	}
+:	continue {
+:	#endif
+:	#ifdef PRINTIT
+:	#ifdef DSEEN
+:	#ifdef ASSUMEP
+:	    print if $printit++;
+:	#else
+:	    if ($printit)
+:		{ print; }
+:	    else
+:		{ $printit++ unless $nflag; }
+:	#endif
+:	#else
+:	    print if $printit;
+:	#endif
+:	#else
+:	    print;
+:	#endif
+:	#ifdef TSEEN
+:	    $tflag = 0;
+:	#endif
+:	#ifdef APPENDSEEN
+:	    if ($atext) { chop $atext; print $atext; $atext = ''; }
+:	#endif
+EOT
+
+print BODY &q(<<'EOT');
+:	}
 EOT
 }
 
@@ -250,12 +272,14 @@ close BODY;
 unless ($debug) {
     open(HEAD,">/tmp/sperl2$$.c")
       || &Die("Can't open temp file 2: $!\n");
-    print HEAD "#define PRINTIT\n" if ($printit);
-    print HEAD "#define APPENDSEEN\n" if ($appendseen);
-    print HEAD "#define TSEEN\n" if ($tseen);
-    print HEAD "#define DSEEN\n" if ($dseen);
-    print HEAD "#define ASSUMEN\n" if ($assumen);
-    print HEAD "#define ASSUMEP\n" if ($assumep);
+    print HEAD "#define PRINTIT\n"	if $printit;
+    print HEAD "#define APPENDSEEN\n"	if $appendseen;
+    print HEAD "#define TSEEN\n"	if $tseen;
+    print HEAD "#define DSEEN\n"	if $dseen;
+    print HEAD "#define ASSUMEN\n"	if $assumen;
+    print HEAD "#define ASSUMEP\n"	if $assumep;
+    print HEAD "#define TOPLABEL\n"	if $toplabel;
+    print HEAD "#define SAWNEXT\n"	if $sawnext;
     if ($opens) {print HEAD "$opens\n";}
     open(BODY,"/tmp/sperl$$")
       || &Die("Can't reopen temp file: $!\n");
@@ -264,11 +288,11 @@ unless ($debug) {
     }
     close HEAD;
 
-    print <<"EOT";
-#!$bin/perl
-eval 'exec $bin/perl -S \$0 \$*'
-	if \$running_under_some_shell;
-
+    print &q(<<"EOT");
+:	#!$bin/perl
+:	eval 'exec $bin/perl -S \$0 \${1+"\$@"}'
+:		if \$running_under_some_shell;
+:	
 EOT
     open(BODY,"cc -E /tmp/sperl2$$.c |") ||
 	&Die("Can't reopen temp file: $!\n");
@@ -297,15 +321,22 @@ sub tab {
 sub make_filehandle {
     local($_) = $_[0];
     local($fname) = $_;
-    s/[^a-zA-Z]/_/g;
-    s/^_*//;
-    substr($_,0,1) =~ y/a-z/A-Z/ if /^[a-z]/;
-    if (!$seen{$_}) {
-	$opens .= <<"EOT";
-open($_,'>$fname') || die "Can't create $fname";
+    if (!$seen{$fname}) {
+	$_ = "FH_" . $_ if /^\d/;
+	s/[^a-zA-Z0-9]/_/g;
+	s/^_*//;
+	$_ = "\U$_";
+	if ($fhseen{$_}) {
+	    for ($tmp = "a"; $fhseen{"$_$tmp"}; $a++) {}
+	    $_ .= $tmp;
+	}
+	$fhseen{$_} = 1;
+	$opens .= &q(<<"EOT");
+:	open($_, '>$fname') || die "Can't create $fname: \$!";
 EOT
+	$seen{$fname} = $_;
     }
-    $seen{$_} = $_;
+    $seen{$fname};
 }
 
 sub make_label {
@@ -325,67 +356,69 @@ sub transmogrify {
     {	# case
 	if (/^d/) {
 	    $dseen++;
-	    chop($_ = <<'EOT');
-<<--#ifdef PRINTIT
-$printit = '';
-<<--#endif
-next LINE;
+	    chop($_ = &q(<<'EOT'));
+:	<<--#ifdef PRINTIT
+:	$printit = 0;
+:	<<--#endif
+:	next LINE;
 EOT
+	    $sawnext++;
 	    next;
 	}
 
 	if (/^n/) {
-	    chop($_ = <<'EOT');
-<<--#ifdef PRINTIT
-<<--#ifdef DSEEN
-<<--#ifdef ASSUMEP
-print if $printit++;
-<<--#else
-if ($printit)
-    { print; }
-else
-    { $printit++ unless $nflag; }
-<<--#endif
-<<--#else
-print if $printit;
-<<--#endif
-<<--#else
-print;
-<<--#endif
-<<--#ifdef APPENDSEEN
-if ($atext) {print $atext; $atext = '';}
-<<--#endif
-$_ = <>;
-<<--#ifdef TSEEN
-$tflag = '';
-<<--#endif
+	    chop($_ = &q(<<'EOT'));
+:	<<--#ifdef PRINTIT
+:	<<--#ifdef DSEEN
+:	<<--#ifdef ASSUMEP
+:	print if $printit++;
+:	<<--#else
+:	if ($printit)
+:	    { print; }
+:	else
+:	    { $printit++ unless $nflag; }
+:	<<--#endif
+:	<<--#else
+:	print if $printit;
+:	<<--#endif
+:	<<--#else
+:	print;
+:	<<--#endif
+:	<<--#ifdef APPENDSEEN
+:	if ($atext) {chop $atext; print $atext; $atext = '';}
+:	<<--#endif
+:	$_ = <>;
+:	chop;
+:	<<--#ifdef TSEEN
+:	$tflag = 0;
+:	<<--#endif
 EOT
 	    next;
 	}
 
 	if (/^a/) {
 	    $appendseen++;
-	    $command = $space . '$atext .=' . "\n<<--'";
+	    $command = $space . "\$atext .= <<'End_Of_Text';\n<<--";
 	    $lastline = 0;
 	    while (<>) {
 		s/^[ \t]*//;
 		s/^[\\]//;
 		unless (s|\\$||) { $lastline = 1;}
-		s/'/\\'/g;
 		s/^([ \t]*\n)/<><>$1/;
 		$command .= $_;
 		$command .= '<<--';
 		last if $lastline;
 	    }
-	    $_ = $command . "';";
+	    $_ = $command . "End_Of_Text";
 	    last;
 	}
 
 	if (/^[ic]/) {
 	    if (/^c/) { $change = 1; }
+	    $addr1 = 1 if $addr1 eq '';
 	    $addr1 = '$iter = (' . $addr1 . ')';
-	    $command = $space . 'if ($iter == 1) { print'
-	      . "\n<<--'";
+	    $command = $space .
+	      "    if (\$iter == 1) { print <<'End_Of_Text'; }\n<<--";
 	    $lastline = 0;
 	    while (<>) {
 		s/^[ \t]*//;
@@ -397,16 +430,17 @@ EOT
 		$command .= '<<--';
 		last if $lastline;
 	    }
-	    $_ = $command . "';}";
+	    $_ = $command . "End_Of_Text";
 	    if ($change) {
 		$dseen++;
 		$change = "$_\n";
-		chop($_ = <<"EOT");
-<<--#ifdef PRINTIT
-$space\$printit = '';
-<<--#endif
-${space}next LINE;
+		chop($_ = &q(<<"EOT"));
+:	<<--#ifdef PRINTIT
+:	$space\$printit = 0;
+:	<<--#endif
+:	${space}next LINE;
 EOT
+		$sawnext++;
 	    }
 	    last;
 	}
@@ -463,6 +497,11 @@ EOT
 		elsif ($c eq ']') {
 		    $inbracket = 0;
 		}
+		elsif ($c eq "\t") {
+		    substr($_, $i, 1) = '\\t';
+		    $i++;
+		    $len++;
+		}
 		elsif (!$repl && index("()+",$c) >= 0) {
 		    substr($_, $i, 0) = '\\';
 		    $i++;
@@ -474,6 +513,7 @@ EOT
 	    $pat = substr($_, 0, $repl + 1);
 	    $repl = substr($_, $repl+1, $end-$repl-1);
 	    $end = substr($_, $end + 1, 1000);
+	    &simplify($pat);
 	    $dol = '$';
 	    $repl =~ s/\$/\\$/;
 	    $repl =~ s'&'$&'g;
@@ -498,12 +538,12 @@ EOT
 		&Die("Unrecognized substitution command".
 		  "($end) at line $.\n");
 	    }
-	    chop ($_ = <<"EOT");
-<<--#ifdef TSEEN
-$subst && \$tflag++$cmd;
-<<--#else
-$subst$cmd;
-<<--#endif
+	    chop ($_ = &q(<<"EOT"));
+:	<<--#ifdef TSEEN
+:	$subst && \$tflag++$cmd;
+:	<<--#else
+:	$subst$cmd;
+:	<<--#endif
 EOT
 	    next;
 	}
@@ -529,25 +569,29 @@ EOT
 	}
 
 	if (/^P/) {
-	    $_ = 'print $1 if /(^.*\n)/;';
+	    $_ = 'print $1 if /^(.*)/;';
 	    next;
 	}
 
 	if (/^D/) {
-	    chop($_ = <<'EOT');
-s/^.*\n//;
-redo LINE if $_;
-next LINE;
+	    chop($_ = &q(<<'EOT'));
+:	s/^.*\n?//;
+:	redo LINE if $_;
+:	next LINE;
 EOT
+	    $sawnext++;
 	    next;
 	}
 
 	if (/^N/) {
-	    chop($_ = <<'EOT');
-$_ .= <>;
-<<--#ifdef TSEEN
-$tflag = '';
-<<--#endif
+	    chop($_ = &q(<<'EOT'));
+:	$_ .= "\n";
+:	$len1 = length;
+:	$_ .= <>;
+:	chop if $len1 < length;
+:	<<--#ifdef TSEEN
+:	$tflag = 0;
+:	<<--#endif
 EOT
 	    next;
 	}
@@ -558,7 +602,7 @@ EOT
 	}
 
 	if (/^H/) {
-	    $_ = '$hold .= $_ ? $_ : "\n";';
+	    $_ = '$hold .= "\n"; $hold .= $_;';
 	    next;
 	}
 
@@ -568,7 +612,7 @@ EOT
 	}
 
 	if (/^G/) {
-	    $_ = '$_ .= $hold ? $hold : "\n";';
+	    $_ = '$_ .= "\n"; $_ .= $hold;';
 	    next;
 	}
 
@@ -579,6 +623,7 @@ EOT
 
 	if (/^b$/) {
 	    $_ = 'next LINE;';
+	    $sawnext++;
 	    next;
 	}
 
@@ -595,6 +640,7 @@ EOT
 
 	if (/^t$/) {
 	    $_ = 'next LINE if $tflag;';
+	    $sawnext++;
 	    $tseen++;
 	    next;
 	}
@@ -602,7 +648,7 @@ EOT
 	if (/^t/) {
 	    s/^t[ \t]*//;
 	    $lab = &make_label($_);
-	    $_ = q/if ($tflag) {$tflag = ''; /;
+	    $_ = q/if ($tflag) {$tflag = 0; /;
 	    if ($lab eq $toplabel) {
 		$_ .= 'redo LINE;}';
 	    } else {
@@ -612,17 +658,28 @@ EOT
 	    next;
 	}
 
+	if (/^y/) {
+	    s/abcdefghijklmnopqrstuvwxyz/a-z/g;
+	    s/ABCDEFGHIJKLMNOPQRSTUVWXYZ/A-Z/g;
+	    s/abcdef/a-f/g;
+	    s/ABCDEF/A-F/g;
+	    s/0123456789/0-9/g;
+	    s/01234567/0-7/g;
+	    $_ .= ';';
+	}
+
 	if (/^=/) {
-	    $_ = 'print "$.\n";';
+	    $_ = 'print $.;';
 	    next;
 	}
 
 	if (/^q/) {
-	    chop($_ = <<'EOT');
-close(ARGV);
-@ARGV = ();
-next LINE;
+	    chop($_ = &q(<<'EOT'));
+:	close(ARGV);
+:	@ARGV = ();
+:	next LINE;
 EOT
+	    $sawnext++;
 	    next;
 	}
     } continue {
@@ -670,9 +727,39 @@ sub fetchpat {
 	    last DELIM;
 	}
     }
+    $addr =~ s/\t/\\t/g;
+    &simplify($addr);
     $addr;
 }
 
+sub q {
+    local($string) = @_;
+    local($*) = 1;
+    $string =~ s/^:\t?//g;
+    $string;
+}
+
+sub simplify {
+    $_[0] =~ s/_a-za-z0-9/\\w/ig;
+    $_[0] =~ s/a-z_a-z0-9/\\w/ig;
+    $_[0] =~ s/a-za-z_0-9/\\w/ig;
+    $_[0] =~ s/a-za-z0-9_/\\w/ig;
+    $_[0] =~ s/_0-9a-za-z/\\w/ig;
+    $_[0] =~ s/0-9_a-za-z/\\w/ig;
+    $_[0] =~ s/0-9a-z_a-z/\\w/ig;
+    $_[0] =~ s/0-9a-za-z_/\\w/ig;
+    $_[0] =~ s/\[\\w\]/\\w/g;
+    $_[0] =~ s/\[^\\w\]/\\W/g;
+    $_[0] =~ s/\[0-9\]/\\d/g;
+    $_[0] =~ s/\[^0-9\]/\\D/g;
+    $_[0] =~ s/\\d\\d\*/\\d+/g;
+    $_[0] =~ s/\\D\\D\*/\\D+/g;
+    $_[0] =~ s/\\w\\w\*/\\w+/g;
+    $_[0] =~ s/\\t\\t\*/\\t+/g;
+    $_[0] =~ s/(\[.[^]]*\])\1\*/$1+/g;
+    $_[0] =~ s/([\w\s!@#%^&-=,:;'"])\1\*/$1+/g;
+}
+
 !NO!SUBS!
 chmod 755 s2p
 $eunicefix s2p
diff --git a/x2p/s2p.man b/x2p/s2p.man
index 1017d37626..6ece802ce1 100644
--- a/x2p/s2p.man
+++ b/x2p/s2p.man
@@ -1,7 +1,10 @@
 .rn '' }`
-''' $Header: s2p.man,v 4.0 91/03/20 01:58:07 lwall Locked $
+''' $RCSfile: s2p.man,v $$Revision: 4.0.1.1 $$Date: 91/06/07 12:19:57 $
 ''' 
 ''' $Log:	s2p.man,v $
+''' Revision 4.0.1.1  91/06/07  12:19:57  lwall
+''' patch4: s2p now handles embedded newlines better and optimizes common idioms
+''' 
 ''' Revision 4.0  91/03/20  01:58:07  lwall
 ''' 4.0 baseline.
 ''' 
@@ -86,6 +89,8 @@ The perl script you end up with may be either faster or slower than the original
 sed script.
 If you're only interested in speed you'll just have to try it both ways.
 Of course, if you want to do something sed doesn't do, you have no choice.
+It's often possible to speed up the perl script by various methods, such
+as deleting all references to $\e and chop.
 .SH ENVIRONMENT
 S2p uses no environment variables.
 .SH AUTHOR