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", (double) 5
125 + ((double) PATCHLEVEL / (double) 1000)
126 + ((double) SUBVERSION / (double) 100000));
128 sprintf(patchlevel, "%5.3f", (double) 5 +
129 ((double) PATCHLEVEL / (double) 1000));
132 #if defined(LOCAL_PATCH_COUNT)
133 localpatches = local_patches; /* For possible -v */
136 PerlIO_init(); /* Hook to IO system */
138 fdpid = newAV(); /* for remembering popen pids by fd */
139 pidstatus = newHV();/* for remembering status of dead pids */
146 perl_destruct(sv_interp)
147 register PerlInterpreter *sv_interp;
149 int destruct_level; /* 0=none, 1=full, 2=full with checks */
153 if (!(curinterp = sv_interp))
156 destruct_level = perl_destruct_level;
160 if (s = getenv("PERL_DESTRUCT_LEVEL"))
161 destruct_level = atoi(s);
168 /* We must account for everything. First the syntax tree. */
170 curpad = AvARRAY(comppad);
176 * Try to destruct global references. We do this first so that the
177 * destructors and destructees still exist. Some sv's might remain.
178 * Non-referenced objects are on their own.
185 if (destruct_level == 0){
187 DEBUG_P(debprofdump());
189 /* The exit() function will do everything that needs doing. */
193 /* Prepare to destruct main symbol table. */
199 if (destruct_level >= 2) {
200 if (scopestack_ix != 0)
201 warn("Unbalanced scopes: %d more ENTERs than LEAVEs\n", scopestack_ix);
202 if (savestack_ix != 0)
203 warn("Unbalanced saves: %d more saves than restores\n", savestack_ix);
204 if (tmps_floor != -1)
205 warn("Unbalanced tmps: %d more allocs than frees\n", tmps_floor + 1);
206 if (cxstack_ix != -1)
207 warn("Unbalanced context: %d more PUSHes than POPs\n", cxstack_ix + 1);
210 /* Now absolutely destruct everything, somehow or other, loops or no. */
212 SvFLAGS(strtab) |= SVTYPEMASK; /* don't clean out strtab now */
213 while (sv_count != 0 && sv_count != last_sv_count) {
214 last_sv_count = sv_count;
217 SvFLAGS(strtab) &= ~SVTYPEMASK;
218 SvFLAGS(strtab) |= SVt_PVHV;
220 /* Destruct the global string table. */
222 /* Yell and reset the HeVAL() slots that are still holding refcounts,
223 * so that sv_free() won't fail on them.
232 array = HvARRAY(strtab);
236 warn("Unbalanced string table refcount: (%d) for \"%s\"",
237 HeVAL(hent) - Nullsv, HeKEY(hent));
238 HeVAL(hent) = Nullsv;
248 SvREFCNT_dec(strtab);
251 warn("Scalars leaked: %d\n", sv_count);
255 linestr = NULL; /* No SVs have survived, need to clean out */
257 Safefree(origfilename);
259 hints = 0; /* Reset hints. Should hints be per-interpreter ? */
261 DEBUG_P(debprofdump());
266 PerlInterpreter *sv_interp;
268 if (!(curinterp = sv_interp))
272 #if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE)
273 char *getenv _((char *)); /* Usually in <stdlib.h> */
277 perl_parse(sv_interp, xsinit, argc, argv, env)
278 PerlInterpreter *sv_interp;
279 void (*xsinit)_((void));
286 char *scriptname = NULL;
287 VOL bool dosearch = FALSE;
291 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
294 croak("suidperl is no longer needed since the kernel can now execute\n\
295 setuid perl scripts securely.\n");
299 if (!(curinterp = sv_interp))
302 #if defined(NeXT) && defined(__DYNAMIC__)
303 _dyld_lookup_and_bind
304 ("__environ", (unsigned long *) &environ_pointer, NULL);
309 #ifndef VMS /* VMS doesn't have environ array */
310 origenviron = environ;
316 /* Come here if running an undumped a.out. */
318 origfilename = savepv(argv[0]);
320 cxstack_ix = -1; /* start label stack again */
322 init_postdump_symbols(argc,argv,env);
330 switch (Sigsetjmp(top_env,1)) {
341 return(statusvalue); /* my_exit() was called */
343 PerlIO_printf(PerlIO_stderr(), "panic: top_env\n");
347 sv_setpvn(linestr,"",0);
348 sv = newSVpv("",0); /* first used for -I flags */
351 for (argc--,argv++; argc > 0; argc--,argv++) {
352 if (argv[0][0] != '-' || !argv[0][1])
356 validarg = " PHOOEY ";
382 if (s = moreswitches(s))
387 if (euid != uid || egid != gid)
388 croak("No -e allowed in setuid scripts");
390 e_tmpname = savepv(TMPPATH);
391 (void)mktemp(e_tmpname);
393 croak("Can't mktemp()");
394 e_fp = PerlIO_open(e_tmpname,"w");
396 croak("Cannot open temporary file");
399 PerlIO_puts(e_fp,argv[1]);
402 (void)PerlIO_putc(e_fp,'\n');
410 av_push(GvAVn(incgv),newSVpv(s,0));
413 av_push(GvAVn(incgv),newSVpv(argv[1],0));
414 sv_catpv(sv,argv[1]);
431 preambleav = newAV();
432 av_push(preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
434 Sv = newSVpv("print myconfig();",0);
436 sv_catpv(Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
438 sv_catpv(Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
440 #if defined(DEBUGGING) || defined(NOEMBED) || defined(MULTIPLICITY)
441 strcpy(buf,"\" Compile-time options:");
443 strcat(buf," DEBUGGING");
446 strcat(buf," NOEMBED");
449 strcat(buf," MULTIPLICITY");
451 strcat(buf,"\\n\",");
454 #if defined(LOCAL_PATCH_COUNT)
455 if (LOCAL_PATCH_COUNT > 0)
457 sv_catpv(Sv,"print \" Locally applied patches:\\n\",");
458 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
459 if (localpatches[i]) {
460 sprintf(buf,"\" \\t%s\\n\",",localpatches[i]);
466 sprintf(buf,"\" Built under %s\\n\",",OSNAME);
470 sprintf(buf,"\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
472 sprintf(buf,"\" Compiled on %s\\n\"",__DATE__);
476 sv_catpv(Sv,"; $\"=\"\\n \"; print \" \\@INC:\\n @INC\\n\"");
479 Sv = newSVpv("config_vars(qw(",0);
484 av_push(preambleav, Sv);
485 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
499 croak("Unrecognized switch: -%s",s);
504 scriptname = argv[0];
506 if (PerlIO_flush(e_fp) || PerlIO_error(e_fp) || PerlIO_close(e_fp))
507 croak("Can't write to temp file for -e: %s", Strerror(errno));
510 scriptname = e_tmpname;
512 else if (scriptname == Nullch) {
514 if ( isatty(PerlIO_fileno(PerlIO_stdin())) )
522 open_script(scriptname,dosearch,sv);
524 validate_suid(validarg, scriptname);
529 compcv = (CV*)NEWSV(1104,0);
530 sv_upgrade((SV *)compcv, SVt_PVCV);
533 av_push(comppad, Nullsv);
534 curpad = AvARRAY(comppad);
535 comppad_name = newAV();
536 comppad_name_fill = 0;
537 min_intro_pending = 0;
540 comppadlist = newAV();
541 AvREAL_off(comppadlist);
542 av_store(comppadlist, 0, (SV*)comppad_name);
543 av_store(comppadlist, 1, (SV*)comppad);
544 CvPADLIST(compcv) = comppadlist;
546 boot_core_UNIVERSAL();
548 (*xsinit)(); /* in case linked C routines want magical variables */
553 init_predump_symbols();
555 init_postdump_symbols(argc,argv,env);
559 /* now parse the script */
562 if (yyparse() || error_count) {
564 croak("%s had compilation errors.\n", origfilename);
566 croak("Execution of %s aborted due to compilation errors.\n",
570 curcop->cop_line = 0;
574 (void)UNLINK(e_tmpname);
579 /* now that script is parsed, we can modify record separator */
581 rs = SvREFCNT_inc(nrs);
582 sv_setsv(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), rs);
593 #ifdef DEBUGGING_MSTATS
594 if ((s=getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
595 dump_mstats("after compilation:");
605 PerlInterpreter *sv_interp;
607 if (!(curinterp = sv_interp))
609 switch (Sigsetjmp(top_env,1)) {
611 cxstack_ix = -1; /* start context stack again */
618 #ifdef DEBUGGING_MSTATS
619 if (getenv("PERL_DEBUG_MSTATS"))
620 dump_mstats("after execution: ");
622 return(statusvalue); /* my_exit() was called */
625 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
629 if (curstack != mainstack) {
631 SWITCHSTACK(curstack, mainstack);
636 DEBUG_r(PerlIO_printf(PerlIO_stderr(), "%s $` $& $' support.\n",
637 sawampersand ? "Enabling" : "Omitting"));
641 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
644 PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", origfilename);
647 if (perldb && DBsingle)
648 sv_setiv(DBsingle, 1);
658 else if (main_start) {
671 register CONTEXT *cx;
675 statusvalue = FIXSTATUS(status);
676 if (cxstack_ix >= 0) {
682 Siglongjmp(top_env, 2);
686 perl_get_sv(name, create)
690 GV* gv = gv_fetchpv(name, create, SVt_PV);
697 perl_get_av(name, create)
701 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
710 perl_get_hv(name, create)
714 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
723 perl_get_cv(name, create)
727 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
728 if (create && !GvCV(gv))
729 return newSUB(start_subparse(),
730 newSVOP(OP_CONST, 0, newSVpv(name,0)),
738 /* Be sure to refetch the stack pointer after calling these routines. */
741 perl_call_argv(subname, flags, argv)
743 I32 flags; /* See G_* flags in cop.h */
744 register char **argv; /* null terminated arg list */
751 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
756 return perl_call_pv(subname, flags);
760 perl_call_pv(subname, flags)
761 char *subname; /* name of the subroutine */
762 I32 flags; /* See G_* flags in cop.h */
764 return perl_call_sv((SV*)perl_get_cv(subname, TRUE), flags);
768 perl_call_method(methname, flags)
769 char *methname; /* name of the subroutine */
770 I32 flags; /* See G_* flags in cop.h */
776 XPUSHs(sv_2mortal(newSVpv(methname,0)));
779 return perl_call_sv(*stack_sp--, flags);
782 /* May be called with any of a CV, a GV, or an SV containing the name. */
784 perl_call_sv(sv, flags)
786 I32 flags; /* See G_* flags in cop.h */
788 LOGOP myop; /* fake syntax tree node */
790 I32 oldmark = TOPMARK;
796 if (flags & G_DISCARD) {
806 oldscope = scopestack_ix;
808 if (!(flags & G_NOARGS))
809 myop.op_flags = OPf_STACKED;
810 myop.op_next = Nullop;
811 myop.op_flags |= OPf_KNOW;
813 myop.op_flags |= OPf_LIST;
815 if (perldb && curstash != debstash
816 && (DBcv || (DBcv = GvCV(DBsub)))) /* to handle first BEGIN of -d */
817 op->op_private |= OPpENTERSUB_DB;
819 if (flags & G_EVAL) {
820 Copy(top_env, oldtop, 1, Sigjmp_buf);
822 cLOGOP->op_other = op;
824 /* we're trying to emulate pp_entertry() here */
826 register CONTEXT *cx;
832 push_return(op->op_next);
833 PUSHBLOCK(cx, CXt_EVAL, stack_sp);
835 eval_root = op; /* Only needed so that goto works right. */
838 if (flags & G_KEEPERR)
841 sv_setpv(GvSV(errgv),"");
846 switch (Sigsetjmp(top_env,1)) {
851 statusvalue = 255; /* XXX I don't think we use 1 anymore. */
857 /* my_exit() was called */
860 Copy(oldtop, top_env, 1, Sigjmp_buf);
862 croak("Callback called exit");
863 my_exit(statusvalue);
871 stack_sp = stack_base + oldmark;
876 *++stack_sp = &sv_undef;
882 if (op == (OP*)&myop)
886 retval = stack_sp - (stack_base + oldmark);
887 if ((flags & G_EVAL) && !(flags & G_KEEPERR))
888 sv_setpv(GvSV(errgv),"");
891 if (flags & G_EVAL) {
892 if (scopestack_ix > oldscope) {
896 register CONTEXT *cx;
905 Copy(oldtop, top_env, 1, Sigjmp_buf);
907 if (flags & G_DISCARD) {
908 stack_sp = stack_base + oldmark;
916 /* Eval a string. The G_EVAL flag is always assumed. */
919 perl_eval_sv(sv, flags)
921 I32 flags; /* See G_* flags in cop.h */
923 UNOP myop; /* fake syntax tree node */
925 I32 oldmark = sp - stack_base;
930 if (flags & G_DISCARD) {
940 oldscope = scopestack_ix;
942 if (!(flags & G_NOARGS))
943 myop.op_flags = OPf_STACKED;
944 myop.op_next = Nullop;
945 myop.op_type = OP_ENTEREVAL;
946 myop.op_flags |= OPf_KNOW;
947 if (flags & G_KEEPERR)
948 myop.op_flags |= OPf_SPECIAL;
950 myop.op_flags |= OPf_LIST;
952 Copy(top_env, oldtop, 1, Sigjmp_buf);
955 switch (Sigsetjmp(top_env,1)) {
960 statusvalue = 255; /* XXX I don't think we use 1 anymore. */
966 /* my_exit() was called */
969 Copy(oldtop, top_env, 1, Sigjmp_buf);
971 croak("Callback called exit");
972 my_exit(statusvalue);
980 stack_sp = stack_base + oldmark;
985 *++stack_sp = &sv_undef;
990 if (op == (OP*)&myop)
994 retval = stack_sp - (stack_base + oldmark);
995 if (!(flags & G_KEEPERR))
996 sv_setpv(GvSV(errgv),"");
999 Copy(oldtop, top_env, 1, Sigjmp_buf);
1000 if (flags & G_DISCARD) {
1001 stack_sp = stack_base + oldmark;
1009 /* Require a module. */
1015 SV* sv = sv_newmortal();
1016 sv_setpv(sv, "require '");
1019 perl_eval_sv(sv, G_DISCARD);
1023 magicname(sym,name,namlen)
1030 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1031 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1035 # define PERLLIB_SEP ';'
1038 # define PERLLIB_SEP '|'
1040 # define PERLLIB_SEP ':'
1043 #ifndef PERLLIB_MANGLE
1044 # define PERLLIB_MANGLE(s,n) (s)
1056 /* Break at all separators */
1058 /* First, skip any consecutive separators */
1059 while ( *p == PERLLIB_SEP ) {
1060 /* Uncomment the next line for PATH semantics */
1061 /* av_push(GvAVn(incgv), newSVpv(".", 1)); */
1064 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
1065 av_push(GvAVn(incgv), newSVpv(PERLLIB_MANGLE(p, (STRLEN)(s - p)),
1069 av_push(GvAVn(incgv), newSVpv(PERLLIB_MANGLE(p, 0), 0));
1076 usage(name) /* XXX move this out into a module ? */
1079 /* This message really ought to be max 23 lines.
1080 * Removed -h because the user already knows that opton. Others? */
1081 printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1082 printf("\n -0[octal] specify record separator (\\0, if no argument)");
1083 printf("\n -a autosplit mode with -n or -p (splits $_ into @F)");
1084 printf("\n -c check syntax only (runs BEGIN and END blocks)");
1085 printf("\n -d[:debugger] run scripts under debugger");
1086 printf("\n -D[number/list] set debugging flags (argument is a bit mask or flags)");
1087 printf("\n -e 'command' one line of script. Several -e's allowed. Omit [programfile].");
1088 printf("\n -F/pattern/ split() pattern for autosplit (-a). The //'s are optional.");
1089 printf("\n -i[extension] edit <> files in place (make backup if extension supplied)");
1090 printf("\n -Idirectory specify @INC/#include directory (may be used more then once)");
1091 printf("\n -l[octal] enable line ending processing, specifies line teminator");
1092 printf("\n -[mM][-]module.. executes `use/no module...' before executing your script.");
1093 printf("\n -n assume 'while (<>) { ... }' loop arround your script");
1094 printf("\n -p assume loop like -n but print line also like sed");
1095 printf("\n -P run script through C preprocessor before compilation");
1096 printf("\n -s enable some switch parsing for switches after script name");
1097 printf("\n -S look for the script using PATH environment variable");
1098 printf("\n -T turn on tainting checks");
1099 printf("\n -u dump core after parsing script");
1100 printf("\n -U allow unsafe operations");
1101 printf("\n -v print version number and patchlevel of perl");
1102 printf("\n -V[:variable] print perl configuration information");
1103 printf("\n -w TURN WARNINGS ON FOR COMPILATION OF YOUR SCRIPT.");
1104 printf("\n -x[directory] strip off text before #!perl line and perhaps cd to directory\n");
1107 /* This routine handles any switches that can be given during run */
1118 rschar = scan_oct(s, 4, &numlen);
1120 if (rschar & ~((U8)~0))
1122 else if (!rschar && numlen >= 2)
1123 nrs = newSVpv("", 0);
1126 nrs = newSVpv(&ch, 1);
1131 splitstr = savepv(s + 1);
1145 if (*s == ':' || *s == '=') {
1146 sprintf(buf, "use Devel::%s;", ++s);
1148 my_setenv("PERL5DB",buf);
1158 if (isALPHA(s[1])) {
1159 static char debopts[] = "psltocPmfrxuLHXD";
1162 for (s++; *s && (d = strchr(debopts,*s)); s++)
1163 debug |= 1 << (d - debopts);
1167 for (s++; isDIGIT(*s); s++) ;
1169 debug |= 0x80000000;
1171 warn("Recompile perl with -DDEBUGGING to use -D switch\n");
1172 for (s++; isALNUM(*s); s++) ;
1182 inplace = savepv(s+1);
1184 for (s = inplace; *s && !isSPACE(*s); s++) ;
1191 for (e = s; *e && !isSPACE(*e); e++) ;
1192 av_push(GvAVn(incgv),newSVpv(s,e-s));
1197 croak("No space allowed after -I");
1207 *ors = scan_oct(s, 3 + (*s == '0'), &numlen);
1216 ors = SvPV(nrs, orslen);
1217 ors = savepvn(ors, orslen);
1221 taint_not("-M"); /* XXX ? */
1224 taint_not("-m"); /* XXX ? */
1228 /* -M-foo == 'no foo' */
1229 if (*s == '-') { use = "no "; ++s; }
1230 Sv = newSVpv(use,0);
1232 /* We allow -M'Module qw(Foo Bar)' */
1233 while(isALNUM(*s) || *s==':') ++s;
1235 sv_catpv(Sv, start);
1236 if (*(start-1) == 'm') {
1238 croak("Can't use '%c' after -mname", *s);
1239 sv_catpv( Sv, " ()");
1242 sv_catpvn(Sv, start, s-start);
1243 sv_catpv(Sv, " split(/,/,q{");
1248 if (preambleav == NULL)
1249 preambleav = newAV();
1250 av_push(preambleav, Sv);
1253 croak("No space allowed after -%c", *(s-1));
1281 #if defined(SUBVERSION) && SUBVERSION > 0
1282 printf("\nThis is perl, version 5.%03d_%02d", PATCHLEVEL, SUBVERSION);
1284 printf("\nThis is perl, version %s",patchlevel);
1287 printf("\n\nCopyright 1987-1996, Larry Wall\n");
1288 printf("\n\t+ suidperl security patch");
1290 printf("MS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1293 printf("OS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1294 "Version 5 port Copyright (c) 1994-1996, Andreas Kaiser, Ilya Zakharevich\n");
1297 printf("atariST series port, ++jrb bammi@cadence.com\n");
1300 Perl may be copied only under the terms of either the Artistic License or the\n\
1301 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n");
1312 if (s[1] == '-') /* Additional switches on #! line. */
1325 croak("Can't emulate -%.1s on #! line",s);
1330 /* compliments of Tom Christiansen */
1332 /* unexec() can be found in the Gnu emacs distribution */
1341 sprintf (buf, "%s.perldump", origfilename);
1342 sprintf (tokenbuf, "%s/perl", BIN);
1344 status = unexec(buf, tokenbuf, &etext, sbrk(0), 0);
1346 PerlIO_printf(PerlIO_stderr(), "unexec of %s into %s failed!\n", tokenbuf, buf);
1350 # include <lib$routines.h>
1351 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
1353 ABORT(); /* for use with undump */
1363 /* Note that strtab is a rather special HV. Assumptions are made
1364 about not iterating on it, and not adding tie magic to it.
1365 It is properly deallocated in perl_destruct() */
1367 HvSHAREKEYS_off(strtab); /* mandatory */
1368 Newz(506,((XPVHV*)SvANY(strtab))->xhv_array,
1369 sizeof(HE*) * (((XPVHV*)SvANY(strtab))->xhv_max + 1), char);
1371 curstash = defstash = newHV();
1372 curstname = newSVpv("main",4);
1373 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1374 SvREFCNT_dec(GvHV(gv));
1375 GvHV(gv) = (HV*)SvREFCNT_inc(defstash);
1377 HvNAME(defstash) = savepv("main");
1378 incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1380 defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1381 errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1383 curstash = defstash;
1384 compiling.cop_stash = defstash;
1385 debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
1386 /* We must init $/ before switches are processed. */
1387 sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1);
1390 #ifdef CAN_PROTOTYPE
1392 open_script(char *scriptname, bool dosearch, SV *sv)
1395 open_script(scriptname,dosearch,sv)
1401 char *xfound = Nullch;
1402 char *xfailed = Nullch;
1406 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
1407 #define SEARCH_EXTS ".bat", ".cmd", NULL
1410 # define SEARCH_EXTS ".pl", ".com", NULL
1412 /* additional extensions to try in each dir if scriptname not found */
1414 char *ext[] = { SEARCH_EXTS };
1415 int extidx = (strchr(scriptname,'.')) ? -1 : 0; /* has ext already */
1420 int hasdir, idx = 0, deftypes = 1;
1422 hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
1423 /* The first time through, just add SEARCH_EXTS to whatever we
1424 * already have, so we can check for default file types. */
1425 while (deftypes || (!hasdir && my_trnlnm("DCL$PATH",tokenbuf,idx++)) ) {
1426 if (deftypes) { deftypes = 0; *tokenbuf = '\0'; }
1427 strcat(tokenbuf,scriptname);
1429 if (dosearch && !strchr(scriptname, '/') && (s = getenv("PATH"))) {
1431 bufend = s + strlen(s);
1434 s = cpytill(tokenbuf,s,bufend,':',&len);
1437 for (len = 0; *s && *s != ',' && *s != ';'; tokenbuf[len++] = *s++);
1438 tokenbuf[len] = '\0';
1440 for (len = 0; *s && *s != ';'; tokenbuf[len++] = *s++);
1441 tokenbuf[len] = '\0';
1447 if (len && tokenbuf[len-1] != '/')
1450 if (len && ((tokenbuf[len-1] != '\\') && (tokenbuf[len-1] != '/')))
1452 if (len && tokenbuf[len-1] != '\\')
1455 (void)strcat(tokenbuf+len,"/");
1456 (void)strcat(tokenbuf+len,scriptname);
1460 len = strlen(tokenbuf);
1461 if (extidx > 0) /* reset after previous loop */
1465 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tokenbuf));
1466 retval = Stat(tokenbuf,&statbuf);
1468 } while ( retval < 0 /* not there */
1469 && extidx>=0 && ext[extidx] /* try an extension? */
1470 && strcpy(tokenbuf+len, ext[extidx++])
1475 if (S_ISREG(statbuf.st_mode)
1476 && cando(S_IRUSR,TRUE,&statbuf) && cando(S_IXUSR,TRUE,&statbuf)) {
1477 xfound = tokenbuf; /* bingo! */
1481 xfailed = savepv(tokenbuf);
1484 croak("Can't execute %s", xfailed ? xfailed : scriptname );
1487 scriptname = xfound;
1490 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
1491 char *s = scriptname + 8;
1500 origfilename = savepv(e_tmpname ? "-e" : scriptname);
1501 curcop->cop_filegv = gv_fetchfile(origfilename);
1502 if (strEQ(origfilename,"-"))
1504 if (fdscript >= 0) {
1505 rsfp = PerlIO_fdopen(fdscript,"r");
1506 #if defined(HAS_FCNTL) && defined(F_SETFD)
1507 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
1510 else if (preprocess) {
1511 char *cpp = CPPSTDIN;
1513 if (strEQ(cpp,"cppstdin"))
1514 sprintf(tokenbuf, "%s/%s", SCRIPTDIR, cpp);
1516 sprintf(tokenbuf, "%s", cpp);
1518 sv_catpv(sv,PRIVLIB_EXP);
1520 (void)sprintf(buf, "\
1521 sed %s -e \"/^[^#]/b\" \
1522 -e \"/^#[ ]*include[ ]/b\" \
1523 -e \"/^#[ ]*define[ ]/b\" \
1524 -e \"/^#[ ]*if[ ]/b\" \
1525 -e \"/^#[ ]*ifdef[ ]/b\" \
1526 -e \"/^#[ ]*ifndef[ ]/b\" \
1527 -e \"/^#[ ]*else/b\" \
1528 -e \"/^#[ ]*elif[ ]/b\" \
1529 -e \"/^#[ ]*undef[ ]/b\" \
1530 -e \"/^#[ ]*endif/b\" \
1533 (doextract ? "-e \"1,/^#/d\n\"" : ""),
1535 (void)sprintf(buf, "\
1536 %s %s -e '/^[^#]/b' \
1537 -e '/^#[ ]*include[ ]/b' \
1538 -e '/^#[ ]*define[ ]/b' \
1539 -e '/^#[ ]*if[ ]/b' \
1540 -e '/^#[ ]*ifdef[ ]/b' \
1541 -e '/^#[ ]*ifndef[ ]/b' \
1542 -e '/^#[ ]*else/b' \
1543 -e '/^#[ ]*elif[ ]/b' \
1544 -e '/^#[ ]*undef[ ]/b' \
1545 -e '/^#[ ]*endif/b' \
1553 (doextract ? "-e '1,/^#/d\n'" : ""),
1555 scriptname, tokenbuf, SvPV(sv, na), CPPMINUS);
1557 #ifdef IAMSUID /* actually, this is caught earlier */
1558 if (euid != uid && !euid) { /* if running suidperl */
1560 (void)seteuid(uid); /* musn't stay setuid root */
1563 (void)setreuid((Uid_t)-1, uid);
1565 #ifdef HAS_SETRESUID
1566 (void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
1572 if (geteuid() != uid)
1573 croak("Can't do seteuid!\n");
1575 #endif /* IAMSUID */
1576 rsfp = my_popen(buf,"r");
1578 else if (!*scriptname) {
1579 taint_not("program input from stdin");
1580 rsfp = PerlIO_stdin();
1583 rsfp = PerlIO_open(scriptname,"r");
1584 #if defined(HAS_FCNTL) && defined(F_SETFD)
1585 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
1588 if ((PerlIO*)rsfp == Nullfp) {
1590 #ifndef IAMSUID /* in case script is not readable before setuid */
1591 if (euid && Stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
1592 statbuf.st_mode & (S_ISUID|S_ISGID)) {
1593 (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
1594 execv(buf, origargv); /* try again */
1595 croak("Can't do setuid\n");
1599 croak("Can't open perl script \"%s\": %s\n",
1600 SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno));
1605 validate_suid(validarg, scriptname)
1611 /* do we need to emulate setuid on scripts? */
1613 /* This code is for those BSD systems that have setuid #! scripts disabled
1614 * in the kernel because of a security problem. Merely defining DOSUID
1615 * in perl will not fix that problem, but if you have disabled setuid
1616 * scripts in the kernel, this will attempt to emulate setuid and setgid
1617 * on scripts that have those now-otherwise-useless bits set. The setuid
1618 * root version must be called suidperl or sperlN.NNN. If regular perl
1619 * discovers that it has opened a setuid script, it calls suidperl with
1620 * the same argv that it had. If suidperl finds that the script it has
1621 * just opened is NOT setuid root, it sets the effective uid back to the
1622 * uid. We don't just make perl setuid root because that loses the
1623 * effective uid we had before invoking perl, if it was different from the
1626 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
1627 * be defined in suidperl only. suidperl must be setuid root. The
1628 * Configure script will set this up for you if you want it.
1634 if (Fstat(PerlIO_fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
1635 croak("Can't stat script \"%s\"",origfilename);
1636 if (fdscript < 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) {
1640 #ifndef HAS_SETREUID
1641 /* On this access check to make sure the directories are readable,
1642 * there is actually a small window that the user could use to make
1643 * filename point to an accessible directory. So there is a faint
1644 * chance that someone could execute a setuid script down in a
1645 * non-accessible directory. I don't know what to do about that.
1646 * But I don't think it's too important. The manual lies when
1647 * it says access() is useful in setuid programs.
1649 if (access(SvPVX(GvSV(curcop->cop_filegv)),1)) /*double check*/
1650 croak("Permission denied");
1652 /* If we can swap euid and uid, then we can determine access rights
1653 * with a simple stat of the file, and then compare device and
1654 * inode to make sure we did stat() on the same file we opened.
1655 * Then we just have to make sure he or she can execute it.
1658 struct stat tmpstatbuf;
1662 setreuid(euid,uid) < 0
1665 setresuid(euid,uid,(Uid_t)-1) < 0
1668 || getuid() != euid || geteuid() != uid)
1669 croak("Can't swap uid and euid"); /* really paranoid */
1670 if (Stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
1671 croak("Permission denied"); /* testing full pathname here */
1672 if (tmpstatbuf.st_dev != statbuf.st_dev ||
1673 tmpstatbuf.st_ino != statbuf.st_ino) {
1674 (void)PerlIO_close(rsfp);
1675 if (rsfp = my_popen("/bin/mail root","w")) { /* heh, heh */
1677 "User %d tried to run dev %d ino %d in place of dev %d ino %d!\n\
1678 (Filename of set-id script was %s, uid %d gid %d.)\n\nSincerely,\nperl\n",
1679 uid,tmpstatbuf.st_dev, tmpstatbuf.st_ino,
1680 statbuf.st_dev, statbuf.st_ino,
1681 SvPVX(GvSV(curcop->cop_filegv)),
1682 statbuf.st_uid, statbuf.st_gid);
1683 (void)my_pclose(rsfp);
1685 croak("Permission denied\n");
1689 setreuid(uid,euid) < 0
1691 # if defined(HAS_SETRESUID)
1692 setresuid(uid,euid,(Uid_t)-1) < 0
1695 || getuid() != uid || geteuid() != euid)
1696 croak("Can't reswap uid and euid");
1697 if (!cando(S_IXUSR,FALSE,&statbuf)) /* can real uid exec? */
1698 croak("Permission denied\n");
1700 #endif /* HAS_SETREUID */
1701 #endif /* IAMSUID */
1703 if (!S_ISREG(statbuf.st_mode))
1704 croak("Permission denied");
1705 if (statbuf.st_mode & S_IWOTH)
1706 croak("Setuid/gid script is writable by world");
1707 doswitches = FALSE; /* -s is insecure in suid */
1709 if (sv_gets(linestr, rsfp, 0) == Nullch ||
1710 strnNE(SvPV(linestr,na),"#!",2) ) /* required even on Sys V */
1711 croak("No #! line");
1712 s = SvPV(linestr,na)+2;
1714 while (!isSPACE(*s)) s++;
1715 for (s2 = s; (s2 > SvPV(linestr,na)+2 &&
1716 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
1717 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
1718 croak("Not a perl script");
1719 while (*s == ' ' || *s == '\t') s++;
1721 * #! arg must be what we saw above. They can invoke it by
1722 * mentioning suidperl explicitly, but they may not add any strange
1723 * arguments beyond what #! says if they do invoke suidperl that way.
1725 len = strlen(validarg);
1726 if (strEQ(validarg," PHOOEY ") ||
1727 strnNE(s,validarg,len) || !isSPACE(s[len]))
1728 croak("Args must match #! line");
1731 if (euid != uid && (statbuf.st_mode & S_ISUID) &&
1732 euid == statbuf.st_uid)
1734 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
1735 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
1736 #endif /* IAMSUID */
1738 if (euid) { /* oops, we're not the setuid root perl */
1739 (void)PerlIO_close(rsfp);
1741 (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
1742 execv(buf, origargv); /* try again */
1744 croak("Can't do setuid\n");
1747 if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
1749 (void)setegid(statbuf.st_gid);
1752 (void)setregid((Gid_t)-1,statbuf.st_gid);
1754 #ifdef HAS_SETRESGID
1755 (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
1757 setgid(statbuf.st_gid);
1761 if (getegid() != statbuf.st_gid)
1762 croak("Can't do setegid!\n");
1764 if (statbuf.st_mode & S_ISUID) {
1765 if (statbuf.st_uid != euid)
1767 (void)seteuid(statbuf.st_uid); /* all that for this */
1770 (void)setreuid((Uid_t)-1,statbuf.st_uid);
1772 #ifdef HAS_SETRESUID
1773 (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
1775 setuid(statbuf.st_uid);
1779 if (geteuid() != statbuf.st_uid)
1780 croak("Can't do seteuid!\n");
1782 else if (uid) { /* oops, mustn't run as root */
1784 (void)seteuid((Uid_t)uid);
1787 (void)setreuid((Uid_t)-1,(Uid_t)uid);
1789 #ifdef HAS_SETRESUID
1790 (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
1796 if (geteuid() != uid)
1797 croak("Can't do seteuid!\n");
1800 if (!cando(S_IXUSR,TRUE,&statbuf))
1801 croak("Permission denied\n"); /* they can't do this */
1804 else if (preprocess)
1805 croak("-P not allowed for setuid/setgid script\n");
1806 else if (fdscript >= 0)
1807 croak("fd script not allowed in suidperl\n");
1809 croak("Script is not setuid/setgid in suidperl\n");
1811 /* We absolutely must clear out any saved ids here, so we */
1812 /* exec the real perl, substituting fd script for scriptname. */
1813 /* (We pass script name as "subdir" of fd, which perl will grok.) */
1814 PerlIO_rewind(rsfp);
1815 lseek(PerlIO_fileno(rsfp),(Off_t)0,0); /* just in case rewind didn't */
1816 for (which = 1; origargv[which] && origargv[which] != scriptname; which++) ;
1817 if (!origargv[which])
1818 croak("Permission denied");
1819 (void)sprintf(buf, "/dev/fd/%d/%.127s", PerlIO_fileno(rsfp), origargv[which]);
1820 origargv[which] = buf;
1822 #if defined(HAS_FCNTL) && defined(F_SETFD)
1823 fcntl(PerlIO_fileno(rsfp),F_SETFD,0); /* ensure no close-on-exec */
1826 (void)sprintf(tokenbuf, "%s/perl%s", BIN, patchlevel);
1827 execv(tokenbuf, origargv); /* try again */
1828 croak("Can't do setuid\n");
1829 #endif /* IAMSUID */
1831 if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */
1832 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
1833 Fstat(PerlIO_fileno(rsfp),&statbuf); /* may be either wrapped or real suid */
1834 if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
1836 (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
1839 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
1840 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
1841 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
1842 /* not set-id, must be wrapped */
1850 register char *s, *s2;
1852 /* skip forward in input to the real script? */
1856 if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
1857 croak("No Perl script found in input\n");
1858 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
1859 PerlIO_ungetc(rsfp, '\n'); /* to keep line count right */
1861 while (*s && !(isSPACE (*s) || *s == '#')) s++;
1863 while (*s == ' ' || *s == '\t') s++;
1865 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
1866 if (strnEQ(s2-4,"perl",4))
1868 while (s = moreswitches(s)) ;
1870 if (cddir && chdir(cddir) < 0)
1871 croak("Can't chdir to %s",cddir);
1879 uid = (int)getuid();
1880 euid = (int)geteuid();
1881 gid = (int)getgid();
1882 egid = (int)getegid();
1887 tainting |= (uid && (euid != uid || egid != gid));
1893 curstash = debstash;
1894 dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
1896 DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
1897 DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
1898 DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
1899 DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
1900 sv_setiv(DBsingle, 0);
1901 DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
1902 sv_setiv(DBtrace, 0);
1903 DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
1904 sv_setiv(DBsignal, 0);
1905 curstash = defstash;
1912 mainstack = curstack; /* remember in case we switch stacks */
1913 AvREAL_off(curstack); /* not a real array */
1914 av_extend(curstack,127);
1916 stack_base = AvARRAY(curstack);
1917 stack_sp = stack_base;
1918 stack_max = stack_base + 127;
1920 /* Shouldn't these stacks be per-interpreter? */
1922 markstack_ptr = markstack;
1924 New(54,markstack,64,I32);
1925 markstack_ptr = markstack;
1926 markstack_max = markstack + 64;
1932 New(54,scopestack,32,I32);
1934 scopestack_max = 32;
1940 New(54,savestack,128,ANY);
1942 savestack_max = 128;
1948 New(54,retstack,16,OP*);
1953 cxstack_max = 8192 / sizeof(CONTEXT) - 2; /* Use most of 8K. */
1954 New(50,cxstack,cxstack_max + 1,CONTEXT);
1957 New(50,tmps_stack,128,SV*);
1962 New(51,debname,128,char);
1963 New(52,debdelim,128,char);
1971 Safefree(tmps_stack);
1974 static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
1982 subname = newSVpv("main",4);
1986 init_predump_symbols()
1991 sv_setpvn(GvSV(gv_fetchpv("\"", TRUE, SVt_PV)), " ", 1);
1993 stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
1994 GvMULTI_on(stdingv);
1995 IoIFP(GvIOp(stdingv)) = PerlIO_stdin();
1996 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
1998 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv));
2000 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2002 IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
2004 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2006 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv));
2008 othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2009 GvMULTI_on(othergv);
2010 IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr();
2011 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2013 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
2015 statname = NEWSV(66,0); /* last filename we did stat on */
2018 osname = savepv(OSNAME);
2022 init_postdump_symbols(argc,argv,env)
2024 register char **argv;
2025 register char **env;
2031 argc--,argv++; /* skip name of script */
2033 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2036 if (argv[0][1] == '-') {
2040 if (s = strchr(argv[0], '=')) {
2042 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2045 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2048 toptarget = NEWSV(0,0);
2049 sv_upgrade(toptarget, SVt_PVFM);
2050 sv_setpvn(toptarget, "", 0);
2051 bodytarget = NEWSV(0,0);
2052 sv_upgrade(bodytarget, SVt_PVFM);
2053 sv_setpvn(bodytarget, "", 0);
2054 formtarget = bodytarget;
2057 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2058 sv_setpv(GvSV(tmpgv),origfilename);
2059 magicname("0", "0", 1);
2061 if (tmpgv = gv_fetchpv("\024",TRUE, SVt_PV))
2063 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2064 sv_setpv(GvSV(tmpgv),origargv[0]);
2065 if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2067 (void)gv_AVadd(argvgv);
2068 av_clear(GvAVn(argvgv));
2069 for (; argc > 0; argc--,argv++) {
2070 av_push(GvAVn(argvgv),newSVpv(argv[0],0));
2073 if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2078 #ifndef VMS /* VMS doesn't have environ array */
2079 /* Note that if the supplied env parameter is actually a copy
2080 of the global environ then it may now point to free'd memory
2081 if the environment has been modified since. To avoid this
2082 problem we treat env==NULL as meaning 'use the default'
2086 if (env != environ) {
2087 environ[0] = Nullch;
2088 hv_magic(hv, envgv, 'E');
2090 for (; *env; env++) {
2091 if (!(s = strchr(*env,'=')))
2094 sv = newSVpv(s--,0);
2095 sv_magic(sv, sv, 'e', *env, s - *env);
2096 (void)hv_store(hv, *env, s - *env, sv, 0);
2100 #ifdef DYNAMIC_ENV_FETCH
2101 HvNAME(hv) = savepv(ENV_HV_NAME);
2103 hv_magic(hv, envgv, 'E');
2106 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2107 sv_setiv(GvSV(tmpgv),(I32)getpid());
2116 s = getenv("PERL5LIB");
2120 incpush(getenv("PERLLIB"));
2123 /* Use the ~-expanded versions of APPLIB (undocumented),
2124 ARCHLIB PRIVLIB SITEARCH SITELIB and OLDARCHLIB
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);