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 /* XXX If this causes problems, set i_unistd=undef in the hint file. */
23 dEXT char rcsid[] = "perl.c\nPatch level: ###\n";
31 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
37 static void find_beginning _((void));
38 static void incpush _((char *));
39 static void init_ids _((void));
40 static void init_debugger _((void));
41 static void init_lexer _((void));
42 static void init_main_stash _((void));
43 static void init_perllib _((void));
44 static void init_postdump_symbols _((int, char **, char **));
45 static void init_predump_symbols _((void));
46 static void init_stacks _((void));
47 static void nuke_stacks _((void));
48 static void open_script _((char *, bool, SV *));
49 static void usage _((char *));
50 static void validate_suid _((char *, char*));
52 static int fdscript = -1;
57 PerlInterpreter *sv_interp;
60 New(53, sv_interp, 1, PerlInterpreter);
65 perl_construct( sv_interp )
66 register PerlInterpreter *sv_interp;
68 if (!(curinterp = sv_interp))
72 Zero(sv_interp, 1, PerlInterpreter);
75 /* Init the real globals? */
77 linestr = NEWSV(65,80);
78 sv_upgrade(linestr,SVt_PVIV);
80 if (!SvREADONLY(&sv_undef)) {
81 SvREADONLY_on(&sv_undef);
85 SvREADONLY_on(&sv_no);
87 sv_setpv(&sv_yes,Yes);
89 SvREADONLY_on(&sv_yes);
92 nrs = newSVpv("\n", 1);
93 rs = SvREFCNT_inc(nrs);
97 * There is no way we can refer to them from Perl so close them to save
98 * space. The other alternative would be to provide STDAUX and STDPRN
101 (void)fclose(stdaux);
102 (void)fclose(stdprn);
123 #if defined(SUBVERSION) && SUBVERSION > 0
124 sprintf(patchlevel, "%7.5f", 5.0 + (PATCHLEVEL / 1000.0)
125 + (SUBVERSION / 100000.0));
127 sprintf(patchlevel, "%5.3f", 5.0 + (PATCHLEVEL / 1000.0));
130 #if defined(LOCAL_PATCH_COUNT)
131 localpatches = local_patches; /* For possible -v */
134 PerlIO_init(); /* Hook to IO system */
136 fdpid = newAV(); /* for remembering popen pids by fd */
137 pidstatus = newHV();/* for remembering status of dead pids */
144 perl_destruct(sv_interp)
145 register PerlInterpreter *sv_interp;
147 int destruct_level; /* 0=none, 1=full, 2=full with checks */
151 if (!(curinterp = sv_interp))
154 destruct_level = perl_destruct_level;
158 if (s = getenv("PERL_DESTRUCT_LEVEL"))
159 destruct_level = atoi(s);
166 /* We must account for everything. First the syntax tree. */
168 curpad = AvARRAY(comppad);
174 * Try to destruct global references. We do this first so that the
175 * destructors and destructees still exist. Some sv's might remain.
176 * Non-referenced objects are on their own.
183 if (destruct_level == 0){
185 DEBUG_P(debprofdump());
187 /* The exit() function will do everything that needs doing. */
191 /* Prepare to destruct main symbol table. */
197 if (destruct_level >= 2) {
198 if (scopestack_ix != 0)
199 warn("Unbalanced scopes: %d more ENTERs than LEAVEs\n", scopestack_ix);
200 if (savestack_ix != 0)
201 warn("Unbalanced saves: %d more saves than restores\n", savestack_ix);
202 if (tmps_floor != -1)
203 warn("Unbalanced tmps: %d more allocs than frees\n", tmps_floor + 1);
204 if (cxstack_ix != -1)
205 warn("Unbalanced context: %d more PUSHes than POPs\n", cxstack_ix + 1);
208 /* Now absolutely destruct everything, somehow or other, loops or no. */
210 SvFLAGS(strtab) |= SVTYPEMASK; /* don't clean out strtab now */
211 while (sv_count != 0 && sv_count != last_sv_count) {
212 last_sv_count = sv_count;
215 SvFLAGS(strtab) &= ~SVTYPEMASK;
216 SvFLAGS(strtab) |= SVt_PVHV;
218 /* Destruct the global string table. */
220 /* Yell and reset the HeVAL() slots that are still holding refcounts,
221 * so that sv_free() won't fail on them.
230 array = HvARRAY(strtab);
234 warn("Unbalanced string table refcount: (%d) for \"%s\"",
235 HeVAL(hent) - Nullsv, HeKEY(hent));
236 HeVAL(hent) = Nullsv;
246 SvREFCNT_dec(strtab);
249 warn("Scalars leaked: %d\n", sv_count);
253 linestr = NULL; /* No SVs have survived, need to clean out */
255 Safefree(origfilename);
257 hints = 0; /* Reset hints. Should hints be per-interpreter ? */
259 DEBUG_P(debprofdump());
264 PerlInterpreter *sv_interp;
266 if (!(curinterp = sv_interp))
270 #if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE)
271 char *getenv _((char *)); /* Usually in <stdlib.h> */
275 perl_parse(sv_interp, xsinit, argc, argv, env)
276 PerlInterpreter *sv_interp;
277 void (*xsinit)_((void));
284 char *scriptname = NULL;
285 VOL bool dosearch = FALSE;
289 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
292 croak("suidperl is no longer needed since the kernel can now execute\n\
293 setuid perl scripts securely.\n");
297 if (!(curinterp = sv_interp))
300 #if defined(NeXT) && defined(__DYNAMIC__)
301 _dyld_lookup_and_bind
302 ("__environ", (unsigned long *) &environ_pointer, NULL);
307 #ifndef VMS /* VMS doesn't have environ array */
308 origenviron = environ;
314 /* Come here if running an undumped a.out. */
316 origfilename = savepv(argv[0]);
318 cxstack_ix = -1; /* start label stack again */
320 init_postdump_symbols(argc,argv,env);
328 switch (Sigsetjmp(top_env,1)) {
339 return(statusvalue); /* my_exit() was called */
341 PerlIO_printf(PerlIO_stderr(), "panic: top_env\n");
345 sv_setpvn(linestr,"",0);
346 sv = newSVpv("",0); /* first used for -I flags */
349 for (argc--,argv++; argc > 0; argc--,argv++) {
350 if (argv[0][0] != '-' || !argv[0][1])
354 validarg = " PHOOEY ";
380 if (s = moreswitches(s))
385 if (euid != uid || egid != gid)
386 croak("No -e allowed in setuid scripts");
388 e_tmpname = savepv(TMPPATH);
389 (void)mktemp(e_tmpname);
391 croak("Can't mktemp()");
392 e_fp = PerlIO_open(e_tmpname,"w");
394 croak("Cannot open temporary file");
397 PerlIO_puts(e_fp,argv[1]);
400 (void)PerlIO_putc(e_fp,'\n');
408 av_push(GvAVn(incgv),newSVpv(s,0));
411 av_push(GvAVn(incgv),newSVpv(argv[1],0));
412 sv_catpv(sv,argv[1]);
429 preambleav = newAV();
430 av_push(preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
432 Sv = newSVpv("print myconfig();",0);
434 sv_catpv(Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
436 sv_catpv(Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
438 #if defined(DEBUGGING) || defined(NOEMBED) || defined(MULTIPLICITY)
439 strcpy(buf,"\" Compile-time options:");
441 strcat(buf," DEBUGGING");
444 strcat(buf," NOEMBED");
447 strcat(buf," MULTIPLICITY");
449 strcat(buf,"\\n\",");
452 #if defined(LOCAL_PATCH_COUNT)
453 if (LOCAL_PATCH_COUNT > 0)
455 sv_catpv(Sv,"print \" Locally applied patches:\\n\",");
456 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
457 if (localpatches[i]) {
458 sprintf(buf,"\" \\t%s\\n\",",localpatches[i]);
464 sprintf(buf,"\" Built under %s\\n\",",OSNAME);
468 sprintf(buf,"\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
470 sprintf(buf,"\" Compiled on %s\\n\"",__DATE__);
474 sv_catpv(Sv,"; $\"=\"\\n \"; print \" \\@INC:\\n @INC\\n\"");
477 Sv = newSVpv("config_vars(qw(",0);
482 av_push(preambleav, Sv);
483 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
497 croak("Unrecognized switch: -%s",s);
502 scriptname = argv[0];
504 if (PerlIO_flush(e_fp) || PerlIO_error(e_fp) || PerlIO_close(e_fp))
505 croak("Can't write to temp file for -e: %s", Strerror(errno));
508 scriptname = e_tmpname;
510 else if (scriptname == Nullch) {
512 if ( isatty(PerlIO_fileno(PerlIO_stdin())) )
520 open_script(scriptname,dosearch,sv);
522 validate_suid(validarg, scriptname);
527 compcv = (CV*)NEWSV(1104,0);
528 sv_upgrade((SV *)compcv, SVt_PVCV);
531 av_push(comppad, Nullsv);
532 curpad = AvARRAY(comppad);
533 comppad_name = newAV();
534 comppad_name_fill = 0;
535 min_intro_pending = 0;
538 comppadlist = newAV();
539 AvREAL_off(comppadlist);
540 av_store(comppadlist, 0, (SV*)comppad_name);
541 av_store(comppadlist, 1, (SV*)comppad);
542 CvPADLIST(compcv) = comppadlist;
544 boot_core_UNIVERSAL();
546 (*xsinit)(); /* in case linked C routines want magical variables */
551 init_predump_symbols();
553 init_postdump_symbols(argc,argv,env);
557 /* now parse the script */
560 if (yyparse() || error_count) {
562 croak("%s had compilation errors.\n", origfilename);
564 croak("Execution of %s aborted due to compilation errors.\n",
568 curcop->cop_line = 0;
572 (void)UNLINK(e_tmpname);
577 /* now that script is parsed, we can modify record separator */
579 rs = SvREFCNT_inc(nrs);
580 sv_setsv(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), rs);
591 #ifdef DEBUGGING_MSTATS
592 if ((s=getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
593 dump_mstats("after compilation:");
603 PerlInterpreter *sv_interp;
605 if (!(curinterp = sv_interp))
607 switch (Sigsetjmp(top_env,1)) {
609 cxstack_ix = -1; /* start context stack again */
616 #ifdef DEBUGGING_MSTATS
617 if (getenv("PERL_DEBUG_MSTATS"))
618 dump_mstats("after execution: ");
620 return(statusvalue); /* my_exit() was called */
623 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
627 if (curstack != mainstack) {
629 SWITCHSTACK(curstack, mainstack);
634 DEBUG_r(PerlIO_printf(PerlIO_stderr(), "%s $` $& $' support.\n",
635 sawampersand ? "Enabling" : "Omitting"));
639 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
642 PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", origfilename);
645 if (perldb && DBsingle)
646 sv_setiv(DBsingle, 1);
656 else if (main_start) {
669 register CONTEXT *cx;
673 statusvalue = FIXSTATUS(status);
674 if (cxstack_ix >= 0) {
680 Siglongjmp(top_env, 2);
684 perl_get_sv(name, create)
688 GV* gv = gv_fetchpv(name, create, SVt_PV);
695 perl_get_av(name, create)
699 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
708 perl_get_hv(name, create)
712 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
721 perl_get_cv(name, create)
725 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
726 if (create && !GvCV(gv))
727 return newSUB(start_subparse(),
728 newSVOP(OP_CONST, 0, newSVpv(name,0)),
736 /* Be sure to refetch the stack pointer after calling these routines. */
739 perl_call_argv(subname, flags, argv)
741 I32 flags; /* See G_* flags in cop.h */
742 register char **argv; /* null terminated arg list */
749 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
754 return perl_call_pv(subname, flags);
758 perl_call_pv(subname, flags)
759 char *subname; /* name of the subroutine */
760 I32 flags; /* See G_* flags in cop.h */
762 return perl_call_sv((SV*)perl_get_cv(subname, TRUE), flags);
766 perl_call_method(methname, flags)
767 char *methname; /* name of the subroutine */
768 I32 flags; /* See G_* flags in cop.h */
774 XPUSHs(sv_2mortal(newSVpv(methname,0)));
777 return perl_call_sv(*stack_sp--, flags);
780 /* May be called with any of a CV, a GV, or an SV containing the name. */
782 perl_call_sv(sv, flags)
784 I32 flags; /* See G_* flags in cop.h */
786 LOGOP myop; /* fake syntax tree node */
788 I32 oldmark = TOPMARK;
794 if (flags & G_DISCARD) {
804 oldscope = scopestack_ix;
806 if (!(flags & G_NOARGS))
807 myop.op_flags = OPf_STACKED;
808 myop.op_next = Nullop;
809 myop.op_flags |= OPf_KNOW;
811 myop.op_flags |= OPf_LIST;
813 if (perldb && curstash != debstash
814 && (DBcv || (DBcv = GvCV(DBsub)))) /* to handle first BEGIN of -d */
815 op->op_private |= OPpENTERSUB_DB;
817 if (flags & G_EVAL) {
818 Copy(top_env, oldtop, 1, Sigjmp_buf);
820 cLOGOP->op_other = op;
822 /* we're trying to emulate pp_entertry() here */
824 register CONTEXT *cx;
830 push_return(op->op_next);
831 PUSHBLOCK(cx, CXt_EVAL, stack_sp);
833 eval_root = op; /* Only needed so that goto works right. */
836 if (flags & G_KEEPERR)
839 sv_setpv(GvSV(errgv),"");
844 switch (Sigsetjmp(top_env,1)) {
849 statusvalue = 255; /* XXX I don't think we use 1 anymore. */
855 /* my_exit() was called */
858 Copy(oldtop, top_env, 1, Sigjmp_buf);
860 croak("Callback called exit");
861 my_exit(statusvalue);
869 stack_sp = stack_base + oldmark;
874 *++stack_sp = &sv_undef;
880 if (op == (OP*)&myop)
884 retval = stack_sp - (stack_base + oldmark);
885 if ((flags & G_EVAL) && !(flags & G_KEEPERR))
886 sv_setpv(GvSV(errgv),"");
889 if (flags & G_EVAL) {
890 if (scopestack_ix > oldscope) {
894 register CONTEXT *cx;
903 Copy(oldtop, top_env, 1, Sigjmp_buf);
905 if (flags & G_DISCARD) {
906 stack_sp = stack_base + oldmark;
914 /* Eval a string. The G_EVAL flag is always assumed. */
917 perl_eval_sv(sv, flags)
919 I32 flags; /* See G_* flags in cop.h */
921 UNOP myop; /* fake syntax tree node */
923 I32 oldmark = sp - stack_base;
928 if (flags & G_DISCARD) {
938 oldscope = scopestack_ix;
940 if (!(flags & G_NOARGS))
941 myop.op_flags = OPf_STACKED;
942 myop.op_next = Nullop;
943 myop.op_type = OP_ENTEREVAL;
944 myop.op_flags |= OPf_KNOW;
945 if (flags & G_KEEPERR)
946 myop.op_flags |= OPf_SPECIAL;
948 myop.op_flags |= OPf_LIST;
950 Copy(top_env, oldtop, 1, Sigjmp_buf);
953 switch (Sigsetjmp(top_env,1)) {
958 statusvalue = 255; /* XXX I don't think we use 1 anymore. */
964 /* my_exit() was called */
967 Copy(oldtop, top_env, 1, Sigjmp_buf);
969 croak("Callback called exit");
970 my_exit(statusvalue);
978 stack_sp = stack_base + oldmark;
983 *++stack_sp = &sv_undef;
988 if (op == (OP*)&myop)
992 retval = stack_sp - (stack_base + oldmark);
993 if (!(flags & G_KEEPERR))
994 sv_setpv(GvSV(errgv),"");
997 Copy(oldtop, top_env, 1, Sigjmp_buf);
998 if (flags & G_DISCARD) {
999 stack_sp = stack_base + oldmark;
1007 /* Require a module. */
1013 SV* sv = sv_newmortal();
1014 sv_setpv(sv, "require '");
1017 perl_eval_sv(sv, G_DISCARD);
1021 magicname(sym,name,namlen)
1028 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1029 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1033 # define PERLLIB_SEP ';'
1036 # define PERLLIB_SEP '|'
1038 # define PERLLIB_SEP ':'
1041 #ifndef PERLLIB_MANGLE
1042 # define PERLLIB_MANGLE(s,n) (s)
1054 /* Break at all separators */
1056 /* First, skip any consecutive separators */
1057 while ( *p == PERLLIB_SEP ) {
1058 /* Uncomment the next line for PATH semantics */
1059 /* av_push(GvAVn(incgv), newSVpv(".", 1)); */
1062 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
1063 av_push(GvAVn(incgv), newSVpv(PERLLIB_MANGLE(p, (STRLEN)(s - p)),
1067 av_push(GvAVn(incgv), newSVpv(PERLLIB_MANGLE(p, 0), 0));
1074 usage(name) /* XXX move this out into a module ? */
1077 /* This message really ought to be max 23 lines.
1078 * Removed -h because the user already knows that opton. Others? */
1079 printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1080 printf("\n -0[octal] specify record separator (\\0, if no argument)");
1081 printf("\n -a autosplit mode with -n or -p (splits $_ into @F)");
1082 printf("\n -c check syntax only (runs BEGIN and END blocks)");
1083 printf("\n -d[:debugger] run scripts under debugger");
1084 printf("\n -D[number/list] set debugging flags (argument is a bit mask or flags)");
1085 printf("\n -e 'command' one line of script. Several -e's allowed. Omit [programfile].");
1086 printf("\n -F/pattern/ split() pattern for autosplit (-a). The //'s are optional.");
1087 printf("\n -i[extension] edit <> files in place (make backup if extension supplied)");
1088 printf("\n -Idirectory specify @INC/#include directory (may be used more then once)");
1089 printf("\n -l[octal] enable line ending processing, specifies line teminator");
1090 printf("\n -[mM][-]module.. executes `use/no module...' before executing your script.");
1091 printf("\n -n assume 'while (<>) { ... }' loop arround your script");
1092 printf("\n -p assume loop like -n but print line also like sed");
1093 printf("\n -P run script through C preprocessor before compilation");
1094 printf("\n -s enable some switch parsing for switches after script name");
1095 printf("\n -S look for the script using PATH environment variable");
1096 printf("\n -T turn on tainting checks");
1097 printf("\n -u dump core after parsing script");
1098 printf("\n -U allow unsafe operations");
1099 printf("\n -v print version number and patchlevel of perl");
1100 printf("\n -V[:variable] print perl configuration information");
1101 printf("\n -w TURN WARNINGS ON FOR COMPILATION OF YOUR SCRIPT.");
1102 printf("\n -x[directory] strip off text before #!perl line and perhaps cd to directory\n");
1105 /* This routine handles any switches that can be given during run */
1116 rschar = scan_oct(s, 4, &numlen);
1118 if (rschar & ~((U8)~0))
1120 else if (!rschar && numlen >= 2)
1121 nrs = newSVpv("", 0);
1124 nrs = newSVpv(&ch, 1);
1129 splitstr = savepv(s + 1);
1143 if (*s == ':' || *s == '=') {
1144 sprintf(buf, "use Devel::%s;", ++s);
1146 my_setenv("PERL5DB",buf);
1156 if (isALPHA(s[1])) {
1157 static char debopts[] = "psltocPmfrxuLHXD";
1160 for (s++; *s && (d = strchr(debopts,*s)); s++)
1161 debug |= 1 << (d - debopts);
1165 for (s++; isDIGIT(*s); s++) ;
1167 debug |= 0x80000000;
1169 warn("Recompile perl with -DDEBUGGING to use -D switch\n");
1170 for (s++; isALNUM(*s); s++) ;
1180 inplace = savepv(s+1);
1182 for (s = inplace; *s && !isSPACE(*s); s++) ;
1189 for (e = s; *e && !isSPACE(*e); e++) ;
1190 av_push(GvAVn(incgv),newSVpv(s,e-s));
1195 croak("No space allowed after -I");
1205 *ors = scan_oct(s, 3 + (*s == '0'), &numlen);
1214 ors = SvPV(nrs, orslen);
1215 ors = savepvn(ors, orslen);
1219 taint_not("-M"); /* XXX ? */
1222 taint_not("-m"); /* XXX ? */
1226 /* -M-foo == 'no foo' */
1227 if (*s == '-') { use = "no "; ++s; }
1228 Sv = newSVpv(use,0);
1230 /* We allow -M'Module qw(Foo Bar)' */
1231 while(isALNUM(*s) || *s==':') ++s;
1233 sv_catpv(Sv, start);
1234 if (*(start-1) == 'm') {
1236 croak("Can't use '%c' after -mname", *s);
1237 sv_catpv( Sv, " ()");
1240 sv_catpvn(Sv, start, s-start);
1241 sv_catpv(Sv, " split(/,/,q{");
1246 if (preambleav == NULL)
1247 preambleav = newAV();
1248 av_push(preambleav, Sv);
1251 croak("No space allowed after -%c", *(s-1));
1279 #if defined(SUBVERSION) && SUBVERSION > 0
1280 printf("\nThis is perl, version 5.%03d_%02d", PATCHLEVEL, SUBVERSION);
1282 printf("\nThis is perl, version %s",patchlevel);
1285 printf("\n\nCopyright 1987-1996, Larry Wall\n");
1286 printf("\n\t+ suidperl security patch");
1288 printf("MS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1291 printf("OS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1292 "Version 5 port Copyright (c) 1994-1996, Andreas Kaiser, Ilya Zakharevich\n");
1295 printf("atariST series port, ++jrb bammi@cadence.com\n");
1298 Perl may be copied only under the terms of either the Artistic License or the\n\
1299 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n");
1310 if (s[1] == '-') /* Additional switches on #! line. */
1323 croak("Can't emulate -%.1s on #! line",s);
1328 /* compliments of Tom Christiansen */
1330 /* unexec() can be found in the Gnu emacs distribution */
1339 sprintf (buf, "%s.perldump", origfilename);
1340 sprintf (tokenbuf, "%s/perl", BIN);
1342 status = unexec(buf, tokenbuf, &etext, sbrk(0), 0);
1344 PerlIO_printf(PerlIO_stderr(), "unexec of %s into %s failed!\n", tokenbuf, buf);
1348 # include <lib$routines.h>
1349 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
1351 ABORT(); /* for use with undump */
1361 /* Note that strtab is a rather special HV. Assumptions are made
1362 about not iterating on it, and not adding tie magic to it.
1363 It is properly deallocated in perl_destruct() */
1365 HvSHAREKEYS_off(strtab); /* mandatory */
1366 Newz(506,((XPVHV*)SvANY(strtab))->xhv_array,
1367 sizeof(HE*) * (((XPVHV*)SvANY(strtab))->xhv_max + 1), char);
1369 curstash = defstash = newHV();
1370 curstname = newSVpv("main",4);
1371 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1372 SvREFCNT_dec(GvHV(gv));
1373 GvHV(gv) = (HV*)SvREFCNT_inc(defstash);
1375 HvNAME(defstash) = savepv("main");
1376 incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1378 defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1379 errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1381 curstash = defstash;
1382 compiling.cop_stash = defstash;
1383 debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
1384 /* We must init $/ before switches are processed. */
1385 sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1);
1388 #ifdef CAN_PROTOTYPE
1390 open_script(char *scriptname, bool dosearch, SV *sv)
1393 open_script(scriptname,dosearch,sv)
1399 char *xfound = Nullch;
1400 char *xfailed = Nullch;
1404 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
1405 #define SEARCH_EXTS ".bat", ".cmd", NULL
1408 # define SEARCH_EXTS ".pl", ".com", NULL
1410 /* additional extensions to try in each dir if scriptname not found */
1412 char *ext[] = { SEARCH_EXTS };
1413 int extidx = (strchr(scriptname,'.')) ? -1 : 0; /* has ext already */
1418 int hasdir, idx = 0, deftypes = 1;
1420 hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
1421 /* The first time through, just add SEARCH_EXTS to whatever we
1422 * already have, so we can check for default file types. */
1423 while (deftypes || (!hasdir && my_trnlnm("DCL$PATH",tokenbuf,idx++)) ) {
1424 if (deftypes) { deftypes = 0; *tokenbuf = '\0'; }
1425 strcat(tokenbuf,scriptname);
1427 if (dosearch && !strchr(scriptname, '/') && (s = getenv("PATH"))) {
1429 bufend = s + strlen(s);
1432 s = cpytill(tokenbuf,s,bufend,':',&len);
1435 for (len = 0; *s && *s != ',' && *s != ';'; tokenbuf[len++] = *s++);
1436 tokenbuf[len] = '\0';
1438 for (len = 0; *s && *s != ';'; tokenbuf[len++] = *s++);
1439 tokenbuf[len] = '\0';
1445 if (len && tokenbuf[len-1] != '/')
1448 if (len && ((tokenbuf[len-1] != '\\') && (tokenbuf[len-1] != '/')))
1450 if (len && tokenbuf[len-1] != '\\')
1453 (void)strcat(tokenbuf+len,"/");
1454 (void)strcat(tokenbuf+len,scriptname);
1458 len = strlen(tokenbuf);
1459 if (extidx > 0) /* reset after previous loop */
1463 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tokenbuf));
1464 retval = Stat(tokenbuf,&statbuf);
1466 } while ( retval < 0 /* not there */
1467 && extidx>=0 && ext[extidx] /* try an extension? */
1468 && strcpy(tokenbuf+len, ext[extidx++])
1473 if (S_ISREG(statbuf.st_mode)
1474 && cando(S_IRUSR,TRUE,&statbuf) && cando(S_IXUSR,TRUE,&statbuf)) {
1475 xfound = tokenbuf; /* bingo! */
1479 xfailed = savepv(tokenbuf);
1482 croak("Can't execute %s", xfailed ? xfailed : scriptname );
1485 scriptname = xfound;
1488 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
1489 char *s = scriptname + 8;
1498 origfilename = savepv(e_tmpname ? "-e" : scriptname);
1499 curcop->cop_filegv = gv_fetchfile(origfilename);
1500 if (strEQ(origfilename,"-"))
1502 if (fdscript >= 0) {
1503 rsfp = PerlIO_fdopen(fdscript,"r");
1504 #if defined(HAS_FCNTL) && defined(F_SETFD)
1505 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
1508 else if (preprocess) {
1509 char *cpp = CPPSTDIN;
1511 if (strEQ(cpp,"cppstdin"))
1512 sprintf(tokenbuf, "%s/%s", SCRIPTDIR, cpp);
1514 sprintf(tokenbuf, "%s", cpp);
1516 sv_catpv(sv,PRIVLIB_EXP);
1518 (void)sprintf(buf, "\
1519 sed %s -e \"/^[^#]/b\" \
1520 -e \"/^#[ ]*include[ ]/b\" \
1521 -e \"/^#[ ]*define[ ]/b\" \
1522 -e \"/^#[ ]*if[ ]/b\" \
1523 -e \"/^#[ ]*ifdef[ ]/b\" \
1524 -e \"/^#[ ]*ifndef[ ]/b\" \
1525 -e \"/^#[ ]*else/b\" \
1526 -e \"/^#[ ]*elif[ ]/b\" \
1527 -e \"/^#[ ]*undef[ ]/b\" \
1528 -e \"/^#[ ]*endif/b\" \
1531 (doextract ? "-e \"1,/^#/d\n\"" : ""),
1533 (void)sprintf(buf, "\
1534 %s %s -e '/^[^#]/b' \
1535 -e '/^#[ ]*include[ ]/b' \
1536 -e '/^#[ ]*define[ ]/b' \
1537 -e '/^#[ ]*if[ ]/b' \
1538 -e '/^#[ ]*ifdef[ ]/b' \
1539 -e '/^#[ ]*ifndef[ ]/b' \
1540 -e '/^#[ ]*else/b' \
1541 -e '/^#[ ]*elif[ ]/b' \
1542 -e '/^#[ ]*undef[ ]/b' \
1543 -e '/^#[ ]*endif/b' \
1551 (doextract ? "-e '1,/^#/d\n'" : ""),
1553 scriptname, tokenbuf, SvPV(sv, na), CPPMINUS);
1555 #ifdef IAMSUID /* actually, this is caught earlier */
1556 if (euid != uid && !euid) { /* if running suidperl */
1558 (void)seteuid(uid); /* musn't stay setuid root */
1561 (void)setreuid((Uid_t)-1, uid);
1563 #ifdef HAS_SETRESUID
1564 (void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
1570 if (geteuid() != uid)
1571 croak("Can't do seteuid!\n");
1573 #endif /* IAMSUID */
1574 rsfp = my_popen(buf,"r");
1576 else if (!*scriptname) {
1577 taint_not("program input from stdin");
1578 rsfp = PerlIO_stdin();
1581 rsfp = PerlIO_open(scriptname,"r");
1582 #if defined(HAS_FCNTL) && defined(F_SETFD)
1583 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
1586 if ((PerlIO*)rsfp == Nullfp) {
1588 #ifndef IAMSUID /* in case script is not readable before setuid */
1589 if (euid && Stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
1590 statbuf.st_mode & (S_ISUID|S_ISGID)) {
1591 (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
1592 execv(buf, origargv); /* try again */
1593 croak("Can't do setuid\n");
1597 croak("Can't open perl script \"%s\": %s\n",
1598 SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno));
1603 validate_suid(validarg, scriptname)
1609 /* do we need to emulate setuid on scripts? */
1611 /* This code is for those BSD systems that have setuid #! scripts disabled
1612 * in the kernel because of a security problem. Merely defining DOSUID
1613 * in perl will not fix that problem, but if you have disabled setuid
1614 * scripts in the kernel, this will attempt to emulate setuid and setgid
1615 * on scripts that have those now-otherwise-useless bits set. The setuid
1616 * root version must be called suidperl or sperlN.NNN. If regular perl
1617 * discovers that it has opened a setuid script, it calls suidperl with
1618 * the same argv that it had. If suidperl finds that the script it has
1619 * just opened is NOT setuid root, it sets the effective uid back to the
1620 * uid. We don't just make perl setuid root because that loses the
1621 * effective uid we had before invoking perl, if it was different from the
1624 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
1625 * be defined in suidperl only. suidperl must be setuid root. The
1626 * Configure script will set this up for you if you want it.
1632 if (Fstat(PerlIO_fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
1633 croak("Can't stat script \"%s\"",origfilename);
1634 if (fdscript < 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) {
1638 #ifndef HAS_SETREUID
1639 /* On this access check to make sure the directories are readable,
1640 * there is actually a small window that the user could use to make
1641 * filename point to an accessible directory. So there is a faint
1642 * chance that someone could execute a setuid script down in a
1643 * non-accessible directory. I don't know what to do about that.
1644 * But I don't think it's too important. The manual lies when
1645 * it says access() is useful in setuid programs.
1647 if (access(SvPVX(GvSV(curcop->cop_filegv)),1)) /*double check*/
1648 croak("Permission denied");
1650 /* If we can swap euid and uid, then we can determine access rights
1651 * with a simple stat of the file, and then compare device and
1652 * inode to make sure we did stat() on the same file we opened.
1653 * Then we just have to make sure he or she can execute it.
1656 struct stat tmpstatbuf;
1660 setreuid(euid,uid) < 0
1663 setresuid(euid,uid,(Uid_t)-1) < 0
1666 || getuid() != euid || geteuid() != uid)
1667 croak("Can't swap uid and euid"); /* really paranoid */
1668 if (Stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
1669 croak("Permission denied"); /* testing full pathname here */
1670 if (tmpstatbuf.st_dev != statbuf.st_dev ||
1671 tmpstatbuf.st_ino != statbuf.st_ino) {
1672 (void)PerlIO_close(rsfp);
1673 if (rsfp = my_popen("/bin/mail root","w")) { /* heh, heh */
1675 "User %d tried to run dev %d ino %d in place of dev %d ino %d!\n\
1676 (Filename of set-id script was %s, uid %d gid %d.)\n\nSincerely,\nperl\n",
1677 uid,tmpstatbuf.st_dev, tmpstatbuf.st_ino,
1678 statbuf.st_dev, statbuf.st_ino,
1679 SvPVX(GvSV(curcop->cop_filegv)),
1680 statbuf.st_uid, statbuf.st_gid);
1681 (void)my_pclose(rsfp);
1683 croak("Permission denied\n");
1687 setreuid(uid,euid) < 0
1689 # if defined(HAS_SETRESUID)
1690 setresuid(uid,euid,(Uid_t)-1) < 0
1693 || getuid() != uid || geteuid() != euid)
1694 croak("Can't reswap uid and euid");
1695 if (!cando(S_IXUSR,FALSE,&statbuf)) /* can real uid exec? */
1696 croak("Permission denied\n");
1698 #endif /* HAS_SETREUID */
1699 #endif /* IAMSUID */
1701 if (!S_ISREG(statbuf.st_mode))
1702 croak("Permission denied");
1703 if (statbuf.st_mode & S_IWOTH)
1704 croak("Setuid/gid script is writable by world");
1705 doswitches = FALSE; /* -s is insecure in suid */
1707 if (sv_gets(linestr, rsfp, 0) == Nullch ||
1708 strnNE(SvPV(linestr,na),"#!",2) ) /* required even on Sys V */
1709 croak("No #! line");
1710 s = SvPV(linestr,na)+2;
1712 while (!isSPACE(*s)) s++;
1713 for (s2 = s; (s2 > SvPV(linestr,na)+2 &&
1714 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
1715 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
1716 croak("Not a perl script");
1717 while (*s == ' ' || *s == '\t') s++;
1719 * #! arg must be what we saw above. They can invoke it by
1720 * mentioning suidperl explicitly, but they may not add any strange
1721 * arguments beyond what #! says if they do invoke suidperl that way.
1723 len = strlen(validarg);
1724 if (strEQ(validarg," PHOOEY ") ||
1725 strnNE(s,validarg,len) || !isSPACE(s[len]))
1726 croak("Args must match #! line");
1729 if (euid != uid && (statbuf.st_mode & S_ISUID) &&
1730 euid == statbuf.st_uid)
1732 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
1733 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
1734 #endif /* IAMSUID */
1736 if (euid) { /* oops, we're not the setuid root perl */
1737 (void)PerlIO_close(rsfp);
1739 (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
1740 execv(buf, origargv); /* try again */
1742 croak("Can't do setuid\n");
1745 if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
1747 (void)setegid(statbuf.st_gid);
1750 (void)setregid((Gid_t)-1,statbuf.st_gid);
1752 #ifdef HAS_SETRESGID
1753 (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
1755 setgid(statbuf.st_gid);
1759 if (getegid() != statbuf.st_gid)
1760 croak("Can't do setegid!\n");
1762 if (statbuf.st_mode & S_ISUID) {
1763 if (statbuf.st_uid != euid)
1765 (void)seteuid(statbuf.st_uid); /* all that for this */
1768 (void)setreuid((Uid_t)-1,statbuf.st_uid);
1770 #ifdef HAS_SETRESUID
1771 (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
1773 setuid(statbuf.st_uid);
1777 if (geteuid() != statbuf.st_uid)
1778 croak("Can't do seteuid!\n");
1780 else if (uid) { /* oops, mustn't run as root */
1782 (void)seteuid((Uid_t)uid);
1785 (void)setreuid((Uid_t)-1,(Uid_t)uid);
1787 #ifdef HAS_SETRESUID
1788 (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
1794 if (geteuid() != uid)
1795 croak("Can't do seteuid!\n");
1798 if (!cando(S_IXUSR,TRUE,&statbuf))
1799 croak("Permission denied\n"); /* they can't do this */
1802 else if (preprocess)
1803 croak("-P not allowed for setuid/setgid script\n");
1804 else if (fdscript >= 0)
1805 croak("fd script not allowed in suidperl\n");
1807 croak("Script is not setuid/setgid in suidperl\n");
1809 /* We absolutely must clear out any saved ids here, so we */
1810 /* exec the real perl, substituting fd script for scriptname. */
1811 /* (We pass script name as "subdir" of fd, which perl will grok.) */
1812 PerlIO_rewind(rsfp);
1813 lseek(PerlIO_fileno(rsfp),(Off_t)0,0); /* just in case rewind didn't */
1814 for (which = 1; origargv[which] && origargv[which] != scriptname; which++) ;
1815 if (!origargv[which])
1816 croak("Permission denied");
1817 (void)sprintf(buf, "/dev/fd/%d/%.127s", PerlIO_fileno(rsfp), origargv[which]);
1818 origargv[which] = buf;
1820 #if defined(HAS_FCNTL) && defined(F_SETFD)
1821 fcntl(PerlIO_fileno(rsfp),F_SETFD,0); /* ensure no close-on-exec */
1824 (void)sprintf(tokenbuf, "%s/perl%s", BIN, patchlevel);
1825 execv(tokenbuf, origargv); /* try again */
1826 croak("Can't do setuid\n");
1827 #endif /* IAMSUID */
1829 if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */
1830 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
1831 Fstat(PerlIO_fileno(rsfp),&statbuf); /* may be either wrapped or real suid */
1832 if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
1834 (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
1837 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
1838 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
1839 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
1840 /* not set-id, must be wrapped */
1848 register char *s, *s2;
1850 /* skip forward in input to the real script? */
1854 if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
1855 croak("No Perl script found in input\n");
1856 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
1857 PerlIO_ungetc(rsfp, '\n'); /* to keep line count right */
1859 while (*s && !(isSPACE (*s) || *s == '#')) s++;
1861 while (*s == ' ' || *s == '\t') s++;
1863 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
1864 if (strnEQ(s2-4,"perl",4))
1866 while (s = moreswitches(s)) ;
1868 if (cddir && chdir(cddir) < 0)
1869 croak("Can't chdir to %s",cddir);
1877 uid = (int)getuid();
1878 euid = (int)geteuid();
1879 gid = (int)getgid();
1880 egid = (int)getegid();
1885 tainting |= (uid && (euid != uid || egid != gid));
1891 curstash = debstash;
1892 dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
1894 DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
1895 DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
1896 DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
1897 DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
1898 sv_setiv(DBsingle, 0);
1899 DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
1900 sv_setiv(DBtrace, 0);
1901 DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
1902 sv_setiv(DBsignal, 0);
1903 curstash = defstash;
1910 mainstack = curstack; /* remember in case we switch stacks */
1911 AvREAL_off(curstack); /* not a real array */
1912 av_extend(curstack,127);
1914 stack_base = AvARRAY(curstack);
1915 stack_sp = stack_base;
1916 stack_max = stack_base + 127;
1918 /* Shouldn't these stacks be per-interpreter? */
1920 markstack_ptr = markstack;
1922 New(54,markstack,64,I32);
1923 markstack_ptr = markstack;
1924 markstack_max = markstack + 64;
1930 New(54,scopestack,32,I32);
1932 scopestack_max = 32;
1938 New(54,savestack,128,ANY);
1940 savestack_max = 128;
1946 New(54,retstack,16,OP*);
1951 cxstack_max = 8192 / sizeof(CONTEXT) - 2; /* Use most of 8K. */
1952 New(50,cxstack,cxstack_max + 1,CONTEXT);
1955 New(50,tmps_stack,128,SV*);
1960 New(51,debname,128,char);
1961 New(52,debdelim,128,char);
1969 Safefree(tmps_stack);
1972 static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
1980 subname = newSVpv("main",4);
1984 init_predump_symbols()
1989 sv_setpvn(GvSV(gv_fetchpv("\"", TRUE, SVt_PV)), " ", 1);
1991 stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
1992 GvMULTI_on(stdingv);
1993 IoIFP(GvIOp(stdingv)) = PerlIO_stdin();
1994 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
1996 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv));
1998 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2000 IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
2002 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2004 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv));
2006 othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2007 GvMULTI_on(othergv);
2008 IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr();
2009 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2011 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
2013 statname = NEWSV(66,0); /* last filename we did stat on */
2016 osname = savepv(OSNAME);
2020 init_postdump_symbols(argc,argv,env)
2022 register char **argv;
2023 register char **env;
2029 argc--,argv++; /* skip name of script */
2031 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2034 if (argv[0][1] == '-') {
2038 if (s = strchr(argv[0], '=')) {
2040 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2043 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2046 toptarget = NEWSV(0,0);
2047 sv_upgrade(toptarget, SVt_PVFM);
2048 sv_setpvn(toptarget, "", 0);
2049 bodytarget = NEWSV(0,0);
2050 sv_upgrade(bodytarget, SVt_PVFM);
2051 sv_setpvn(bodytarget, "", 0);
2052 formtarget = bodytarget;
2055 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2056 sv_setpv(GvSV(tmpgv),origfilename);
2057 magicname("0", "0", 1);
2059 if (tmpgv = gv_fetchpv("\024",TRUE, SVt_PV))
2061 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2062 sv_setpv(GvSV(tmpgv),origargv[0]);
2063 if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2065 (void)gv_AVadd(argvgv);
2066 av_clear(GvAVn(argvgv));
2067 for (; argc > 0; argc--,argv++) {
2068 av_push(GvAVn(argvgv),newSVpv(argv[0],0));
2071 if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2076 #ifndef VMS /* VMS doesn't have environ array */
2077 /* Note that if the supplied env parameter is actually a copy
2078 of the global environ then it may now point to free'd memory
2079 if the environment has been modified since. To avoid this
2080 problem we treat env==NULL as meaning 'use the default'
2084 if (env != environ) {
2085 environ[0] = Nullch;
2086 hv_magic(hv, envgv, 'E');
2088 for (; *env; env++) {
2089 if (!(s = strchr(*env,'=')))
2092 sv = newSVpv(s--,0);
2093 sv_magic(sv, sv, 'e', *env, s - *env);
2094 (void)hv_store(hv, *env, s - *env, sv, 0);
2098 #ifdef DYNAMIC_ENV_FETCH
2099 HvNAME(hv) = savepv(ENV_HV_NAME);
2101 hv_magic(hv, envgv, 'E');
2104 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2105 sv_setiv(GvSV(tmpgv),(I32)getpid());
2114 s = getenv("PERL5LIB");
2118 incpush(getenv("PERLLIB"));
2121 /* Use the ~-expanded versions of APPLIB (undocumented),
2122 ARCHLIB PRIVLIB SITEARCH SITELIB and OLDARCHLIB
2125 incpush(APPLLIB_EXP);
2129 incpush(ARCHLIB_EXP);
2132 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2134 incpush(PRIVLIB_EXP);
2137 incpush(SITEARCH_EXP);
2140 incpush(SITELIB_EXP);
2142 #ifdef OLDARCHLIB_EXP /* 5.00[01] compatibility */
2143 incpush(OLDARCHLIB_EXP);
2156 line_t oldline = curcop->cop_line;
2158 Copy(top_env, oldtop, 1, Sigjmp_buf);
2160 while (AvFILL(list) >= 0) {
2161 CV *cv = (CV*)av_shift(list);
2165 switch (Sigsetjmp(top_env,1)) {
2167 SV* atsv = GvSV(errgv);
2169 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
2170 (void)SvPV(atsv, len);
2172 Copy(oldtop, top_env, 1, Sigjmp_buf);
2173 curcop = &compiling;
2174 curcop->cop_line = oldline;
2175 if (list == beginav)
2176 sv_catpv(atsv, "BEGIN failed--compilation aborted");
2178 sv_catpv(atsv, "END failed--cleanup aborted");
2179 croak("%s", SvPVX(atsv));
2185 statusvalue = 255; /* XXX I don't think we use 1 anymore. */
2191 /* my_exit() was called */
2192 curstash = defstash;
2196 Copy(oldtop, top_env, 1, Sigjmp_buf);
2197 curcop = &compiling;
2198 curcop->cop_line = oldline;
2200 if (list == beginav)
2201 croak("BEGIN failed--compilation aborted");
2203 croak("END failed--cleanup aborted");
2205 my_exit(statusvalue);
2210 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
2214 Copy(oldtop, top_env, 1, Sigjmp_buf);
2215 curcop = &compiling;
2216 curcop->cop_line = oldline;
2217 Siglongjmp(top_env, 3);
2221 Copy(oldtop, top_env, 1, Sigjmp_buf);