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");
401 PerlIO_puts(e_fp,argv[1]);
405 croak("No code specified for -e");
406 (void)PerlIO_putc(e_fp,'\n');
414 av_push(GvAVn(incgv),newSVpv(s,0));
417 av_push(GvAVn(incgv),newSVpv(argv[1],0));
418 sv_catpv(sv,argv[1]);
435 preambleav = newAV();
436 av_push(preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
438 Sv = newSVpv("print myconfig();",0);
440 sv_catpv(Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
442 sv_catpv(Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
444 #if defined(DEBUGGING) || defined(NOEMBED) || defined(MULTIPLICITY)
445 strcpy(buf,"\" Compile-time options:");
447 strcat(buf," DEBUGGING");
450 strcat(buf," NOEMBED");
453 strcat(buf," MULTIPLICITY");
455 strcat(buf,"\\n\",");
458 #if defined(LOCAL_PATCH_COUNT)
459 if (LOCAL_PATCH_COUNT > 0)
461 sv_catpv(Sv,"print \" Locally applied patches:\\n\",");
462 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
463 if (localpatches[i]) {
464 sprintf(buf,"\" \\t%s\\n\",",localpatches[i]);
470 sprintf(buf,"\" Built under %s\\n\",",OSNAME);
474 sprintf(buf,"\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
476 sprintf(buf,"\" Compiled on %s\\n\"",__DATE__);
480 sv_catpv(Sv,"; $\"=\"\\n \"; print \" \\@INC:\\n @INC\\n\"");
483 Sv = newSVpv("config_vars(qw(",0);
488 av_push(preambleav, Sv);
489 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
503 croak("Unrecognized switch: -%s",s);
508 scriptname = argv[0];
510 if (PerlIO_flush(e_fp) || PerlIO_error(e_fp) || PerlIO_close(e_fp))
511 croak("Can't write to temp file for -e: %s", Strerror(errno));
514 scriptname = e_tmpname;
516 else if (scriptname == Nullch) {
518 if ( isatty(PerlIO_fileno(PerlIO_stdin())) )
526 open_script(scriptname,dosearch,sv);
528 validate_suid(validarg, scriptname);
533 compcv = (CV*)NEWSV(1104,0);
534 sv_upgrade((SV *)compcv, SVt_PVCV);
537 av_push(comppad, Nullsv);
538 curpad = AvARRAY(comppad);
539 comppad_name = newAV();
540 comppad_name_fill = 0;
541 min_intro_pending = 0;
544 comppadlist = newAV();
545 AvREAL_off(comppadlist);
546 av_store(comppadlist, 0, (SV*)comppad_name);
547 av_store(comppadlist, 1, (SV*)comppad);
548 CvPADLIST(compcv) = comppadlist;
550 boot_core_UNIVERSAL();
552 (*xsinit)(); /* in case linked C routines want magical variables */
557 init_predump_symbols();
559 init_postdump_symbols(argc,argv,env);
563 /* now parse the script */
566 if (yyparse() || error_count) {
568 croak("%s had compilation errors.\n", origfilename);
570 croak("Execution of %s aborted due to compilation errors.\n",
574 curcop->cop_line = 0;
578 (void)UNLINK(e_tmpname);
583 /* now that script is parsed, we can modify record separator */
585 rs = SvREFCNT_inc(nrs);
586 sv_setsv(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), rs);
597 #ifdef DEBUGGING_MSTATS
598 if ((s=getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
599 dump_mstats("after compilation:");
609 PerlInterpreter *sv_interp;
611 if (!(curinterp = sv_interp))
613 switch (Sigsetjmp(top_env,1)) {
615 cxstack_ix = -1; /* start context stack again */
622 #ifdef DEBUGGING_MSTATS
623 if (getenv("PERL_DEBUG_MSTATS"))
624 dump_mstats("after execution: ");
626 return(statusvalue); /* my_exit() was called */
629 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
633 if (curstack != mainstack) {
635 SWITCHSTACK(curstack, mainstack);
640 DEBUG_r(PerlIO_printf(PerlIO_stderr(), "%s $` $& $' support.\n",
641 sawampersand ? "Enabling" : "Omitting"));
645 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
648 PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", origfilename);
651 if (perldb && DBsingle)
652 sv_setiv(DBsingle, 1);
662 else if (main_start) {
675 register CONTEXT *cx;
679 statusvalue = FIXSTATUS(status);
680 if (cxstack_ix >= 0) {
686 Siglongjmp(top_env, 2);
690 perl_get_sv(name, create)
694 GV* gv = gv_fetchpv(name, create, SVt_PV);
701 perl_get_av(name, create)
705 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
714 perl_get_hv(name, create)
718 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
727 perl_get_cv(name, create)
731 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
732 if (create && !GvCV(gv))
733 return newSUB(start_subparse(),
734 newSVOP(OP_CONST, 0, newSVpv(name,0)),
742 /* Be sure to refetch the stack pointer after calling these routines. */
745 perl_call_argv(subname, flags, argv)
747 I32 flags; /* See G_* flags in cop.h */
748 register char **argv; /* null terminated arg list */
755 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
760 return perl_call_pv(subname, flags);
764 perl_call_pv(subname, flags)
765 char *subname; /* name of the subroutine */
766 I32 flags; /* See G_* flags in cop.h */
768 return perl_call_sv((SV*)perl_get_cv(subname, TRUE), flags);
772 perl_call_method(methname, flags)
773 char *methname; /* name of the subroutine */
774 I32 flags; /* See G_* flags in cop.h */
780 XPUSHs(sv_2mortal(newSVpv(methname,0)));
783 return perl_call_sv(*stack_sp--, flags);
786 /* May be called with any of a CV, a GV, or an SV containing the name. */
788 perl_call_sv(sv, flags)
790 I32 flags; /* See G_* flags in cop.h */
792 LOGOP myop; /* fake syntax tree node */
794 I32 oldmark = TOPMARK;
800 if (flags & G_DISCARD) {
810 oldscope = scopestack_ix;
812 if (!(flags & G_NOARGS))
813 myop.op_flags = OPf_STACKED;
814 myop.op_next = Nullop;
815 myop.op_flags |= OPf_KNOW;
817 myop.op_flags |= OPf_LIST;
819 if (perldb && curstash != debstash
820 && (DBcv || (DBcv = GvCV(DBsub)))) /* to handle first BEGIN of -d */
821 op->op_private |= OPpENTERSUB_DB;
823 if (flags & G_EVAL) {
824 Copy(top_env, oldtop, 1, Sigjmp_buf);
826 cLOGOP->op_other = op;
828 /* we're trying to emulate pp_entertry() here */
830 register CONTEXT *cx;
836 push_return(op->op_next);
837 PUSHBLOCK(cx, CXt_EVAL, stack_sp);
839 eval_root = op; /* Only needed so that goto works right. */
842 if (flags & G_KEEPERR)
845 sv_setpv(GvSV(errgv),"");
850 switch (Sigsetjmp(top_env,1)) {
855 statusvalue = 255; /* XXX I don't think we use 1 anymore. */
861 /* my_exit() was called */
864 Copy(oldtop, top_env, 1, Sigjmp_buf);
866 croak("Callback called exit");
867 my_exit(statusvalue);
875 stack_sp = stack_base + oldmark;
880 *++stack_sp = &sv_undef;
886 if (op == (OP*)&myop)
890 retval = stack_sp - (stack_base + oldmark);
891 if ((flags & G_EVAL) && !(flags & G_KEEPERR))
892 sv_setpv(GvSV(errgv),"");
895 if (flags & G_EVAL) {
896 if (scopestack_ix > oldscope) {
900 register CONTEXT *cx;
909 Copy(oldtop, top_env, 1, Sigjmp_buf);
911 if (flags & G_DISCARD) {
912 stack_sp = stack_base + oldmark;
920 /* Eval a string. The G_EVAL flag is always assumed. */
923 perl_eval_sv(sv, flags)
925 I32 flags; /* See G_* flags in cop.h */
927 UNOP myop; /* fake syntax tree node */
929 I32 oldmark = sp - stack_base;
934 if (flags & G_DISCARD) {
944 oldscope = scopestack_ix;
946 if (!(flags & G_NOARGS))
947 myop.op_flags = OPf_STACKED;
948 myop.op_next = Nullop;
949 myop.op_type = OP_ENTEREVAL;
950 myop.op_flags |= OPf_KNOW;
951 if (flags & G_KEEPERR)
952 myop.op_flags |= OPf_SPECIAL;
954 myop.op_flags |= OPf_LIST;
956 Copy(top_env, oldtop, 1, Sigjmp_buf);
959 switch (Sigsetjmp(top_env,1)) {
964 statusvalue = 255; /* XXX I don't think we use 1 anymore. */
970 /* my_exit() was called */
973 Copy(oldtop, top_env, 1, Sigjmp_buf);
975 croak("Callback called exit");
976 my_exit(statusvalue);
984 stack_sp = stack_base + oldmark;
989 *++stack_sp = &sv_undef;
994 if (op == (OP*)&myop)
998 retval = stack_sp - (stack_base + oldmark);
999 if (!(flags & G_KEEPERR))
1000 sv_setpv(GvSV(errgv),"");
1003 Copy(oldtop, top_env, 1, Sigjmp_buf);
1004 if (flags & G_DISCARD) {
1005 stack_sp = stack_base + oldmark;
1013 /* Require a module. */
1019 SV* sv = sv_newmortal();
1020 sv_setpv(sv, "require '");
1023 perl_eval_sv(sv, G_DISCARD);
1027 magicname(sym,name,namlen)
1034 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1035 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1039 # define PERLLIB_SEP ';'
1042 # define PERLLIB_SEP '|'
1044 # define PERLLIB_SEP ':'
1047 #ifndef PERLLIB_MANGLE
1048 # define PERLLIB_MANGLE(s,n) (s)
1060 /* Break at all separators */
1062 /* First, skip any consecutive separators */
1063 while ( *p == PERLLIB_SEP ) {
1064 /* Uncomment the next line for PATH semantics */
1065 /* av_push(GvAVn(incgv), newSVpv(".", 1)); */
1068 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
1069 av_push(GvAVn(incgv), newSVpv(PERLLIB_MANGLE(p, (STRLEN)(s - p)),
1073 av_push(GvAVn(incgv), newSVpv(PERLLIB_MANGLE(p, 0), 0));
1080 usage(name) /* XXX move this out into a module ? */
1083 /* This message really ought to be max 23 lines.
1084 * Removed -h because the user already knows that opton. Others? */
1085 printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1086 printf("\n -0[octal] specify record separator (\\0, if no argument)");
1087 printf("\n -a autosplit mode with -n or -p (splits $_ into @F)");
1088 printf("\n -c check syntax only (runs BEGIN and END blocks)");
1089 printf("\n -d[:debugger] run scripts under debugger");
1090 printf("\n -D[number/list] set debugging flags (argument is a bit mask or flags)");
1091 printf("\n -e 'command' one line of script. Several -e's allowed. Omit [programfile].");
1092 printf("\n -F/pattern/ split() pattern for autosplit (-a). The //'s are optional.");
1093 printf("\n -i[extension] edit <> files in place (make backup if extension supplied)");
1094 printf("\n -Idirectory specify @INC/#include directory (may be used more then once)");
1095 printf("\n -l[octal] enable line ending processing, specifies line teminator");
1096 printf("\n -[mM][-]module.. executes `use/no module...' before executing your script.");
1097 printf("\n -n assume 'while (<>) { ... }' loop arround your script");
1098 printf("\n -p assume loop like -n but print line also like sed");
1099 printf("\n -P run script through C preprocessor before compilation");
1100 printf("\n -s enable some switch parsing for switches after script name");
1101 printf("\n -S look for the script using PATH environment variable");
1102 printf("\n -T turn on tainting checks");
1103 printf("\n -u dump core after parsing script");
1104 printf("\n -U allow unsafe operations");
1105 printf("\n -v print version number and patchlevel of perl");
1106 printf("\n -V[:variable] print perl configuration information");
1107 printf("\n -w TURN WARNINGS ON FOR COMPILATION OF YOUR SCRIPT.");
1108 printf("\n -x[directory] strip off text before #!perl line and perhaps cd to directory\n");
1111 /* This routine handles any switches that can be given during run */
1122 rschar = scan_oct(s, 4, &numlen);
1124 if (rschar & ~((U8)~0))
1126 else if (!rschar && numlen >= 2)
1127 nrs = newSVpv("", 0);
1130 nrs = newSVpv(&ch, 1);
1135 splitstr = savepv(s + 1);
1149 if (*s == ':' || *s == '=') {
1150 sprintf(buf, "use Devel::%s;", ++s);
1152 my_setenv("PERL5DB",buf);
1162 if (isALPHA(s[1])) {
1163 static char debopts[] = "psltocPmfrxuLHXD";
1166 for (s++; *s && (d = strchr(debopts,*s)); s++)
1167 debug |= 1 << (d - debopts);
1171 for (s++; isDIGIT(*s); s++) ;
1173 debug |= 0x80000000;
1175 warn("Recompile perl with -DDEBUGGING to use -D switch\n");
1176 for (s++; isALNUM(*s); s++) ;
1186 inplace = savepv(s+1);
1188 for (s = inplace; *s && !isSPACE(*s); s++) ;
1195 for (e = s; *e && !isSPACE(*e); e++) ;
1196 av_push(GvAVn(incgv),newSVpv(s,e-s));
1201 croak("No space allowed after -I");
1211 *ors = scan_oct(s, 3 + (*s == '0'), &numlen);
1220 ors = SvPV(nrs, orslen);
1221 ors = savepvn(ors, orslen);
1225 taint_not("-M"); /* XXX ? */
1228 taint_not("-m"); /* XXX ? */
1232 /* -M-foo == 'no foo' */
1233 if (*s == '-') { use = "no "; ++s; }
1234 Sv = newSVpv(use,0);
1236 /* We allow -M'Module qw(Foo Bar)' */
1237 while(isALNUM(*s) || *s==':') ++s;
1239 sv_catpv(Sv, start);
1240 if (*(start-1) == 'm') {
1242 croak("Can't use '%c' after -mname", *s);
1243 sv_catpv( Sv, " ()");
1246 sv_catpvn(Sv, start, s-start);
1247 sv_catpv(Sv, " split(/,/,q{");
1252 if (preambleav == NULL)
1253 preambleav = newAV();
1254 av_push(preambleav, Sv);
1257 croak("No space allowed after -%c", *(s-1));
1285 #if defined(SUBVERSION) && SUBVERSION > 0
1286 printf("\nThis is perl, version 5.%03d_%02d", PATCHLEVEL, SUBVERSION);
1288 printf("\nThis is perl, version %s",patchlevel);
1291 printf("\n\nCopyright 1987-1996, Larry Wall\n");
1292 printf("\n\t+ suidperl security patch");
1294 printf("MS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1297 printf("OS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1298 "Version 5 port Copyright (c) 1994-1996, Andreas Kaiser, Ilya Zakharevich\n");
1301 printf("atariST series port, ++jrb bammi@cadence.com\n");
1304 Perl may be copied only under the terms of either the Artistic License or the\n\
1305 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n");
1316 if (s[1] == '-') /* Additional switches on #! line. */
1329 croak("Can't emulate -%.1s on #! line",s);
1334 /* compliments of Tom Christiansen */
1336 /* unexec() can be found in the Gnu emacs distribution */
1345 sprintf (buf, "%s.perldump", origfilename);
1346 sprintf (tokenbuf, "%s/perl", BIN);
1348 status = unexec(buf, tokenbuf, &etext, sbrk(0), 0);
1350 PerlIO_printf(PerlIO_stderr(), "unexec of %s into %s failed!\n", tokenbuf, buf);
1354 # include <lib$routines.h>
1355 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
1357 ABORT(); /* for use with undump */
1367 /* Note that strtab is a rather special HV. Assumptions are made
1368 about not iterating on it, and not adding tie magic to it.
1369 It is properly deallocated in perl_destruct() */
1371 HvSHAREKEYS_off(strtab); /* mandatory */
1372 Newz(506,((XPVHV*)SvANY(strtab))->xhv_array,
1373 sizeof(HE*) * (((XPVHV*)SvANY(strtab))->xhv_max + 1), char);
1375 curstash = defstash = newHV();
1376 curstname = newSVpv("main",4);
1377 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1378 SvREFCNT_dec(GvHV(gv));
1379 GvHV(gv) = (HV*)SvREFCNT_inc(defstash);
1381 HvNAME(defstash) = savepv("main");
1382 incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1384 defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1385 errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1387 sv_setpvn(GvSV(errgv), "", 0);
1388 curstash = defstash;
1389 compiling.cop_stash = defstash;
1390 debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
1391 /* We must init $/ before switches are processed. */
1392 sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1);
1395 #ifdef CAN_PROTOTYPE
1397 open_script(char *scriptname, bool dosearch, SV *sv)
1400 open_script(scriptname,dosearch,sv)
1406 char *xfound = Nullch;
1407 char *xfailed = Nullch;
1411 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
1412 #define SEARCH_EXTS ".bat", ".cmd", NULL
1415 # define SEARCH_EXTS ".pl", ".com", NULL
1417 /* additional extensions to try in each dir if scriptname not found */
1419 char *ext[] = { SEARCH_EXTS };
1420 int extidx = (strchr(scriptname,'.')) ? -1 : 0; /* has ext already */
1425 int hasdir, idx = 0, deftypes = 1;
1427 hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
1428 /* The first time through, just add SEARCH_EXTS to whatever we
1429 * already have, so we can check for default file types. */
1430 while (deftypes || (!hasdir && my_trnlnm("DCL$PATH",tokenbuf,idx++)) ) {
1431 if (deftypes) { deftypes = 0; *tokenbuf = '\0'; }
1432 strcat(tokenbuf,scriptname);
1434 if (dosearch && !strchr(scriptname, '/') && (s = getenv("PATH"))) {
1436 bufend = s + strlen(s);
1439 s = cpytill(tokenbuf,s,bufend,':',&len);
1442 for (len = 0; *s && *s != ',' && *s != ';'; tokenbuf[len++] = *s++);
1443 tokenbuf[len] = '\0';
1445 for (len = 0; *s && *s != ';'; tokenbuf[len++] = *s++);
1446 tokenbuf[len] = '\0';
1452 if (len && tokenbuf[len-1] != '/')
1455 if (len && ((tokenbuf[len-1] != '\\') && (tokenbuf[len-1] != '/')))
1457 if (len && tokenbuf[len-1] != '\\')
1460 (void)strcat(tokenbuf+len,"/");
1461 (void)strcat(tokenbuf+len,scriptname);
1465 len = strlen(tokenbuf);
1466 if (extidx > 0) /* reset after previous loop */
1470 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tokenbuf));
1471 retval = Stat(tokenbuf,&statbuf);
1473 } while ( retval < 0 /* not there */
1474 && extidx>=0 && ext[extidx] /* try an extension? */
1475 && strcpy(tokenbuf+len, ext[extidx++])
1480 if (S_ISREG(statbuf.st_mode)
1481 && cando(S_IRUSR,TRUE,&statbuf) && cando(S_IXUSR,TRUE,&statbuf)) {
1482 xfound = tokenbuf; /* bingo! */
1486 xfailed = savepv(tokenbuf);
1489 croak("Can't execute %s", xfailed ? xfailed : scriptname );
1492 scriptname = xfound;
1495 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
1496 char *s = scriptname + 8;
1505 origfilename = savepv(e_tmpname ? "-e" : scriptname);
1506 curcop->cop_filegv = gv_fetchfile(origfilename);
1507 if (strEQ(origfilename,"-"))
1509 if (fdscript >= 0) {
1510 rsfp = PerlIO_fdopen(fdscript,"r");
1511 #if defined(HAS_FCNTL) && defined(F_SETFD)
1512 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
1515 else if (preprocess) {
1516 char *cpp = CPPSTDIN;
1518 if (strEQ(cpp,"cppstdin"))
1519 sprintf(tokenbuf, "%s/%s", SCRIPTDIR, cpp);
1521 sprintf(tokenbuf, "%s", cpp);
1523 sv_catpv(sv,PRIVLIB_EXP);
1525 (void)sprintf(buf, "\
1526 sed %s -e \"/^[^#]/b\" \
1527 -e \"/^#[ ]*include[ ]/b\" \
1528 -e \"/^#[ ]*define[ ]/b\" \
1529 -e \"/^#[ ]*if[ ]/b\" \
1530 -e \"/^#[ ]*ifdef[ ]/b\" \
1531 -e \"/^#[ ]*ifndef[ ]/b\" \
1532 -e \"/^#[ ]*else/b\" \
1533 -e \"/^#[ ]*elif[ ]/b\" \
1534 -e \"/^#[ ]*undef[ ]/b\" \
1535 -e \"/^#[ ]*endif/b\" \
1538 (doextract ? "-e \"1,/^#/d\n\"" : ""),
1540 (void)sprintf(buf, "\
1541 %s %s -e '/^[^#]/b' \
1542 -e '/^#[ ]*include[ ]/b' \
1543 -e '/^#[ ]*define[ ]/b' \
1544 -e '/^#[ ]*if[ ]/b' \
1545 -e '/^#[ ]*ifdef[ ]/b' \
1546 -e '/^#[ ]*ifndef[ ]/b' \
1547 -e '/^#[ ]*else/b' \
1548 -e '/^#[ ]*elif[ ]/b' \
1549 -e '/^#[ ]*undef[ ]/b' \
1550 -e '/^#[ ]*endif/b' \
1558 (doextract ? "-e '1,/^#/d\n'" : ""),
1560 scriptname, tokenbuf, SvPV(sv, na), CPPMINUS);
1562 #ifdef IAMSUID /* actually, this is caught earlier */
1563 if (euid != uid && !euid) { /* if running suidperl */
1565 (void)seteuid(uid); /* musn't stay setuid root */
1568 (void)setreuid((Uid_t)-1, uid);
1570 #ifdef HAS_SETRESUID
1571 (void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
1577 if (geteuid() != uid)
1578 croak("Can't do seteuid!\n");
1580 #endif /* IAMSUID */
1581 rsfp = my_popen(buf,"r");
1583 else if (!*scriptname) {
1584 taint_not("program input from stdin");
1585 rsfp = PerlIO_stdin();
1588 rsfp = PerlIO_open(scriptname,"r");
1589 #if defined(HAS_FCNTL) && defined(F_SETFD)
1590 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
1593 if ((PerlIO*)rsfp == Nullfp) {
1595 #ifndef IAMSUID /* in case script is not readable before setuid */
1596 if (euid && Stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
1597 statbuf.st_mode & (S_ISUID|S_ISGID)) {
1598 (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
1599 execv(buf, origargv); /* try again */
1600 croak("Can't do setuid\n");
1604 croak("Can't open perl script \"%s\": %s\n",
1605 SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno));
1610 validate_suid(validarg, scriptname)
1616 /* do we need to emulate setuid on scripts? */
1618 /* This code is for those BSD systems that have setuid #! scripts disabled
1619 * in the kernel because of a security problem. Merely defining DOSUID
1620 * in perl will not fix that problem, but if you have disabled setuid
1621 * scripts in the kernel, this will attempt to emulate setuid and setgid
1622 * on scripts that have those now-otherwise-useless bits set. The setuid
1623 * root version must be called suidperl or sperlN.NNN. If regular perl
1624 * discovers that it has opened a setuid script, it calls suidperl with
1625 * the same argv that it had. If suidperl finds that the script it has
1626 * just opened is NOT setuid root, it sets the effective uid back to the
1627 * uid. We don't just make perl setuid root because that loses the
1628 * effective uid we had before invoking perl, if it was different from the
1631 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
1632 * be defined in suidperl only. suidperl must be setuid root. The
1633 * Configure script will set this up for you if you want it.
1639 if (Fstat(PerlIO_fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
1640 croak("Can't stat script \"%s\"",origfilename);
1641 if (fdscript < 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) {
1645 #ifndef HAS_SETREUID
1646 /* On this access check to make sure the directories are readable,
1647 * there is actually a small window that the user could use to make
1648 * filename point to an accessible directory. So there is a faint
1649 * chance that someone could execute a setuid script down in a
1650 * non-accessible directory. I don't know what to do about that.
1651 * But I don't think it's too important. The manual lies when
1652 * it says access() is useful in setuid programs.
1654 if (access(SvPVX(GvSV(curcop->cop_filegv)),1)) /*double check*/
1655 croak("Permission denied");
1657 /* If we can swap euid and uid, then we can determine access rights
1658 * with a simple stat of the file, and then compare device and
1659 * inode to make sure we did stat() on the same file we opened.
1660 * Then we just have to make sure he or she can execute it.
1663 struct stat tmpstatbuf;
1667 setreuid(euid,uid) < 0
1670 setresuid(euid,uid,(Uid_t)-1) < 0
1673 || getuid() != euid || geteuid() != uid)
1674 croak("Can't swap uid and euid"); /* really paranoid */
1675 if (Stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
1676 croak("Permission denied"); /* testing full pathname here */
1677 if (tmpstatbuf.st_dev != statbuf.st_dev ||
1678 tmpstatbuf.st_ino != statbuf.st_ino) {
1679 (void)PerlIO_close(rsfp);
1680 if (rsfp = my_popen("/bin/mail root","w")) { /* heh, heh */
1682 "User %d tried to run dev %d ino %d in place of dev %d ino %d!\n\
1683 (Filename of set-id script was %s, uid %d gid %d.)\n\nSincerely,\nperl\n",
1684 uid,tmpstatbuf.st_dev, tmpstatbuf.st_ino,
1685 statbuf.st_dev, statbuf.st_ino,
1686 SvPVX(GvSV(curcop->cop_filegv)),
1687 statbuf.st_uid, statbuf.st_gid);
1688 (void)my_pclose(rsfp);
1690 croak("Permission denied\n");
1694 setreuid(uid,euid) < 0
1696 # if defined(HAS_SETRESUID)
1697 setresuid(uid,euid,(Uid_t)-1) < 0
1700 || getuid() != uid || geteuid() != euid)
1701 croak("Can't reswap uid and euid");
1702 if (!cando(S_IXUSR,FALSE,&statbuf)) /* can real uid exec? */
1703 croak("Permission denied\n");
1705 #endif /* HAS_SETREUID */
1706 #endif /* IAMSUID */
1708 if (!S_ISREG(statbuf.st_mode))
1709 croak("Permission denied");
1710 if (statbuf.st_mode & S_IWOTH)
1711 croak("Setuid/gid script is writable by world");
1712 doswitches = FALSE; /* -s is insecure in suid */
1714 if (sv_gets(linestr, rsfp, 0) == Nullch ||
1715 strnNE(SvPV(linestr,na),"#!",2) ) /* required even on Sys V */
1716 croak("No #! line");
1717 s = SvPV(linestr,na)+2;
1719 while (!isSPACE(*s)) s++;
1720 for (s2 = s; (s2 > SvPV(linestr,na)+2 &&
1721 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
1722 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
1723 croak("Not a perl script");
1724 while (*s == ' ' || *s == '\t') s++;
1726 * #! arg must be what we saw above. They can invoke it by
1727 * mentioning suidperl explicitly, but they may not add any strange
1728 * arguments beyond what #! says if they do invoke suidperl that way.
1730 len = strlen(validarg);
1731 if (strEQ(validarg," PHOOEY ") ||
1732 strnNE(s,validarg,len) || !isSPACE(s[len]))
1733 croak("Args must match #! line");
1736 if (euid != uid && (statbuf.st_mode & S_ISUID) &&
1737 euid == statbuf.st_uid)
1739 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
1740 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
1741 #endif /* IAMSUID */
1743 if (euid) { /* oops, we're not the setuid root perl */
1744 (void)PerlIO_close(rsfp);
1746 (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
1747 execv(buf, origargv); /* try again */
1749 croak("Can't do setuid\n");
1752 if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
1754 (void)setegid(statbuf.st_gid);
1757 (void)setregid((Gid_t)-1,statbuf.st_gid);
1759 #ifdef HAS_SETRESGID
1760 (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
1762 setgid(statbuf.st_gid);
1766 if (getegid() != statbuf.st_gid)
1767 croak("Can't do setegid!\n");
1769 if (statbuf.st_mode & S_ISUID) {
1770 if (statbuf.st_uid != euid)
1772 (void)seteuid(statbuf.st_uid); /* all that for this */
1775 (void)setreuid((Uid_t)-1,statbuf.st_uid);
1777 #ifdef HAS_SETRESUID
1778 (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
1780 setuid(statbuf.st_uid);
1784 if (geteuid() != statbuf.st_uid)
1785 croak("Can't do seteuid!\n");
1787 else if (uid) { /* oops, mustn't run as root */
1789 (void)seteuid((Uid_t)uid);
1792 (void)setreuid((Uid_t)-1,(Uid_t)uid);
1794 #ifdef HAS_SETRESUID
1795 (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
1801 if (geteuid() != uid)
1802 croak("Can't do seteuid!\n");
1805 if (!cando(S_IXUSR,TRUE,&statbuf))
1806 croak("Permission denied\n"); /* they can't do this */
1809 else if (preprocess)
1810 croak("-P not allowed for setuid/setgid script\n");
1811 else if (fdscript >= 0)
1812 croak("fd script not allowed in suidperl\n");
1814 croak("Script is not setuid/setgid in suidperl\n");
1816 /* We absolutely must clear out any saved ids here, so we */
1817 /* exec the real perl, substituting fd script for scriptname. */
1818 /* (We pass script name as "subdir" of fd, which perl will grok.) */
1819 PerlIO_rewind(rsfp);
1820 lseek(PerlIO_fileno(rsfp),(Off_t)0,0); /* just in case rewind didn't */
1821 for (which = 1; origargv[which] && origargv[which] != scriptname; which++) ;
1822 if (!origargv[which])
1823 croak("Permission denied");
1824 (void)sprintf(buf, "/dev/fd/%d/%.127s", PerlIO_fileno(rsfp), origargv[which]);
1825 origargv[which] = buf;
1827 #if defined(HAS_FCNTL) && defined(F_SETFD)
1828 fcntl(PerlIO_fileno(rsfp),F_SETFD,0); /* ensure no close-on-exec */
1831 (void)sprintf(tokenbuf, "%s/perl%s", BIN, patchlevel);
1832 execv(tokenbuf, origargv); /* try again */
1833 croak("Can't do setuid\n");
1834 #endif /* IAMSUID */
1836 if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */
1837 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
1838 Fstat(PerlIO_fileno(rsfp),&statbuf); /* may be either wrapped or real suid */
1839 if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
1841 (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
1844 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
1845 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
1846 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
1847 /* not set-id, must be wrapped */
1855 register char *s, *s2;
1857 /* skip forward in input to the real script? */
1861 if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
1862 croak("No Perl script found in input\n");
1863 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
1864 PerlIO_ungetc(rsfp, '\n'); /* to keep line count right */
1866 while (*s && !(isSPACE (*s) || *s == '#')) s++;
1868 while (*s == ' ' || *s == '\t') s++;
1870 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
1871 if (strnEQ(s2-4,"perl",4))
1873 while (s = moreswitches(s)) ;
1875 if (cddir && chdir(cddir) < 0)
1876 croak("Can't chdir to %s",cddir);
1884 uid = (int)getuid();
1885 euid = (int)geteuid();
1886 gid = (int)getgid();
1887 egid = (int)getegid();
1892 tainting |= (uid && (euid != uid || egid != gid));
1898 curstash = debstash;
1899 dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
1901 DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
1902 DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
1903 DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
1904 DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
1905 sv_setiv(DBsingle, 0);
1906 DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
1907 sv_setiv(DBtrace, 0);
1908 DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
1909 sv_setiv(DBsignal, 0);
1910 curstash = defstash;
1917 mainstack = curstack; /* remember in case we switch stacks */
1918 AvREAL_off(curstack); /* not a real array */
1919 av_extend(curstack,127);
1921 stack_base = AvARRAY(curstack);
1922 stack_sp = stack_base;
1923 stack_max = stack_base + 127;
1925 /* Shouldn't these stacks be per-interpreter? */
1927 markstack_ptr = markstack;
1929 New(54,markstack,64,I32);
1930 markstack_ptr = markstack;
1931 markstack_max = markstack + 64;
1937 New(54,scopestack,32,I32);
1939 scopestack_max = 32;
1945 New(54,savestack,128,ANY);
1947 savestack_max = 128;
1953 New(54,retstack,16,OP*);
1958 cxstack_max = 8192 / sizeof(CONTEXT) - 2; /* Use most of 8K. */
1959 New(50,cxstack,cxstack_max + 1,CONTEXT);
1962 New(50,tmps_stack,128,SV*);
1967 New(51,debname,128,char);
1968 New(52,debdelim,128,char);
1976 Safefree(tmps_stack);
1979 static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
1987 subname = newSVpv("main",4);
1991 init_predump_symbols()
1996 sv_setpvn(GvSV(gv_fetchpv("\"", TRUE, SVt_PV)), " ", 1);
1998 stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
1999 GvMULTI_on(stdingv);
2000 IoIFP(GvIOp(stdingv)) = PerlIO_stdin();
2001 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2003 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv));
2005 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2007 IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
2009 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2011 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv));
2013 othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2014 GvMULTI_on(othergv);
2015 IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr();
2016 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2018 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
2020 statname = NEWSV(66,0); /* last filename we did stat on */
2023 osname = savepv(OSNAME);
2027 init_postdump_symbols(argc,argv,env)
2029 register char **argv;
2030 register char **env;
2036 argc--,argv++; /* skip name of script */
2038 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2041 if (argv[0][1] == '-') {
2045 if (s = strchr(argv[0], '=')) {
2047 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2050 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2053 toptarget = NEWSV(0,0);
2054 sv_upgrade(toptarget, SVt_PVFM);
2055 sv_setpvn(toptarget, "", 0);
2056 bodytarget = NEWSV(0,0);
2057 sv_upgrade(bodytarget, SVt_PVFM);
2058 sv_setpvn(bodytarget, "", 0);
2059 formtarget = bodytarget;
2062 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2063 sv_setpv(GvSV(tmpgv),origfilename);
2064 magicname("0", "0", 1);
2066 if (tmpgv = gv_fetchpv("\024",TRUE, SVt_PV))
2068 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2069 sv_setpv(GvSV(tmpgv),origargv[0]);
2070 if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2072 (void)gv_AVadd(argvgv);
2073 av_clear(GvAVn(argvgv));
2074 for (; argc > 0; argc--,argv++) {
2075 av_push(GvAVn(argvgv),newSVpv(argv[0],0));
2078 if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2083 #ifndef VMS /* VMS doesn't have environ array */
2084 /* Note that if the supplied env parameter is actually a copy
2085 of the global environ then it may now point to free'd memory
2086 if the environment has been modified since. To avoid this
2087 problem we treat env==NULL as meaning 'use the default'
2091 if (env != environ) {
2092 environ[0] = Nullch;
2093 hv_magic(hv, envgv, 'E');
2095 for (; *env; env++) {
2096 if (!(s = strchr(*env,'=')))
2099 sv = newSVpv(s--,0);
2100 sv_magic(sv, sv, 'e', *env, s - *env);
2101 (void)hv_store(hv, *env, s - *env, sv, 0);
2105 #ifdef DYNAMIC_ENV_FETCH
2106 HvNAME(hv) = savepv(ENV_HV_NAME);
2108 hv_magic(hv, envgv, 'E');
2111 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2112 sv_setiv(GvSV(tmpgv),(I32)getpid());
2122 s = getenv("PERL5LIB");
2126 incpush(getenv("PERLLIB"));
2128 /* Treat PERL5?LIB as a possible search list logical name -- the
2129 * "natural" VMS idiom for a Unix path string. We allow each
2130 * element to be a set of |-separated directories for compatibility.
2134 if (my_trnlnm("PERL5LIB",buf,0))
2135 do { incpush(buf); } while (my_trnlnm("PERL5LIB",buf,++idx));
2137 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf);
2141 /* Use the ~-expanded versions of APPLIB (undocumented),
2142 ARCHLIB PRIVLIB SITEARCH SITELIB and OLDARCHLIB
2145 incpush(APPLLIB_EXP);
2149 incpush(ARCHLIB_EXP);
2152 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2154 incpush(PRIVLIB_EXP);
2157 incpush(SITEARCH_EXP);
2160 incpush(SITELIB_EXP);
2162 #ifdef OLDARCHLIB_EXP /* 5.00[01] compatibility */
2163 incpush(OLDARCHLIB_EXP);
2176 line_t oldline = curcop->cop_line;
2178 Copy(top_env, oldtop, 1, Sigjmp_buf);
2180 while (AvFILL(list) >= 0) {
2181 CV *cv = (CV*)av_shift(list);
2185 switch (Sigsetjmp(top_env,1)) {
2187 SV* atsv = GvSV(errgv);
2189 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
2190 (void)SvPV(atsv, len);
2192 Copy(oldtop, top_env, 1, Sigjmp_buf);
2193 curcop = &compiling;
2194 curcop->cop_line = oldline;
2195 if (list == beginav)
2196 sv_catpv(atsv, "BEGIN failed--compilation aborted");
2198 sv_catpv(atsv, "END failed--cleanup aborted");
2199 croak("%s", SvPVX(atsv));
2205 statusvalue = 255; /* XXX I don't think we use 1 anymore. */
2211 /* my_exit() was called */
2212 curstash = defstash;
2216 Copy(oldtop, top_env, 1, Sigjmp_buf);
2217 curcop = &compiling;
2218 curcop->cop_line = oldline;
2220 if (list == beginav)
2221 croak("BEGIN failed--compilation aborted");
2223 croak("END failed--cleanup aborted");
2225 my_exit(statusvalue);
2230 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
2234 Copy(oldtop, top_env, 1, Sigjmp_buf);
2235 curcop = &compiling;
2236 curcop->cop_line = oldline;
2237 Siglongjmp(top_env, 3);
2241 Copy(oldtop, top_env, 1, Sigjmp_buf);