perl.c

早期freebsd实现

char rcsid[] = "$RCSfile: perl.c,v $$Revision: 4.0.1.8 $$Date: 1993/02/05 19:39:30 $\nPatch level: ###\n";
/*
 *    Copyright (c) 1991, Larry Wall
 *
 *    You may distribute under the terms of either the GNU General Public
 *    License or the Artistic License, as specified in the README file.
 *
 * $Log: perl.c,v $
 * Revision 4.0.1.8  1993/02/05  19:39:30  lwall
 * patch36: the taintanyway code wasn't tainting anyway
 * patch36: Malformed cmd links core dump apparently fixed
 *
 * Revision 4.0.1.7  92/06/08  14:50:39  lwall
 * patch20: PERLLIB now supports multiple directories
 * patch20: running taintperl explicitly now does checks even if $< == $>
 * patch20: -e 'cmd' no longer fails silently if /tmp runs out of space
 * patch20: perl -P now uses location of sed determined by Configure
 * patch20: form feed for formats is now specifiable via $^L
 * patch20: paragraph mode now skips extra newlines automatically
 * patch20: eval "1 #comment" didn't work
 * patch20: couldn't require . files
 * patch20: semantic compilation errors didn't abort execution
 * 
 * Revision 4.0.1.6  91/11/11  16:38:45  lwall
 * patch19: default arg for shift was wrong after first subroutine definition
 * patch19: op/regexp.t failed from missing arg to bcmp()
 * 
 * Revision 4.0.1.5  91/11/05  18:03:32  lwall
 * patch11: random cleanup
 * patch11: $0 was being truncated at times
 * patch11: cppstdin now installed outside of source directory
 * patch11: -P didn't allow use of #elif or #undef
 * patch11: prepared for ctype implementations that don't define isascii()
 * patch11: added eval {}
 * patch11: eval confused by string containing null
 * 
 * Revision 4.0.1.4  91/06/10  01:23:07  lwall
 * patch10: perl -v printed incorrect copyright notice
 * 
 * Revision 4.0.1.3  91/06/07  11:40:18  lwall
 * patch4: changed old $^P to $^X
 * 
 * Revision 4.0.1.2  91/06/07  11:26:16  lwall
 * patch4: new copyright notice
 * patch4: added $^P variable to control calling of perldb routines
 * patch4: added $^F variable to specify maximum system fd, default 2
 * patch4: debugger lost track of lines in eval
 * 
 * Revision 4.0.1.1  91/04/11  17:49:05  lwall
 * patch1: fixed undefined environ problem
 * 
 * Revision 4.0  91/03/20  01:37:44  lwall
 * 4.0 baseline.
 * 
 */

/*SUPPRESS 560*/

#include "EXTERN.h"
#include "perl.h"
#include "perly.h"
#include "patchlevel.h"

char *getenv();

#ifdef IAMSUID
#ifndef DOSUID
#define DOSUID
#endif
#endif

#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
#ifdef DOSUID
#undef DOSUID
#endif
#endif

static char* moreswitches();
static void incpush();
static char* cddir;
static bool minus_c;
static char patchlevel[6];
static char *nrs = "\n";
static int nrschar = '\n';      /* final char of rs, or 0777 if none */
static int nrslen = 1;

main(argc,argv,env)
register int argc;
register char **argv;
register char **env;
{
    register STR *str;
    register char *s;
    char *scriptname;
    char *getenv();
    bool dosearch = FALSE;
#ifdef DOSUID
    char *validarg = "";
#endif

#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
#ifdef IAMSUID
#undef IAMSUID
    fatal("suidperl is no longer needed since the kernel can now execute\n\
setuid perl scripts securely.\n");
#endif
#endif

    origargv = argv;
    origargc = argc;
    origenviron = environ;
    uid = (int)getuid();
    euid = (int)geteuid();
    gid = (int)getgid();
    egid = (int)getegid();
    sprintf(patchlevel,"%3.3s%2.2d", index(rcsid,'4'), PATCHLEVEL);
#ifdef MSDOS
    /*
     * There is no way we can refer to them from Perl so close them to save
     * space.  The other alternative would be to provide STDAUX and STDPRN
     * filehandles.
     */
    (void)fclose(stdaux);
    (void)fclose(stdprn);
#endif
    if (do_undump) {
	origfilename = savestr(argv[0]);
	do_undump = 0;
	loop_ptr = -1;		/* start label stack again */
	goto just_doit;
    }
#ifdef TAINT
#ifndef DOSUID
    if (uid == euid && gid == egid)
	taintanyway = TRUE;		/* running taintperl explicitly */
#endif
#endif
    (void)sprintf(index(rcsid,'#'), "%d\n", PATCHLEVEL);
    linestr = Str_new(65,80);
    str_nset(linestr,"",0);
    str = str_make("",0);		/* first used for -I flags */
    curstash = defstash = hnew(0);
    curstname = str_make("main",4);
    stab_xhash(stabent("_main",TRUE)) = defstash;
    defstash->tbl_name = "main";
    incstab = hadd(aadd(stabent("INC",TRUE)));
    incstab->str_pok |= SP_MULTI;
    for (argc--,argv++; argc > 0; 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 '0':
	case 'a':
	case 'c':
	case 'd':
	case 'D':
	case 'i':
	case 'l':
	case 'n':
	case 'p':
	case 'u':
	case 'U':
	case 'v':
	case 'w':
	    if (s = moreswitches(s))
		goto reswitch;
	    break;

	case 'e':
#ifdef TAINT
	    if (euid != uid || egid != gid)
		fatal("No -e allowed in setuid scripts");
#endif
	    if (!e_fp) {
	        e_tmpname = savestr(TMPPATH);
		(void)mktemp(e_tmpname);
		if (!*e_tmpname)
		    fatal("Can't mktemp()");
		e_fp = fopen(e_tmpname,"w");
		if (!e_fp)
		    fatal("Cannot open temporary file");
	    }
	    if (argv[1]) {
		fputs(argv[1],e_fp);
		argc--,argv++;
	    }
	    (void)putc('\n', e_fp);
	    break;
	case 'I':
#ifdef TAINT
	    if (euid != uid || egid != gid)
		fatal("No -I allowed in setuid scripts");
#endif
	    str_cat(str,"-");
	    str_cat(str,s);
	    str_cat(str," ");
	    if (*++s) {
		(void)apush(stab_array(incstab),str_make(s,0));
	    }
	    else if (argv[1]) {
		(void)apush(stab_array(incstab),str_make(argv[1],0));
		str_cat(str,argv[1]);
		argc--,argv++;
		str_cat(str," ");
	    }
	    break;
	case 'P':
#ifdef TAINT
	    if (euid != uid || egid != gid)
		fatal("No -P allowed in setuid scripts");
#endif
	    preprocess = TRUE;
	    s++;
	    goto reswitch;
	case 's':
#ifdef TAINT
	    if (euid != uid || egid != gid)
		fatal("No -s allowed in setuid scripts");
#endif
	    doswitches = TRUE;
	    s++;
	    goto reswitch;
	case 'S':
#ifdef TAINT
	    if (euid != uid || egid != gid)
		fatal("No -S allowed in setuid scripts");
#endif
	    dosearch = TRUE;
	    s++;
	    goto reswitch;
	case 'x':
	    doextract = TRUE;
	    s++;
	    if (*s)
		cddir = savestr(s);
	    break;
	case '-':
	    argc--,argv++;
	    goto switch_end;
	case 0:
	    break;
	default:
	    fatal("Unrecognized switch: -%s",s);
	}
    }
  switch_end:
    scriptname = argv[0];
    if (e_fp) {
	if (fflush(e_fp) || ferror(e_fp) || fclose(e_fp))
	    fatal("Can't write to temp file for -e: %s", strerror(errno));
	argc++,argv--;
	scriptname = e_tmpname;
    }

#ifdef DOSISH
#define PERLLIB_SEP ';'
#else
#define PERLLIB_SEP ':'
#endif
#ifndef TAINT		/* Can't allow arbitrary PERLLIB in setuid script */
    incpush(getenv("PERLLIB"));
#endif /* TAINT */

#ifndef PRIVLIB
#define PRIVLIB "/usr/local/lib/perl"
#endif
    incpush(PRIVLIB);
    (void)apush(stab_array(incstab),str_make(".",1));

    str_set(&str_no,No);
    str_set(&str_yes,Yes);

    /* open script */

    if (scriptname == Nullch)
#ifdef MSDOS
    {
	if ( isatty(fileno(stdin)) )
	  moreswitches("v");
	scriptname = "-";
    }
#else
	scriptname = "-";
#endif
    if (dosearch && !index(scriptname, '/') && (s = getenv("PATH"))) {
	char *xfound = Nullch, *xfailed = Nullch;
	int len;

	bufend = s + strlen(s);
	while (*s) {
#ifndef DOSISH
	    s = cpytill(tokenbuf,s,bufend,':',&len);
#else
#ifdef atarist
	    for (len = 0; *s && *s != ',' && *s != ';'; tokenbuf[len++] = *s++);
	    tokenbuf[len] = '\0';
#else
	    for (len = 0; *s && *s != ';'; tokenbuf[len++] = *s++);
	    tokenbuf[len] = '\0';
#endif
#endif
	    if (*s)
		s++;
#ifndef DOSISH
	    if (len && tokenbuf[len-1] != '/')
#else
#ifdef atarist
	    if (len && ((tokenbuf[len-1] != '\\') && (tokenbuf[len-1] != '/')))
#else
	    if (len && tokenbuf[len-1] != '\\')
#endif
#endif
		(void)strcat(tokenbuf+len,"/");
	    (void)strcat(tokenbuf+len,scriptname);
#ifdef DEBUGGING
	    if (debug & 1)
		fprintf(stderr,"Looking for %s\n",tokenbuf);
#endif
	    if (stat(tokenbuf,&statbuf) < 0)		/* not there? */
		continue;
	    if (S_ISREG(statbuf.st_mode)
	     && cando(S_IRUSR,TRUE,&statbuf) && cando(S_IXUSR,TRUE,&statbuf)) {
		xfound = tokenbuf;              /* bingo! */
		break;
	    }
	    if (!xfailed)
		xfailed = savestr(tokenbuf);
	}
	if (!xfound)
	    fatal("Can't execute %s", xfailed ? xfailed : scriptname );
	if (xfailed)
	    Safefree(xfailed);
	scriptname = savestr(xfound);
    }

    fdpid = anew(Nullstab);	/* for remembering popen pids by fd */
    pidstatus = hnew(COEFFSIZE);/* for remembering status of dead pids */

    origfilename = savestr(scriptname);
    curcmd->c_filestab = fstab(origfilename);
    if (strEQ(origfilename,"-"))
	scriptname = "";
    if (preprocess) {
	char *cpp = CPPSTDIN;

	if (strEQ(cpp,"cppstdin"))
	    sprintf(tokenbuf, "%s/%s", SCRIPTDIR, cpp);
	else
	    sprintf(tokenbuf, "%s", cpp);
	str_cat(str,"-I");
	str_cat(str,PRIVLIB);
#ifdef MSDOS
	(void)sprintf(buf, "\
sed %s -e \"/^[^#]/b\" \
 -e \"/^#[ 	]*include[ 	]/b\" \
 -e \"/^#[ 	]*define[ 	]/b\" \
 -e \"/^#[ 	]*if[ 	]/b\" \
 -e \"/^#[ 	]*ifdef[ 	]/b\" \
 -e \"/^#[ 	]*ifndef[ 	]/b\" \
 -e \"/^#[ 	]*else/b\" \
 -e \"/^#[ 	]*elif[ 	]/b\" \
 -e \"/^#[ 	]*undef[ 	]/b\" \
 -e \"/^#[ 	]*endif/b\" \
 -e \"s/^#.*//\" \
 %s | %s -C %s %s",
	  (doextract ? "-e \"1,/^#/d\n\"" : ""),
#else
	(void)sprintf(buf, "\
%s %s -e '/^[^#]/b' \
 -e '/^#[ 	]*include[ 	]/b' \
 -e '/^#[ 	]*define[ 	]/b' \
 -e '/^#[ 	]*if[ 	]/b' \
 -e '/^#[ 	]*ifdef[ 	]/b' \
 -e '/^#[ 	]*ifndef[ 	]/b' \
 -e '/^#[ 	]*else/b' \
 -e '/^#[ 	]*elif[ 	]/b' \
 -e '/^#[ 	]*undef[ 	]/b' \
 -e '/^#[ 	]*endif/b' \
 -e 's/^[ 	]*#.*//' \
 %s | %s -C %s %s",
#ifdef LOC_SED
	  LOC_SED,
#else
	  "sed",
#endif
	  (doextract ? "-e '1,/^#/d\n'" : ""),
#endif
	  scriptname, tokenbuf, str_get(str), CPPMINUS);
#ifdef DEBUGGING
	if (debug & 64) {
	    fputs(buf,stderr);
	    fputs("\n",stderr);
	}
#endif
	doextract = FALSE;
#ifdef IAMSUID				/* actually, this is caught earlier */
	if (euid != uid && !euid) {	/* if running suidperl */
#ifdef HAS_SETEUID
	    (void)seteuid(uid);		/* musn't stay setuid root */
#else
#ifdef HAS_SETREUID
	    (void)setreuid(-1, uid);
#else
	    setuid(uid);
#endif
#endif
	    if (geteuid() != uid)
		fatal("Can't do seteuid!\n");
	}
#endif /* IAMSUID */
	rsfp = mypopen(buf,"r");
    }
    else if (!*scriptname) {
#ifdef TAINT
	if (euid != uid || egid != gid)
	    fatal("Can't take set-id script from stdin");
#endif
	rsfp = stdin;
    }
    else
	rsfp = fopen(scriptname,"r");
    if ((FILE*)rsfp == Nullfp) {
#ifdef DOSUID
#ifndef IAMSUID		/* in case script is not readable before setuid */
	if (euid && stat(stab_val(curcmd->c_filestab)->str_ptr,&statbuf) >= 0 &&
	  statbuf.st_mode & (S_ISUID|S_ISGID)) {
	    (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
	    execv(buf, origargv);	/* try again */
	    fatal("Can't do setuid\n");
	}
#endif
#endif
	fatal("Can't open perl script \"%s\": %s\n",
	  stab_val(curcmd->c_filestab)->str_ptr, strerror(errno));
    }
    str_free(str);		/* free -I directories */
    str = Nullstr;

    /* 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 or sperlN.NNN.  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.
     *
     * There is also the possibility of have a script which is running
     * set-id due to a C wrapper.  We want to do the TAINT checks
     * on these set-id scripts, but don't want to have the overhead of
     * them in normal perl, and can't use suidperl because it will lose
     * the effective uid info, so we have an additional non-setuid root
     * version called taintperl or tperlN.NNN that just does the TAINT checks.
     */

#ifdef DOSUID
    if (fstat(fileno(rsfp),&statbuf) < 0)	/* normal stat is insecure */
	fatal("Can't stat script \"%s\"",origfilename);
    if (statbuf.st_mode & (S_ISUID|S_ISGID)) {
	int len;

#ifdef IAMSUID
#ifndef HAS_SETREUID
	/* On this access check to make sure the directories are readable,
	 * there is actually a small window that the user could use to make