THIS IS A PATCH FOR PERL 5.0.  DO NOT APPLY THIS PATCH TO PERL 4.0.
(See the corresponding Perl 4.0 patch instead.)

Directions:

    cd your_perl5_source_directory
    patch -N <thisfile
    make

Then, as root:

    make install

Then double-check your bin directories to make sure that every file
named suidperl or sperl?.??? has been reinstalled.  If not, fix the
other versions too.

Index: perl.c
*** perl.c.orig	Wed Jun 19 10:00:26 1996
--- perl.c	Wed Jun 19 14:02:14 1996
***************
*** 46,52 ****
  static void init_predump_symbols _((void));
  static void init_stacks _((void));
  static void open_script _((char *, bool, SV *));
! static void validate_suid _((char *));
  
  PerlInterpreter *
  perl_alloc()
--- 46,54 ----
  static void init_predump_symbols _((void));
  static void init_stacks _((void));
  static void open_script _((char *, bool, SV *));
! static void validate_suid _((char *, char *));
! 
! static int fdscript = -1;
  
  PerlInterpreter *
  perl_alloc()
***************
*** 420,426 ****
  
      open_script(scriptname,dosearch,sv);
  
!     validate_suid(validarg);
  
      if (doextract)
  	find_beginning();
--- 422,428 ----
  
      open_script(scriptname,dosearch,sv);
  
!     validate_suid(validarg, scriptname);
  
      if (doextract)
  	find_beginning();
***************
*** 1182,1187 ****
--- 1184,1190 ----
  #endif
  #endif
  
+ 	fputs("\n+ suidperl security patch", stdout);
  	fputs("\n\nCopyright 1987-1996, Larry Wall\n",stdout);
  #ifdef MSDOS
  	fputs("MS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n",
***************
*** 1369,1379 ****
  	scriptname = xfound;
      }
  
      origfilename = savepv(e_fp ? "-e" : scriptname);
      curcop->cop_filegv = gv_fetchfile(origfilename);
      if (strEQ(origfilename,"-"))
  	scriptname = "";
!     if (preprocess) {
  	char *cpp = CPPSTDIN;
  
  	if (strEQ(cpp,"cppstdin"))
--- 1372,1398 ----
  	scriptname = xfound;
      }
  
+     if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
+ 	char *s = scriptname + 8;
+ 	fdscript = atoi(s);
+ 	while (isDIGIT(*s))
+ 	    s++;
+ 	if (*s)
+ 	    scriptname = s + 1;
+     }
+     else
+ 	fdscript = -1;
      origfilename = savepv(e_fp ? "-e" : scriptname);
      curcop->cop_filegv = gv_fetchfile(origfilename);
      if (strEQ(origfilename,"-"))
  	scriptname = "";
!     if (fdscript >= 0) {
! 	rsfp = fdopen(fdscript,"r");
! #if defined(HAS_FCNTL) && defined(F_SETFD)
! 	fcntl(fileno(rsfp),F_SETFD,1);	/* ensure close-on-exec */
! #endif
!     }
!     else if (preprocess) {
  	char *cpp = CPPSTDIN;
  
  	if (strEQ(cpp,"cppstdin"))
***************
*** 1445,1452 ****
  	taint_not("program input from stdin");
  	rsfp = stdin;
      }
!     else
  	rsfp = fopen(scriptname,"r");
      if ((FILE*)rsfp == Nullfp) {
  #ifdef DOSUID
  #ifndef IAMSUID		/* in case script is not readable before setuid */
--- 1464,1475 ----
  	taint_not("program input from stdin");
  	rsfp = stdin;
      }
!     else {
  	rsfp = fopen(scriptname,"r");
+ #if defined(HAS_FCNTL) && defined(F_SETFD)
+ 	fcntl(fileno(rsfp),F_SETFD,1);	/* ensure close-on-exec */
+ #endif
+     }
      if ((FILE*)rsfp == Nullfp) {
  #ifdef DOSUID
  #ifndef IAMSUID		/* in case script is not readable before setuid */
***************
*** 1464,1472 ****
  }
  
  static void
! validate_suid(validarg)
  char *validarg;
  {
      /* do we need to emulate setuid on scripts? */
  
      /* This code is for those BSD systems that have setuid #! scripts disabled
--- 1487,1498 ----
  }
  
  static void
! validate_suid(validarg, scriptname)
  char *validarg;
+ char *scriptname;
  {
+     int which;
+ 
      /* do we need to emulate setuid on scripts? */
  
      /* This code is for those BSD systems that have setuid #! scripts disabled
***************
*** 1492,1498 ****
  
      if (Fstat(fileno(rsfp),&statbuf) < 0)	/* normal stat is insecure */
  	croak("Can't stat script \"%s\"",origfilename);
!     if (statbuf.st_mode & (S_ISUID|S_ISGID)) {
  	I32 len;
  
  #ifdef IAMSUID
--- 1518,1524 ----
  
      if (Fstat(fileno(rsfp),&statbuf) < 0)	/* normal stat is insecure */
  	croak("Can't stat script \"%s\"",origfilename);
!     if (fdscript < 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) {
  	I32 len;
  
  #ifdef IAMSUID
***************
*** 1660,1667 ****
--- 1686,1713 ----
  #ifdef IAMSUID
      else if (preprocess)
  	croak("-P not allowed for setuid/setgid script\n");
+     else if (fdscript >= 0)
+ 	croak("fd script not allowed in suidperl\n");
      else
  	croak("Script is not setuid/setgid in suidperl\n");
+ 
+     /* We absolutely must clear out any saved ids here, so we */
+     /* exec the real perl, substituting fd script for scriptname. */
+     /* (We pass script name as "subdir" of fd, which perl will grok.) */
+     rewind(rsfp);
+     for (which = 1; origargv[which] && origargv[which] != scriptname; which++) ;
+     if (!origargv[which])
+ 	croak("Permission denied");
+     (void)sprintf(buf, "/dev/fd/%d/%.127s", fileno(rsfp), origargv[which]);
+     origargv[which] = buf;
+ 
+ #if defined(HAS_FCNTL) && defined(F_SETFD)
+     fcntl(fileno(rsfp),F_SETFD,0);	/* ensure no close-on-exec */
+ #endif
+ 
+     (void)sprintf(tokenbuf, "%s/perl%s", BIN, patchlevel);
+     execv(tokenbuf, origargv);	/* try again */
+     croak("Can't do setuid\n");
  #endif /* IAMSUID */
  #else /* !DOSUID */
      if (euid != uid || egid != gid) {	/* (suidperl doesn't exist, in fact) */

END OF PATCH