perl 2.0 patch 1: removed redundant debugging code in regexp.c

If you used ++ on a variable that had the value '' (as opposed to
being undefined) it would increment the numeric part but not
invalidate the string part, which could then give false results.

Berkeley recently sent out a patch that disables setuid #! scripts
because of an inherent problem in the semantics as they are
currently defined.  If you have installed that patch, your setuid
and setgid bits are useless on scripts.  I've added a means
for perl to examine those bits and emulate setuid/setgid scripts
itself in what I believe is a secure manner.  If normal perl
detects such a script, it passes it off to another version of
perl that runs setuid root, and can run the script under the
desired uid/gid.  This feature is optional, and Configure will
ask if you want to do it.

Some machines didn't like config.h when it said #/*undef SYMBOL.
Config.h.SH now is smart enough to tuck the # inside the comment.

There were several small problems in Configure: the return code from
ar was hidden by a piped call to sed, so if ar failed it went
undetected.  The Cray uses a program called bld instead of ar.
Let's hear it for compatibilty.  At least one version of gnucpp
adds a space after symbol interpolation, which was giving the
C preprocessor detector fits.  There was a call to grep '-i' that
needed to have the -i protected by a backslash.  Also, Configure
should remove the UU subdirectory that it makes while running.

"make realclean" now knows about the alternate patch extension ~.

In the manual page, I fixed some quotes that were ugly in troff,
and did some clarification of LIST, study, tr and unlink.

regexp.c had some redundant debugging code.

tr/x/y/ could dump core if y is shorter than x.  I found this out
when I tried translating a bunch of characters to space by saying
something like y/a-z/ /.

10 files changed, 343 insertions, 84 deletions

diff --git a/Configure b/Configure
index 8d5a95ac70..81be1407dd 100755
--- a/Configure
+++ b/Configure
@@ -8,7 +8,7 @@
 # and edit it to reflect your system.  Some packages may include samples
 # of config.h for certain machines, so you might look for one of those.)
 #
-# $Header: Configure,v 2.0 88/06/05 00:07:37 root Exp $
+# $Header: Configure,v 2.0.1.1 88/06/28 16:24:02 root Exp $
 #
 # Yes, you may rip this off to use in other distribution packages.
 # (Note: this Configure script was generated automatically.  Rather than
@@ -76,6 +76,7 @@ cppminus=''
 d_bcopy=''
 d_charsprf=''
 d_crypt=''
+d_dosuid=''
 d_fchmod=''
 d_fchown=''
 d_getgrps=''
@@ -124,7 +125,6 @@ voidflags=''
 defvoidused=''
 privlib=''
 CONFIG=''
-
 : set package name
 package=perl
 
@@ -134,7 +134,7 @@ echo "Beginning of configuration questions for $package kit."
 echo " "
 
 define='define'
-undef='/*undef'
+undef='undef'
 libpth='/usr/lib /usr/local/lib /lib'
 smallmach='pdp11 i8086 z8000 i80286 iAPX286'
 rmlist='kit[1-9]isdone kit[1-9][0-9]isdone'
@@ -480,11 +480,19 @@ else
 	echo " "
 	echo "nm didn't seem to work right."
 	echo "Trying ar instead..."
-	if ar t $libc | sed -e 's/\.o$//' > libc.list; then
+	rmlist="$rmlist libc.tmp"
+	if ar t $libc > libc.tmp; then
+	    sed -e 's/\.o$//' < libc.tmp > libc.list
 	    echo "Ok."
 	else
-	    echo "That didn't work either.  Giving up."
-	    exit 1
+	    echo "ar didn't seem to work right."
+	    echo "Maybe this is a Cray...trying bld instead..."
+	    if bld t $libc | sed -e 's/.*\///' -e 's/\.o:.*$//' > libc.list; then
+		echo "Ok."
+	    else
+	    	echo "That didn't work either.  Giving up."
+	    	exit 1
+	    fi
 	fi
     fi
 fi
@@ -621,42 +629,42 @@ ABC.XYZ
 EOT
 echo 'Maybe "'$cpp'" will work...'
 $cpp <testcpp.c >testcpp.out 2>&1
-if $contains 'abc.xyz' testcpp.out >/dev/null 2>&1 ; then
+if $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then
     echo "Yup, it does."
     cppstdin="$cpp"
     cppminus='';
 else
     echo 'Nope, maybe "'$cpp' -" will work...'
     $cpp - <testcpp.c >testcpp.out 2>&1
-    if $contains 'abc.xyz' testcpp.out >/dev/null 2>&1 ; then
+    if $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then
 	echo "Yup, it does."
 	cppstdin="$cpp"
 	cppminus='-';
     else
 	echo 'No such luck...maybe "cc -E" will work...'
 	cc -E <testcpp.c >testcpp.out 2>&1
-	if $contains 'abc.xyz' testcpp.out >/dev/null 2>&1 ; then
+	if $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then
 	    echo "It works!"
 	    cppstdin='cc -E'
 	    cppminus='';
 	else
 	    echo 'Nixed again...maybe "cc -E -" will work...'
 	    cc -E - <testcpp.c >testcpp.out 2>&1
-	    if $contains 'abc.xyz' testcpp.out >/dev/null 2>&1 ; then
+	    if $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then
 		echo "Hooray, it works!  I was beginning to wonder."
 		cppstdin='cc -E'
 		cppminus='-';
 	    else
 		echo 'Nope...maybe "cc -P" will work...'
 		cc -P <testcpp.c >testcpp.out 2>&1
-		if $contains 'abc.xyz' testcpp.out >/dev/null 2>&1 ; then
+		if $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then
 		    echo "Yup, that does."
 		    cppstdin='cc -P'
 		    cppminus='';
 		else
 		    echo 'Nope...maybe "cc -P -" will work...'
 		    cc -P - <testcpp.c >testcpp.out 2>&1
-		    if $contains 'abc.xyz' testcpp.out >/dev/null 2>&1 ; then
+		    if $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then
 			echo "Yup, that does."
 			cppstdin='cc -P'
 			cppminus='-';
@@ -666,7 +674,7 @@ else
 			'') ;;
 			*) $cppstdin $cppminus <testcpp.c >testcpp.out 2>&1;;
 			esac
-			if $contains 'abc.xyz' testcpp.out >/dev/null 2>&1 ; then
+			if $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then
 			    echo "Hooray, you did!  I was beginning to wonder."
 			else
 			    echo 'Uh-uh.  Time to get fancy...'
@@ -674,7 +682,7 @@ else
 			    cppstdin='(cat >/tmp/$$.c; cc -E /tmp/$$.c; rm /tmp/$$.c)'
 			    cppminus='';
 			    $cppstdin <testcpp.c >testcpp.out 2>&1
-			    if $contains 'abc.xyz' testcpp.out >/dev/null 2>&1 ; then
+			    if $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then
 				echo "Eureka!."
 			    else
 				dflt=blurfl
@@ -683,7 +691,7 @@ else
 				. myread
 				cppstdin="$ans"
 				$cppstdin <testcpp.c >testcpp.out 2>&1
-				if $contains 'abc.xyz' testcpp.out >/dev/null 2>&1 ; then
+				if $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then
 				    echo "OK, that will do."
 				else
 				    echo "Sorry, I can't get that to work.  Go find one."
@@ -733,6 +741,37 @@ else
     d_crypt="$undef"
 fi
 
+: now see if they want to do setuid emulation
+case "$d_dosuid" in
+'') if bsd; then
+	dflt=y
+    else
+	dflt=n
+    fi
+    ;;
+*undef*) dflt=n;;
+*) dflt=y;;
+esac
+cat <<EOM
+ 
+Some sites have disabled setuid #! scripts because of a bug in the kernel
+that prevents them from being secure.  If you are on such a system, the
+setuid/setgid bits on scripts are currently useless.  It is possible for
+$package to detect those bits and emulate setuid/setgid in a secure fashion
+until a better solution is devised for the kernel problem.
+
+EOM
+rp="Do you want to do setuid/setgid emulation? [$dflt]"
+echo $n "$rp $c"
+. myread
+case "$ans" in
+'') $ans="$dflt";;
+esac
+case "$ans" in
+y*)  d_dosuid="$define";;
+*) d_dosuid="$undef";;
+esac
+
 : see if fchmod exists
 echo " "
 if $contains '^fchmod$' libc.list >/dev/null 2>&1; then
@@ -1334,8 +1373,8 @@ none)
 *split)
     case "$split" in
     '') 
-	if $contains '-i' $mansrc/ld.1 >/dev/null 2>&1 || \
-	   $contains '-i' $mansrc/cc.1 >/dev/null 2>&1; then
+	if $contains '\-i' $mansrc/ld.1 >/dev/null 2>&1 || \
+	   $contains '\-i' $mansrc/cc.1 >/dev/null 2>&1; then
 	    dflt='-i'
 	else
 	    dflt='none'
@@ -1594,6 +1633,7 @@ cppminus='$cppminus'
 d_bcopy='$d_bcopy'
 d_charsprf='$d_charsprf'
 d_crypt='$d_crypt'
+d_dosuid='$d_dosuid'
 d_fchmod='$d_fchmod'
 d_fchown='$d_fchown'
 d_getgrps='$d_getgrps'
@@ -1643,7 +1683,7 @@ defvoidused='$defvoidused'
 privlib='$privlib'
 CONFIG=true
 EOT
- 
+
 CONFIG=true
 
 echo " "
@@ -1716,5 +1756,8 @@ else
 fi
 
 $rm -f kit*isdone
+: the following is currently useless
 cd UU && $rm -f $rmlist
+: since this removes it all anyway
+cd .. && $rm -rf UU
 : end of Configure
diff --git a/Makefile.SH b/Makefile.SH
index 25ad1f838b..931a3af78c 100644
--- a/Makefile.SH
+++ b/Makefile.SH
@@ -18,11 +18,20 @@ case "$d_symlink" in
 *) sln='ln';;
 esac
 
+case "$d_dosuid" in
+*define*) suidperl='suidperl' ;;
+*) suidperl='';;
+esac
+
 echo "Extracting Makefile (with variable substitutions)"
 cat >Makefile <<!GROK!THIS!
-# $Header: Makefile.SH,v 2.0 88/06/05 00:07:54 root Exp $
+# $Header: Makefile.SH,v 2.0.1.1 88/06/28 16:26:04 root Exp $
 #
 # $Log:	Makefile.SH,v $
+# Revision 2.0.1.1  88/06/28  16:26:04  root
+# patch1: support for DOSUID
+# patch1: realclean now knows about ~ extension
+# 
 # Revision 2.0  88/06/05  00:07:54  root
 # Baseline version 2.0.
 # 
@@ -42,12 +51,12 @@ mallocobj = $mallocobj
 SLN = $sln
 
 libs = $libnm -lm
-!GROK!THIS!
 
-cat >>Makefile <<'!NO!SUBS!'
+public = perl perldb $suidperl
 
-public = perl perldb
+!GROK!THIS!
 
+cat >>Makefile <<'!NO!SUBS!'
 private = 
 
 manpages = perl.man perldb.man
@@ -67,7 +76,7 @@ c2 = perly.c regexp.c stab.c str.c toke.c util.c version.c
 c = $(c1) $(c2)
 
 obj1 = arg.o array.o cmd.o dump.o eval.o form.o hash.o $(mallocobj)
-obj2 = perly.o regexp.o stab.o str.o toke.o util.o version.o
+obj2 = regexp.o stab.o str.o toke.o util.o version.o
 
 obj = $(obj1) $(obj2)
 
@@ -84,8 +93,28 @@ SHELL = /bin/sh
 all: $(public) $(private) $(util)
 	touch all
 
-perl: $(obj) perl.o
-	$(CC) $(LDFLAGS) $(LARGE) $(obj) perl.o $(libs) -o perl
+perl: perly.o $(obj) perl.o
+	$(CC) $(LDFLAGS) $(LARGE) perly.o $(obj) perl.o $(libs) -o perl
+
+!NO!SUBS!
+
+case "$d_dosuid" in
+*define*)
+    cat >>Makefile <<'!NO!SUBS!'
+
+suidperl: sperly.o $(obj) perl.o
+	$(CC) $(LDFLAGS) $(LARGE) sperly.o $(obj) perl.o $(libs) -o suidperl
+
+sperly.o: perly.c
+	/bin/rm -f sperly.c
+	ln perly.c sperly.c
+	$(CC) -c -DIAMSUID $(CFLAGS) $(LARGE) sperly.c
+	/bin/rm -f sperly.c
+!NO!SUBS!
+    ;;
+esac
+
+cat >>Makefile <<'!NO!SUBS!'
 
 perl.c perly.h: perl.y
 	@ echo Expect 37 shift/reduce errors...
@@ -108,10 +137,21 @@ install: perl perl.man
 	export PATH || exit 1
 	- mv $(bin)/perl $(bin)/perl.old 2>/dev/null
 	- if test `pwd` != $(bin); then cp $(public) $(bin); fi
-	cd $(bin); \
+	- cd $(bin); \
 for pub in $(public); do \
 chmod +x `basename $$pub`; \
 done
+!NO!SUBS!
+
+case "$d_dosuid" in
+*define*)
+    cat >>Makefile <<'!NO!SUBS!'
+	- chmod 4711 $(bin)/suidperl 2>/dev/null
+!NO!SUBS!
+    ;;
+esac
+
+cat >>Makefile <<'!NO!SUBS!'
 	- test $(bin) = /usr/bin || rm -f /usr/bin/perl
 	- test $(bin) = /usr/bin || $(SLN) $(bin)/perl /usr/bin || cp $(bin)/perl /usr/bin
 	chmod +x makedir
@@ -134,7 +174,7 @@ clean:
 	rm -f *.o
 
 realclean:
-	rm -f perl *.orig */*.orig *.o core $(addedbyconf)
+	rm -f perl *.orig */*.orig *~ */*~ *.o core $(addedbyconf)
 
 # The following lint has practically everything turned on.  Unfortunately,
 # you have to wade through a lot of mumbo jumbo that can't be suppressed.
@@ -163,7 +203,7 @@ shlist:
 	echo $(sh) | tr ' ' '\012' >.shlist
 
 # AUTOMATICALLY GENERATED MAKE DEPENDENCIES--PUT NOTHING BELOW THIS LINE
-$(obj):
+perly.o $(obj):
 	@ echo "You haven't done a "'"make depend" yet!'; exit 1
 makedepend: makedepend.SH
 	/bin/sh makedepend.SH
diff --git a/config.h.SH b/config.h.SH
index d26f8422f7..bb4b62bc72 100644
--- a/config.h.SH
+++ b/config.h.SH
@@ -11,7 +11,7 @@ case $CONFIG in
     ;;
 esac
 echo "Extracting config.h (with variable substitutions)"
-cat <<!GROK!THIS! >config.h
+sed <<!GROK!THIS! >config.h -e 's!^#undef!/\*#undef!'
 /* config.h
  * This file was produced by running the config.h.SH script, which
  * gets its values from config.sh, which is generally produced by
@@ -71,6 +71,21 @@ cat <<!GROK!THIS! >config.h
  */
 #$d_crypt	CRYPT		/**/
 
+/* DOSUID:
+ *	This symbol, if defined, indicates that the C program should
+ *	check the script that it is executing for setuid/setgid bits, and
+ *	attempt to emulate setuid/setgid on systems that have disabled
+ *	setuid #! scripts because the kernel can't do it securely.
+ *	It is up to the package designer to make sure that this emulation
+ *	is done securely.  Among other things, it should do an fstat on
+ *	the script it just opened to make sure it really is a setuid/setgid
+ *	script, it should make sure the arguments passed correspond exactly
+ *	to the argument on the #! line, and it should not trust any
+ *	subprocesses to which it must pass the filename rather than the
+ *	file descriptor of the script to be executed.
+ */
+#$d_dosuid DOSUID		/**/
+
 /* FCHMOD:
  *	This symbol, if defined, indicates that the fchmod routine is available
  *	to change mode of opened files.  If unavailable, use chmod().
diff --git a/patchlevel.h b/patchlevel.h
index 935ec354b7..110c86f392 100644
--- a/patchlevel.h
+++ b/patchlevel.h
@@ -1 +1 @@
-#define PATCHLEVEL 0
+#define PATCHLEVEL 1
diff --git a/perl.man.1 b/perl.man.1
index 75fac69f37..3a4db8beb1 100644
--- a/perl.man.1
+++ b/perl.man.1
@@ -1,7 +1,11 @@
 .rn '' }`
-''' $Header: perl.man.1,v 2.0 88/06/05 00:09:23 root Exp $
+''' $Header: perl.man.1,v 2.0.1.1 88/06/28 16:28:09 root Exp $
 ''' 
 ''' $Log:	perl.man.1,v $
+''' Revision 2.0.1.1  88/06/28  16:28:09  root
+''' patch1: fixed some quotes
+''' patch1: clarified syntax of LIST
+''' 
 ''' Revision 2.0  88/06/05  00:09:23  root
 ''' Baseline version 2.0.
 ''' 
@@ -292,7 +296,7 @@ the variable $running_under_some_shell is never true.
 .TP 5
 .B \-U
 allows perl to do unsafe operations.
-Currently the only "unsafe" operation is the unlinking of directories while
+Currently the only \*(L"unsafe\*(R" operation is the unlinking of directories while
 running as superuser.
 .TP 5
 .B \-v
@@ -731,8 +735,8 @@ is the same as
 .PP
 The foreach loop iterates over a normal array value and sets the variable
 VAR to be each element of the array in turn.
-The "foreach" keyword is actually identical to the "for" keyword,
-so you can use "foreach" for readability or "for" for brevity.
+The \*(L"foreach\*(R" keyword is actually identical to the \*(L"for\*(R" keyword,
+so you can use \*(L"foreach\*(R" for readability or \*(L"for\*(R" for brevity.
 If VAR is omitted, $_ is set to each value.
 If ARRAY is an actual array (as opposed to an expression returning an array
 value), you can modify each element of the array
@@ -909,8 +913,8 @@ AFTER which the range operator becomes false again.
 (It doesn't become false till the next time the range operator evaluated.
 It can become false on the same evaluation it became true, but it still returns
 true once.)
-The right operand is not evaluated while the operator is in the "false" state,
-and the left operand is not evaluated while the operator is in the "true" state.
+The right operand is not evaluated while the operator is in the \*(L"false\*(R" state,
+and the left operand is not evaluated while the operator is in the \*(L"true\*(R" state.
 The .. operator is primarily intended for doing line number ranges after
 the fashion of \fIsed\fR or \fIawk\fR.
 The precedence is a little lower than || and &&.
@@ -1057,6 +1061,7 @@ Some of these operations take a LIST as an argument.
 Such a list can consist of any combination of scalar arguments or arrays;
 the arrays will be included in the list as if each individual element were
 interpolated at that point in the list.
+Elements of the LIST should be separated by commas.
 .Ip "/PATTERN/i" 8 4
 Searches a string for a pattern, and returns true (1) or false ('').
 If no string is specified via the =~ or !~ operator,
@@ -1234,9 +1239,9 @@ Equivalent examples:
 If the value of EXPR does not end in a newline, the current script line
 number and input line number (if any) are also printed, and a newline is
 supplied.
-Hint: sometimes appending ", stopped" to your message will cause it to make
-better sense when the string "at foo line 123" is appended.
-Suppose you are running script "canasta".
+Hint: sometimes appending \*(L", stopped\*(R" to your message will cause it to make
+better sense when the string \*(L"at foo line 123\*(R" is appended.
+Suppose you are running script \*(L"canasta\*(R".
 .nf
 
 .ne 7
@@ -1267,7 +1272,7 @@ 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 next form of "do".
+The parentheses are required to avoid confusion with the next form of \*(L"do\*(R".
 .Ip "do EXPR" 8 3
 Uses the value of EXPR as a filename and executes the contents of the file
 as a perl script.
@@ -1287,7 +1292,7 @@ It's the same, however, in that it does reparse the file every time you
 call it, so if you are going to use the file inside a loop you might prefer
 to use #include, at the expense of a little more startup time.
 (The main problem with #include is that cpp doesn't grok # comments--a
-workaround is to use ";#" for standalone comments.)
+workaround is to use \*(L";#\*(R" for standalone comments.)
 Note that the following are NOT equivalent:
 .nf
 
diff --git a/perl.man.2 b/perl.man.2
index be2e4a9e73..9abd3901f3 100644
--- a/perl.man.2
+++ b/perl.man.2
@@ -1,7 +1,13 @@
 ''' Beginning of part 2
-''' $Header: perl.man.2,v 2.0 88/06/05 00:09:30 root Exp $
+''' $Header: perl.man.2,v 2.0.1.1 88/06/28 16:31:49 root Exp $
 '''
 ''' $Log:	perl.man.2,v $
+''' Revision 2.0.1.1  88/06/28  16:31:49  root
+''' patch1: fixed some quotes
+''' patch1: clarified semantics of study
+''' patch1: added example of y with short second string
+''' patch1: added example of unlink with <*>
+''' 
 ''' Revision 2.0  88/06/05  00:09:30  root
 ''' Baseline version 2.0.
 ''' 
@@ -99,7 +105,7 @@ Returns 1 for success, 0 otherwise.
 .Ip "local(LIST)" 8 4
 Declares the listed (scalar) variables to be local to the enclosing block,
 subroutine or eval.
-(The "do 'filename';" operator also counts as an eval.)
+(The \*(L"do 'filename';\*(R" operator also counts as an eval.)
 This operator works by saving the current values of those variables in LIST
 on a hidden stack and restoring them upon exiting the block, subroutine or eval.
 The LIST may be assigned to if desired, which allows you to initialize
@@ -226,7 +232,7 @@ Examples:
 
 .fi
 You may also, in the Bourne shell tradition, specify an EXPR beginning
-with ">&", in which case the rest of the string
+with \*(L">&\*(R", in which case the rest of the string
 is interpreted as the name of a filehandle
 (or file descriptor, if numeric) which is to be duped and opened.
 Here is a script that saves, redirects, and restores stdout and stdin:
@@ -256,7 +262,7 @@ Here is a script that saves, redirects, and restores stdout and stdin:
 	print stderr "stderr 2\en";
 
 .fi
-If you open a pipe on the command "-", i.e. either "|-" or "-|",
+If you open a pipe on the command \*(L"-\*(R", i.e. either \*(L"|-\*(R" or \*(L"-|\*(R",
 then there is an implicit fork done, and the return value of open
 is the pid of the child within the parent process, and 0 within the child
 process.
@@ -304,7 +310,7 @@ If LIST is also omitted, prints $_ to stdout.
 To set the default output channel to something other than stdout use the select operation.
 .Ip "printf FILEHANDLE LIST" 8 9
 .Ip "printf LIST" 8
-Equivalent to a "print FILEHANDLE sprintf(LIST)".
+Equivalent to a \*(L"print FILEHANDLE sprintf(LIST)\*(R".
 .Ip "push(ARRAY,LIST)" 8 7
 Treats ARRAY (@ is optional) as a stack, and pushes the values of LIST
 onto the end of ARRAY.
@@ -559,11 +565,19 @@ Typically used as follows:
 Takes extra time to study SCALAR ($_ if unspecified) in anticipation of
 doing many pattern matches on the string before it is next modified.
 This may or may not save time, depending on the nature and number of patterns
-you are searching on\*(--you probably want to compare runtimes with and
+you are searching on, and on the distribution of character frequencies in
+the string to be searched\*(--you probably want to compare runtimes with and
 without it to see which runs faster.
 Those loops which scan for many short constant strings (including the constant
 parts of more complex patterns) will benefit most.
-For example, a loop which inserts index producing entries before an line
+(The way study works is this: a linked list of every character in the string
+to be searched is made, so we know, for example, where all the `k' characters
+are.
+From each search string, the rarest character is selected, based on some
+static frequency tables constructed from some C programs and English text.
+Only those places that contain this \*(L"rarest\*(R" character are examined.)
+.Sp
+For example, here is a loop which inserts index producing entries before an line
 containing a certain pattern:
 .nf
 
@@ -578,6 +592,37 @@ containing a certain pattern:
 	}
 
 .fi
+In searching for /\ebfoo\eb/, only those locations in $_ that contain `f'
+will be looked at, because `f' is rarer than `o'.
+In general, this is a big win except in pathological cases.
+The only question is whether it saves you more time than it took to build
+the linked list in the first place.
+.Sp
+Note that if you have to look for strings that you don't know till runtime,
+you can build an entire loop as a string and eval that to avoid recompiling
+all your patterns all the time.
+Together with setting $/ to input entire files as one record, this can
+be very fast, often faster than specialized programs like fgrep.
+The following scans a list of files (@files)
+for a list of words (@words), and prints out the names of those files that
+contain a match:
+.nf
+
+.ne 12
+	$search = 'while (<>) { study;';
+	foreach $word (@words) {
+	    $search .= "\e++$seen{\e$ARGV} if /\eb$word\eb/;\en";
+	}
+	$search .= "}";
+	@ARGV = @files;
+	$/ = "\e177";		# something that doesn't occur
+	eval $search;		# this screams
+	$/ = "\en";		# put back to normal input delim
+	foreach $file (sort keys(seen)) {
+	    print $file,"\en";
+	}
+
+.fi
 .Ip "substr(EXPR,OFFSET,LEN)" 8 2
 Extracts a substring out of EXPR and returns it.
 First character is at offset 0, or whatever you've set $[ to.
@@ -639,6 +684,8 @@ Examples:
 
     ($HOST = $host) =~ tr/a-z/A-Z/;
 
+    y/\e001-@[-_{-\e177/ /;	\h'|3i'# change non-alphas to space
+
 .fi
 .Ip "umask(EXPR)" 8 3
 Sets the umask for the process and returns the old one.
@@ -650,6 +697,7 @@ Returns the number of files successfully deleted.
 .ne 2
 	$cnt = unlink 'a','b','c';
 	unlink @goners;
+	unlink <*.bak>;
 
 .fi
 Note: unlink will not delete directories unless you are superuser and the \-U
@@ -671,7 +719,7 @@ The first two elements of the list must be the NUMERICAL access and
 modification times, in that order.
 Returns the number of files successfully changed.
 The inode modification time of each file is set to the current time.
-Example of a "touch" command:
+Example of a \*(L"touch\*(R" command:
 .nf
 
 .ne 3
@@ -769,7 +817,7 @@ Any arguments passed to the routine come in as array @_,
 that is ($_[0], $_[1], .\|.\|.).
 The return value of the subroutine is the value of the last expression
 evaluated.
-To create local variables see the "local" operator.
+To create local variables see the \*(L"local\*(R" operator.
 .PP
 A subroutine is called using the
 .I do
@@ -830,7 +878,7 @@ The patterns used in pattern matching are regular expressions such as
 those supplied in the Version 8 regexp routines.
 (In fact, the routines are derived from Henry Spencer's freely redistributable
 reimplementation of the V8 routines.)
-In addition, \ew matches an alphanumeric character (including "_") and \eW a nonalphanumeric.
+In addition, \ew matches an alphanumeric character (including \*(L"_\*(R") and \eW a nonalphanumeric.
 Word boundaries may be matched by \eb, and non-boundaries by \eB.
 A whitespace character is matched by \es, non-whitespace by \eS.
 A numeric character is matched by \ed, non-numeric by \eD.
@@ -1011,7 +1059,7 @@ field and forgetting to zero it.
 The following names have special meaning to
 .IR perl .
 I could have used alphabetic symbols for some of these, but I didn't want
-to take the chance that someone would say reset "a-zA-Z" and wipe them all
+to take the chance that someone would say reset \*(L"a-zA-Z\*(R" and wipe them all
 out.
 You'll just have to suffer along with these silly symbols.
 Most of them have reasonable mnemonics, or analogues in one of the shells.
@@ -1167,7 +1215,7 @@ to set the exit value for the die operator.
 .Ip $@ 8 2
 The error message from the last eval command.
 If null, the last eval parsed and executed correctly.
-(Mnemonic: Where was the syntax error "at"?)
+(Mnemonic: Where was the syntax error \*(L"at\*(R"?)
 .Ip $< 8 2
 The real uid of this process.
 (Mnemonic: it's the uid you came FROM, if you're running setuid.)
@@ -1206,9 +1254,9 @@ $ARGV[0] is the first argument, NOT the command name.
 See $0 for the command name.
 .Ip @INC 8 3
 The array INC contains the list of places to look for perl scripts to be
-evaluated by the "do EXPR" command.
+evaluated by the \*(L"do EXPR\*(R" command.
 It initially consists of the arguments to any -I command line switches, followed
-by the default perl library, probably "/usr/local/lib/perl".
+by the default perl library, probably \*(L"/usr/local/lib/perl\*(R".
 .Ip $ENV{expr} 8 2
 The associative array ENV contains your current environment.
 Setting a value in ENV changes the environment for child processes.
diff --git a/perly.c b/perly.c
index ace93d0790..bedc75dfbb 100644
--- a/perly.c
+++ b/perly.c
@@ -1,6 +1,9 @@
-char rcsid[] = "$Header: perly.c,v 2.0 88/06/05 00:09:56 root Exp $";
+char rcsid[] = "$Header: perly.c,v 2.0.1.1 88/06/28 16:36:49 root Exp $";
 /*
  * $Log:	perly.c,v $
+ * Revision 2.0.1.1  88/06/28  16:36:49  root
+ * patch1: added DOSUID code
+ * 
  * Revision 2.0  88/06/05  00:09:56  root
  * Baseline version 2.0.
  * 
@@ -26,6 +29,10 @@ register char **env;
     register char *s;
     char *index(), *strcpy(), *getenv();
     bool dosearch = FALSE;
+#ifdef DOSUID
+    char **origargv = argv;
+    char *validarg = "";
+#endif
 
     uid = (int)getuid();
     euid = (int)geteuid();
@@ -36,15 +43,22 @@ register char **env;
     for (argc--,argv++; argc; argc--,argv++) {
 	if (argv[0][0] != '-' || !argv[0][1])
 	    break;
+#ifdef DOSUID
+    if (*validarg)
+	validarg = " PHOOEY ";
+    else
+	validarg = argv[0];
+#endif
+	s = argv[0]+1;
       reswitch:
-	switch (argv[0][1]) {
+	switch (*s) {
 	case 'a':
 	    minus_a = TRUE;
-	    strcpy(argv[0], argv[0]+1);
+	    s++;
 	    goto reswitch;
 #ifdef DEBUGGING
 	case 'D':
-	    debug = atoi(argv[0]+2);
+	    debug = atoi(s+1);
 #ifdef YYDEBUG
 	    yydebug = (debug & 1);
 #endif
@@ -62,14 +76,15 @@ register char **env;
 	    argc--,argv++;
 	    break;
 	case 'i':
-	    inplace = savestr(argv[0]+2);
+	    inplace = savestr(s+1);
 	    argvoutstab = stabent("ARGVOUT",TRUE);
 	    break;
 	case 'I':
-	    str_cat(str,argv[0]);
+	    str_cat(str,"-");
+	    str_cat(str,s);
 	    str_cat(str," ");
-	    if (argv[0][2]) {
-		apush(incstab->stab_array,str_make(argv[0]+2));
+	    if (s[1]) {
+		apush(incstab->stab_array,str_make(s+1));
 	    }
 	    else {
 		apush(incstab->stab_array,str_make(argv[1]));
@@ -80,34 +95,34 @@ register char **env;
 	    break;
 	case 'n':
 	    minus_n = TRUE;
-	    strcpy(argv[0], argv[0]+1);
+	    s++;
 	    goto reswitch;
 	case 'p':
 	    minus_p = TRUE;
-	    strcpy(argv[0], argv[0]+1);
+	    s++;
 	    goto reswitch;
 	case 'P':
 	    preprocess = TRUE;
-	    strcpy(argv[0], argv[0]+1);
+	    s++;
 	    goto reswitch;
 	case 's':
 	    doswitches = TRUE;
-	    strcpy(argv[0], argv[0]+1);
+	    s++;
 	    goto reswitch;
 	case 'S':
 	    dosearch = TRUE;
-	    strcpy(argv[0], argv[0]+1);
+	    s++;
 	    goto reswitch;
 	case 'U':
 	    unsafe = TRUE;
-	    strcpy(argv[0], argv[0]+1);
+	    s++;
 	    goto reswitch;
 	case 'v':
 	    version();
 	    exit(0);
 	case 'w':
 	    dowarn = TRUE;
-	    strcpy(argv[0], argv[0]+1);
+	    s++;
 	    goto reswitch;
 	case '-':
 	    argc--,argv++;
@@ -115,7 +130,7 @@ register char **env;
 	case 0:
 	    break;
 	default:
-	    fatal("Unrecognized switch: %s",argv[0]);
+	    fatal("Unrecognized switch: -%s",s);
 	}
     }
   switch_end:
@@ -186,16 +201,103 @@ register char **env;
  -e 's/^#.*//' \
  %s | %s -C %s %s",
 	  argv[0], CPPSTDIN, str_get(str), CPPMINUS);
+#ifdef IAMSUID
+	if (euid != uid && !euid)	/* if running suidperl */
+	    seteuid(uid);		/* musn't stay setuid root */
+#endif
 	rsfp = popen(buf,"r");
     }
     else if (!*argv[0])
 	rsfp = stdin;
     else
 	rsfp = fopen(argv[0],"r");
-    if (rsfp == Nullfp)
+    if (rsfp == Nullfp) {
+#ifdef DOSUID
+#ifndef IAMSUID
+	if (euid && stat(filename,&statbuf) >= 0 &&
+	  statbuf.st_mode & (S_ISUID|S_ISGID)) {
+	    execvp("suidperl", origargv);	/* try again */
+	    fatal("Can't do setuid\n");
+	}
+#endif
+#endif
 	fatal("Perl script \"%s\" doesn't seem to exist",filename);
+    }
     str_free(str);		/* free -I directories */
 
+    /* do we need to emulate setuid on scripts? */
+
+    /* This code is for those BSD systems that have setuid #! scripts disabled
+     * in the kernel because of a security problem.  Merely defining DOSUID
+     * in perl will not fix that problem, but if you have disabled setuid
+     * scripts in the kernel, this will attempt to emulate setuid and setgid
+     * on scripts that have those now-otherwise-useless bits set.  The setuid
+     * root version must be called suidperl.  If regular perl discovers that
+     * it has opened a setuid script, it calls suidperl with the same argv
+     * that it had.  If suidperl finds that the script it has just opened
+     * is NOT setuid root, it sets the effective uid back to the uid.  We
+     * don't just make perl setuid root because that loses the effective
+     * uid we had before invoking perl, if it was different from the uid.
+     *
+     * DOSUID must be defined in both perl and suidperl, and IAMSUID must
+     * be defined in suidperl only.  suidperl must be setuid root.  The
+     * Configure script will set this up for you if you want it.
+     */
+#ifdef DOSUID
+    if (fstat(fileno(rsfp),&statbuf) < 0)	/* normal stat is insecure */
+	fatal("Can't stat script \"%s\"",filename);
+    if (statbuf.st_mode & (S_ISUID|S_ISGID)) {
+	int len;
+
+	if (access(filename,1))		/* as a double check */
+	    fatal("Permission denied");
+	if ((statbuf.st_mode & S_IFMT) != S_IFREG)
+	    fatal("Permission denied");
+	doswitches = FALSE;		/* -s is insecure in suid */
+	line++;
+	if (fgets(tokenbuf,sizeof tokenbuf, rsfp) == Nullch ||
+	  strnNE(tokenbuf,"#!",2) )	/* required even on Sys V */
+	    fatal("No #! line");
+	for (s = tokenbuf+2; !isspace(*s); s++) ;
+	if (strnNE(s-4,"perl",4))	/* sanity check */
+	    fatal("Not a perl script");
+	while (*s && isspace(*s)) s++;
+	/*
+	 * #! arg must be what we saw above.  They can invoke it by
+	 * mentioning suidperl explicitly, but they may not add any strange
+	 * arguments beyond what #! says if they do invoke suidperl that way.
+	 */
+	len = strlen(validarg);
+	if (strEQ(validarg," PHOOEY ") ||
+	    strnNE(s,validarg,len) || !isspace(s[len]))
+	    fatal("Arg must be \"%s\"\n",s);
+
+	if (euid) {	/* oops, we're not the setuid root perl */
+	    fclose(rsfp);
+#ifndef IAMSUID
+	    execvp("suidperl", origargv);	/* try again */
+#endif
+	    fatal("Can't do setuid\n");
+	}
+
+	if (statbuf.st_mode & S_ISUID && statbuf.st_uid != euid)
+	    seteuid(statbuf.st_uid);	/* all that for this */
+	else if (uid)			/* oops, mustn't run as root */
+	    seteuid(uid);
+	if (statbuf.st_mode & S_ISGID && statbuf.st_gid != getegid())
+	    setegid(statbuf.st_gid);
+	euid = (int)geteuid();
+	if (!cando(S_IEXEC,TRUE))
+	    fatal("Permission denied\n");	/* they can't do this */
+    }
+#ifdef IAMSUID
+    else if (preprocess)
+	fatal("-P not allowed for setuid/setgid script\n");
+    else
+	fatal("Script is not setuid/setgid in suidperl\n");
+#endif /* IAMSUID */
+#endif /* DOSUID */
+
     defstab = stabent("_",TRUE);
 
     /* init tokener */
diff --git a/regexp.c b/regexp.c
index dde700ca9c..5b0e7b21de 100644
--- a/regexp.c
+++ b/regexp.c
@@ -7,9 +7,12 @@
  * blame Henry for some of the lack of readability.
  */
 
-/* $Header: regexp.c,v 2.0 88/06/05 00:10:45 root Exp $
+/* $Header: regexp.c,v 2.0.1.1 88/06/28 16:37:19 root Exp $
  *
  * $Log:	regexp.c,v $
+ * Revision 2.0.1.1  88/06/28  16:37:19  root
+ * patch1: removed redundant debugging code
+ * 
  * Revision 2.0  88/06/05  00:10:45  root
  * Baseline version 2.0.
  * 
@@ -398,11 +401,6 @@ int rare;
 			if (len > !(sawstudy))
 				fbmcompile(r->regmust);
 			*(long*)&r->regmust->str_nval = 100;
-#ifdef DEBUGGING
-			if (debug & 512)
-			    fprintf(stderr,"must = '%s' back=%d\n",
-				longest,back);
-#endif
 		}
 		else
 			str_free(longest);
diff --git a/str.c b/str.c
index 3175e91d0a..d7cacdad97 100644
--- a/str.c
+++ b/str.c
@@ -1,6 +1,9 @@
-/* $Header: str.c,v 2.0 88/06/05 00:11:07 root Exp $
+/* $Header: str.c,v 2.0.1.1 88/06/28 16:38:11 root Exp $
  *
  * $Log:	str.c,v $
+ * Revision 2.0.1.1  88/06/28  16:38:11  root
+ * patch1: autoincrement of '' didn't work right.
+ * 
  * Revision 2.0  88/06/05  00:11:07  root
  * Baseline version 2.0.
  * 
@@ -468,6 +471,7 @@ register STR *str;
     if (!str->str_pok || !*str->str_ptr) {
 	str->str_nval = 1.0;
 	str->str_nok = 1;
+	str->str_pok = 0;
 	return;
     }
     d = str->str_ptr;
diff --git a/toke.c b/toke.c
index 912945adbb..35be332ea8 100644
--- a/toke.c
+++ b/toke.c
@@ -1,6 +1,9 @@
-/* $Header: toke.c,v 2.0 88/06/05 00:11:16 root Exp $
+/* $Header: toke.c,v 2.0.1.1 88/06/28 16:39:50 root Exp $
  *
  * $Log:	toke.c,v $
+ * Revision 2.0.1.1  88/06/28  16:39:50  root
+ * patch1: tr/x/y/ can dump core if y is shorter than x
+ * 
  * Revision 2.0  88/06/05  00:11:16  root
  * Baseline version 2.0.
  * 
@@ -922,6 +925,7 @@ register char *s;
     register char *r;
     register char *tbl = safemalloc(256);
     register int i;
+    register int j;
 
     arg[2].arg_type = A_NULL;
     arg[2].arg_ptr.arg_cval = tbl;
@@ -942,10 +946,10 @@ register char *s;
 	safefree(r);
 	r = t;
     }
-    for (i = 0; t[i]; i++) {
-	if (!r[i])
-	    r[i] = r[i-1];
-	tbl[t[i] & 0377] = r[i];
+    for (i = 0, j = 0; t[i]; i++,j++) {
+	if (!r[j])
+	    --j;
+	tbl[t[i] & 0377] = r[j];
     }
     if (r != t)
 	safefree(r);