From @uunet.uu.net:root@jpl-devvax.jpl.nasa.gov Tue Jun 28 21:10:41 1988
Received: from BBN.COM by pineapple.bbn.com id AA10547; Tue, 28 Jun 88 21:09:08 EDT
Received: from uunet.uu.net by BBN.COM id aa01770; 28 Jun 88 20:43 EDT
Received: from elroy.jpl.nasa.gov by uunet.UU.NET (5.59/1.14) 
	id AA04557; Tue, 28 Jun 88 20:37:37 EDT
Received: from devvax.Jpl.Nasa.Gov (jpl-devvax.jpl.nasa.gov) by elroy.jpl.nasa.gov (4.0/SMI-4.0+DXR)
	id AA00556; Tue, 28 Jun 88 17:34:47 PDT
Received: by devvax.Jpl.Nasa.Gov (5.51/4.7)
	id AA25520; Tue, 28 Jun 88 17:34:14 PDT
Date: Tue, 28 Jun 88 17:34:14 PDT
From: root@jpl-devvax.jpl.nasa.gov (The Superuser)
Message-Id: <8806290034.AA25520@devvax.Jpl.Nasa.Gov>
Subject: perl 2.0 patch #1
Organization: Jet Propulsion Laboratory, Pasadena, CA
Apparently-To: source-patches@uunet.uu.net
Status: R

[The latest patch for perl version 2.0 is #1.]

System: perl version 2.0
Patch #: 1
Priority: MEDIUM
Subject: autoincrement of '' didn't work right.
Subject: tr/x/y/ can dump core if y is shorter than x
Subject: added support for DOSUID
Subject: in Configure, fix for machines that can't do #/*undef
Subject: in Configure, return code from ar was ignored
Subject: in Configure, Cray uses bld instead of ar
Subject: in Configure, Gnucpp adds space after symbol interpolation
Subject: in Configure, grep '-i' should be grep '\-i'
Subject: Configure should remove UU subdirectory entirely
Subject: realclean now knows about ~ extension
Subject: fixed some quotes in manual page
Subject: clarified syntax of LIST in manual page
Subject: clarified semantics of study in manual page
Subject: added example of y with short second string in manual page
Subject: added example of unlink with <*> in manual page
Subject: removed redundant debugging code in regexp.c

Description:
	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/ /.

Fix:	From rn, say "| patch -p -N -d DIR", where DIR is your perl source
	directory.  Outside of rn, say "cd DIR; patch -p -N <thisarticle".
	If you don't have the patch program, apply the following by hand,
	or get patch (version 2.0, latest patchlevel).

	After patching:
		Configure
		make depend
		make
		make test
		make install

	If patch indicates that patchlevel is the wrong version, you may need
	to apply one or more previous patches, or the patch may already
	have been applied.  See the patchlevel.h file to find out what has or
	has not been applied.  In any event, don't continue with the patch.

	If you are missing previous patches they can be obtained from me:

	Larry Wall
	lwall@jpl-devvax.jpl.nasa.gov

	If you send a mail message of the following form it will greatly speed
	processing:

	Subject: Command
	@SH mailpatch PATH perl 2.0 LIST
		   ^ note the c

	where PATH is a return path FROM ME TO YOU either in Internet notation,
	or in bang notation from some well-known host, and LIST is the number
	of one or more patches you need, separated by spaces, commas, and/or
	hyphens.  Saying 35- says everything from 35 to the end.

	You can also get the patches via anonymous FTP from
	jpl-devvax.jpl.nasa.gov (128.149.8.43).

Index: patchlevel.h
Prereq: 0
1c1
< #define PATCHLEVEL 0
---
> #define PATCHLEVEL 1

Index: Configure
Prereq: 2.0
*** Configure.old	Tue Jun 28 16:40:03 1988
--- Configure	Tue Jun 28 16:40:04 1988
***************
*** 8,14 ****
  # 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 $
  #
  # Yes, you may rip this off to use in other distribution packages.
  # (Note: this Configure script was generated automatically.  Rather than
--- 8,14 ----
  # 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.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,81 ****
--- 76,82 ----
  d_bcopy=''
  d_charsprf=''
  d_crypt=''
+ d_dosuid=''
  d_fchmod=''
  d_fchown=''
  d_getgrps=''
***************
*** 124,130 ****
  defvoidused=''
  privlib=''
  CONFIG=''
- 
  : set package name
  package=perl
  
--- 125,130 ----
***************
*** 134,140 ****
  echo " "
  
  define='define'
! 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'
--- 134,140 ----
  echo " "
  
  define='define'
! 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,490 ****
  	echo " "
  	echo "nm didn't seem to work right."
  	echo "Trying ar instead..."
! 	if ar t $libc | sed -e 's/\.o$//' > libc.list; then
  	    echo "Ok."
  	else
! 	    echo "That didn't work either.  Giving up."
! 	    exit 1
  	fi
      fi
  fi
--- 480,498 ----
  	echo " "
  	echo "nm didn't seem to work right."
  	echo "Trying ar instead..."
! 	rmlist="$rmlist libc.tmp"
! 	if ar t $libc > libc.tmp; then
! 	    sed -e 's/\.o$//' < libc.tmp > libc.list
  	    echo "Ok."
  	else
! 	    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,627 ****
  EOT
  echo 'Maybe "'$cpp'" will work...'
  $cpp <testcpp.c >testcpp.out 2>&1
! if $contains 'abc.xyz' testcpp.out >/dev/null 2>&1 ; then
      echo "Yup, it does."
      cppstdin="$cpp"
      cppminus='';
--- 629,635 ----
  EOT
  echo 'Maybe "'$cpp'" will work...'
  $cpp <testcpp.c >testcpp.out 2>&1
! if $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then
      echo "Yup, it does."
      cppstdin="$cpp"
      cppminus='';
***************
*** 628,634 ****
  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
  	echo "Yup, it does."
  	cppstdin="$cpp"
  	cppminus='-';
--- 636,642 ----
  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
  	echo "Yup, it does."
  	cppstdin="$cpp"
  	cppminus='-';
***************
*** 635,641 ****
      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
  	    echo "It works!"
  	    cppstdin='cc -E'
  	    cppminus='';
--- 643,649 ----
      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
  	    echo "It works!"
  	    cppstdin='cc -E'
  	    cppminus='';
***************
*** 642,648 ****
  	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
  		echo "Hooray, it works!  I was beginning to wonder."
  		cppstdin='cc -E'
  		cppminus='-';
--- 650,656 ----
  	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
  		echo "Hooray, it works!  I was beginning to wonder."
  		cppstdin='cc -E'
  		cppminus='-';
***************
*** 649,655 ****
  	    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
  		    echo "Yup, that does."
  		    cppstdin='cc -P'
  		    cppminus='';
--- 657,663 ----
  	    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
  		    echo "Yup, that does."
  		    cppstdin='cc -P'
  		    cppminus='';
***************
*** 656,662 ****
  		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
  			echo "Yup, that does."
  			cppstdin='cc -P'
  			cppminus='-';
--- 664,670 ----
  		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
  			echo "Yup, that does."
  			cppstdin='cc -P'
  			cppminus='-';
***************
*** 666,672 ****
  			'') ;;
  			*) $cppstdin $cppminus <testcpp.c >testcpp.out 2>&1;;
  			esac
! 			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,680 ----
  			'') ;;
  			*) $cppstdin $cppminus <testcpp.c >testcpp.out 2>&1;;
  			esac
! 			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,680 ****
  			    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
  				echo "Eureka!."
  			    else
  				dflt=blurfl
--- 682,688 ----
  			    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
  				echo "Eureka!."
  			    else
  				dflt=blurfl
***************
*** 683,689 ****
  				. myread
  				cppstdin="$ans"
  				$cppstdin <testcpp.c >testcpp.out 2>&1
! 				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."
--- 691,697 ----
  				. myread
  				cppstdin="$ans"
  				$cppstdin <testcpp.c >testcpp.out 2>&1
! 				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,738 ****
--- 741,777 ----
      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,1341 ****
  *split)
      case "$split" in
      '') 
! 	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'
--- 1373,1380 ----
  *split)
      case "$split" in
      '') 
! 	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,1599 ****
--- 1633,1639 ----
  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,1649 ****
  privlib='$privlib'
  CONFIG=true
  EOT
!  
  CONFIG=true
  
  echo " "
--- 1683,1689 ----
  privlib='$privlib'
  CONFIG=true
  EOT
! 
  CONFIG=true
  
  echo " "
***************
*** 1716,1720 ****
--- 1756,1763 ----
  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

Index: Makefile.SH
Prereq: 2.0
*** Makefile.SH.old	Tue Jun 28 16:40:14 1988
--- Makefile.SH	Tue Jun 28 16:40:15 1988
***************
*** 18,28 ****
  *) sln='ln';;
  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 $
  #
  # $Log:	Makefile.SH,v $
  # Revision 2.0  88/06/05  00:07:54  root
  # Baseline version 2.0.
  # 
--- 18,37 ----
  *) 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.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,53 ****
  SLN = $sln
  
  libs = $libnm -lm
- !GROK!THIS!
  
! cat >>Makefile <<'!NO!SUBS!'
  
! public = perl perldb
  
  private = 
  
  manpages = perl.man perldb.man
--- 51,62 ----
  SLN = $sln
  
  libs = $libnm -lm
  
! public = perl perldb $suidperl
  
! !GROK!THIS!
  
+ cat >>Makefile <<'!NO!SUBS!'
  private = 
  
  manpages = perl.man perldb.man
***************
*** 67,73 ****
  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
  
  obj = $(obj1) $(obj2)
  
--- 76,82 ----
  c = $(c1) $(c2)
  
  obj1 = arg.o array.o cmd.o dump.o eval.o form.o hash.o $(mallocobj)
! obj2 = regexp.o stab.o str.o toke.o util.o version.o
  
  obj = $(obj1) $(obj2)
  
***************
*** 84,92 ****
  all: $(public) $(private) $(util)
  	touch all
  
! perl: $(obj) perl.o
! 	$(CC) $(LDFLAGS) $(LARGE) $(obj) perl.o $(libs) -o perl
  
  perl.c perly.h: perl.y
  	@ echo Expect 37 shift/reduce errors...
  	yacc -d perl.y
--- 93,121 ----
  all: $(public) $(private) $(util)
  	touch all
  
! 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...
  	yacc -d perl.y
***************
*** 108,117 ****
  	export PATH || exit 1
  	- mv $(bin)/perl $(bin)/perl.old 2>/dev/null
  	- if test `pwd` != $(bin); then cp $(public) $(bin); fi
! 	cd $(bin); \
  for pub in $(public); do \
  chmod +x `basename $$pub`; \
  done
  	- 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
--- 137,157 ----
  	export PATH || exit 1
  	- mv $(bin)/perl $(bin)/perl.old 2>/dev/null
  	- if test `pwd` != $(bin); then cp $(public) $(bin); fi
! 	- 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,140 ****
  	rm -f *.o
  
  realclean:
! 	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.
--- 174,180 ----
  	rm -f *.o
  
  realclean:
! 	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,169 ****
  	echo $(sh) | tr ' ' '\012' >.shlist
  
  # AUTOMATICALLY GENERATED MAKE DEPENDENCIES--PUT NOTHING BELOW THIS LINE
! $(obj):
  	@ echo "You haven't done a "'"make depend" yet!'; exit 1
  makedepend: makedepend.SH
  	/bin/sh makedepend.SH
--- 203,209 ----
  	echo $(sh) | tr ' ' '\012' >.shlist
  
  # AUTOMATICALLY GENERATED MAKE DEPENDENCIES--PUT NOTHING BELOW THIS LINE
! perly.o $(obj):
  	@ echo "You haven't done a "'"make depend" yet!'; exit 1
  makedepend: makedepend.SH
  	/bin/sh makedepend.SH

Index: config.h.SH
*** config.h.SH.old	Tue Jun 28 16:40:19 1988
--- config.h.SH	Tue Jun 28 16:40:20 1988
***************
*** 11,17 ****
      ;;
  esac
  echo "Extracting config.h (with variable substitutions)"
! cat <<!GROK!THIS! >config.h
  /* 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
--- 11,17 ----
      ;;
  esac
  echo "Extracting config.h (with variable substitutions)"
! 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
***************
*** 70,75 ****
--- 70,90 ----
   *	to encrypt passwords and the like.
   */
  #$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

Index: perl.man.1
Prereq: 2.0
*** perl.man.1.old	Tue Jun 28 16:40:27 1988
--- perl.man.1	Tue Jun 28 16:40:29 1988
***************
*** 1,7 ****
  .rn '' }`
! ''' $Header: perl.man.1,v 2.0 88/06/05 00:09:23 root Exp $
  ''' 
  ''' $Log:	perl.man.1,v $
  ''' Revision 2.0  88/06/05  00:09:23  root
  ''' Baseline version 2.0.
  ''' 
--- 1,11 ----
  .rn '' }`
! ''' $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,298 ****
  .TP 5
  .B \-U
  allows perl to do unsafe operations.
! Currently the only "unsafe" operation is the unlinking of directories while
  running as superuser.
  .TP 5
  .B \-v
--- 296,302 ----
  .TP 5
  .B \-U
  allows perl to do unsafe operations.
! Currently the only \*(L"unsafe\*(R" operation is the unlinking of directories while
  running as superuser.
  .TP 5
  .B \-v
***************
*** 731,738 ****
  .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.
  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
--- 735,742 ----
  .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 \*(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,916 ****
  (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 .. 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 &&.
--- 913,920 ----
  (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 \*(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,1062 ****
--- 1061,1067 ----
  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,1242 ****
  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".
  .nf
  
  .ne 7
--- 1239,1247 ----
  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 \*(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,1273 ****
  (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".
  .Ip "do EXPR" 8 3
  Uses the value of EXPR as a filename and executes the contents of the file
  as a perl script.
--- 1272,1278 ----
  (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 \*(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,1293 ****
  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.)
  Note that the following are NOT equivalent:
  .nf
  
--- 1292,1298 ----
  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 \*(L";#\*(R" for standalone comments.)
  Note that the following are NOT equivalent:
  .nf
  

Index: perl.man.2
Prereq: 2.0
*** perl.man.2.old	Tue Jun 28 16:40:37 1988
--- perl.man.2	Tue Jun 28 16:40:39 1988
***************
*** 1,7 ****
  ''' Beginning of part 2
! ''' $Header: perl.man.2,v 2.0 88/06/05 00:09:30 root Exp $
  '''
  ''' $Log:	perl.man.2,v $
  ''' Revision 2.0  88/06/05  00:09:30  root
  ''' Baseline version 2.0.
  ''' 
--- 1,13 ----
  ''' Beginning of part 2
! ''' $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,105 ****
  .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.)
  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
--- 105,111 ----
  .Ip "local(LIST)" 8 4
  Declares the listed (scalar) variables to be local to the enclosing block,
  subroutine or 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,232 ****
  
  .fi
  You may also, in the Bourne shell tradition, specify an EXPR beginning
! with ">&", 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:
--- 232,238 ----
  
  .fi
  You may also, in the Bourne shell tradition, specify an EXPR beginning
! 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,262 ****
  	print stderr "stderr 2\en";
  
  .fi
! If you open a pipe on the command "-", i.e. either "|-" or "-|",
  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.
--- 262,268 ----
  	print stderr "stderr 2\en";
  
  .fi
! 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,310 ****
  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)".
  .Ip "push(ARRAY,LIST)" 8 7
  Treats ARRAY (@ is optional) as a stack, and pushes the values of LIST
  onto the end of ARRAY.
--- 310,316 ----
  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 \*(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,569 ****
  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
  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
  containing a certain pattern:
  .nf
  
--- 565,583 ----
  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, 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.
! (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,583 ****
--- 592,628 ----
  	}
  
  .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,644 ****
--- 684,691 ----
  
      ($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,655 ****
--- 697,703 ----
  .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,677 ****
  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:
  .nf
  
  .ne 3
--- 719,725 ----
  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 \*(L"touch\*(R" command:
  .nf
  
  .ne 3
***************
*** 769,775 ****
  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.
  .PP
  A subroutine is called using the
  .I do
--- 817,823 ----
  that is ($_[0], $_[1], .\|.\|.).
  The return value of the subroutine is the value of the last expression
  evaluated.
! To create local variables see the \*(L"local\*(R" operator.
  .PP
  A subroutine is called using the
  .I do
***************
*** 830,836 ****
  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.
  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.
--- 878,884 ----
  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 \*(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,1017 ****
  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
  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.
--- 1059,1065 ----
  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 \*(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,1173 ****
  .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"?)
  .Ip $< 8 2
  The real uid of this process.
  (Mnemonic: it's the uid you came FROM, if you're running setuid.)
--- 1215,1221 ----
  .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 \*(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,1214 ****
  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.
  It initially consists of the arguments to any -I command line switches, followed
! by the default perl library, probably "/usr/local/lib/perl".
  .Ip $ENV{expr} 8 2
  The associative array ENV contains your current environment.
  Setting a value in ENV changes the environment for child processes.
--- 1254,1262 ----
  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 \*(L"do EXPR\*(R" command.
  It initially consists of the arguments to any -I command line switches, followed
! 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.

Index: perly.c
Prereq: 2.0
*** perly.c.old	Tue Jun 28 16:40:49 1988
--- perly.c	Tue Jun 28 16:40:51 1988
***************
*** 1,6 ****
! char rcsid[] = "$Header: perly.c,v 2.0 88/06/05 00:09:56 root Exp $";
  /*
   * $Log:	perly.c,v $
   * Revision 2.0  88/06/05  00:09:56  root
   * Baseline version 2.0.
   * 
--- 1,9 ----
! 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,31 ****
--- 29,38 ----
      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,50 ****
      for (argc--,argv++; argc; argc--,argv++) {
  	if (argv[0][0] != '-' || !argv[0][1])
  	    break;
        reswitch:
! 	switch (argv[0][1]) {
  	case 'a':
  	    minus_a = TRUE;
! 	    strcpy(argv[0], argv[0]+1);
  	    goto reswitch;
  #ifdef DEBUGGING
  	case 'D':
! 	    debug = atoi(argv[0]+2);
  #ifdef YYDEBUG
  	    yydebug = (debug & 1);
  #endif
--- 43,64 ----
      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 (*s) {
  	case 'a':
  	    minus_a = TRUE;
! 	    s++;
  	    goto reswitch;
  #ifdef DEBUGGING
  	case 'D':
! 	    debug = atoi(s+1);
  #ifdef YYDEBUG
  	    yydebug = (debug & 1);
  #endif
***************
*** 62,75 ****
  	    argc--,argv++;
  	    break;
  	case 'i':
! 	    inplace = savestr(argv[0]+2);
  	    argvoutstab = stabent("ARGVOUT",TRUE);
  	    break;
  	case 'I':
! 	    str_cat(str,argv[0]);
  	    str_cat(str," ");
! 	    if (argv[0][2]) {
! 		apush(incstab->stab_array,str_make(argv[0]+2));
  	    }
  	    else {
  		apush(incstab->stab_array,str_make(argv[1]));
--- 76,90 ----
  	    argc--,argv++;
  	    break;
  	case 'i':
! 	    inplace = savestr(s+1);
  	    argvoutstab = stabent("ARGVOUT",TRUE);
  	    break;
  	case 'I':
! 	    str_cat(str,"-");
! 	    str_cat(str,s);
  	    str_cat(str," ");
! 	    if (s[1]) {
! 		apush(incstab->stab_array,str_make(s+1));
  	    }
  	    else {
  		apush(incstab->stab_array,str_make(argv[1]));
***************
*** 80,106 ****
  	    break;
  	case 'n':
  	    minus_n = TRUE;
! 	    strcpy(argv[0], argv[0]+1);
  	    goto reswitch;
  	case 'p':
  	    minus_p = TRUE;
! 	    strcpy(argv[0], argv[0]+1);
  	    goto reswitch;
  	case 'P':
  	    preprocess = TRUE;
! 	    strcpy(argv[0], argv[0]+1);
  	    goto reswitch;
  	case 's':
  	    doswitches = TRUE;
! 	    strcpy(argv[0], argv[0]+1);
  	    goto reswitch;
  	case 'S':
  	    dosearch = TRUE;
! 	    strcpy(argv[0], argv[0]+1);
  	    goto reswitch;
  	case 'U':
  	    unsafe = TRUE;
! 	    strcpy(argv[0], argv[0]+1);
  	    goto reswitch;
  	case 'v':
  	    version();
--- 95,121 ----
  	    break;
  	case 'n':
  	    minus_n = TRUE;
! 	    s++;
  	    goto reswitch;
  	case 'p':
  	    minus_p = TRUE;
! 	    s++;
  	    goto reswitch;
  	case 'P':
  	    preprocess = TRUE;
! 	    s++;
  	    goto reswitch;
  	case 's':
  	    doswitches = TRUE;
! 	    s++;
  	    goto reswitch;
  	case 'S':
  	    dosearch = TRUE;
! 	    s++;
  	    goto reswitch;
  	case 'U':
  	    unsafe = TRUE;
! 	    s++;
  	    goto reswitch;
  	case 'v':
  	    version();
***************
*** 107,113 ****
  	    exit(0);
  	case 'w':
  	    dowarn = TRUE;
! 	    strcpy(argv[0], argv[0]+1);
  	    goto reswitch;
  	case '-':
  	    argc--,argv++;
--- 122,128 ----
  	    exit(0);
  	case 'w':
  	    dowarn = TRUE;
! 	    s++;
  	    goto reswitch;
  	case '-':
  	    argc--,argv++;
***************
*** 115,121 ****
  	case 0:
  	    break;
  	default:
! 	    fatal("Unrecognized switch: %s",argv[0]);
  	}
      }
    switch_end:
--- 130,136 ----
  	case 0:
  	    break;
  	default:
! 	    fatal("Unrecognized switch: -%s",s);
  	}
      }
    switch_end:
***************
*** 186,191 ****
--- 201,210 ----
   -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])
***************
*** 192,200 ****
  	rsfp = stdin;
      else
  	rsfp = fopen(argv[0],"r");
!     if (rsfp == Nullfp)
  	fatal("Perl script \"%s\" doesn't seem to exist",filename);
      str_free(str);		/* free -I directories */
  
      defstab = stabent("_",TRUE);
  
--- 211,302 ----
  	rsfp = stdin;
      else
  	rsfp = fopen(argv[0],"r");
!     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);
  

Index: regexp.c
Prereq: 2.0
*** regexp.c.old	Tue Jun 28 16:41:00 1988
--- regexp.c	Tue Jun 28 16:41:02 1988
***************
*** 7,15 ****
   * blame Henry for some of the lack of readability.
   */
  
! /* $Header: regexp.c,v 2.0 88/06/05 00:10:45 root Exp $
   *
   * $Log:	regexp.c,v $
   * Revision 2.0  88/06/05  00:10:45  root
   * Baseline version 2.0.
   * 
--- 7,18 ----
   * blame Henry for some of the lack of readability.
   */
  
! /* $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,408 ****
  			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);
--- 401,406 ----

Index: str.c
Prereq: 2.0
*** str.c.old	Tue Jun 28 16:41:09 1988
--- str.c	Tue Jun 28 16:41:10 1988
***************
*** 1,6 ****
! /* $Header: str.c,v 2.0 88/06/05 00:11:07 root Exp $
   *
   * $Log:	str.c,v $
   * Revision 2.0  88/06/05  00:11:07  root
   * Baseline version 2.0.
   * 
--- 1,9 ----
! /* $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,473 ****
--- 471,477 ----
      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;

Index: toke.c
Prereq: 2.0
*** toke.c.old	Tue Jun 28 16:41:16 1988
--- toke.c	Tue Jun 28 16:41:18 1988
***************
*** 1,6 ****
! /* $Header: toke.c,v 2.0 88/06/05 00:11:16 root Exp $
   *
   * $Log:	toke.c,v $
   * Revision 2.0  88/06/05  00:11:16  root
   * Baseline version 2.0.
   * 
--- 1,9 ----
! /* $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,927 ****
--- 925,931 ----
      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,951 ****
  	safefree(r);
  	r = t;
      }
!     for (i = 0; t[i]; i++) {
! 	if (!r[i])
! 	    r[i] = r[i-1];
! 	tbl[t[i] & 0377] = r[i];
      }
      if (r != t)
  	safefree(r);
--- 946,955 ----
  	safefree(r);
  	r = t;
      }
!     for (i = 0, j = 0; t[i]; i++,j++) {
! 	if (!r[j])
! 	    --j;
! 	tbl[t[i] & 0377] = r[j];
      }
      if (r != t)
  	safefree(r);

