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

1 files changed, 119 insertions, 17 deletions

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 */