3 * Copyright (c) 1987-1996 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.
11 * "A ship then new they built for him/of mithril and of elven glass" --Bilbo
16 #include "patchlevel.h"
18 /* Omit -- it causes too much grief on mixed systems.
24 dEXT char rcsid[] = "perl.c\nPatch level: ###\n";
32 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
38 static void find_beginning _((void));
39 static void incpush _((char *));
40 static void init_ids _((void));
41 static void init_debugger _((void));
42 static void init_lexer _((void));
43 static void init_main_stash _((void));
44 static void init_perllib _((void));
45 static void init_postdump_symbols _((int, char **, char **));
46 static void init_predump_symbols _((void));
47 static void init_stacks _((void));
48 static void open_script _((char *, bool, SV *));
49 static void usage _((char *));
50 static void validate_suid _((char *));
55 PerlInterpreter *sv_interp;
58 New(53, sv_interp, 1, PerlInterpreter);
63 perl_construct( sv_interp )
64 register PerlInterpreter *sv_interp;
66 if (!(curinterp = sv_interp))
70 Zero(sv_interp, 1, PerlInterpreter);
73 /* Init the real globals? */
75 linestr = NEWSV(65,80);
76 sv_upgrade(linestr,SVt_PVIV);
78 SvREADONLY_on(&sv_undef);
82 SvREADONLY_on(&sv_no);
84 sv_setpv(&sv_yes,Yes);
86 SvREADONLY_on(&sv_yes);
88 nrs = newSVpv("\n", 1);
89 rs = SvREFCNT_inc(nrs);
93 * There is no way we can refer to them from Perl so close them to save
94 * space. The other alternative would be to provide STDAUX and STDPRN
119 #if defined(SUBVERSION) && SUBVERSION > 0
120 sprintf(patchlevel, "%7.5f", 5.0 + (PATCHLEVEL / 1000.0)
121 + (SUBVERSION / 100000.0));
123 sprintf(patchlevel, "%5.3f", 5.0 + (PATCHLEVEL / 1000.0));
126 #if defined(LOCAL_PATCH_COUNT)
127 Ilocalpatches = local_patches; /* For possible -v */
130 fdpid = newAV(); /* for remembering popen pids by fd */
131 pidstatus = newHV();/* for remembering status of dead pids */
138 perl_destruct(sv_interp)
139 register PerlInterpreter *sv_interp;
141 int destruct_level; /* 0=none, 1=full, 2=full with checks */
145 if (!(curinterp = sv_interp))
148 destruct_level = perl_destruct_level;
152 if (s = getenv("PERL_DESTRUCT_LEVEL"))
153 destruct_level = atoi(s);
161 /* We must account for everything. First the syntax tree. */
163 curpad = AvARRAY(comppad);
170 * Try to destruct global references. We do this first so that the
171 * destructors and destructees still exist. Some sv's might remain.
172 * Non-referenced objects are on their own.
179 if (destruct_level == 0){
181 DEBUG_P(debprofdump());
183 /* The exit() function will do everything that needs doing. */
187 /* Prepare to destruct main symbol table. */
193 if (destruct_level >= 2) {
194 if (scopestack_ix != 0)
195 warn("Unbalanced scopes: %d more ENTERs than LEAVEs\n", scopestack_ix);
196 if (savestack_ix != 0)
197 warn("Unbalanced saves: %d more saves than restores\n", savestack_ix);
198 if (tmps_floor != -1)
199 warn("Unbalanced tmps: %d more allocs than frees\n", tmps_floor + 1);
200 if (cxstack_ix != -1)
201 warn("Unbalanced context: %d more PUSHes than POPs\n", cxstack_ix + 1);
204 /* Now absolutely destruct everything, somehow or other, loops or no. */
206 while (sv_count != 0 && sv_count != last_sv_count) {
207 last_sv_count = sv_count;
211 warn("Scalars leaked: %d\n", sv_count);
214 DEBUG_P(debprofdump());
219 PerlInterpreter *sv_interp;
221 if (!(curinterp = sv_interp))
225 #if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE)
226 char *getenv _((char *)); /* Usually in <stdlib.h> */
230 perl_parse(sv_interp, xsinit, argc, argv, env)
231 PerlInterpreter *sv_interp;
232 void (*xsinit)_((void));
239 char *scriptname = NULL;
240 VOL bool dosearch = FALSE;
244 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
247 croak("suidperl is no longer needed since the kernel can now execute\n\
248 setuid perl scripts securely.\n");
252 if (!(curinterp = sv_interp))
257 #ifndef VMS /* VMS doesn't have environ array */
258 origenviron = environ;
264 /* Come here if running an undumped a.out. */
266 origfilename = savepv(argv[0]);
268 cxstack_ix = -1; /* start label stack again */
270 init_postdump_symbols(argc,argv,env);
278 switch (Sigsetjmp(top_env,1)) {
289 return(statusvalue); /* my_exit() was called */
291 fprintf(stderr, "panic: top_env\n");
295 sv_setpvn(linestr,"",0);
296 sv = newSVpv("",0); /* first used for -I flags */
299 for (argc--,argv++; argc > 0; argc--,argv++) {
300 if (argv[0][0] != '-' || !argv[0][1])
304 validarg = " PHOOEY ";
330 if (s = moreswitches(s))
335 if (euid != uid || egid != gid)
336 croak("No -e allowed in setuid scripts");
338 e_tmpname = savepv(TMPPATH);
339 (void)mktemp(e_tmpname);
341 croak("Can't mktemp()");
342 e_fp = fopen(e_tmpname,"w");
344 croak("Cannot open temporary file");
350 (void)putc('\n', e_fp);
358 av_push(GvAVn(incgv),newSVpv(s,0));
361 av_push(GvAVn(incgv),newSVpv(argv[1],0));
362 sv_catpv(sv,argv[1]);
379 preambleav = newAV();
380 av_push(preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
382 Sv = newSVpv("print myconfig(),'@INC: '.\"@INC\\n\"",0);
385 Sv = newSVpv("config_vars(qw(",0);
390 av_push(preambleav, Sv);
391 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
405 croak("Unrecognized switch: -%s",s);
410 scriptname = argv[0];
412 if (Fflush(e_fp) || ferror(e_fp) || fclose(e_fp))
413 croak("Can't write to temp file for -e: %s", Strerror(errno));
416 scriptname = e_tmpname;
418 else if (scriptname == Nullch) {
420 if ( isatty(fileno(stdin)) )
428 open_script(scriptname,dosearch,sv);
430 validate_suid(validarg);
435 compcv = (CV*)NEWSV(1104,0);
436 sv_upgrade((SV *)compcv, SVt_PVCV);
440 av_push(comppad, Nullsv);
441 curpad = AvARRAY(comppad);
443 comppad_name = padname;
444 comppad_name_fill = 0;
445 min_intro_pending = 0;
448 comppadlist = newAV();
449 AvREAL_off(comppadlist);
450 av_store(comppadlist, 0, (SV*)comppad_name);
451 av_store(comppadlist, 1, (SV*)comppad);
452 CvPADLIST(compcv) = comppadlist;
455 (*xsinit)(); /* in case linked C routines want magical variables */
460 init_predump_symbols();
462 init_postdump_symbols(argc,argv,env);
466 /* now parse the script */
469 if (yyparse() || error_count) {
471 croak("%s had compilation errors.\n", origfilename);
473 croak("Execution of %s aborted due to compilation errors.\n",
477 curcop->cop_line = 0;
481 (void)UNLINK(e_tmpname);
486 /* now that script is parsed, we can modify record separator */
488 rs = SvREFCNT_inc(nrs);
489 sv_setsv(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), rs);
500 #ifdef DEBUGGING_MSTATS
501 if ((s=getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
502 dump_mstats("after compilation:");
512 PerlInterpreter *sv_interp;
514 if (!(curinterp = sv_interp))
516 switch (Sigsetjmp(top_env,1)) {
518 cxstack_ix = -1; /* start context stack again */
525 #ifdef DEBUGGING_MSTATS
526 if (getenv("PERL_DEBUG_MSTATS"))
527 dump_mstats("after execution: ");
529 return(statusvalue); /* my_exit() was called */
532 fprintf(stderr, "panic: restartop\n");
536 if (stack != mainstack) {
538 SWITCHSTACK(stack, mainstack);
545 DEBUG(fprintf(stderr,"\nEXECUTING...\n\n"));
548 fprintf(stderr,"%s syntax OK\n", origfilename);
551 if (perldb && DBsingle)
552 sv_setiv(DBsingle, 1);
562 else if (main_start) {
575 register CONTEXT *cx;
579 statusvalue = FIXSTATUS(status);
580 if (cxstack_ix >= 0) {
586 Siglongjmp(top_env, 2);
590 perl_get_sv(name, create)
594 GV* gv = gv_fetchpv(name, create, SVt_PV);
601 perl_get_av(name, create)
605 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
614 perl_get_hv(name, create)
618 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
627 perl_get_cv(name, create)
631 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
632 if (create && !GvCV(gv))
633 return newSUB(start_subparse(),
634 newSVOP(OP_CONST, 0, newSVpv(name,0)),
642 /* Be sure to refetch the stack pointer after calling these routines. */
645 perl_call_argv(subname, flags, argv)
647 I32 flags; /* See G_* flags in cop.h */
648 register char **argv; /* null terminated arg list */
655 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
660 return perl_call_pv(subname, flags);
664 perl_call_pv(subname, flags)
665 char *subname; /* name of the subroutine */
666 I32 flags; /* See G_* flags in cop.h */
668 return perl_call_sv((SV*)perl_get_cv(subname, TRUE), flags);
672 perl_call_method(methname, flags)
673 char *methname; /* name of the subroutine */
674 I32 flags; /* See G_* flags in cop.h */
680 XPUSHs(sv_2mortal(newSVpv(methname,0)));
683 return perl_call_sv(*stack_sp--, flags);
686 /* May be called with any of a CV, a GV, or an SV containing the name. */
688 perl_call_sv(sv, flags)
690 I32 flags; /* See G_* flags in cop.h */
692 LOGOP myop; /* fake syntax tree node */
694 I32 oldmark = TOPMARK;
699 if (flags & G_DISCARD) {
709 oldscope = scopestack_ix;
711 if (!(flags & G_NOARGS))
712 myop.op_flags = OPf_STACKED;
713 myop.op_next = Nullop;
714 myop.op_flags |= OPf_KNOW;
716 myop.op_flags |= OPf_LIST;
718 if (flags & G_EVAL) {
719 Copy(top_env, oldtop, 1, Sigjmp_buf);
721 cLOGOP->op_other = op;
723 /* we're trying to emulate pp_entertry() here */
725 register CONTEXT *cx;
731 push_return(op->op_next);
732 PUSHBLOCK(cx, CXt_EVAL, stack_sp);
734 eval_root = op; /* Only needed so that goto works right. */
737 if (flags & G_KEEPERR)
740 sv_setpv(GvSV(errgv),"");
745 switch (Sigsetjmp(top_env,1)) {
750 statusvalue = 255; /* XXX I don't think we use 1 anymore. */
756 /* my_exit() was called */
759 Copy(oldtop, top_env, 1, Sigjmp_buf);
761 croak("Callback called exit");
762 my_exit(statusvalue);
770 stack_sp = stack_base + oldmark;
775 *++stack_sp = &sv_undef;
781 if (op == (OP*)&myop)
785 retval = stack_sp - (stack_base + oldmark);
786 if ((flags & G_EVAL) && !(flags & G_KEEPERR))
787 sv_setpv(GvSV(errgv),"");
790 if (flags & G_EVAL) {
791 if (scopestack_ix > oldscope) {
795 register CONTEXT *cx;
804 Copy(oldtop, top_env, 1, Sigjmp_buf);
806 if (flags & G_DISCARD) {
807 stack_sp = stack_base + oldmark;
818 perl_eval_sv(sv, flags)
820 I32 flags; /* See G_* flags in cop.h */
822 UNOP myop; /* fake syntax tree node */
824 I32 oldmark = sp - stack_base;
829 if (flags & G_DISCARD) {
839 oldscope = scopestack_ix;
841 if (!(flags & G_NOARGS))
842 myop.op_flags = OPf_STACKED;
843 myop.op_next = Nullop;
844 myop.op_flags |= OPf_KNOW;
846 myop.op_flags |= OPf_LIST;
848 Copy(top_env, oldtop, 1, Sigjmp_buf);
851 switch (Sigsetjmp(top_env,1)) {
856 statusvalue = 255; /* XXX I don't think we use 1 anymore. */
862 /* my_exit() was called */
865 Copy(oldtop, top_env, 1, Sigjmp_buf);
867 croak("Callback called exit");
868 my_exit(statusvalue);
876 stack_sp = stack_base + oldmark;
881 *++stack_sp = &sv_undef;
886 if (op == (OP*)&myop)
890 retval = stack_sp - (stack_base + oldmark);
891 if ((flags & G_EVAL) && !(flags & G_KEEPERR))
892 sv_setpv(GvSV(errgv),"");
895 Copy(oldtop, top_env, 1, Sigjmp_buf);
896 if (flags & G_DISCARD) {
897 stack_sp = stack_base + oldmark;
905 /* Require a module. */
911 SV* sv = sv_newmortal();
912 sv_setpv(sv, "require '");
915 perl_eval_sv(sv, G_DISCARD);
919 magicname(sym,name,namlen)
926 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
927 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
931 # define PERLLIB_SEP ';'
934 # define PERLLIB_SEP '|'
936 # define PERLLIB_SEP ':'
949 /* Break at all separators */
951 /* First, skip any consecutive separators */
952 while ( *p == PERLLIB_SEP ) {
953 /* Uncomment the next line for PATH semantics */
954 /* av_push(GvAVn(incgv), newSVpv(".", 1)); */
957 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
958 av_push(GvAVn(incgv), newSVpv(p, (STRLEN)(s - p)));
961 av_push(GvAVn(incgv), newSVpv(p, 0));
968 usage(name) /* XXX move this out into a module ? */
971 /* This message really ought to be max 23 lines.
972 * Removed -h because the user already knows that opton. Others? */
973 printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
974 printf("\n -0[octal] specify record separator (\\0, if no argument)");
975 printf("\n -a autosplit mode with -n or -p (splits $_ into @F)");
976 printf("\n -c check syntax only (runs BEGIN and END blocks)");
977 printf("\n -d[:debugger] run scripts under debugger");
978 printf("\n -D[number/list] set debugging flags (argument is a bit mask or flags)");
979 printf("\n -e 'command' one line of script. Several -e's allowed. Omit [programfile].");
980 printf("\n -F/pattern/ split() pattern for autosplit (-a). The //'s are optional.");
981 printf("\n -i[extension] edit <> files in place (make backup if extension supplied)");
982 printf("\n -Idirectory specify @INC/#include directory (may be used more then once)");
983 printf("\n -l[octal] enable line ending processing, specifies line teminator");
984 printf("\n -[mM][-]module.. executes `use/no module...' before executing your script.");
985 printf("\n -n assume 'while (<>) { ... }' loop arround your script");
986 printf("\n -p assume loop like -n but print line also like sed");
987 printf("\n -P run script through C preprocessor before compilation");
989 printf("\n -R enable REXX variable pool");
991 printf("\n -s enable some switch parsing for switches after script name");
992 printf("\n -S look for the script using PATH environment variable");
993 printf("\n -T turn on tainting checks");
994 printf("\n -u dump core after parsing script");
995 printf("\n -U allow unsafe operations");
996 printf("\n -v print version number and patchlevel of perl");
997 printf("\n -V[:variable] print perl configuration information");
998 printf("\n -w TURN WARNINGS ON FOR COMPILATION OF YOUR SCRIPT.");
999 printf("\n -x[directory] strip off text before #!perl line and perhaps cd to directory\n");
1002 /* This routine handles any switches that can be given during run */
1013 rschar = scan_oct(s, 4, &numlen);
1015 if (rschar & ~((U8)~0))
1017 else if (!rschar && numlen >= 2)
1018 nrs = newSVpv("", 0);
1021 nrs = newSVpv(&ch, 1);
1026 splitstr = savepv(s + 1);
1040 if (*s == ':' || *s == '=') {
1041 sprintf(buf, "use Devel::%s;", ++s);
1043 my_setenv("PERL5DB",buf);
1053 if (isALPHA(s[1])) {
1054 static char debopts[] = "psltocPmfrxuLHXD";
1057 for (s++; *s && (d = strchr(debopts,*s)); s++)
1058 debug |= 1 << (d - debopts);
1062 for (s++; isDIGIT(*s); s++) ;
1064 debug |= 0x80000000;
1066 warn("Recompile perl with -DDEBUGGING to use -D switch\n");
1067 for (s++; isALNUM(*s); s++) ;
1077 inplace = savepv(s+1);
1079 for (s = inplace; *s && !isSPACE(*s); s++) ;
1086 for (e = s; *e && !isSPACE(*e); e++) ;
1087 av_push(GvAVn(incgv),newSVpv(s,e-s));
1092 croak("No space allowed after -I");
1102 *ors = scan_oct(s, 3 + (*s == '0'), &numlen);
1107 ors = savepvn("\n\n", 2);
1111 ors = SvPV(nrs, orslen);
1115 taint_not("-M"); /* XXX ? */
1118 taint_not("-m"); /* XXX ? */
1122 /* -M-foo == 'no foo' */
1123 if (*s == '-') { use = "no "; ++s; }
1124 Sv = newSVpv(use,0);
1126 /* We allow -M'Module qw(Foo Bar)' */
1127 while(isALNUM(*s) || *s==':') ++s;
1129 sv_catpv(Sv, start);
1130 if (*(start-1) == 'm') {
1132 croak("Can't use '%c' after -mname", *s);
1133 sv_catpv( Sv, " ()");
1136 sv_catpvn(Sv, start, s-start);
1137 sv_catpv(Sv, " split(/,/,q{");
1142 if (preambleav == NULL)
1143 preambleav = newAV();
1144 av_push(preambleav, Sv);
1147 croak("No space allowed after -%c", *(s-1));
1175 #if defined(SUBVERSION) && SUBVERSION > 0
1176 printf("\nThis is perl, version 5.%03d_%02d", PATCHLEVEL, SUBVERSION);
1178 printf("\nThis is perl, version %s",patchlevel);
1181 #if defined(DEBUGGING) || defined(EMBED) || defined(MULTIPLICITY)
1182 fputs(" with", stdout);
1184 fputs(" DEBUGGING", stdout);
1187 fputs(" EMBED", stdout);
1190 fputs(" MULTIPLICITY", stdout);
1194 #if defined(LOCAL_PATCH_COUNT)
1195 if (LOCAL_PATCH_COUNT > 0)
1197 fputs("\n\tLocally applied patches:\n", stdout);
1198 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
1199 if (Ilocalpatches[i])
1200 fprintf(stdout, "\t %s\n", Ilocalpatches[i]);
1204 printf("\n\tbuilt under %s",OSNAME);
1207 printf(" at %s %s",__DATE__,__TIME__);
1209 printf(" on %s",__DATE__);
1212 fputs("\n\nCopyright 1987-1996, Larry Wall\n",stdout);
1214 fputs("MS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n",
1218 fputs("OS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1219 "Version 5 port Copyright (c) 1994-1995, Andreas Kaiser\n", stdout);
1222 fputs("atariST series port, ++jrb bammi@cadence.com\n", stdout);
1225 Perl may be copied only under the terms of either the Artistic License or the\n\
1226 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n",stdout);
1237 if (s[1] == '-') /* Additional switches on #! line. */
1250 croak("Can't emulate -%.1s on #! line",s);
1255 /* compliments of Tom Christiansen */
1257 /* unexec() can be found in the Gnu emacs distribution */
1266 sprintf (buf, "%s.perldump", origfilename);
1267 sprintf (tokenbuf, "%s/perl", BIN);
1269 status = unexec(buf, tokenbuf, &etext, sbrk(0), 0);
1271 fprintf(stderr, "unexec of %s into %s failed!\n", tokenbuf, buf);
1275 # include <lib$routines.h>
1276 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
1278 ABORT(); /* for use with undump */
1287 curstash = defstash = newHV();
1288 curstname = newSVpv("main",4);
1289 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1290 SvREFCNT_dec(GvHV(gv));
1291 GvHV(gv) = (HV*)SvREFCNT_inc(defstash);
1293 HvNAME(defstash) = savepv("main");
1294 incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1296 defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1297 errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1299 curstash = defstash;
1300 compiling.cop_stash = defstash;
1301 debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
1302 /* We must init $/ before switches are processed. */
1303 sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1);
1306 #ifdef CAN_PROTOTYPE
1308 open_script(char *scriptname, bool dosearch, SV *sv)
1311 open_script(scriptname,dosearch,sv)
1317 char *xfound = Nullch;
1318 char *xfailed = Nullch;
1322 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
1323 #define SEARCH_EXTS ".bat", ".cmd", NULL
1326 # define SEARCH_EXTS ".pl", ".com", NULL
1328 /* additional extensions to try in each dir if scriptname not found */
1330 char *ext[] = { SEARCH_EXTS };
1331 int extidx = (strchr(scriptname,'.')) ? -1 : 0; /* has ext already */
1335 if (dosearch && !strpbrk(scriptname,":[</") && (my_getenv("DCL$PATH"))) {
1338 while (my_trnlnm("DCL$PATH",tokenbuf,idx++)) {
1339 strcat(tokenbuf,scriptname);
1341 if (dosearch && !strchr(scriptname, '/') && (s = getenv("PATH"))) {
1343 bufend = s + strlen(s);
1346 s = cpytill(tokenbuf,s,bufend,':',&len);
1349 for (len = 0; *s && *s != ',' && *s != ';'; tokenbuf[len++] = *s++);
1350 tokenbuf[len] = '\0';
1352 for (len = 0; *s && *s != ';'; tokenbuf[len++] = *s++);
1353 tokenbuf[len] = '\0';
1359 if (len && tokenbuf[len-1] != '/')
1362 if (len && ((tokenbuf[len-1] != '\\') && (tokenbuf[len-1] != '/')))
1364 if (len && tokenbuf[len-1] != '\\')
1367 (void)strcat(tokenbuf+len,"/");
1368 (void)strcat(tokenbuf+len,scriptname);
1372 len = strlen(tokenbuf);
1373 if (extidx > 0) /* reset after previous loop */
1377 DEBUG_p(fprintf(stderr,"Looking for %s\n",tokenbuf));
1378 retval = Stat(tokenbuf,&statbuf);
1380 } while ( retval < 0 /* not there */
1381 && extidx>=0 && ext[extidx] /* try an extension? */
1382 && strcpy(tokenbuf+len, ext[extidx++])
1387 if (S_ISREG(statbuf.st_mode)
1388 && cando(S_IRUSR,TRUE,&statbuf) && cando(S_IXUSR,TRUE,&statbuf)) {
1389 xfound = tokenbuf; /* bingo! */
1393 xfailed = savepv(tokenbuf);
1396 croak("Can't execute %s", xfailed ? xfailed : scriptname );
1399 scriptname = xfound;
1402 origfilename = savepv(e_tmpname ? "-e" : scriptname);
1403 curcop->cop_filegv = gv_fetchfile(origfilename);
1404 if (strEQ(origfilename,"-"))
1407 char *cpp = CPPSTDIN;
1409 if (strEQ(cpp,"cppstdin"))
1410 sprintf(tokenbuf, "%s/%s", SCRIPTDIR, cpp);
1412 sprintf(tokenbuf, "%s", cpp);
1414 sv_catpv(sv,PRIVLIB_EXP);
1416 (void)sprintf(buf, "\
1417 sed %s -e \"/^[^#]/b\" \
1418 -e \"/^#[ ]*include[ ]/b\" \
1419 -e \"/^#[ ]*define[ ]/b\" \
1420 -e \"/^#[ ]*if[ ]/b\" \
1421 -e \"/^#[ ]*ifdef[ ]/b\" \
1422 -e \"/^#[ ]*ifndef[ ]/b\" \
1423 -e \"/^#[ ]*else/b\" \
1424 -e \"/^#[ ]*elif[ ]/b\" \
1425 -e \"/^#[ ]*undef[ ]/b\" \
1426 -e \"/^#[ ]*endif/b\" \
1429 (doextract ? "-e \"1,/^#/d\n\"" : ""),
1431 (void)sprintf(buf, "\
1432 %s %s -e '/^[^#]/b' \
1433 -e '/^#[ ]*include[ ]/b' \
1434 -e '/^#[ ]*define[ ]/b' \
1435 -e '/^#[ ]*if[ ]/b' \
1436 -e '/^#[ ]*ifdef[ ]/b' \
1437 -e '/^#[ ]*ifndef[ ]/b' \
1438 -e '/^#[ ]*else/b' \
1439 -e '/^#[ ]*elif[ ]/b' \
1440 -e '/^#[ ]*undef[ ]/b' \
1441 -e '/^#[ ]*endif/b' \
1449 (doextract ? "-e '1,/^#/d\n'" : ""),
1451 scriptname, tokenbuf, SvPV(sv, na), CPPMINUS);
1453 #ifdef IAMSUID /* actually, this is caught earlier */
1454 if (euid != uid && !euid) { /* if running suidperl */
1456 (void)seteuid(uid); /* musn't stay setuid root */
1459 (void)setreuid((Uid_t)-1, uid);
1461 #ifdef HAS_SETRESUID
1462 (void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
1468 if (geteuid() != uid)
1469 croak("Can't do seteuid!\n");
1471 #endif /* IAMSUID */
1472 rsfp = my_popen(buf,"r");
1474 else if (!*scriptname) {
1475 taint_not("program input from stdin");
1479 rsfp = fopen(scriptname,"r");
1480 if ((FILE*)rsfp == Nullfp) {
1482 #ifndef IAMSUID /* in case script is not readable before setuid */
1483 if (euid && Stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
1484 statbuf.st_mode & (S_ISUID|S_ISGID)) {
1485 (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
1486 execv(buf, origargv); /* try again */
1487 croak("Can't do setuid\n");
1491 croak("Can't open perl script \"%s\": %s\n",
1492 SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno));
1497 validate_suid(validarg)
1500 /* do we need to emulate setuid on scripts? */
1502 /* This code is for those BSD systems that have setuid #! scripts disabled
1503 * in the kernel because of a security problem. Merely defining DOSUID
1504 * in perl will not fix that problem, but if you have disabled setuid
1505 * scripts in the kernel, this will attempt to emulate setuid and setgid
1506 * on scripts that have those now-otherwise-useless bits set. The setuid
1507 * root version must be called suidperl or sperlN.NNN. If regular perl
1508 * discovers that it has opened a setuid script, it calls suidperl with
1509 * the same argv that it had. If suidperl finds that the script it has
1510 * just opened is NOT setuid root, it sets the effective uid back to the
1511 * uid. We don't just make perl setuid root because that loses the
1512 * effective uid we had before invoking perl, if it was different from the
1515 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
1516 * be defined in suidperl only. suidperl must be setuid root. The
1517 * Configure script will set this up for you if you want it.
1523 if (Fstat(fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
1524 croak("Can't stat script \"%s\"",origfilename);
1525 if (statbuf.st_mode & (S_ISUID|S_ISGID)) {
1529 #ifndef HAS_SETREUID
1530 /* On this access check to make sure the directories are readable,
1531 * there is actually a small window that the user could use to make
1532 * filename point to an accessible directory. So there is a faint
1533 * chance that someone could execute a setuid script down in a
1534 * non-accessible directory. I don't know what to do about that.
1535 * But I don't think it's too important. The manual lies when
1536 * it says access() is useful in setuid programs.
1538 if (access(SvPVX(GvSV(curcop->cop_filegv)),1)) /*double check*/
1539 croak("Permission denied");
1541 /* If we can swap euid and uid, then we can determine access rights
1542 * with a simple stat of the file, and then compare device and
1543 * inode to make sure we did stat() on the same file we opened.
1544 * Then we just have to make sure he or she can execute it.
1547 struct stat tmpstatbuf;
1551 setreuid(euid,uid) < 0
1554 setresuid(euid,uid,(Uid_t)-1) < 0
1557 || getuid() != euid || geteuid() != uid)
1558 croak("Can't swap uid and euid"); /* really paranoid */
1559 if (Stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
1560 croak("Permission denied"); /* testing full pathname here */
1561 if (tmpstatbuf.st_dev != statbuf.st_dev ||
1562 tmpstatbuf.st_ino != statbuf.st_ino) {
1564 if (rsfp = my_popen("/bin/mail root","w")) { /* heh, heh */
1566 "User %d tried to run dev %d ino %d in place of dev %d ino %d!\n\
1567 (Filename of set-id script was %s, uid %d gid %d.)\n\nSincerely,\nperl\n",
1568 uid,tmpstatbuf.st_dev, tmpstatbuf.st_ino,
1569 statbuf.st_dev, statbuf.st_ino,
1570 SvPVX(GvSV(curcop->cop_filegv)),
1571 statbuf.st_uid, statbuf.st_gid);
1572 (void)my_pclose(rsfp);
1574 croak("Permission denied\n");
1578 setreuid(uid,euid) < 0
1580 # if defined(HAS_SETRESUID)
1581 setresuid(uid,euid,(Uid_t)-1) < 0
1584 || getuid() != uid || geteuid() != euid)
1585 croak("Can't reswap uid and euid");
1586 if (!cando(S_IXUSR,FALSE,&statbuf)) /* can real uid exec? */
1587 croak("Permission denied\n");
1589 #endif /* HAS_SETREUID */
1590 #endif /* IAMSUID */
1592 if (!S_ISREG(statbuf.st_mode))
1593 croak("Permission denied");
1594 if (statbuf.st_mode & S_IWOTH)
1595 croak("Setuid/gid script is writable by world");
1596 doswitches = FALSE; /* -s is insecure in suid */
1598 if (fgets(tokenbuf,sizeof tokenbuf, rsfp) == Nullch ||
1599 strnNE(tokenbuf,"#!",2) ) /* required even on Sys V */
1600 croak("No #! line");
1603 while (!isSPACE(*s)) s++;
1604 if (strnNE(s-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
1605 croak("Not a perl script");
1606 while (*s == ' ' || *s == '\t') s++;
1608 * #! arg must be what we saw above. They can invoke it by
1609 * mentioning suidperl explicitly, but they may not add any strange
1610 * arguments beyond what #! says if they do invoke suidperl that way.
1612 len = strlen(validarg);
1613 if (strEQ(validarg," PHOOEY ") ||
1614 strnNE(s,validarg,len) || !isSPACE(s[len]))
1615 croak("Args must match #! line");
1618 if (euid != uid && (statbuf.st_mode & S_ISUID) &&
1619 euid == statbuf.st_uid)
1621 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
1622 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
1623 #endif /* IAMSUID */
1625 if (euid) { /* oops, we're not the setuid root perl */
1628 (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
1629 execv(buf, origargv); /* try again */
1631 croak("Can't do setuid\n");
1634 if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
1636 (void)setegid(statbuf.st_gid);
1639 (void)setregid((Gid_t)-1,statbuf.st_gid);
1641 #ifdef HAS_SETRESGID
1642 (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
1644 setgid(statbuf.st_gid);
1648 if (getegid() != statbuf.st_gid)
1649 croak("Can't do setegid!\n");
1651 if (statbuf.st_mode & S_ISUID) {
1652 if (statbuf.st_uid != euid)
1654 (void)seteuid(statbuf.st_uid); /* all that for this */
1657 (void)setreuid((Uid_t)-1,statbuf.st_uid);
1659 #ifdef HAS_SETRESUID
1660 (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
1662 setuid(statbuf.st_uid);
1666 if (geteuid() != statbuf.st_uid)
1667 croak("Can't do seteuid!\n");
1669 else if (uid) { /* oops, mustn't run as root */
1671 (void)seteuid((Uid_t)uid);
1674 (void)setreuid((Uid_t)-1,(Uid_t)uid);
1676 #ifdef HAS_SETRESUID
1677 (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
1683 if (geteuid() != uid)
1684 croak("Can't do seteuid!\n");
1687 if (!cando(S_IXUSR,TRUE,&statbuf))
1688 croak("Permission denied\n"); /* they can't do this */
1691 else if (preprocess)
1692 croak("-P not allowed for setuid/setgid script\n");
1694 croak("Script is not setuid/setgid in suidperl\n");
1695 #endif /* IAMSUID */
1697 if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */
1698 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
1699 Fstat(fileno(rsfp),&statbuf); /* may be either wrapped or real suid */
1700 if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
1702 (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
1705 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
1706 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
1707 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
1708 /* not set-id, must be wrapped */
1718 /* skip forward in input to the real script? */
1722 if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
1723 croak("No Perl script found in input\n");
1724 if (*s == '#' && s[1] == '!' && instr(s,"perl")) {
1725 ungetc('\n',rsfp); /* to keep line count right */
1727 if (s = instr(s,"perl -")) {
1730 while (s = moreswitches(s)) ;
1732 if (cddir && chdir(cddir) < 0)
1733 croak("Can't chdir to %s",cddir);
1741 uid = (int)getuid();
1742 euid = (int)geteuid();
1743 gid = (int)getgid();
1744 egid = (int)getegid();
1749 tainting |= (uid && (euid != uid || egid != gid));
1755 curstash = debstash;
1756 dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
1758 DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
1759 DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
1760 DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
1761 DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
1762 sv_setiv(DBsingle, 0);
1763 DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
1764 sv_setiv(DBtrace, 0);
1765 DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
1766 sv_setiv(DBsignal, 0);
1767 curstash = defstash;
1774 mainstack = stack; /* remember in case we switch stacks */
1775 AvREAL_off(stack); /* not a real array */
1776 av_extend(stack,127);
1778 stack_base = AvARRAY(stack);
1779 stack_sp = stack_base;
1780 stack_max = stack_base + 127;
1782 New(54,markstack,64,I32);
1783 markstack_ptr = markstack;
1784 markstack_max = markstack + 64;
1786 New(54,scopestack,32,I32);
1788 scopestack_max = 32;
1790 New(54,savestack,128,ANY);
1792 savestack_max = 128;
1794 New(54,retstack,16,OP*);
1798 cxstack_max = 8192 / sizeof(CONTEXT) - 2; /* Use most of 8K. */
1799 New(50,cxstack,cxstack_max + 1,CONTEXT);
1802 New(50,tmps_stack,128,SV*);
1807 New(51,debname,128,char);
1808 New(52,debdelim,128,char);
1812 static FILE *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
1820 subname = newSVpv("main",4);
1824 init_predump_symbols()
1829 sv_setpvn(GvSV(gv_fetchpv("\"", TRUE, SVt_PV)), " ", 1);
1831 stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
1832 GvMULTI_on(stdingv);
1833 IoIFP(GvIOp(stdingv)) = stdin;
1834 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
1836 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv));
1838 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
1840 IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = stdout;
1842 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
1844 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv));
1846 othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
1847 GvMULTI_on(othergv);
1848 IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = stderr;
1849 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
1851 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
1853 statname = NEWSV(66,0); /* last filename we did stat on */
1855 osname = savepv(OSNAME);
1859 init_postdump_symbols(argc,argv,env)
1861 register char **argv;
1862 register char **env;
1868 argc--,argv++; /* skip name of script */
1870 for (; argc > 0 && **argv == '-'; argc--,argv++) {
1873 if (argv[0][1] == '-') {
1877 if (s = strchr(argv[0], '=')) {
1879 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
1882 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
1885 toptarget = NEWSV(0,0);
1886 sv_upgrade(toptarget, SVt_PVFM);
1887 sv_setpvn(toptarget, "", 0);
1888 bodytarget = NEWSV(0,0);
1889 sv_upgrade(bodytarget, SVt_PVFM);
1890 sv_setpvn(bodytarget, "", 0);
1891 formtarget = bodytarget;
1894 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
1895 sv_setpv(GvSV(tmpgv),origfilename);
1896 magicname("0", "0", 1);
1898 if (tmpgv = gv_fetchpv("\024",TRUE, SVt_PV))
1900 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
1901 sv_setpv(GvSV(tmpgv),origargv[0]);
1902 if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
1904 (void)gv_AVadd(argvgv);
1905 av_clear(GvAVn(argvgv));
1906 for (; argc > 0; argc--,argv++) {
1907 av_push(GvAVn(argvgv),newSVpv(argv[0],0));
1910 if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
1915 #ifndef VMS /* VMS doesn't have environ array */
1916 /* Note that if the supplied env parameter is actually a copy
1917 of the global environ then it may now point to free'd memory
1918 if the environment has been modified since. To avoid this
1919 problem we treat env==NULL as meaning 'use the default'
1923 if (env != environ) {
1924 environ[0] = Nullch;
1925 hv_magic(hv, envgv, 'E');
1927 for (; *env; env++) {
1928 if (!(s = strchr(*env,'=')))
1931 sv = newSVpv(s--,0);
1932 sv_magic(sv, sv, 'e', *env, s - *env);
1933 (void)hv_store(hv, *env, s - *env, sv, 0);
1937 #ifdef DYNAMIC_ENV_FETCH
1938 HvNAME(hv) = savepv(ENV_HV_NAME);
1940 hv_magic(hv, envgv, 'E');
1943 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
1944 sv_setiv(GvSV(tmpgv),(I32)getpid());
1953 s = getenv("PERL5LIB");
1957 incpush(getenv("PERLLIB"));
1961 incpush(APPLLIB_EXP);
1965 incpush(ARCHLIB_EXP);
1968 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
1970 incpush(PRIVLIB_EXP);
1973 incpush(SITEARCH_EXP);
1976 incpush(SITELIB_EXP);
1978 #ifdef OLDARCHLIB_EXP /* 5.00[01] compatibility */
1979 incpush(OLDARCHLIB_EXP);
1992 line_t oldline = curcop->cop_line;
1994 Copy(top_env, oldtop, 1, Sigjmp_buf);
1996 while (AvFILL(list) >= 0) {
1997 CV *cv = (CV*)av_shift(list);
2001 switch (Sigsetjmp(top_env,1)) {
2003 SV* atsv = GvSV(errgv);
2005 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
2006 (void)SvPV(atsv, len);
2008 Copy(oldtop, top_env, 1, Sigjmp_buf);
2009 curcop = &compiling;
2010 curcop->cop_line = oldline;
2011 if (list == beginav)
2012 sv_catpv(atsv, "BEGIN failed--compilation aborted");
2014 sv_catpv(atsv, "END failed--cleanup aborted");
2015 croak("%s", SvPVX(atsv));
2021 statusvalue = 255; /* XXX I don't think we use 1 anymore. */
2027 /* my_exit() was called */
2028 curstash = defstash;
2032 Copy(oldtop, top_env, 1, Sigjmp_buf);
2033 curcop = &compiling;
2034 curcop->cop_line = oldline;
2036 if (list == beginav)
2037 croak("BEGIN failed--compilation aborted");
2039 croak("END failed--cleanup aborted");
2041 my_exit(statusvalue);
2046 fprintf(stderr, "panic: restartop\n");
2050 Copy(oldtop, top_env, 1, Sigjmp_buf);
2051 curcop = &compiling;
2052 curcop->cop_line = oldline;
2053 Siglongjmp(top_env, 3);
2057 Copy(oldtop, top_env, 1, Sigjmp_buf);