1 char rcsid[] = "$RCSfile: perl.c,v $$Revision: 5.0 $$Date: 92/08/07 18:25:50 $\nPatch level: ###\n";
3 * Copyright (c) 1991, Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
9 * Revision 4.1 92/08/07 18:25:50 lwall
11 * Revision 4.0.1.7 92/06/08 14:50:39 lwall
12 * patch20: PERLLIB now supports multiple directories
13 * patch20: running taintperl explicitly now does checks even if $< == $>
14 * patch20: -e 'cmd' no longer fails silently if /tmp runs out of space
15 * patch20: perl -P now uses location of sed determined by Configure
16 * patch20: form feed for formats is now specifiable via $^L
17 * patch20: paragraph mode now skips extra newlines automatically
18 * patch20: oldeval "1 #comment" didn't work
19 * patch20: couldn't require . files
20 * patch20: semantic compilation errors didn't abort execution
22 * Revision 4.0.1.6 91/11/11 16:38:45 lwall
23 * patch19: default arg for shift was wrong after first subroutine definition
24 * patch19: op/regexp.t failed from missing arg to bcmp()
26 * Revision 4.0.1.5 91/11/05 18:03:32 lwall
27 * patch11: random cleanup
28 * patch11: $0 was being truncated at times
29 * patch11: cppstdin now installed outside of source directory
30 * patch11: -P didn't allow use of #elif or #undef
31 * patch11: prepared for ctype implementations that don't define isascii()
32 * patch11: added oldeval {}
33 * patch11: oldeval confused by string containing null
35 * Revision 4.0.1.4 91/06/10 01:23:07 lwall
36 * patch10: perl -v printed incorrect copyright notice
38 * Revision 4.0.1.3 91/06/07 11:40:18 lwall
39 * patch4: changed old $^P to $^X
41 * Revision 4.0.1.2 91/06/07 11:26:16 lwall
42 * patch4: new copyright notice
43 * patch4: added $^P variable to control calling of perldb routines
44 * patch4: added $^F variable to specify maximum system fd, default 2
45 * patch4: debugger lost track of lines in oldeval
47 * Revision 4.0.1.1 91/04/11 17:49:05 lwall
48 * patch1: fixed undefined environ problem
50 * Revision 4.0 91/03/20 01:37:44 lwall
60 #include "patchlevel.h"
68 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
74 static void incpush();
75 static void validate_suid();
76 static void find_beginning();
77 static void init_main_stash();
78 static void open_script();
79 static void init_debugger();
80 static void init_stack();
81 static void init_lexer();
82 static void init_context_stack();
83 static void init_predump_symbols();
84 static void init_postdump_symbols();
85 static void init_perllib();
90 PerlInterpreter *sv_interp;
94 Zero(&junk, 1, PerlInterpreter);
95 New(53, sv_interp, 1, PerlInterpreter);
100 perl_construct( sv_interp )
101 register PerlInterpreter *sv_interp;
103 if (!(curinterp = sv_interp))
106 Zero(sv_interp, 1, PerlInterpreter);
108 /* Init the real globals? */
110 linestr = NEWSV(65,80);
112 SvREADONLY_on(&sv_undef);
116 SvREADONLY_on(&sv_no);
118 sv_setpv(&sv_yes,Yes);
120 SvREADONLY_on(&sv_yes);
124 * There is no way we can refer to them from Perl so close them to save
125 * space. The other alternative would be to provide STDAUX and STDPRN
128 (void)fclose(stdaux);
129 (void)fclose(stdprn);
158 euid = (int)geteuid();
160 egid = (int)getegid();
161 sprintf(patchlevel,"%3.3s%2.2d", strchr(rcsid,'4'), PATCHLEVEL);
163 (void)sprintf(strchr(rcsid,'#'), "%d\n", PATCHLEVEL);
165 fdpid = newAV(); /* for remembering popen pids by fd */
166 pidstatus = newHV(COEFFSIZE);/* for remembering status of dead pids */
170 if (uid == euid && gid == egid)
171 taintanyway = TRUE; /* running taintperl explicitly */
178 perl_destruct(sv_interp)
179 register PerlInterpreter *sv_interp;
181 if (!(curinterp = sv_interp))
192 PerlInterpreter *sv_interp;
194 if (!(curinterp = sv_interp))
200 perl_parse(sv_interp, argc, argv, env)
201 PerlInterpreter *sv_interp;
203 register char **argv;
210 bool dosearch = FALSE;
213 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
216 fatal("suidperl is no longer needed since the kernel can now execute\n\
217 setuid perl scripts securely.\n");
221 if (!(curinterp = sv_interp))
230 origenviron = environ;
232 switch (setjmp(top_env)) {
236 return(statusvalue); /* my_exit() was called */
238 fprintf(stderr, "panic: top_env\n");
243 origfilename = savestr(argv[0]);
245 cxstack_ix = -1; /* start label stack again */
248 sv_setpvn(linestr,"",0);
249 sv = newSVpv("",0); /* first used for -I flags */
251 for (argc--,argv++; argc > 0; argc--,argv++) {
252 if (argv[0][0] != '-' || !argv[0][1])
256 validarg = " PHOOEY ";
277 if (s = moreswitches(s))
283 if (euid != uid || egid != gid)
284 fatal("No -e allowed in setuid scripts");
287 e_tmpname = savestr(TMPPATH);
288 (void)mktemp(e_tmpname);
290 fatal("Can't mktemp()");
291 e_fp = fopen(e_tmpname,"w");
293 fatal("Cannot open temporary file");
299 (void)putc('\n', e_fp);
303 if (euid != uid || egid != gid)
304 fatal("No -I allowed in setuid scripts");
310 (void)av_push(GvAVn(incgv),newSVpv(s,0));
313 (void)av_push(GvAVn(incgv),newSVpv(argv[1],0));
314 sv_catpv(sv,argv[1]);
321 if (euid != uid || egid != gid)
322 fatal("No -P allowed in setuid scripts");
329 if (euid != uid || egid != gid)
330 fatal("No -S allowed in setuid scripts");
347 fatal("Unrecognized switch: -%s",s);
351 scriptname = argv[0];
353 if (fflush(e_fp) || ferror(e_fp) || fclose(e_fp))
354 fatal("Can't write to temp file for -e: %s", strerror(errno));
356 scriptname = e_tmpname;
358 else if (scriptname == Nullch) {
360 if ( isatty(fileno(stdin)) )
368 open_script(scriptname,dosearch,sv);
370 sv_free(sv); /* free -I directories */
373 validate_suid(validarg);
383 av_push(comppad, Nullsv);
384 curpad = AvARRAY(comppad);
386 comppadname = padname;
387 comppadnamefill = -1;
392 init_context_stack();
394 userinit(); /* in case linked C routines want magical variables */
397 init_predump_symbols();
401 /* now parse the script */
404 if (yyparse() || error_count) {
406 fatal("%s had compilation errors.\n", origfilename);
408 fatal("Execution of %s aborted due to compilation errors.\n",
412 curcop->cop_line = 0;
417 (void)UNLINK(e_tmpname);
420 /* now that script is parsed, we can modify record separator */
425 rspara = (nrslen == 2);
426 sv_setpvn(GvSV(gv_fetchpv("/", TRUE)), rs, rslen);
431 just_doit: /* come here if running an undumped a.out */
432 init_postdump_symbols(argc,argv,env);
438 PerlInterpreter *sv_interp;
440 if (!(curinterp = sv_interp))
444 switch (setjmp(top_env)) {
446 cxstack_ix = -1; /* start context stack again */
452 return(statusvalue); /* my_exit() was called */
455 fprintf(stderr, "panic: restartop\n");
458 if (stack != mainstack) {
460 SWITCHSTACK(stack, mainstack);
467 DEBUG(fprintf(stderr,"\nEXECUTING...\n\n"));
470 fprintf(stderr,"%s syntax OK\n", origfilename);
482 else if (main_start) {
494 statusvalue = (unsigned short)(status & 0xffff);
498 /* Be sure to refetch the stack pointer after calling these routines. */
501 perl_callback(subname, sp, gimme, hasargs, numargs)
503 I32 sp; /* stack pointer after args are pushed */
504 I32 gimme; /* called in array or scalar context */
505 I32 hasargs; /* whether to create a @_ array for routine */
506 I32 numargs; /* how many args are pushed on the stack */
508 BINOP myop; /* fake syntax tree node */
512 stack_base = AvARRAY(stack);
513 stack_sp = stack_base + sp - numargs - 1;
515 pp_pushmark(); /* doesn't look at op, actually, except to return */
516 *++stack_sp = (SV*)gv_fetchpv(subname, FALSE);
519 myop.op_last = hasargs ? (OP*)&myop : Nullop;
520 myop.op_next = Nullop;
525 return stack_sp - stack_base;
529 perl_callv(subname, sp, gimme, argv)
531 register I32 sp; /* current stack pointer */
532 I32 gimme; /* called in array or scalar context */
533 register char **argv; /* null terminated arg list, NULL for no arglist */
535 register I32 items = 0;
536 I32 hasargs = (argv != 0);
538 av_store(stack, ++sp, Nullsv); /* reserve spot for 1st return arg */
541 av_store(stack, ++sp, sv_2mortal(newSVpv(*argv,0)));
546 return perl_callback(subname, sp, gimme, hasargs, items);
550 magicname(sym,name,namlen)
557 if (gv = gv_fetchpv(sym,allgvs))
558 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
562 #define PERLLIB_SEP ';'
564 #define PERLLIB_SEP ':'
576 /* Break at all separators */
578 /* First, skip any consecutive separators */
579 while ( *p == PERLLIB_SEP ) {
580 /* Uncomment the next line for PATH semantics */
581 /* (void)av_push(GvAVn(incgv), newSVpv(".", 1)); */
584 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
585 (void)av_push(GvAVn(incgv), newSVpv(p, (I32)(s - p)));
588 (void)av_push(GvAVn(incgv), newSVpv(p, 0));
594 /* This routine handles any switches that can be given during run */
604 nrschar = scan_oct(s, 4, &numlen);
605 nrs = nsavestr("\n",1);
607 if (nrschar > 0377) {
611 else if (!nrschar && numlen >= 2) {
627 if (euid != uid || egid != gid)
628 fatal("No -d allowed in setuid scripts");
636 if (euid != uid || egid != gid)
637 fatal("No -D allowed in setuid scripts");
640 static char debopts[] = "psltocPmfrxuLHX";
643 for (s++; *s && (d = strchr(debopts,*s)); s++)
644 debug |= 1 << (d - debopts);
648 for (s++; isDIGIT(*s); s++) ;
652 warn("Recompile perl with -DDEBUGGING to use -D switch\n");
653 for (s++; isDIGIT(*s); s++) ;
660 inplace = savestr(s+1);
662 for (s = inplace; *s && !isSPACE(*s); s++) ;
667 if (euid != uid || egid != gid)
668 fatal("No -I allowed in setuid scripts");
671 (void)av_push(GvAVn(incgv),newSVpv(s,0));
674 fatal("No space allowed after -I");
682 *ors = scan_oct(s, 3 + (*s == '0'), &numlen);
686 ors = nsavestr(nrs,nrslen);
700 if (euid != uid || egid != gid)
701 fatal("No -s allowed in setuid scripts");
715 fputs("\nThis is perl, version 5.0, Alpha 2 (unsupported)\n\n",stdout);
717 fputs("\nCopyright (c) 1989, 1990, 1991, 1992, 1993 Larry Wall\n",stdout);
719 fputs("MS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n",
722 fputs("OS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n",
727 fputs("atariST series port, ++jrb bammi@cadence.com\n", stdout);
730 Perl may be copied only under the terms of either the Artistic License or the\n\
731 GNU General Public License, which may be found in the Perl 5.0 source kit.\n",stdout);
741 if (s[1] == '-') /* Additional switches on #! line. */
749 fatal("Switch meaningless after -x: -%s",s);
754 /* compliments of Tom Christiansen */
756 /* unexec() can be found in the Gnu emacs distribution */
765 sprintf (buf, "%s.perldump", origfilename);
766 sprintf (tokenbuf, "%s/perl", BIN);
768 status = unexec(buf, tokenbuf, &etext, sbrk(0), 0);
770 fprintf(stderr, "unexec of %s into %s failed!\n", tokenbuf, buf);
773 ABORT(); /* for use with undump */
780 curstash = defstash = newHV(0);
781 curstname = newSVpv("main",4);
782 GvHV(gv_fetchpv("_main",TRUE)) = defstash;
783 HvNAME(defstash) = "main";
784 incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE)));
786 defgv = gv_fetchpv("_",TRUE);
790 open_script(scriptname,dosearch,sv)
795 char *xfound = Nullch;
796 char *xfailed = Nullch;
800 if (dosearch && !strchr(scriptname, '/') && (s = getenv("PATH"))) {
802 bufend = s + strlen(s);
805 s = cpytill(tokenbuf,s,bufend,':',&len);
808 for (len = 0; *s && *s != ',' && *s != ';'; tokenbuf[len++] = *s++);
809 tokenbuf[len] = '\0';
811 for (len = 0; *s && *s != ';'; tokenbuf[len++] = *s++);
812 tokenbuf[len] = '\0';
818 if (len && tokenbuf[len-1] != '/')
821 if (len && ((tokenbuf[len-1] != '\\') && (tokenbuf[len-1] != '/')))
823 if (len && tokenbuf[len-1] != '\\')
826 (void)strcat(tokenbuf+len,"/");
827 (void)strcat(tokenbuf+len,scriptname);
828 DEBUG_p(fprintf(stderr,"Looking for %s\n",tokenbuf));
829 if (stat(tokenbuf,&statbuf) < 0) /* not there? */
831 if (S_ISREG(statbuf.st_mode)
832 && cando(S_IRUSR,TRUE,&statbuf) && cando(S_IXUSR,TRUE,&statbuf)) {
833 xfound = tokenbuf; /* bingo! */
837 xfailed = savestr(tokenbuf);
840 fatal("Can't execute %s", xfailed ? xfailed : scriptname );
846 origfilename = savestr(scriptname);
847 curcop->cop_filegv = gv_fetchfile(origfilename);
848 if (strEQ(origfilename,"-"))
851 char *cpp = CPPSTDIN;
853 if (strEQ(cpp,"cppstdin"))
854 sprintf(tokenbuf, "%s/%s", SCRIPTDIR, cpp);
856 sprintf(tokenbuf, "%s", cpp);
858 sv_catpv(sv,PRIVLIB);
860 (void)sprintf(buf, "\
861 sed %s -e \"/^[^#]/b\" \
862 -e \"/^#[ ]*include[ ]/b\" \
863 -e \"/^#[ ]*define[ ]/b\" \
864 -e \"/^#[ ]*if[ ]/b\" \
865 -e \"/^#[ ]*ifdef[ ]/b\" \
866 -e \"/^#[ ]*ifndef[ ]/b\" \
867 -e \"/^#[ ]*else/b\" \
868 -e \"/^#[ ]*elif[ ]/b\" \
869 -e \"/^#[ ]*undef[ ]/b\" \
870 -e \"/^#[ ]*endif/b\" \
873 (doextract ? "-e \"1,/^#/d\n\"" : ""),
875 (void)sprintf(buf, "\
876 %s %s -e '/^[^#]/b' \
877 -e '/^#[ ]*include[ ]/b' \
878 -e '/^#[ ]*define[ ]/b' \
879 -e '/^#[ ]*if[ ]/b' \
880 -e '/^#[ ]*ifdef[ ]/b' \
881 -e '/^#[ ]*ifndef[ ]/b' \
883 -e '/^#[ ]*elif[ ]/b' \
884 -e '/^#[ ]*undef[ ]/b' \
885 -e '/^#[ ]*endif/b' \
893 (doextract ? "-e '1,/^#/d\n'" : ""),
895 scriptname, tokenbuf, SvPVn(sv), CPPMINUS);
896 DEBUG_P(fprintf(stderr, "%s\n", buf));
898 #ifdef IAMSUID /* actually, this is caught earlier */
899 if (euid != uid && !euid) { /* if running suidperl */
901 (void)seteuid(uid); /* musn't stay setuid root */
904 (void)setreuid(-1, uid);
909 if (geteuid() != uid)
910 fatal("Can't do seteuid!\n");
913 rsfp = my_popen(buf,"r");
915 else if (!*scriptname) {
917 if (euid != uid || egid != gid)
918 fatal("Can't take set-id script from stdin");
923 rsfp = fopen(scriptname,"r");
924 if ((FILE*)rsfp == Nullfp) {
926 #ifndef IAMSUID /* in case script is not readable before setuid */
927 if (euid && stat(SvPV(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
928 statbuf.st_mode & (S_ISUID|S_ISGID)) {
929 (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
930 execv(buf, origargv); /* try again */
931 fatal("Can't do setuid\n");
935 fatal("Can't open perl script \"%s\": %s\n",
936 SvPV(GvSV(curcop->cop_filegv)), strerror(errno));
941 validate_suid(validarg)
945 /* do we need to emulate setuid on scripts? */
947 /* This code is for those BSD systems that have setuid #! scripts disabled
948 * in the kernel because of a security problem. Merely defining DOSUID
949 * in perl will not fix that problem, but if you have disabled setuid
950 * scripts in the kernel, this will attempt to emulate setuid and setgid
951 * on scripts that have those now-otherwise-useless bits set. The setuid
952 * root version must be called suidperl or sperlN.NNN. If regular perl
953 * discovers that it has opened a setuid script, it calls suidperl with
954 * the same argv that it had. If suidperl finds that the script it has
955 * just opened is NOT setuid root, it sets the effective uid back to the
956 * uid. We don't just make perl setuid root because that loses the
957 * effective uid we had before invoking perl, if it was different from the
960 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
961 * be defined in suidperl only. suidperl must be setuid root. The
962 * Configure script will set this up for you if you want it.
964 * There is also the possibility of have a script which is running
965 * set-id due to a C wrapper. We want to do the TAINT checks
966 * on these set-id scripts, but don't want to have the overhead of
967 * them in normal perl, and can't use suidperl because it will lose
968 * the effective uid info, so we have an additional non-setuid root
969 * version called taintperl or tperlN.NNN that just does the TAINT checks.
973 if (fstat(fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
974 fatal("Can't stat script \"%s\"",origfilename);
975 if (statbuf.st_mode & (S_ISUID|S_ISGID)) {
980 /* On this access check to make sure the directories are readable,
981 * there is actually a small window that the user could use to make
982 * filename point to an accessible directory. So there is a faint
983 * chance that someone could execute a setuid script down in a
984 * non-accessible directory. I don't know what to do about that.
985 * But I don't think it's too important. The manual lies when
986 * it says access() is useful in setuid programs.
988 if (access(SvPV(GvSV(curcop->cop_filegv)),1)) /*double check*/
989 fatal("Permission denied");
991 /* If we can swap euid and uid, then we can determine access rights
992 * with a simple stat of the file, and then compare device and
993 * inode to make sure we did stat() on the same file we opened.
994 * Then we just have to make sure he or she can execute it.
997 struct stat tmpstatbuf;
999 if (setreuid(euid,uid) < 0 || getuid() != euid || geteuid() != uid)
1000 fatal("Can't swap uid and euid"); /* really paranoid */
1001 if (stat(SvPV(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
1002 fatal("Permission denied"); /* testing full pathname here */
1003 if (tmpstatbuf.st_dev != statbuf.st_dev ||
1004 tmpstatbuf.st_ino != statbuf.st_ino) {
1006 if (rsfp = my_popen("/bin/mail root","w")) { /* heh, heh */
1008 "User %d tried to run dev %d ino %d in place of dev %d ino %d!\n\
1009 (Filename of set-id script was %s, uid %d gid %d.)\n\nSincerely,\nperl\n",
1010 uid,tmpstatbuf.st_dev, tmpstatbuf.st_ino,
1011 statbuf.st_dev, statbuf.st_ino,
1012 SvPV(GvSV(curcop->cop_filegv)),
1013 statbuf.st_uid, statbuf.st_gid);
1014 (void)my_pclose(rsfp);
1016 fatal("Permission denied\n");
1018 if (setreuid(uid,euid) < 0 || getuid() != uid || geteuid() != euid)
1019 fatal("Can't reswap uid and euid");
1020 if (!cando(S_IXUSR,FALSE,&statbuf)) /* can real uid exec? */
1021 fatal("Permission denied\n");
1023 #endif /* HAS_SETREUID */
1024 #endif /* IAMSUID */
1026 if (!S_ISREG(statbuf.st_mode))
1027 fatal("Permission denied");
1028 if (statbuf.st_mode & S_IWOTH)
1029 fatal("Setuid/gid script is writable by world");
1030 doswitches = FALSE; /* -s is insecure in suid */
1032 if (fgets(tokenbuf,sizeof tokenbuf, rsfp) == Nullch ||
1033 strnNE(tokenbuf,"#!",2) ) /* required even on Sys V */
1034 fatal("No #! line");
1037 while (!isSPACE(*s)) s++;
1038 if (strnNE(s-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
1039 fatal("Not a perl script");
1040 while (*s == ' ' || *s == '\t') s++;
1042 * #! arg must be what we saw above. They can invoke it by
1043 * mentioning suidperl explicitly, but they may not add any strange
1044 * arguments beyond what #! says if they do invoke suidperl that way.
1046 len = strlen(validarg);
1047 if (strEQ(validarg," PHOOEY ") ||
1048 strnNE(s,validarg,len) || !isSPACE(s[len]))
1049 fatal("Args must match #! line");
1052 if (euid != uid && (statbuf.st_mode & S_ISUID) &&
1053 euid == statbuf.st_uid)
1055 fatal("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
1056 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
1057 #endif /* IAMSUID */
1059 if (euid) { /* oops, we're not the setuid root perl */
1062 (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
1063 execv(buf, origargv); /* try again */
1065 fatal("Can't do setuid\n");
1068 if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
1070 (void)setegid(statbuf.st_gid);
1073 (void)setregid((GIDTYPE)-1,statbuf.st_gid);
1075 setgid(statbuf.st_gid);
1078 if (getegid() != statbuf.st_gid)
1079 fatal("Can't do setegid!\n");
1081 if (statbuf.st_mode & S_ISUID) {
1082 if (statbuf.st_uid != euid)
1084 (void)seteuid(statbuf.st_uid); /* all that for this */
1087 (void)setreuid((UIDTYPE)-1,statbuf.st_uid);
1089 setuid(statbuf.st_uid);
1092 if (geteuid() != statbuf.st_uid)
1093 fatal("Can't do seteuid!\n");
1095 else if (uid) { /* oops, mustn't run as root */
1097 (void)seteuid((UIDTYPE)uid);
1100 (void)setreuid((UIDTYPE)-1,(UIDTYPE)uid);
1102 setuid((UIDTYPE)uid);
1105 if (geteuid() != uid)
1106 fatal("Can't do seteuid!\n");
1108 uid = (int)getuid();
1109 euid = (int)geteuid();
1110 gid = (int)getgid();
1111 egid = (int)getegid();
1112 if (!cando(S_IXUSR,TRUE,&statbuf))
1113 fatal("Permission denied\n"); /* they can't do this */
1116 else if (preprocess)
1117 fatal("-P not allowed for setuid/setgid script\n");
1119 fatal("Script is not setuid/setgid in suidperl\n");
1121 #ifndef TAINT /* we aren't taintperl or suidperl */
1122 /* script has a wrapper--can't run suidperl or we lose euid */
1123 else if (euid != uid || egid != gid) {
1125 (void)sprintf(buf, "%s/tperl%s", BIN, patchlevel);
1126 execv(buf, origargv); /* try again */
1127 fatal("Can't run setuid script with taint checks");
1130 #endif /* IAMSUID */
1132 #ifndef TAINT /* we aren't taintperl or suidperl */
1133 if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */
1134 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
1135 fstat(fileno(rsfp),&statbuf); /* may be either wrapped or real suid */
1136 if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
1138 (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
1141 fatal("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
1142 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
1143 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
1144 /* not set-id, must be wrapped */
1146 (void)sprintf(buf, "%s/tperl%s", BIN, patchlevel);
1147 execv(buf, origargv); /* try again */
1148 fatal("Can't run setuid script with taint checks");
1157 #if !defined(IAMSUID) && !defined(TAINT)
1160 /* skip forward in input to the real script? */
1163 if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
1164 fatal("No Perl script found in input\n");
1165 if (*s == '#' && s[1] == '!' && instr(s,"perl")) {
1166 ungetc('\n',rsfp); /* to keep line count right */
1168 if (s = instr(s,"perl -")) {
1171 while (s = moreswitches(s)) ;
1173 if (cddir && chdir(cddir) < 0)
1174 fatal("Can't chdir to %s",cddir);
1177 #endif /* !defined(IAMSUID) && !defined(TAINT) */
1185 debstash = newHV(0);
1186 GvHV(gv_fetchpv("_DB",TRUE)) = debstash;
1187 curstash = debstash;
1188 dbargs = GvAV(gv_AVadd((tmpgv = gv_fetchpv("args",TRUE))));
1191 DBgv = gv_fetchpv("DB",TRUE);
1193 DBline = gv_fetchpv("dbline",TRUE);
1195 DBsub = gv_HVadd(tmpgv = gv_fetchpv("sub",TRUE));
1197 DBsingle = GvSV((tmpgv = gv_fetchpv("single",TRUE)));
1199 DBtrace = GvSV((tmpgv = gv_fetchpv("trace",TRUE)));
1201 DBsignal = GvSV((tmpgv = gv_fetchpv("signal",TRUE)));
1203 curstash = defstash;
1210 mainstack = stack; /* remember in case we switch stacks */
1211 AvREAL_off(stack); /* not a real array */
1212 av_fill(stack,127); av_fill(stack,-1); /* preextend stack */
1214 stack_base = AvARRAY(stack);
1215 stack_sp = stack_base;
1216 stack_max = stack_base + 128;
1218 New(54,markstack,64,int);
1219 markstack_ptr = markstack;
1220 markstack_max = markstack + 64;
1222 New(54,scopestack,32,int);
1224 scopestack_max = 32;
1226 New(54,savestack,128,ANY);
1228 savestack_max = 128;
1230 New(54,retstack,16,OP*);
1238 bufend = bufptr = SvPVn(linestr);
1239 subname = newSVpv("main",4);
1243 init_context_stack()
1245 New(50,cxstack,128,CONTEXT);
1247 New(51,debname,128,char);
1248 New(52,debdelim,128,char);
1253 init_predump_symbols()
1257 sv_setpvn(GvSV(gv_fetchpv("\"", TRUE)), " ", 1);
1259 stdingv = gv_fetchpv("STDIN",TRUE);
1260 SvMULTI_on(stdingv);
1262 GvIO(stdingv) = newIO();
1263 GvIO(stdingv)->ifp = stdin;
1264 tmpgv = gv_fetchpv("stdin",TRUE);
1265 GvIO(tmpgv) = GvIO(stdingv);
1268 tmpgv = gv_fetchpv("STDOUT",TRUE);
1271 GvIO(tmpgv) = newIO();
1272 GvIO(tmpgv)->ofp = GvIO(tmpgv)->ifp = stdout;
1274 tmpgv = gv_fetchpv("stdout",TRUE);
1275 GvIO(tmpgv) = GvIO(defoutgv);
1278 curoutgv = gv_fetchpv("STDERR",TRUE);
1279 SvMULTI_on(curoutgv);
1280 if (!GvIO(curoutgv))
1281 GvIO(curoutgv) = newIO();
1282 GvIO(curoutgv)->ofp = GvIO(curoutgv)->ifp = stderr;
1283 tmpgv = gv_fetchpv("stderr",TRUE);
1284 GvIO(tmpgv) = GvIO(curoutgv);
1286 curoutgv = defoutgv; /* switch back to STDOUT */
1288 statname = NEWSV(66,0); /* last filename we did stat on */
1292 init_postdump_symbols(argc,argv,env)
1294 register char **argv;
1295 register char **env;
1301 argc--,argv++; /* skip name of script */
1303 for (; argc > 0 && **argv == '-'; argc--,argv++) {
1306 if (argv[0][1] == '-') {
1310 if (s = strchr(argv[0], '=')) {
1312 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE)),s);
1315 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE)),1);
1318 toptarget = NEWSV(0,0);
1319 sv_upgrade(toptarget, SVt_PVFM);
1320 sv_setpvn(toptarget, "", 0);
1321 bodytarget = NEWSV(0,0);
1322 sv_upgrade(bodytarget, SVt_PVFM);
1323 sv_setpvn(bodytarget, "", 0);
1324 formtarget = bodytarget;
1329 if (tmpgv = gv_fetchpv("0",allgvs)) {
1330 sv_setpv(GvSV(tmpgv),origfilename);
1331 magicname("0", "0", 1);
1333 if (tmpgv = gv_fetchpv("\024",allgvs))
1335 if (tmpgv = gv_fetchpv("\030",allgvs))
1336 sv_setpv(GvSV(tmpgv),origargv[0]);
1337 if (argvgv = gv_fetchpv("ARGV",allgvs)) {
1339 (void)gv_AVadd(argvgv);
1340 av_clear(GvAVn(argvgv));
1341 for (; argc > 0; argc--,argv++) {
1342 (void)av_push(GvAVn(argvgv),newSVpv(argv[0],0));
1346 (void) gv_fetchpv("ENV",TRUE); /* must test PATH and IFS */
1348 if (envgv = gv_fetchpv("ENV",allgvs)) {
1352 hv_clear(hv, FALSE);
1353 hv_magic(hv, envgv, 'E');
1355 environ[0] = Nullch;
1356 for (; *env; env++) {
1357 if (!(s = strchr(*env,'=')))
1360 sv = newSVpv(s--,0);
1361 (void)hv_store(hv, *env, s - *env, sv, 0);
1368 if (tmpgv = gv_fetchpv("$",allgvs))
1369 sv_setiv(GvSV(tmpgv),(I32)getpid());
1380 #ifndef TAINT /* Can't allow arbitrary PERLLIB in setuid script */
1381 incpush(getenv("PERLLIB"));
1385 #define PRIVLIB "/usr/local/lib/perl"
1388 (void)av_push(GvAVn(incgv),newSVpv(".",1));
1396 I32 fill = AvFILL(list);
1398 I32 sp = stack_sp - stack_base;
1400 av_store(stack, ++sp, Nullsv); /* reserve spot for 1st return arg */
1401 Copy(top_env, oldtop, 1, jmp_buf);
1403 for (i = 0; i <= fill; i++)
1405 GV *gv = (GV*)av_shift(list);
1406 SV* tmpsv = NEWSV(0,0);
1408 if (gv && GvCV(gv)) {
1409 gv_efullname(tmpsv, gv);
1410 if (setjmp(top_env)) {
1411 if (list == beginav)
1415 perl_callback(SvPV(tmpsv), sp, G_SCALAR, 0, 0);
1422 Copy(oldtop, top_env, 1, jmp_buf);