char rcsid[] = "$Header: perl.c,v 4.0 91/03/20 01:37:44 lwall Locked $\nPatch level: ###\n"; /* * Copyright (c) 1989, Larry Wall * * You may distribute under the terms of the GNU General Public License * as specified in the README file that comes with the perl 3.0 kit. * * $Log: perl.c,v $ * Revision 4.0 91/03/20 01:37:44 lwall * 4.0 baseline. * */ #include "EXTERN.h" #include "perl.h" #include "perly.h" #ifdef MSDOS #include "patchlev.h" #else #include "patchlevel.h" #endif #ifdef IAMSUID #ifndef DOSUID #define DOSUID #endif #endif #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW #ifdef DOSUID #undef DOSUID #endif #endif static char* moreswitches(); static char* cddir; #ifndef __STDC__ extern char **environ; #endif /* ! __STDC__ */ 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 *index(), *strcpy(), *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; } (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); 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': 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: if (e_fp) { (void)fclose(e_fp); argc++,argv--; argv[0] = e_tmpname; } #ifdef MSDOS #define PERLLIB_SEP ';' #else #define PERLLIB_SEP ':' #endif #ifndef TAINT /* Can't allow arbitrary PERLLIB in setuid script */ { char * s2 = getenv("PERLLIB"); if ( s2 ) { /* Break at all separators */ while ( *s2 ) { /* First, skip any consecutive separators */ while ( *s2 == PERLLIB_SEP ) { /* Uncomment the next line for PATH semantics */ /* (void)apush(stab_array(incstab),str_make(".",1)); */ s2++; } if ( (s = index(s2,PERLLIB_SEP)) != Nullch ) { (void)apush(stab_array(incstab),str_make(s2,(int)(s-s2))); s2 = s+1; } else { (void)apush(stab_array(incstab),str_make(s2,0)); break; } } } } #endif /* TAINT */ #ifndef PRIVLIB #define PRIVLIB "/usr/local/lib/perl" #endif (void)apush(stab_array(incstab),str_make(PRIVLIB,0)); (void)apush(stab_array(incstab),str_make(".",1)); str_set(&str_no,No); str_set(&str_yes,Yes); /* open script */ if (argv[0] == Nullch) #ifdef MSDOS { if ( isatty(fileno(stdin)) ) moreswitches("v"); argv[0] = "-"; } #else argv[0] = "-"; #endif if (dosearch && !index(argv[0], '/') && (s = getenv("PATH"))) { char *xfound = Nullch, *xfailed = Nullch; int len; bufend = s + strlen(s); while (*s) { #ifndef MSDOS s = cpytill(tokenbuf,s,bufend,':',&len); #else for (len = 0; *s && *s != ';'; tokenbuf[len++] = *s++); tokenbuf[len] = '\0'; #endif if (*s) s++; #ifndef MSDOS if (len && tokenbuf[len-1] != '/') #else if (len && tokenbuf[len-1] != '\\') #endif (void)strcat(tokenbuf+len,"/"); (void)strcat(tokenbuf+len,argv[0]); #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 : argv[0] ); if (xfailed) Safefree(xfailed); argv[0] = savestr(xfound); } fdpid = anew(Nullstab); /* for remembering popen pids by fd */ pidstatus = hnew(COEFFSIZE);/* for remembering status of dead pids */ origfilename = savestr(argv[0]); curcmd->c_filestab = fstab(origfilename); if (strEQ(origfilename,"-")) argv[0] = ""; if (preprocess) { str_cat(str,"-I"); str_cat(str,PRIVLIB); (void)sprintf(buf, "\ %ssed %s -e '/^[^#]/b' \ -e '/^#[ ]*include[ ]/b' \ -e '/^#[ ]*define[ ]/b' \ -e '/^#[ ]*if[ ]/b' \ -e '/^#[ ]*ifdef[ ]/b' \ -e '/^#[ ]*ifndef[ ]/b' \ -e '/^#[ ]*else/b' \ -e '/^#[ ]*endif/b' \ -e 's/^#.*//' \ %s | %s -C %s %s", #ifdef MSDOS "", #else "/bin/", #endif (doextract ? "-e '1,/^#/d\n'" : ""), argv[0], CPPSTDIN, 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 #endif /* IAMSUID */ rsfp = mypopen(buf,"r"); } else if (!*argv[0]) rsfp = stdin; else rsfp = fopen(argv[0],"r"); if (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 * filename point to an accessible directory. So there is a faint * chance that someone could execute a setuid script down in a * non-accessible directory. I don't know what to do about that. * But I don't think it's too important. The manual lies when * it says access() is useful in setuid programs. */ if (access(stab_val(curcmd->c_filestab)->str_ptr,1)) /*double check*/ fatal("Permission denied"); #else /* If we can swap euid and uid, then we can determine access rights * with a simple stat of the file, and then compare device and * inode to make sure we did stat() on the same file we opened. * Then we just have to make sure he or she can execute it. */ { struct stat tmpstatbuf; if (setreuid(euid,uid) < 0 || getuid() != euid || geteuid() != uid) fatal("Can't swap uid and euid"); /* really paranoid */ if (stat(stab_val(curcmd->c_filestab)->str_ptr,&tmpstatbuf) < 0) fatal("Permission denied"); /* testing full pathname here */ if (tmpstatbuf.st_dev != statbuf.st_dev || tmpstatbuf.st_ino != statbuf.st_ino) { (void)fclose(rsfp); if (rsfp = mypopen("/bin/mail root","w")) { /* heh, heh */ fprintf(rsfp, "User %d tried to run dev %d ino %d in place of dev %d ino %d!\n\ (Filename of set-id script was %s, uid %d gid %d.)\n\nSincerely,\nperl\n", uid,tmpstatbuf.st_dev, tmpstatbuf.st_ino, statbuf.st_dev, statbuf.st_ino, stab_val(curcmd->c_filestab)->str_ptr, statbuf.st_uid, statbuf.st_gid); (void)mypclose(rsfp); } fatal("Permission denied\n"); } if (setreuid(uid,euid) < 0 || getuid() != uid || geteuid() != euid) fatal("Can't reswap uid and euid"); if (!cando(S_IXUSR,FALSE,&statbuf)) /* can real uid exec? */ fatal("Permission denied\n"); } #endif /* HAS_SETREUID */ #endif /* IAMSUID */ if (!S_ISREG(statbuf.st_mode)) fatal("Permission denied"); if (statbuf.st_mode & S_IWOTH) fatal("Setuid/gid script is writable by world"); doswitches = FALSE; /* -s is insecure in suid */ curcmd->c_line++; if (fgets(tokenbuf,sizeof tokenbuf, rsfp) == Nullch || strnNE(tokenbuf,"#!",2) ) /* required even on Sys V */ fatal("No #! line"); s = tokenbuf+2; if (*s == ' ') s++; while (!isspace(*s)) s++; if (strnNE(s-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */ fatal("Not a perl script"); while (*s == ' ' || *s == '\t') 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("Args must match #! line"); #ifndef IAMSUID if (euid != uid && (statbuf.st_mode & S_ISUID) && euid == statbuf.st_uid) if (!do_undump) fatal("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n"); #endif /* IAMSUID */ if (euid) { /* oops, we're not the setuid root perl */ (void)fclose(rsfp); #ifndef IAMSUID (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel); execv(buf, origargv); /* try again */ #endif fatal("Can't do setuid\n"); } if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) #ifdef HAS_SETEGID (void)setegid(statbuf.st_gid); #else #ifdef HAS_SETREGID (void)setregid((GIDTYPE)-1,statbuf.st_gid); #else setgid(statbuf.st_gid); #endif #endif if (statbuf.st_mode & S_ISUID) { if (statbuf.st_uid != euid) #ifdef HAS_SETEUID (void)seteuid(statbuf.st_uid); /* all that for this */ #else #ifdef HAS_SETREUID (void)setreuid((UIDTYPE)-1,statbuf.st_uid); #else setuid(statbuf.st_uid); #endif #endif } else if (uid) /* oops, mustn't run as root */ #ifdef HAS_SETEUID (void)seteuid((UIDTYPE)uid); #else #ifdef HAS_SETREUID (void)setreuid((UIDTYPE)-1,(UIDTYPE)uid); #else setuid((UIDTYPE)uid); #endif #endif uid = (int)getuid(); euid = (int)geteuid(); gid = (int)getgid(); egid = (int)getegid(); if (!cando(S_IXUSR,TRUE,&statbuf)) 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"); #else #ifndef TAINT /* we aren't taintperl or suidperl */ /* script has a wrapper--can't run suidperl or we lose euid */ else if (euid != uid || egid != gid) { (void)fclose(rsfp); (void)sprintf(buf, "%s/tperl%s", BIN, patchlevel); execv(buf, origargv); /* try again */ fatal("Can't run setuid script with taint checks"); } #endif /* TAINT */ #endif /* IAMSUID */ #else /* !DOSUID */ #ifndef TAINT /* we aren't taintperl or suidperl */ if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */ #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW fstat(fileno(rsfp),&statbuf); /* may be either wrapped or real suid */ if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID) || (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID) ) if (!do_undump) fatal("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n"); #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */ /* not set-id, must be wrapped */ (void)fclose(rsfp); (void)sprintf(buf, "%s/tperl%s", BIN, patchlevel); execv(buf, origargv); /* try again */ fatal("Can't run setuid script with taint checks"); } #endif /* TAINT */ #endif /* DOSUID */ #if !defined(IAMSUID) && !defined(TAINT) /* skip forward in input to the real script? */ while (doextract) { if ((s = str_gets(linestr, rsfp, 0)) == Nullch) fatal("No Perl script found in input\n"); if (*s == '#' && s[1] == '!' && instr(s,"perl")) { ungetc('\n',rsfp); /* to keep line count right */ doextract = FALSE; if (s = instr(s,"perl -")) { s += 6; while (s = moreswitches(s)) ; } if (cddir && chdir(cddir) < 0) fatal("Can't chdir to %s",cddir); } } #endif /* !defined(IAMSUID) && !defined(TAINT) */ defstab = stabent("_",TRUE); if (perldb) { debstash = hnew(0); stab_xhash(stabent("_DB",TRUE)) = debstash; curstash = debstash; dbargs = stab_xarray(aadd((tmpstab = stabent("args",TRUE)))); tmpstab->str_pok |= SP_MULTI; dbargs->ary_flags = 0; subname = str_make("main",4); DBstab = stabent("DB",TRUE); DBstab->str_pok |= SP_MULTI; DBline = stabent("dbline",TRUE); DBline->str_pok |= SP_MULTI; DBsub = hadd(tmpstab = stabent("sub",TRUE)); tmpstab->str_pok |= SP_MULTI; DBsingle = stab_val((tmpstab = stabent("single",TRUE))); tmpstab->str_pok |= SP_MULTI; DBtrace = stab_val((tmpstab = stabent("trace",TRUE))); tmpstab->str_pok |= SP_MULTI; DBsignal = stab_val((tmpstab = stabent("signal",TRUE))); tmpstab->str_pok |= SP_MULTI; curstash = defstash; } /* init tokener */ bufend = bufptr = str_get(linestr); savestack = anew(Nullstab); /* for saving non-local values */ stack = anew(Nullstab); /* for saving non-local values */ stack->ary_flags = 0; /* not a real array */ afill(stack,63); afill(stack,-1); /* preextend stack */ afill(savestack,63); afill(savestack,-1); /* now parse the script */ error_count = 0; if (yyparse() || error_count) { if (minus_c) fatal("%s had compilation errors.\n", origfilename); else { fatal("Execution of %s aborted due to compilation errors.\n", origfilename); } } New(50,loop_stack,128,struct loop); #ifdef DEBUGGING if (debug) { New(51,debname,128,char); New(52,debdelim,128,char); } #endif curstash = defstash; preprocess = FALSE; if (e_fp) { e_fp = Nullfp; (void)UNLINK(e_tmpname); } /* initialize everything that won't change if we undump */ if (sigstab = stabent("SIG",allstabs)) { sigstab->str_pok |= SP_MULTI; (void)hadd(sigstab); } magicalize("!#?^~=-%.+&*()<>,\\/[|`':\004\t\024\027"); userinit(); /* in case linked C routines want magical variables */ amperstab = stabent("&",allstabs); leftstab = stabent("`",allstabs); rightstab = stabent("'",allstabs); sawampersand = (amperstab || leftstab || rightstab); if (tmpstab = stabent(":",allstabs)) str_set(STAB_STR(tmpstab),chopset); if (tmpstab = stabent("\024",allstabs)) time(&basetime); /* these aren't necessarily magical */ if (tmpstab = stabent(";",allstabs)) str_set(STAB_STR(tmpstab),"\034"); if (tmpstab = stabent("]",allstabs)) { str = STAB_STR(tmpstab); str_set(str,rcsid); str->str_u.str_nval = atof(patchlevel); str->str_nok = 1; } str_nset(stab_val(stabent("\"", TRUE)), " ", 1); stdinstab = stabent("STDIN",TRUE); stdinstab->str_pok |= SP_MULTI; stab_io(stdinstab) = stio_new(); stab_io(stdinstab)->ifp = stdin; tmpstab = stabent("stdin",TRUE); stab_io(tmpstab) = stab_io(stdinstab); tmpstab->str_pok |= SP_MULTI; tmpstab = stabent("STDOUT",TRUE); tmpstab->str_pok |= SP_MULTI; stab_io(tmpstab) = stio_new(); stab_io(tmpstab)->ofp = stab_io(tmpstab)->ifp = stdout; defoutstab = tmpstab; tmpstab = stabent("stdout",TRUE); stab_io(tmpstab) = stab_io(defoutstab); tmpstab->str_pok |= SP_MULTI; curoutstab = stabent("STDERR",TRUE); curoutstab->str_pok |= SP_MULTI; stab_io(curoutstab) = stio_new(); stab_io(curoutstab)->ofp = stab_io(curoutstab)->ifp = stderr; tmpstab = stabent("stderr",TRUE); stab_io(tmpstab) = stab_io(curoutstab); tmpstab->str_pok |= SP_MULTI; curoutstab = defoutstab; /* switch back to STDOUT */ statname = Str_new(66,0); /* last filename we did stat on */ /* now that script is parsed, we can modify record separator */ rs = nrs; rslen = nrslen; rschar = nrschar; str_nset(stab_val(stabent("/", TRUE)), rs, rslen); if (do_undump) my_unexec(); just_doit: /* come here if running an undumped a.out */ argc--,argv++; /* skip name of script */ if (doswitches) { for (; argc > 0 && **argv == '-'; argc--,argv++) { if (argv[0][1] == '-') { argc--,argv++; break; } if (s = index(argv[0], '=')) { *s++ = '\0'; str_set(stab_val(stabent(argv[0]+1,TRUE)),s); } else str_numset(stab_val(stabent(argv[0]+1,TRUE)),(double)1.0); } } #ifdef TAINT tainted = 1; #endif if (tmpstab = stabent("0",allstabs)) { str_set(stab_val(tmpstab),origfilename); magicname("0", Nullch, 0); } if (tmpstab = stabent("\020",allstabs)) str_set(stab_val(tmpstab),origargv[0]); if (argvstab = stabent("ARGV",allstabs)) { argvstab->str_pok |= SP_MULTI; (void)aadd(argvstab); aclear(stab_array(argvstab)); for (; argc > 0; argc--,argv++) { (void)apush(stab_array(argvstab),str_make(argv[0],0)); } } #ifdef TAINT (void) stabent("ENV",TRUE); /* must test PATH and IFS */ #endif if (envstab = stabent("ENV",allstabs)) { envstab->str_pok |= SP_MULTI; (void)hadd(envstab); hclear(stab_hash(envstab), FALSE); if (env != environ) environ[0] = Nullch; for (; *env; env++) { if (!(s = index(*env,'='))) continue; *s++ = '\0'; str = str_make(s--,0); str_magic(str, envstab, 'E', *env, s - *env); (void)hstore(stab_hash(envstab), *env, s - *env, str, 0); *s = '='; } } #ifdef TAINT tainted = 0; #endif if (tmpstab = stabent("$",allstabs)) str_numset(STAB_STR(tmpstab),(double)getpid()); if (dowarn) { stab_check('A','Z'); stab_check('a','z'); } if (setjmp(top_env)) /* sets goto_targ on longjump */ loop_ptr = -1; /* start label stack again */ #ifdef DEBUGGING if (debug & 1024) dump_all(); if (debug) fprintf(stderr,"\nEXECUTING...\n\n"); #endif if (minus_c) { fprintf(stderr,"%s syntax OK\n", origfilename); exit(0); } /* do it */ (void) cmd_exec(main_root,G_SCALAR,-1); if (goto_targ) fatal("Can't find label \"%s\"--aborting",goto_targ); exit(0); /* NOTREACHED */ } void magicalize(list) register char *list; { char sym[2]; sym[1] = '\0'; while (*sym = *list++) magicname(sym, Nullch, 0); } void magicname(sym,name,namlen) char *sym; char *name; int namlen; { register STAB *stab; if (stab = stabent(sym,allstabs)) { stab_flags(stab) = SF_VMAGIC; str_magic(stab_val(stab), stab, 0, name, namlen); } } /* this routine is in perl.c by virtue of being sort of an alternate main() */ int do_eval(str,optype,stash,gimme,arglast) STR *str; int optype; HASH *stash; int gimme; int *arglast; { STR **st = stack->ary_array; int retval; CMD *myroot = Nullcmd; ARRAY *ar; int i; CMD * VOLATILE oldcurcmd = curcmd; VOLATILE int oldtmps_base = tmps_base; VOLATILE int oldsave = savestack->ary_fill; VOLATILE int oldperldb = perldb; SPAT * VOLATILE oldspat = curspat; SPAT * VOLATILE oldlspat = lastspat; static char *last_eval = Nullch; static CMD *last_root = Nullcmd; VOLATILE int sp = arglast[0]; char *specfilename; char *tmpfilename; int parsing = 1; tmps_base = tmps_max; if (curstash != stash) { (void)savehptr(&curstash); curstash = stash; } str_set(stab_val(stabent("@",TRUE)),""); if (curcmd->c_line == 0) /* don't debug debugger... */ perldb = FALSE; curcmd = &compiling; if (optype == O_EVAL) { /* normal eval */ curcmd->c_filestab = fstab("(eval)"); curcmd->c_line = 1; str_sset(linestr,str); str_cat(linestr,";"); /* be kind to them */ } else { if (last_root && !in_eval) { Safefree(last_eval); last_eval = Nullch; cmd_free(last_root); last_root = Nullcmd; } specfilename = str_get(str); str_set(linestr,""); if (optype == O_REQUIRE && &str_undef != hfetch(stab_hash(incstab), specfilename, strlen(specfilename), 0)) { curcmd = oldcurcmd; tmps_base = oldtmps_base; st[++sp] = &str_yes; perldb = oldperldb; return sp; } tmpfilename = savestr(specfilename); if (index("/.", *tmpfilename)) rsfp = fopen(tmpfilename,"r"); else { ar = stab_array(incstab); for (i = 0; i <= ar->ary_fill; i++) { (void)sprintf(buf, "%s/%s", str_get(afetch(ar,i,TRUE)), specfilename); rsfp = fopen(buf,"r"); if (rsfp) { char *s = buf; if (*s == '.' && s[1] == '/') s += 2; Safefree(tmpfilename); tmpfilename = savestr(s); break; } } } curcmd->c_filestab = fstab(tmpfilename); Safefree(tmpfilename); tmpfilename = Nullch; if (!rsfp) { curcmd = oldcurcmd; tmps_base = oldtmps_base; if (optype == O_REQUIRE) { sprintf(tokenbuf,"Can't locate %s in @INC", specfilename); if (instr(tokenbuf,".h ")) strcat(tokenbuf," (change .h to .ph maybe?)"); if (instr(tokenbuf,".ph ")) strcat(tokenbuf," (did you run h2ph?)"); fatal("%s",tokenbuf); } if (gimme != G_ARRAY) st[++sp] = &str_undef; perldb = oldperldb; return sp; } curcmd->c_line = 0; } in_eval++; oldoldbufptr = oldbufptr = bufptr = str_get(linestr); bufend = bufptr + linestr->str_cur; if (++loop_ptr >= loop_max) { loop_max += 128; Renew(loop_stack, loop_max, struct loop); } loop_stack[loop_ptr].loop_label = "_EVAL_"; loop_stack[loop_ptr].loop_sp = sp; #ifdef DEBUGGING if (debug & 4) { deb("(Pushing label #%d _EVAL_)\n", loop_ptr); } #endif eval_root = Nullcmd; if (setjmp(loop_stack[loop_ptr].loop_env)) { retval = 1; } else { error_count = 0; if (rsfp) { retval = yyparse(); retval |= error_count; } else if (last_root && *bufptr == *last_eval && strEQ(bufptr,last_eval)){ retval = 0; eval_root = last_root; /* no point in reparsing */ } else if (in_eval == 1) { if (last_root) { Safefree(last_eval); last_eval = Nullch; cmd_free(last_root); } last_root = Nullcmd; last_eval = savestr(bufptr); retval = yyparse(); retval |= error_count; if (!retval) last_root = eval_root; if (!last_root) { Safefree(last_eval); last_eval = Nullch; } } else retval = yyparse(); } myroot = eval_root; /* in case cmd_exec does another eval! */ if (retval) { st = stack->ary_array; sp = arglast[0]; if (gimme != G_ARRAY) st[++sp] = &str_undef; if (parsing) { #ifndef MANGLEDPARSE #ifdef DEBUGGING if (debug & 128) fprintf(stderr,"Freeing eval_root %lx\n",(long)eval_root); #endif cmd_free(eval_root); #endif if (eval_root == last_root) last_root = Nullcmd; eval_root = myroot = Nullcmd; } if (rsfp) { fclose(rsfp); rsfp = 0; } } else { parsing = 0; sp = cmd_exec(eval_root,gimme,sp); st = stack->ary_array; for (i = arglast[0] + 1; i <= sp; i++) st[i] = str_mortal(st[i]); /* if we don't save result, free zaps it */ if (in_eval != 1 && myroot != last_root) cmd_free(myroot); } perldb = oldperldb; in_eval--; #ifdef DEBUGGING if (debug & 4) { char *tmps = loop_stack[loop_ptr].loop_label; deb("(Popping label #%d %s)\n",loop_ptr, tmps ? tmps : "" ); } #endif loop_ptr--; tmps_base = oldtmps_base; curspat = oldspat; lastspat = oldlspat; if (savestack->ary_fill > oldsave) /* let them use local() */ restorelist(oldsave); if (optype != O_EVAL) { if (retval) { if (optype == O_REQUIRE) fatal("%s", str_get(stab_val(stabent("@",TRUE)))); } else { curcmd = oldcurcmd; if (gimme == G_SCALAR ? str_true(st[sp]) : sp > arglast[0]) { (void)hstore(stab_hash(incstab), specfilename, strlen(specfilename), str_smake(stab_val(curcmd->c_filestab)), 0 ); } else if (optype == O_REQUIRE) fatal("%s did not return a true value", specfilename); } } curcmd = oldcurcmd; return sp; } /* This routine handles any switches that can be given during run */ static char * moreswitches(s) char *s; { int numlen; reswitch: switch (*s) { case '0': nrschar = scanoct(s, 4, &numlen); nrs = nsavestr("\n",1); *nrs = nrschar; if (nrschar > 0377) { nrslen = 0; nrs = ""; } else if (!nrschar && numlen >= 2) { nrslen = 2; nrs = "\n\n"; nrschar = '\n'; } return s + numlen; case 'a': minus_a = TRUE; s++; return s; case 'c': minus_c = TRUE; s++; return s; case 'd': #ifdef TAINT if (euid != uid || egid != gid) fatal("No -d allowed in setuid scripts"); #endif perldb = TRUE; s++; return s; case 'D': #ifdef DEBUGGING #ifdef TAINT if (euid != uid || egid != gid) fatal("No -D allowed in setuid scripts"); #endif debug = atoi(s+1) | 32768; #else warn("Recompile perl with -DDEBUGGING to use -D switch\n"); #endif for (s++; isdigit(*s); s++) ; return s; case 'i': inplace = savestr(s+1); for (s = inplace; *s && !isspace(*s); s++) ; *s = '\0'; break; case 'I': #ifdef TAINT if (euid != uid || egid != gid) fatal("No -I allowed in setuid scripts"); #endif if (*++s) { (void)apush(stab_array(incstab),str_make(s,0)); } else fatal("No space allowed after -I"); break; case 'l': minus_l = TRUE; s++; if (isdigit(*s)) { ors = savestr("\n"); orslen = 1; *ors = scanoct(s, 3 + (*s == '0'), &numlen); s += numlen; } else { ors = nsavestr(nrs,nrslen); orslen = nrslen; } return s; case 'n': minus_n = TRUE; s++; return s; case 'p': minus_p = TRUE; s++; return s; case 'u': do_undump = TRUE; s++; return s; case 'U': unsafe = TRUE; s++; return s; case 'v': fputs("\nThis is perl, version 4.0\n\n",stdout); fputs(rcsid,stdout); fputs("\nCopyright (c) 1989, 1990, 1991, Larry Wall\n",stdout); #ifdef MSDOS fputs("MS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n", stdout); #ifdef OS2 fputs("OS/2 port Copyright (c) 1990, Raymond Chen, Kai Uwe Rommel\n", stdout); #endif #endif fputs("\n\ Perl may be copied only under the terms of the GNU General Public License,\n\ a copy of which can be found with the Perl 4.0 distribution kit.\n",stdout); #ifdef MSDOS usage(origargv[0]); #endif exit(0); case 'w': dowarn = TRUE; s++; return s; case ' ': case '\n': case '\t': break; default: fatal("Switch meaningless after -x: -%s",s); } return Nullch; } /* compliments of Tom Christiansen */ /* unexec() can be found in the Gnu emacs distribution */ my_unexec() { #ifdef UNEXEC int status; extern int etext; static char dumpname[BUFSIZ]; static char perlpath[256]; sprintf (dumpname, "%s.perldump", origfilename); sprintf (perlpath, "%s/perl", BIN); status = unexec(dumpname, perlpath, &etext, sbrk(0), 0); if (status) fprintf(stderr, "unexec of %s into %s failed!\n", perlpath, dumpname); exit(status); #else # ifndef SIGABRT # define SIGABRT SIGILL # endif # ifndef SIGILL # define SIGILL 6 /* blech */ # endif kill(getpid(),SIGABRT); /* for use with undump */ #endif }