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
39 #define OSNAME "unknown"
42 static void find_beginning _((void));
43 static void incpush _((char *));
44 static void init_ids _((void));
45 static void init_debugger _((void));
46 static void init_lexer _((void));
47 static void init_main_stash _((void));
48 static void init_perllib _((void));
49 static void init_postdump_symbols _((int, char **, char **));
50 static void init_predump_symbols _((void));
51 static void init_stacks _((void));
52 static void nuke_stacks _((void));
53 static void open_script _((char *, bool, SV *));
54 static void usage _((char *));
55 static void validate_suid _((char *, char*));
57 static int fdscript = -1;
62 PerlInterpreter *sv_interp;
65 New(53, sv_interp, 1, PerlInterpreter);
70 perl_construct( sv_interp )
71 register PerlInterpreter *sv_interp;
73 if (!(curinterp = sv_interp))
77 Zero(sv_interp, 1, PerlInterpreter);
80 /* Init the real globals? */
82 linestr = NEWSV(65,80);
83 sv_upgrade(linestr,SVt_PVIV);
85 if (!SvREADONLY(&sv_undef)) {
86 SvREADONLY_on(&sv_undef);
90 SvREADONLY_on(&sv_no);
92 sv_setpv(&sv_yes,Yes);
94 SvREADONLY_on(&sv_yes);
97 nrs = newSVpv("\n", 1);
98 rs = SvREFCNT_inc(nrs);
102 * There is no way we can refer to them from Perl so close them to save
103 * space. The other alternative would be to provide STDAUX and STDPRN
106 (void)fclose(stdaux);
107 (void)fclose(stdprn);
128 #if defined(SUBVERSION) && SUBVERSION > 0
129 sprintf(patchlevel, "%7.5f", 5.0 + (PATCHLEVEL / 1000.0)
130 + (SUBVERSION / 100000.0));
132 sprintf(patchlevel, "%5.3f", 5.0 + (PATCHLEVEL / 1000.0));
135 #if defined(LOCAL_PATCH_COUNT)
136 localpatches = local_patches; /* For possible -v */
139 PerlIO_init(); /* Hook to IO system */
141 fdpid = newAV(); /* for remembering popen pids by fd */
142 pidstatus = newHV();/* for remembering status of dead pids */
149 perl_destruct(sv_interp)
150 register PerlInterpreter *sv_interp;
152 int destruct_level; /* 0=none, 1=full, 2=full with checks */
156 if (!(curinterp = sv_interp))
159 destruct_level = perl_destruct_level;
163 if (s = getenv("PERL_DESTRUCT_LEVEL"))
164 destruct_level = atoi(s);
171 /* We must account for everything. First the syntax tree. */
173 curpad = AvARRAY(comppad);
179 * Try to destruct global references. We do this first so that the
180 * destructors and destructees still exist. Some sv's might remain.
181 * Non-referenced objects are on their own.
188 if (destruct_level == 0){
190 DEBUG_P(debprofdump());
192 /* The exit() function will do everything that needs doing. */
196 /* Prepare to destruct main symbol table. */
202 if (destruct_level >= 2) {
203 if (scopestack_ix != 0)
204 warn("Unbalanced scopes: %d more ENTERs than LEAVEs\n", scopestack_ix);
205 if (savestack_ix != 0)
206 warn("Unbalanced saves: %d more saves than restores\n", savestack_ix);
207 if (tmps_floor != -1)
208 warn("Unbalanced tmps: %d more allocs than frees\n", tmps_floor + 1);
209 if (cxstack_ix != -1)
210 warn("Unbalanced context: %d more PUSHes than POPs\n", cxstack_ix + 1);
213 /* Now absolutely destruct everything, somehow or other, loops or no. */
215 SvFLAGS(strtab) |= SVTYPEMASK; /* don't clean out strtab now */
216 while (sv_count != 0 && sv_count != last_sv_count) {
217 last_sv_count = sv_count;
220 SvFLAGS(strtab) &= ~SVTYPEMASK;
221 SvFLAGS(strtab) |= SVt_PVHV;
223 /* Destruct the global string table. */
225 /* Yell and reset the HeVAL() slots that are still holding refcounts,
226 * so that sv_free() won't fail on them.
235 array = HvARRAY(strtab);
239 warn("Unbalanced string table refcount: (%d) for \"%s\"",
240 HeVAL(hent) - Nullsv, HeKEY(hent));
241 HeVAL(hent) = Nullsv;
251 SvREFCNT_dec(strtab);
254 warn("Scalars leaked: %d\n", sv_count);
258 linestr = NULL; /* No SVs have survived, need to clean out */
260 Safefree(origfilename);
262 hints = 0; /* Reset hints. Should hints be per-interpreter ? */
264 DEBUG_P(debprofdump());
269 PerlInterpreter *sv_interp;
271 if (!(curinterp = sv_interp))
275 #if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE)
276 char *getenv _((char *)); /* Usually in <stdlib.h> */
280 perl_parse(sv_interp, xsinit, argc, argv, env)
281 PerlInterpreter *sv_interp;
282 void (*xsinit)_((void));
289 char *scriptname = NULL;
290 VOL bool dosearch = FALSE;
294 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
297 croak("suidperl is no longer needed since the kernel can now execute\n\
298 setuid perl scripts securely.\n");
302 if (!(curinterp = sv_interp))
305 #if defined(NeXT) && defined(__DYNAMIC__)
306 _dyld_lookup_and_bind
307 ("__environ", (unsigned long *) &environ_pointer, NULL);
312 #ifndef VMS /* VMS doesn't have environ array */
313 origenviron = environ;
319 /* Come here if running an undumped a.out. */
321 origfilename = savepv(argv[0]);
323 cxstack_ix = -1; /* start label stack again */
325 init_postdump_symbols(argc,argv,env);
333 switch (Sigsetjmp(top_env,1)) {
344 return(statusvalue); /* my_exit() was called */
346 PerlIO_printf(PerlIO_stderr(), "panic: top_env\n");
350 sv_setpvn(linestr,"",0);
351 sv = newSVpv("",0); /* first used for -I flags */
354 for (argc--,argv++; argc > 0; argc--,argv++) {
355 if (argv[0][0] != '-' || !argv[0][1])
359 validarg = " PHOOEY ";
385 if (s = moreswitches(s))
390 if (euid != uid || egid != gid)
391 croak("No -e allowed in setuid scripts");
393 e_tmpname = savepv(TMPPATH);
394 (void)mktemp(e_tmpname);
396 croak("Can't mktemp()");
397 e_fp = PerlIO_open(e_tmpname,"w");
399 croak("Cannot open temporary file");
402 PerlIO_puts(e_fp,argv[1]);
405 (void)PerlIO_putc(e_fp,'\n');
413 av_push(GvAVn(incgv),newSVpv(s,0));
416 av_push(GvAVn(incgv),newSVpv(argv[1],0));
417 sv_catpv(sv,argv[1]);
434 preambleav = newAV();
435 av_push(preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
437 Sv = newSVpv("print myconfig();",0);
439 sv_catpv(Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
441 sv_catpv(Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
443 #if defined(DEBUGGING) || defined(NOEMBED) || defined(MULTIPLICITY)
444 strcpy(buf,"\" Compile-time options:");
446 strcat(buf," DEBUGGING");
449 strcat(buf," NOEMBED");
452 strcat(buf," MULTIPLICITY");
454 strcat(buf,"\\n\",");
457 #if defined(LOCAL_PATCH_COUNT)
458 if (LOCAL_PATCH_COUNT > 0)
460 sv_catpv(Sv,"print \" Locally applied patches:\\n\",");
461 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
462 if (localpatches[i]) {
463 sprintf(buf,"\" \\t%s\\n\",",localpatches[i]);
469 sprintf(buf,"\" Built under %s\\n\",",OSNAME);
473 sprintf(buf,"\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
475 sprintf(buf,"\" Compiled on %s\\n\"",__DATE__);
479 sv_catpv(Sv,"; $\"=\"\\n \"; print \" \\@INC:\\n @INC\\n\"");
482 Sv = newSVpv("config_vars(qw(",0);
487 av_push(preambleav, Sv);
488 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
502 croak("Unrecognized switch: -%s",s);
507 scriptname = argv[0];
509 if (PerlIO_flush(e_fp) || PerlIO_error(e_fp) || PerlIO_close(e_fp))
510 croak("Can't write to temp file for -e: %s", Strerror(errno));
513 scriptname = e_tmpname;
515 else if (scriptname == Nullch) {
517 if ( isatty(PerlIO_fileno(PerlIO_stdin())) )
525 open_script(scriptname,dosearch,sv);
527 validate_suid(validarg, scriptname);
532 compcv = (CV*)NEWSV(1104,0);
533 sv_upgrade((SV *)compcv, SVt_PVCV);
536 av_push(comppad, Nullsv);
537 curpad = AvARRAY(comppad);
538 comppad_name = newAV();
539 comppad_name_fill = 0;
540 min_intro_pending = 0;
543 comppadlist = newAV();
544 AvREAL_off(comppadlist);
545 av_store(comppadlist, 0, (SV*)comppad_name);
546 av_store(comppadlist, 1, (SV*)comppad);
547 CvPADLIST(compcv) = comppadlist;
549 boot_core_UNIVERSAL();
551 (*xsinit)(); /* in case linked C routines want magical variables */
556 init_predump_symbols();
558 init_postdump_symbols(argc,argv,env);
562 /* now parse the script */
565 if (yyparse() || error_count) {
567 croak("%s had compilation errors.\n", origfilename);
569 croak("Execution of %s aborted due to compilation errors.\n",
573 curcop->cop_line = 0;
577 (void)UNLINK(e_tmpname);
582 /* now that script is parsed, we can modify record separator */
584 rs = SvREFCNT_inc(nrs);
585 sv_setsv(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), rs);
596 #ifdef DEBUGGING_MSTATS
597 if ((s=getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
598 dump_mstats("after compilation:");
608 PerlInterpreter *sv_interp;
610 if (!(curinterp = sv_interp))
612 switch (Sigsetjmp(top_env,1)) {
614 cxstack_ix = -1; /* start context stack again */
621 #ifdef DEBUGGING_MSTATS
622 if (getenv("PERL_DEBUG_MSTATS"))
623 dump_mstats("after execution: ");
625 return(statusvalue); /* my_exit() was called */
628 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
632 if (curstack != mainstack) {
634 SWITCHSTACK(curstack, mainstack);
639 DEBUG_r(PerlIO_printf(PerlIO_stderr(), "%s $` $& $' support.\n",
640 sawampersand ? "Enabling" : "Omitting"));
644 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
647 PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", origfilename);
650 if (perldb && DBsingle)
651 sv_setiv(DBsingle, 1);
661 else if (main_start) {
674 register CONTEXT *cx;
678 statusvalue = FIXSTATUS(status);
679 if (cxstack_ix >= 0) {
685 Siglongjmp(top_env, 2);
689 perl_get_sv(name, create)
693 GV* gv = gv_fetchpv(name, create, SVt_PV);
700 perl_get_av(name, create)
704 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
713 perl_get_hv(name, create)
717 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
726 perl_get_cv(name, create)
730 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
731 if (create && !GvCV(gv))
732 return newSUB(start_subparse(),
733 newSVOP(OP_CONST, 0, newSVpv(name,0)),
741 /* Be sure to refetch the stack pointer after calling these routines. */
744 perl_call_argv(subname, flags, argv)
746 I32 flags; /* See G_* flags in cop.h */
747 register char **argv; /* null terminated arg list */
754 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
759 return perl_call_pv(subname, flags);
763 perl_call_pv(subname, flags)
764 char *subname; /* name of the subroutine */
765 I32 flags; /* See G_* flags in cop.h */
767 return perl_call_sv((SV*)perl_get_cv(subname, TRUE), flags);
771 perl_call_method(methname, flags)
772 char *methname; /* name of the subroutine */
773 I32 flags; /* See G_* flags in cop.h */
779 XPUSHs(sv_2mortal(newSVpv(methname,0)));
782 return perl_call_sv(*stack_sp--, flags);
785 /* May be called with any of a CV, a GV, or an SV containing the name. */
787 perl_call_sv(sv, flags)
789 I32 flags; /* See G_* flags in cop.h */
791 LOGOP myop; /* fake syntax tree node */
793 I32 oldmark = TOPMARK;
799 if (flags & G_DISCARD) {
809 oldscope = scopestack_ix;
811 if (!(flags & G_NOARGS))
812 myop.op_flags = OPf_STACKED;
813 myop.op_next = Nullop;
814 myop.op_flags |= OPf_KNOW;
816 myop.op_flags |= OPf_LIST;
818 if (perldb && curstash != debstash
819 && (DBcv || (DBcv = GvCV(DBsub)))) /* to handle first BEGIN of -d */
820 op->op_private |= OPpENTERSUB_DB;
822 if (flags & G_EVAL) {
823 Copy(top_env, oldtop, 1, Sigjmp_buf);
825 cLOGOP->op_other = op;
827 /* we're trying to emulate pp_entertry() here */
829 register CONTEXT *cx;
835 push_return(op->op_next);
836 PUSHBLOCK(cx, CXt_EVAL, stack_sp);
838 eval_root = op; /* Only needed so that goto works right. */
841 if (flags & G_KEEPERR)
844 sv_setpv(GvSV(errgv),"");
849 switch (Sigsetjmp(top_env,1)) {
854 statusvalue = 255; /* XXX I don't think we use 1 anymore. */
860 /* my_exit() was called */
863 Copy(oldtop, top_env, 1, Sigjmp_buf);
865 croak("Callback called exit");
866 my_exit(statusvalue);
874 stack_sp = stack_base + oldmark;
879 *++stack_sp = &sv_undef;
885 if (op == (OP*)&myop)
889 retval = stack_sp - (stack_base + oldmark);
890 if ((flags & G_EVAL) && !(flags & G_KEEPERR))
891 sv_setpv(GvSV(errgv),"");
894 if (flags & G_EVAL) {
895 if (scopestack_ix > oldscope) {
899 register CONTEXT *cx;
908 Copy(oldtop, top_env, 1, Sigjmp_buf);
910 if (flags & G_DISCARD) {
911 stack_sp = stack_base + oldmark;
919 /* Eval a string. The G_EVAL flag is always assumed. */
922 perl_eval_sv(sv, flags)
924 I32 flags; /* See G_* flags in cop.h */
926 UNOP myop; /* fake syntax tree node */
928 I32 oldmark = sp - stack_base;
933 if (flags & G_DISCARD) {
943 oldscope = scopestack_ix;
945 if (!(flags & G_NOARGS))
946 myop.op_flags = OPf_STACKED;
947 myop.op_next = Nullop;
948 myop.op_type = OP_ENTEREVAL;
949 myop.op_flags |= OPf_KNOW;
950 if (flags & G_KEEPERR)
951 myop.op_flags |= OPf_SPECIAL;
953 myop.op_flags |= OPf_LIST;
955 Copy(top_env, oldtop, 1, Sigjmp_buf);
958 switch (Sigsetjmp(top_env,1)) {
963 statusvalue = 255; /* XXX I don't think we use 1 anymore. */
969 /* my_exit() was called */
972 Copy(oldtop, top_env, 1, Sigjmp_buf);
974 croak("Callback called exit");
975 my_exit(statusvalue);
983 stack_sp = stack_base + oldmark;
988 *++stack_sp = &sv_undef;
993 if (op == (OP*)&myop)
997 retval = stack_sp - (stack_base + oldmark);
998 if (!(flags & G_KEEPERR))
999 sv_setpv(GvSV(errgv),"");
1002 Copy(oldtop, top_env, 1, Sigjmp_buf);
1003 if (flags & G_DISCARD) {
1004 stack_sp = stack_base + oldmark;
1012 /* Require a module. */
1018 SV* sv = sv_newmortal();
1019 sv_setpv(sv, "require '");
1022 perl_eval_sv(sv, G_DISCARD);
1026 magicname(sym,name,namlen)
1033 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1034 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1038 # define PERLLIB_SEP ';'
1041 # define PERLLIB_SEP '|'
1043 # define PERLLIB_SEP ':'
1046 #ifndef PERLLIB_MANGLE
1047 # define PERLLIB_MANGLE(s,n) (s)
1059 /* Break at all separators */
1061 /* First, skip any consecutive separators */
1062 while ( *p == PERLLIB_SEP ) {
1063 /* Uncomment the next line for PATH semantics */
1064 /* av_push(GvAVn(incgv), newSVpv(".", 1)); */
1067 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
1068 av_push(GvAVn(incgv), newSVpv(PERLLIB_MANGLE(p, (STRLEN)(s - p)),
1072 av_push(GvAVn(incgv), newSVpv(PERLLIB_MANGLE(p, 0), 0));
1079 usage(name) /* XXX move this out into a module ? */
1082 /* This message really ought to be max 23 lines.
1083 * Removed -h because the user already knows that opton. Others? */
1084 printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1085 printf("\n -0[octal] specify record separator (\\0, if no argument)");
1086 printf("\n -a autosplit mode with -n or -p (splits $_ into @F)");
1087 printf("\n -c check syntax only (runs BEGIN and END blocks)");
1088 printf("\n -d[:debugger] run scripts under debugger");
1089 printf("\n -D[number/list] set debugging flags (argument is a bit mask or flags)");
1090 printf("\n -e 'command' one line of script. Several -e's allowed. Omit [programfile].");
1091 printf("\n -F/pattern/ split() pattern for autosplit (-a). The //'s are optional.");
1092 printf("\n -i[extension] edit <> files in place (make backup if extension supplied)");
1093 printf("\n -Idirectory specify @INC/#include directory (may be used more then once)");
1094 printf("\n -l[octal] enable line ending processing, specifies line teminator");
1095 printf("\n -[mM][-]module.. executes `use/no module...' before executing your script.");
1096 printf("\n -n assume 'while (<>) { ... }' loop arround your script");
1097 printf("\n -p assume loop like -n but print line also like sed");
1098 printf("\n -P run script through C preprocessor before compilation");
1099 printf("\n -s enable some switch parsing for switches after script name");
1100 printf("\n -S look for the script using PATH environment variable");
1101 printf("\n -T turn on tainting checks");
1102 printf("\n -u dump core after parsing script");
1103 printf("\n -U allow unsafe operations");
1104 printf("\n -v print version number and patchlevel of perl");
1105 printf("\n -V[:variable] print perl configuration information");
1106 printf("\n -w TURN WARNINGS ON FOR COMPILATION OF YOUR SCRIPT.");
1107 printf("\n -x[directory] strip off text before #!perl line and perhaps cd to directory\n");
1110 /* This routine handles any switches that can be given during run */
1121 rschar = scan_oct(s, 4, &numlen);
1123 if (rschar & ~((U8)~0))
1125 else if (!rschar && numlen >= 2)
1126 nrs = newSVpv("", 0);
1129 nrs = newSVpv(&ch, 1);
1134 splitstr = savepv(s + 1);
1148 if (*s == ':' || *s == '=') {
1149 sprintf(buf, "use Devel::%s;", ++s);
1151 my_setenv("PERL5DB",buf);
1161 if (isALPHA(s[1])) {
1162 static char debopts[] = "psltocPmfrxuLHXD";
1165 for (s++; *s && (d = strchr(debopts,*s)); s++)
1166 debug |= 1 << (d - debopts);
1170 for (s++; isDIGIT(*s); s++) ;
1172 debug |= 0x80000000;
1174 warn("Recompile perl with -DDEBUGGING to use -D switch\n");
1175 for (s++; isALNUM(*s); s++) ;
1185 inplace = savepv(s+1);
1187 for (s = inplace; *s && !isSPACE(*s); s++) ;
1194 for (e = s; *e && !isSPACE(*e); e++) ;
1195 av_push(GvAVn(incgv),newSVpv(s,e-s));
1200 croak("No space allowed after -I");
1210 *ors = scan_oct(s, 3 + (*s == '0'), &numlen);
1219 ors = SvPV(nrs, orslen);
1220 ors = savepvn(ors, orslen);
1224 taint_not("-M"); /* XXX ? */
1227 taint_not("-m"); /* XXX ? */
1231 /* -M-foo == 'no foo' */
1232 if (*s == '-') { use = "no "; ++s; }
1233 Sv = newSVpv(use,0);
1235 /* We allow -M'Module qw(Foo Bar)' */
1236 while(isALNUM(*s) || *s==':') ++s;
1238 sv_catpv(Sv, start);
1239 if (*(start-1) == 'm') {
1241 croak("Can't use '%c' after -mname", *s);
1242 sv_catpv( Sv, " ()");
1245 sv_catpvn(Sv, start, s-start);
1246 sv_catpv(Sv, " split(/,/,q{");
1251 if (preambleav == NULL)
1252 preambleav = newAV();
1253 av_push(preambleav, Sv);
1256 croak("No space allowed after -%c", *(s-1));
1284 #if defined(SUBVERSION) && SUBVERSION > 0
1285 printf("\nThis is perl, version 5.%03d_%02d", PATCHLEVEL, SUBVERSION);
1287 printf("\nThis is perl, version %s",patchlevel);
1290 printf("\n\nCopyright 1987-1996, Larry Wall\n");
1291 printf("\n\t+ suidperl security patch");
1293 printf("MS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1296 printf("OS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1297 "Version 5 port Copyright (c) 1994-1996, Andreas Kaiser, Ilya Zakharevich\n");
1300 printf("atariST series port, ++jrb bammi@cadence.com\n");
1303 Perl may be copied only under the terms of either the Artistic License or the\n\
1304 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n");
1315 if (s[1] == '-') /* Additional switches on #! line. */
1328 croak("Can't emulate -%.1s on #! line",s);
1333 /* compliments of Tom Christiansen */
1335 /* unexec() can be found in the Gnu emacs distribution */
1344 sprintf (buf, "%s.perldump", origfilename);
1345 sprintf (tokenbuf, "%s/perl", BIN);
1347 status = unexec(buf, tokenbuf, &etext, sbrk(0), 0);
1349 PerlIO_printf(PerlIO_stderr(), "unexec of %s into %s failed!\n", tokenbuf, buf);
1353 # include <lib$routines.h>
1354 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
1356 ABORT(); /* for use with undump */
1366 /* Note that strtab is a rather special HV. Assumptions are made
1367 about not iterating on it, and not adding tie magic to it.
1368 It is properly deallocated in perl_destruct() */
1370 HvSHAREKEYS_off(strtab); /* mandatory */
1371 Newz(506,((XPVHV*)SvANY(strtab))->xhv_array,
1372 sizeof(HE*) * (((XPVHV*)SvANY(strtab))->xhv_max + 1), char);
1374 curstash = defstash = newHV();
1375 curstname = newSVpv("main",4);
1376 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1377 SvREFCNT_dec(GvHV(gv));
1378 GvHV(gv) = (HV*)SvREFCNT_inc(defstash);
1380 HvNAME(defstash) = savepv("main");
1381 incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1383 defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1384 errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1386 curstash = defstash;
1387 compiling.cop_stash = defstash;
1388 debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
1389 /* We must init $/ before switches are processed. */
1390 sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1);
1393 #ifdef CAN_PROTOTYPE
1395 open_script(char *scriptname, bool dosearch, SV *sv)
1398 open_script(scriptname,dosearch,sv)
1404 char *xfound = Nullch;
1405 char *xfailed = Nullch;
1409 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
1410 #define SEARCH_EXTS ".bat", ".cmd", NULL
1413 # define SEARCH_EXTS ".pl", ".com", NULL
1415 /* additional extensions to try in each dir if scriptname not found */
1417 char *ext[] = { SEARCH_EXTS };
1418 int extidx = (strchr(scriptname,'.')) ? -1 : 0; /* has ext already */
1423 int hasdir, idx = 0, deftypes = 1;
1425 hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
1426 /* The first time through, just add SEARCH_EXTS to whatever we
1427 * already have, so we can check for default file types. */
1428 while (deftypes || (!hasdir && my_trnlnm("DCL$PATH",tokenbuf,idx++)) ) {
1429 if (deftypes) { deftypes = 0; *tokenbuf = '\0'; }
1430 strcat(tokenbuf,scriptname);
1432 if (dosearch && !strchr(scriptname, '/') && (s = getenv("PATH"))) {
1434 bufend = s + strlen(s);
1437 s = cpytill(tokenbuf,s,bufend,':',&len);
1440 for (len = 0; *s && *s != ',' && *s != ';'; tokenbuf[len++] = *s++);
1441 tokenbuf[len] = '\0';
1443 for (len = 0; *s && *s != ';'; tokenbuf[len++] = *s++);
1444 tokenbuf[len] = '\0';
1450 if (len && tokenbuf[len-1] != '/')
1453 if (len && ((tokenbuf[len-1] != '\\') && (tokenbuf[len-1] != '/')))
1455 if (len && tokenbuf[len-1] != '\\')
1458 (void)strcat(tokenbuf+len,"/");
1459 (void)strcat(tokenbuf+len,scriptname);
1463 len = strlen(tokenbuf);
1464 if (extidx > 0) /* reset after previous loop */
1468 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tokenbuf));
1469 retval = Stat(tokenbuf,&statbuf);
1471 } while ( retval < 0 /* not there */
1472 && extidx>=0 && ext[extidx] /* try an extension? */
1473 && strcpy(tokenbuf+len, ext[extidx++])
1478 if (S_ISREG(statbuf.st_mode)
1479 && cando(S_IRUSR,TRUE,&statbuf) && cando(S_IXUSR,TRUE,&statbuf)) {
1480 xfound = tokenbuf; /* bingo! */
1484 xfailed = savepv(tokenbuf);
1487 croak("Can't execute %s", xfailed ? xfailed : scriptname );
1490 scriptname = xfound;
1493 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
1494 char *s = scriptname + 8;
1503 origfilename = savepv(e_tmpname ? "-e" : scriptname);
1504 curcop->cop_filegv = gv_fetchfile(origfilename);
1505 if (strEQ(origfilename,"-"))
1507 if (fdscript >= 0) {
1508 rsfp = PerlIO_fdopen(fdscript,"r");
1509 #if defined(HAS_FCNTL) && defined(F_SETFD)
1510 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
1513 else if (preprocess) {
1514 char *cpp = CPPSTDIN;
1516 if (strEQ(cpp,"cppstdin"))
1517 sprintf(tokenbuf, "%s/%s", SCRIPTDIR, cpp);
1519 sprintf(tokenbuf, "%s", cpp);
1521 sv_catpv(sv,PRIVLIB_EXP);
1523 (void)sprintf(buf, "\
1524 sed %s -e \"/^[^#]/b\" \
1525 -e \"/^#[ ]*include[ ]/b\" \
1526 -e \"/^#[ ]*define[ ]/b\" \
1527 -e \"/^#[ ]*if[ ]/b\" \
1528 -e \"/^#[ ]*ifdef[ ]/b\" \
1529 -e \"/^#[ ]*ifndef[ ]/b\" \
1530 -e \"/^#[ ]*else/b\" \
1531 -e \"/^#[ ]*elif[ ]/b\" \
1532 -e \"/^#[ ]*undef[ ]/b\" \
1533 -e \"/^#[ ]*endif/b\" \
1536 (doextract ? "-e \"1,/^#/d\n\"" : ""),
1538 (void)sprintf(buf, "\
1539 %s %s -e '/^[^#]/b' \
1540 -e '/^#[ ]*include[ ]/b' \
1541 -e '/^#[ ]*define[ ]/b' \
1542 -e '/^#[ ]*if[ ]/b' \
1543 -e '/^#[ ]*ifdef[ ]/b' \
1544 -e '/^#[ ]*ifndef[ ]/b' \
1545 -e '/^#[ ]*else/b' \
1546 -e '/^#[ ]*elif[ ]/b' \
1547 -e '/^#[ ]*undef[ ]/b' \
1548 -e '/^#[ ]*endif/b' \
1556 (doextract ? "-e '1,/^#/d\n'" : ""),
1558 scriptname, tokenbuf, SvPV(sv, na), CPPMINUS);
1560 #ifdef IAMSUID /* actually, this is caught earlier */
1561 if (euid != uid && !euid) { /* if running suidperl */
1563 (void)seteuid(uid); /* musn't stay setuid root */
1566 (void)setreuid((Uid_t)-1, uid);
1568 #ifdef HAS_SETRESUID
1569 (void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
1575 if (geteuid() != uid)
1576 croak("Can't do seteuid!\n");
1578 #endif /* IAMSUID */
1579 rsfp = my_popen(buf,"r");
1581 else if (!*scriptname) {
1582 taint_not("program input from stdin");
1583 rsfp = PerlIO_stdin();
1586 rsfp = PerlIO_open(scriptname,"r");
1587 #if defined(HAS_FCNTL) && defined(F_SETFD)
1588 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
1591 if ((PerlIO*)rsfp == Nullfp) {
1593 #ifndef IAMSUID /* in case script is not readable before setuid */
1594 if (euid && Stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
1595 statbuf.st_mode & (S_ISUID|S_ISGID)) {
1596 (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
1597 execv(buf, origargv); /* try again */
1598 croak("Can't do setuid\n");
1602 croak("Can't open perl script \"%s\": %s\n",
1603 SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno));
1608 validate_suid(validarg, scriptname)
1614 /* do we need to emulate setuid on scripts? */
1616 /* This code is for those BSD systems that have setuid #! scripts disabled
1617 * in the kernel because of a security problem. Merely defining DOSUID
1618 * in perl will not fix that problem, but if you have disabled setuid
1619 * scripts in the kernel, this will attempt to emulate setuid and setgid
1620 * on scripts that have those now-otherwise-useless bits set. The setuid
1621 * root version must be called suidperl or sperlN.NNN. If regular perl
1622 * discovers that it has opened a setuid script, it calls suidperl with
1623 * the same argv that it had. If suidperl finds that the script it has
1624 * just opened is NOT setuid root, it sets the effective uid back to the
1625 * uid. We don't just make perl setuid root because that loses the
1626 * effective uid we had before invoking perl, if it was different from the
1629 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
1630 * be defined in suidperl only. suidperl must be setuid root. The
1631 * Configure script will set this up for you if you want it.
1637 if (Fstat(PerlIO_fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
1638 croak("Can't stat script \"%s\"",origfilename);
1639 if (fdscript < 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) {
1643 #ifndef HAS_SETREUID
1644 /* On this access check to make sure the directories are readable,
1645 * there is actually a small window that the user could use to make
1646 * filename point to an accessible directory. So there is a faint
1647 * chance that someone could execute a setuid script down in a
1648 * non-accessible directory. I don't know what to do about that.
1649 * But I don't think it's too important. The manual lies when
1650 * it says access() is useful in setuid programs.
1652 if (access(SvPVX(GvSV(curcop->cop_filegv)),1)) /*double check*/
1653 croak("Permission denied");
1655 /* If we can swap euid and uid, then we can determine access rights
1656 * with a simple stat of the file, and then compare device and
1657 * inode to make sure we did stat() on the same file we opened.
1658 * Then we just have to make sure he or she can execute it.
1661 struct stat tmpstatbuf;
1665 setreuid(euid,uid) < 0
1668 setresuid(euid,uid,(Uid_t)-1) < 0
1671 || getuid() != euid || geteuid() != uid)
1672 croak("Can't swap uid and euid"); /* really paranoid */
1673 if (Stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
1674 croak("Permission denied"); /* testing full pathname here */
1675 if (tmpstatbuf.st_dev != statbuf.st_dev ||
1676 tmpstatbuf.st_ino != statbuf.st_ino) {
1677 (void)PerlIO_close(rsfp);
1678 if (rsfp = my_popen("/bin/mail root","w")) { /* heh, heh */
1680 "User %d tried to run dev %d ino %d in place of dev %d ino %d!\n\
1681 (Filename of set-id script was %s, uid %d gid %d.)\n\nSincerely,\nperl\n",
1682 uid,tmpstatbuf.st_dev, tmpstatbuf.st_ino,
1683 statbuf.st_dev, statbuf.st_ino,
1684 SvPVX(GvSV(curcop->cop_filegv)),
1685 statbuf.st_uid, statbuf.st_gid);
1686 (void)my_pclose(rsfp);
1688 croak("Permission denied\n");
1692 setreuid(uid,euid) < 0
1694 # if defined(HAS_SETRESUID)
1695 setresuid(uid,euid,(Uid_t)-1) < 0
1698 || getuid() != uid || geteuid() != euid)
1699 croak("Can't reswap uid and euid");
1700 if (!cando(S_IXUSR,FALSE,&statbuf)) /* can real uid exec? */
1701 croak("Permission denied\n");
1703 #endif /* HAS_SETREUID */
1704 #endif /* IAMSUID */
1706 if (!S_ISREG(statbuf.st_mode))
1707 croak("Permission denied");
1708 if (statbuf.st_mode & S_IWOTH)
1709 croak("Setuid/gid script is writable by world");
1710 doswitches = FALSE; /* -s is insecure in suid */
1712 if (sv_gets(linestr, rsfp, 0) == Nullch ||
1713 strnNE(SvPV(linestr,na),"#!",2) ) /* required even on Sys V */
1714 croak("No #! line");
1715 s = SvPV(linestr,na)+2;
1717 while (!isSPACE(*s)) s++;
1718 for (s2 = s; (s2 > SvPV(linestr,na)+2 &&
1719 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
1720 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
1721 croak("Not a perl script");
1722 while (*s == ' ' || *s == '\t') s++;
1724 * #! arg must be what we saw above. They can invoke it by
1725 * mentioning suidperl explicitly, but they may not add any strange
1726 * arguments beyond what #! says if they do invoke suidperl that way.
1728 len = strlen(validarg);
1729 if (strEQ(validarg," PHOOEY ") ||
1730 strnNE(s,validarg,len) || !isSPACE(s[len]))
1731 croak("Args must match #! line");
1734 if (euid != uid && (statbuf.st_mode & S_ISUID) &&
1735 euid == statbuf.st_uid)
1737 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
1738 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
1739 #endif /* IAMSUID */
1741 if (euid) { /* oops, we're not the setuid root perl */
1742 (void)PerlIO_close(rsfp);
1744 (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
1745 execv(buf, origargv); /* try again */
1747 croak("Can't do setuid\n");
1750 if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
1752 (void)setegid(statbuf.st_gid);
1755 (void)setregid((Gid_t)-1,statbuf.st_gid);
1757 #ifdef HAS_SETRESGID
1758 (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
1760 setgid(statbuf.st_gid);
1764 if (getegid() != statbuf.st_gid)
1765 croak("Can't do setegid!\n");
1767 if (statbuf.st_mode & S_ISUID) {
1768 if (statbuf.st_uid != euid)
1770 (void)seteuid(statbuf.st_uid); /* all that for this */
1773 (void)setreuid((Uid_t)-1,statbuf.st_uid);
1775 #ifdef HAS_SETRESUID
1776 (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
1778 setuid(statbuf.st_uid);
1782 if (geteuid() != statbuf.st_uid)
1783 croak("Can't do seteuid!\n");
1785 else if (uid) { /* oops, mustn't run as root */
1787 (void)seteuid((Uid_t)uid);
1790 (void)setreuid((Uid_t)-1,(Uid_t)uid);
1792 #ifdef HAS_SETRESUID
1793 (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
1799 if (geteuid() != uid)
1800 croak("Can't do seteuid!\n");
1803 if (!cando(S_IXUSR,TRUE,&statbuf))
1804 croak("Permission denied\n"); /* they can't do this */
1807 else if (preprocess)
1808 croak("-P not allowed for setuid/setgid script\n");
1809 else if (fdscript >= 0)
1810 croak("fd script not allowed in suidperl\n");
1812 croak("Script is not setuid/setgid in suidperl\n");
1814 /* We absolutely must clear out any saved ids here, so we */
1815 /* exec the real perl, substituting fd script for scriptname. */
1816 /* (We pass script name as "subdir" of fd, which perl will grok.) */
1817 PerlIO_rewind(rsfp);
1818 lseek(PerlIO_fileno(rsfp),(Off_t)0,0); /* just in case rewind didn't */
1819 for (which = 1; origargv[which] && origargv[which] != scriptname; which++) ;
1820 if (!origargv[which])
1821 croak("Permission denied");
1822 (void)sprintf(buf, "/dev/fd/%d/%.127s", PerlIO_fileno(rsfp), origargv[which]);
1823 origargv[which] = buf;
1825 #if defined(HAS_FCNTL) && defined(F_SETFD)
1826 fcntl(PerlIO_fileno(rsfp),F_SETFD,0); /* ensure no close-on-exec */
1829 (void)sprintf(tokenbuf, "%s/perl%s", BIN, patchlevel);
1830 execv(tokenbuf, origargv); /* try again */
1831 croak("Can't do setuid\n");
1832 #endif /* IAMSUID */
1834 if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */
1835 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
1836 Fstat(PerlIO_fileno(rsfp),&statbuf); /* may be either wrapped or real suid */
1837 if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
1839 (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
1842 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
1843 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
1844 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
1845 /* not set-id, must be wrapped */
1853 register char *s, *s2;
1855 /* skip forward in input to the real script? */
1859 if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
1860 croak("No Perl script found in input\n");
1861 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
1862 PerlIO_ungetc(rsfp, '\n'); /* to keep line count right */
1864 while (*s && !(isSPACE (*s) || *s == '#')) s++;
1866 while (*s == ' ' || *s == '\t') s++;
1868 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
1869 if (strnEQ(s2-4,"perl",4))
1871 while (s = moreswitches(s)) ;
1873 if (cddir && chdir(cddir) < 0)
1874 croak("Can't chdir to %s",cddir);
1882 uid = (int)getuid();
1883 euid = (int)geteuid();
1884 gid = (int)getgid();
1885 egid = (int)getegid();
1890 tainting |= (uid && (euid != uid || egid != gid));
1896 curstash = debstash;
1897 dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
1899 DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
1900 DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
1901 DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
1902 DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
1903 sv_setiv(DBsingle, 0);
1904 DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
1905 sv_setiv(DBtrace, 0);
1906 DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
1907 sv_setiv(DBsignal, 0);
1908 curstash = defstash;
1915 mainstack = curstack; /* remember in case we switch stacks */
1916 AvREAL_off(curstack); /* not a real array */
1917 av_extend(curstack,127);
1919 stack_base = AvARRAY(curstack);
1920 stack_sp = stack_base;
1921 stack_max = stack_base + 127;
1923 /* Shouldn't these stacks be per-interpreter? */
1925 markstack_ptr = markstack;
1927 New(54,markstack,64,I32);
1928 markstack_ptr = markstack;
1929 markstack_max = markstack + 64;
1935 New(54,scopestack,32,I32);
1937 scopestack_max = 32;
1943 New(54,savestack,128,ANY);
1945 savestack_max = 128;
1951 New(54,retstack,16,OP*);
1956 cxstack_max = 8192 / sizeof(CONTEXT) - 2; /* Use most of 8K. */
1957 New(50,cxstack,cxstack_max + 1,CONTEXT);
1960 New(50,tmps_stack,128,SV*);
1965 New(51,debname,128,char);
1966 New(52,debdelim,128,char);
1974 Safefree(tmps_stack);
1977 static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
1985 subname = newSVpv("main",4);
1989 init_predump_symbols()
1994 sv_setpvn(GvSV(gv_fetchpv("\"", TRUE, SVt_PV)), " ", 1);
1996 stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
1997 GvMULTI_on(stdingv);
1998 IoIFP(GvIOp(stdingv)) = PerlIO_stdin();
1999 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2001 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv));
2003 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2005 IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
2007 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2009 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv));
2011 othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2012 GvMULTI_on(othergv);
2013 IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr();
2014 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2016 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
2018 statname = NEWSV(66,0); /* last filename we did stat on */
2021 osname = savepv(OSNAME);
2025 init_postdump_symbols(argc,argv,env)
2027 register char **argv;
2028 register char **env;
2034 argc--,argv++; /* skip name of script */
2036 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2039 if (argv[0][1] == '-') {
2043 if (s = strchr(argv[0], '=')) {
2045 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2048 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2051 toptarget = NEWSV(0,0);
2052 sv_upgrade(toptarget, SVt_PVFM);
2053 sv_setpvn(toptarget, "", 0);
2054 bodytarget = NEWSV(0,0);
2055 sv_upgrade(bodytarget, SVt_PVFM);
2056 sv_setpvn(bodytarget, "", 0);
2057 formtarget = bodytarget;
2060 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2061 sv_setpv(GvSV(tmpgv),origfilename);
2062 magicname("0", "0", 1);
2064 if (tmpgv = gv_fetchpv("\024",TRUE, SVt_PV))
2066 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2067 sv_setpv(GvSV(tmpgv),origargv[0]);
2068 if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2070 (void)gv_AVadd(argvgv);
2071 av_clear(GvAVn(argvgv));
2072 for (; argc > 0; argc--,argv++) {
2073 av_push(GvAVn(argvgv),newSVpv(argv[0],0));
2076 if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2081 #ifndef VMS /* VMS doesn't have environ array */
2082 /* Note that if the supplied env parameter is actually a copy
2083 of the global environ then it may now point to free'd memory
2084 if the environment has been modified since. To avoid this
2085 problem we treat env==NULL as meaning 'use the default'
2089 if (env != environ) {
2090 environ[0] = Nullch;
2091 hv_magic(hv, envgv, 'E');
2093 for (; *env; env++) {
2094 if (!(s = strchr(*env,'=')))
2097 sv = newSVpv(s--,0);
2098 sv_magic(sv, sv, 'e', *env, s - *env);
2099 (void)hv_store(hv, *env, s - *env, sv, 0);
2103 #ifdef DYNAMIC_ENV_FETCH
2104 HvNAME(hv) = savepv(ENV_HV_NAME);
2106 hv_magic(hv, envgv, 'E');
2109 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2110 sv_setiv(GvSV(tmpgv),(I32)getpid());
2119 s = getenv("PERL5LIB");
2123 incpush(getenv("PERLLIB"));
2127 incpush(APPLLIB_EXP);
2131 incpush(ARCHLIB_EXP);
2134 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2136 incpush(PRIVLIB_EXP);
2139 incpush(SITEARCH_EXP);
2142 incpush(SITELIB_EXP);
2144 #ifdef OLDARCHLIB_EXP /* 5.00[01] compatibility */
2145 incpush(OLDARCHLIB_EXP);
2158 line_t oldline = curcop->cop_line;
2160 Copy(top_env, oldtop, 1, Sigjmp_buf);
2162 while (AvFILL(list) >= 0) {
2163 CV *cv = (CV*)av_shift(list);
2167 switch (Sigsetjmp(top_env,1)) {
2169 SV* atsv = GvSV(errgv);
2171 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
2172 (void)SvPV(atsv, len);
2174 Copy(oldtop, top_env, 1, Sigjmp_buf);
2175 curcop = &compiling;
2176 curcop->cop_line = oldline;
2177 if (list == beginav)
2178 sv_catpv(atsv, "BEGIN failed--compilation aborted");
2180 sv_catpv(atsv, "END failed--cleanup aborted");
2181 croak("%s", SvPVX(atsv));
2187 statusvalue = 255; /* XXX I don't think we use 1 anymore. */
2193 /* my_exit() was called */
2194 curstash = defstash;
2198 Copy(oldtop, top_env, 1, Sigjmp_buf);
2199 curcop = &compiling;
2200 curcop->cop_line = oldline;
2202 if (list == beginav)
2203 croak("BEGIN failed--compilation aborted");
2205 croak("END failed--cleanup aborted");
2207 my_exit(statusvalue);
2212 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
2216 Copy(oldtop, top_env, 1, Sigjmp_buf);
2217 curcop = &compiling;
2218 curcop->cop_line = oldline;
2219 Siglongjmp(top_env, 3);
2223 Copy(oldtop, top_env, 1, Sigjmp_buf);