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 forbid_setid _((char *));
39 static void incpush _((char *));
40 static void init_ids _((void));
41 static void init_debugger _((void));
42 static void init_lexer _((void));
43 static void init_main_stash _((void));
44 static void init_perllib _((void));
45 static void init_postdump_symbols _((int, char **, char **));
46 static void init_predump_symbols _((void));
47 static void init_stacks _((void));
48 static void nuke_stacks _((void));
49 static void open_script _((char *, bool, SV *));
50 static void usage _((char *));
51 static void validate_suid _((char *, char*));
53 static int fdscript = -1;
58 PerlInterpreter *sv_interp;
61 New(53, sv_interp, 1, PerlInterpreter);
66 perl_construct( sv_interp )
67 register PerlInterpreter *sv_interp;
69 if (!(curinterp = sv_interp))
73 Zero(sv_interp, 1, PerlInterpreter);
76 /* Init the real globals? */
78 linestr = NEWSV(65,80);
79 sv_upgrade(linestr,SVt_PVIV);
81 if (!SvREADONLY(&sv_undef)) {
82 SvREADONLY_on(&sv_undef);
86 SvREADONLY_on(&sv_no);
88 sv_setpv(&sv_yes,Yes);
90 SvREADONLY_on(&sv_yes);
93 nrs = newSVpv("\n", 1);
94 rs = SvREFCNT_inc(nrs);
98 * There is no way we can refer to them from Perl so close them to save
99 * space. The other alternative would be to provide STDAUX and STDPRN
102 (void)fclose(stdaux);
103 (void)fclose(stdprn);
125 #if defined(SUBVERSION) && SUBVERSION > 0
126 sprintf(patchlevel, "%7.5f", (double) 5
127 + ((double) PATCHLEVEL / (double) 1000)
128 + ((double) SUBVERSION / (double) 100000));
130 sprintf(patchlevel, "%5.3f", (double) 5 +
131 ((double) PATCHLEVEL / (double) 1000));
134 #if defined(LOCAL_PATCH_COUNT)
135 localpatches = local_patches; /* For possible -v */
138 PerlIO_init(); /* Hook to IO system */
140 fdpid = newAV(); /* for remembering popen pids by fd */
141 pidstatus = newHV();/* for remembering status of dead pids */
148 perl_destruct(sv_interp)
149 register PerlInterpreter *sv_interp;
151 int destruct_level; /* 0=none, 1=full, 2=full with checks */
155 if (!(curinterp = sv_interp))
158 destruct_level = perl_destruct_level;
162 if (s = getenv("PERL_DESTRUCT_LEVEL"))
163 destruct_level = atoi(s);
170 /* We must account for everything. First the syntax tree. */
172 curpad = AvARRAY(comppad);
178 * Try to destruct global references. We do this first so that the
179 * destructors and destructees still exist. Some sv's might remain.
180 * Non-referenced objects are on their own.
187 if (destruct_level == 0){
189 DEBUG_P(debprofdump());
191 /* The exit() function will do everything that needs doing. */
195 /* unhook hooks which may now point to, or use, broken code */
196 if (warnhook && SvREFCNT(warnhook))
197 SvREFCNT_dec(warnhook);
198 if (diehook && SvREFCNT(diehook))
199 SvREFCNT_dec(diehook);
200 if (parsehook && SvREFCNT(parsehook))
201 SvREFCNT_dec(parsehook);
203 /* Prepare to destruct main symbol table. */
209 if (destruct_level >= 2) {
210 if (scopestack_ix != 0)
211 warn("Unbalanced scopes: %d more ENTERs than LEAVEs\n", scopestack_ix);
212 if (savestack_ix != 0)
213 warn("Unbalanced saves: %d more saves than restores\n", savestack_ix);
214 if (tmps_floor != -1)
215 warn("Unbalanced tmps: %d more allocs than frees\n", tmps_floor + 1);
216 if (cxstack_ix != -1)
217 warn("Unbalanced context: %d more PUSHes than POPs\n", cxstack_ix + 1);
220 /* Now absolutely destruct everything, somehow or other, loops or no. */
222 SvFLAGS(strtab) |= SVTYPEMASK; /* don't clean out strtab now */
223 while (sv_count != 0 && sv_count != last_sv_count) {
224 last_sv_count = sv_count;
227 SvFLAGS(strtab) &= ~SVTYPEMASK;
228 SvFLAGS(strtab) |= SVt_PVHV;
230 /* Destruct the global string table. */
232 /* Yell and reset the HeVAL() slots that are still holding refcounts,
233 * so that sv_free() won't fail on them.
242 array = HvARRAY(strtab);
246 warn("Unbalanced string table refcount: (%d) for \"%s\"",
247 HeVAL(hent) - Nullsv, HeKEY(hent));
248 HeVAL(hent) = Nullsv;
258 SvREFCNT_dec(strtab);
261 warn("Scalars leaked: %d\n", sv_count);
265 linestr = NULL; /* No SVs have survived, need to clean out */
267 Safefree(origfilename);
269 hints = 0; /* Reset hints. Should hints be per-interpreter ? */
271 DEBUG_P(debprofdump());
276 PerlInterpreter *sv_interp;
278 if (!(curinterp = sv_interp))
282 #if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE)
283 char *getenv _((char *)); /* Usually in <stdlib.h> */
287 perl_parse(sv_interp, xsinit, argc, argv, env)
288 PerlInterpreter *sv_interp;
289 void (*xsinit)_((void));
296 char *scriptname = NULL;
297 VOL bool dosearch = FALSE;
301 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
304 croak("suidperl is no longer needed since the kernel can now execute\n\
305 setuid perl scripts securely.\n");
309 if (!(curinterp = sv_interp))
312 #if defined(NeXT) && defined(__DYNAMIC__)
313 _dyld_lookup_and_bind
314 ("__environ", (unsigned long *) &environ_pointer, NULL);
319 #ifndef VMS /* VMS doesn't have environ array */
320 origenviron = environ;
326 /* Come here if running an undumped a.out. */
328 origfilename = savepv(argv[0]);
330 cxstack_ix = -1; /* start label stack again */
332 init_postdump_symbols(argc,argv,env);
340 switch (Sigsetjmp(top_env,1)) {
351 return(statusvalue); /* my_exit() was called */
353 PerlIO_printf(PerlIO_stderr(), "panic: top_env\n");
357 sv_setpvn(linestr,"",0);
358 sv = newSVpv("",0); /* first used for -I flags */
361 for (argc--,argv++; argc > 0; argc--,argv++) {
362 if (argv[0][0] != '-' || !argv[0][1])
366 validarg = " PHOOEY ";
392 if (s = moreswitches(s))
397 if (euid != uid || egid != gid)
398 croak("No -e allowed in setuid scripts");
400 e_tmpname = savepv(TMPPATH);
401 (void)mktemp(e_tmpname);
403 croak("Can't mktemp()");
404 e_fp = PerlIO_open(e_tmpname,"w");
406 croak("Cannot open temporary file");
411 PerlIO_puts(e_fp,argv[1]);
415 croak("No code specified for -e");
416 (void)PerlIO_putc(e_fp,'\n');
424 av_push(GvAVn(incgv),newSVpv(s,0));
427 av_push(GvAVn(incgv),newSVpv(argv[1],0));
428 sv_catpv(sv,argv[1]);
445 preambleav = newAV();
446 av_push(preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
448 Sv = newSVpv("print myconfig();",0);
450 sv_catpv(Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
452 sv_catpv(Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
454 #if defined(DEBUGGING) || defined(NOEMBED) || defined(MULTIPLICITY)
455 strcpy(buf,"\" Compile-time options:");
457 strcat(buf," DEBUGGING");
460 strcat(buf," NOEMBED");
463 strcat(buf," MULTIPLICITY");
465 strcat(buf,"\\n\",");
468 #if defined(LOCAL_PATCH_COUNT)
469 if (LOCAL_PATCH_COUNT > 0)
471 sv_catpv(Sv,"print \" Locally applied patches:\\n\",");
472 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
473 if (localpatches[i]) {
474 sprintf(buf,"\" \\t%s\\n\",",localpatches[i]);
480 sprintf(buf,"\" Built under %s\\n\",",OSNAME);
484 sprintf(buf,"\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
486 sprintf(buf,"\" Compiled on %s\\n\"",__DATE__);
490 sv_catpv(Sv,"; $\"=\"\\n \"; print \" \\@INC:\\n @INC\\n\"");
493 Sv = newSVpv("config_vars(qw(",0);
498 av_push(preambleav, Sv);
499 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
513 croak("Unrecognized switch: -%s",s);
518 scriptname = argv[0];
520 if (PerlIO_flush(e_fp) || PerlIO_error(e_fp) || PerlIO_close(e_fp))
521 croak("Can't write to temp file for -e: %s", Strerror(errno));
524 scriptname = e_tmpname;
526 else if (scriptname == Nullch) {
528 if ( isatty(PerlIO_fileno(PerlIO_stdin())) )
536 open_script(scriptname,dosearch,sv);
538 validate_suid(validarg, scriptname);
543 compcv = (CV*)NEWSV(1104,0);
544 sv_upgrade((SV *)compcv, SVt_PVCV);
547 av_push(comppad, Nullsv);
548 curpad = AvARRAY(comppad);
549 comppad_name = newAV();
550 comppad_name_fill = 0;
551 min_intro_pending = 0;
554 comppadlist = newAV();
555 AvREAL_off(comppadlist);
556 av_store(comppadlist, 0, (SV*)comppad_name);
557 av_store(comppadlist, 1, (SV*)comppad);
558 CvPADLIST(compcv) = comppadlist;
560 boot_core_UNIVERSAL();
562 (*xsinit)(); /* in case linked C routines want magical variables */
567 init_predump_symbols();
569 init_postdump_symbols(argc,argv,env);
573 /* now parse the script */
576 if (yyparse() || error_count) {
578 croak("%s had compilation errors.\n", origfilename);
580 croak("Execution of %s aborted due to compilation errors.\n",
584 curcop->cop_line = 0;
588 (void)UNLINK(e_tmpname);
593 /* now that script is parsed, we can modify record separator */
595 rs = SvREFCNT_inc(nrs);
596 sv_setsv(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), rs);
607 #ifdef DEBUGGING_MSTATS
608 if ((s=getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
609 dump_mstats("after compilation:");
619 PerlInterpreter *sv_interp;
621 if (!(curinterp = sv_interp))
623 switch (Sigsetjmp(top_env,1)) {
625 cxstack_ix = -1; /* start context stack again */
632 #ifdef DEBUGGING_MSTATS
633 if (getenv("PERL_DEBUG_MSTATS"))
634 dump_mstats("after execution: ");
636 return(statusvalue); /* my_exit() was called */
639 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
643 if (curstack != mainstack) {
645 SWITCHSTACK(curstack, mainstack);
650 DEBUG_r(PerlIO_printf(PerlIO_stderr(), "%s $` $& $' support.\n",
651 sawampersand ? "Enabling" : "Omitting"));
655 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
658 PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", origfilename);
661 if (perldb && DBsingle)
662 sv_setiv(DBsingle, 1);
672 else if (main_start) {
685 register CONTEXT *cx;
689 statusvalue = FIXSTATUS(status);
690 if (cxstack_ix >= 0) {
696 Siglongjmp(top_env, 2);
700 perl_get_sv(name, create)
704 GV* gv = gv_fetchpv(name, create, SVt_PV);
711 perl_get_av(name, create)
715 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
724 perl_get_hv(name, create)
728 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
737 perl_get_cv(name, create)
741 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
742 if (create && !GvCV(gv))
743 return newSUB(start_subparse(),
744 newSVOP(OP_CONST, 0, newSVpv(name,0)),
752 /* Be sure to refetch the stack pointer after calling these routines. */
755 perl_call_argv(subname, flags, argv)
757 I32 flags; /* See G_* flags in cop.h */
758 register char **argv; /* null terminated arg list */
765 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
770 return perl_call_pv(subname, flags);
774 perl_call_pv(subname, flags)
775 char *subname; /* name of the subroutine */
776 I32 flags; /* See G_* flags in cop.h */
778 return perl_call_sv((SV*)perl_get_cv(subname, TRUE), flags);
782 perl_call_method(methname, flags)
783 char *methname; /* name of the subroutine */
784 I32 flags; /* See G_* flags in cop.h */
790 XPUSHs(sv_2mortal(newSVpv(methname,0)));
793 return perl_call_sv(*stack_sp--, flags);
796 /* May be called with any of a CV, a GV, or an SV containing the name. */
798 perl_call_sv(sv, flags)
800 I32 flags; /* See G_* flags in cop.h */
802 LOGOP myop; /* fake syntax tree node */
804 I32 oldmark = TOPMARK;
810 if (flags & G_DISCARD) {
820 oldscope = scopestack_ix;
822 if (!(flags & G_NOARGS))
823 myop.op_flags = OPf_STACKED;
824 myop.op_next = Nullop;
825 myop.op_flags |= OPf_KNOW;
827 myop.op_flags |= OPf_LIST;
829 if (perldb && curstash != debstash
830 && (DBcv || (DBcv = GvCV(DBsub)))) /* to handle first BEGIN of -d */
831 op->op_private |= OPpENTERSUB_DB;
833 if (flags & G_EVAL) {
834 Copy(top_env, oldtop, 1, Sigjmp_buf);
836 cLOGOP->op_other = op;
838 /* we're trying to emulate pp_entertry() here */
840 register CONTEXT *cx;
846 push_return(op->op_next);
847 PUSHBLOCK(cx, CXt_EVAL, stack_sp);
849 eval_root = op; /* Only needed so that goto works right. */
852 if (flags & G_KEEPERR)
855 sv_setpv(GvSV(errgv),"");
860 switch (Sigsetjmp(top_env,1)) {
865 statusvalue = 255; /* XXX I don't think we use 1 anymore. */
871 /* my_exit() was called */
874 Copy(oldtop, top_env, 1, Sigjmp_buf);
876 croak("Callback called exit");
877 my_exit(statusvalue);
885 stack_sp = stack_base + oldmark;
890 *++stack_sp = &sv_undef;
896 if (op == (OP*)&myop)
900 retval = stack_sp - (stack_base + oldmark);
901 if ((flags & G_EVAL) && !(flags & G_KEEPERR))
902 sv_setpv(GvSV(errgv),"");
905 if (flags & G_EVAL) {
906 if (scopestack_ix > oldscope) {
910 register CONTEXT *cx;
919 Copy(oldtop, top_env, 1, Sigjmp_buf);
921 if (flags & G_DISCARD) {
922 stack_sp = stack_base + oldmark;
930 /* Eval a string. The G_EVAL flag is always assumed. */
933 perl_eval_sv(sv, flags)
935 I32 flags; /* See G_* flags in cop.h */
937 UNOP myop; /* fake syntax tree node */
939 I32 oldmark = sp - stack_base;
944 if (flags & G_DISCARD) {
954 oldscope = scopestack_ix;
956 if (!(flags & G_NOARGS))
957 myop.op_flags = OPf_STACKED;
958 myop.op_next = Nullop;
959 myop.op_type = OP_ENTEREVAL;
960 myop.op_flags |= OPf_KNOW;
961 if (flags & G_KEEPERR)
962 myop.op_flags |= OPf_SPECIAL;
964 myop.op_flags |= OPf_LIST;
966 Copy(top_env, oldtop, 1, Sigjmp_buf);
969 switch (Sigsetjmp(top_env,1)) {
974 statusvalue = 255; /* XXX I don't think we use 1 anymore. */
980 /* my_exit() was called */
983 Copy(oldtop, top_env, 1, Sigjmp_buf);
985 croak("Callback called exit");
986 my_exit(statusvalue);
994 stack_sp = stack_base + oldmark;
999 *++stack_sp = &sv_undef;
1004 if (op == (OP*)&myop)
1005 op = pp_entereval();
1008 retval = stack_sp - (stack_base + oldmark);
1009 if (!(flags & G_KEEPERR))
1010 sv_setpv(GvSV(errgv),"");
1013 Copy(oldtop, top_env, 1, Sigjmp_buf);
1014 if (flags & G_DISCARD) {
1015 stack_sp = stack_base + oldmark;
1023 /* Require a module. */
1029 SV* sv = sv_newmortal();
1030 sv_setpv(sv, "require '");
1033 perl_eval_sv(sv, G_DISCARD);
1037 magicname(sym,name,namlen)
1044 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1045 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1049 # define PERLLIB_SEP ';'
1052 # define PERLLIB_SEP '|'
1054 # define PERLLIB_SEP ':'
1057 #ifndef PERLLIB_MANGLE
1058 # define PERLLIB_MANGLE(s,n) (s)
1070 /* Break at all separators */
1072 /* First, skip any consecutive separators */
1073 while ( *p == PERLLIB_SEP ) {
1074 /* Uncomment the next line for PATH semantics */
1075 /* av_push(GvAVn(incgv), newSVpv(".", 1)); */
1078 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
1079 av_push(GvAVn(incgv), newSVpv(PERLLIB_MANGLE(p, (STRLEN)(s - p)),
1083 av_push(GvAVn(incgv), newSVpv(PERLLIB_MANGLE(p, 0), 0));
1090 usage(name) /* XXX move this out into a module ? */
1093 /* This message really ought to be max 23 lines.
1094 * Removed -h because the user already knows that opton. Others? */
1095 printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1096 printf("\n -0[octal] specify record separator (\\0, if no argument)");
1097 printf("\n -a autosplit mode with -n or -p (splits $_ into @F)");
1098 printf("\n -c check syntax only (runs BEGIN and END blocks)");
1099 printf("\n -d[:debugger] run scripts under debugger");
1100 printf("\n -D[number/list] set debugging flags (argument is a bit mask or flags)");
1101 printf("\n -e 'command' one line of script. Several -e's allowed. Omit [programfile].");
1102 printf("\n -F/pattern/ split() pattern for autosplit (-a). The //'s are optional.");
1103 printf("\n -i[extension] edit <> files in place (make backup if extension supplied)");
1104 printf("\n -Idirectory specify @INC/#include directory (may be used more then once)");
1105 printf("\n -l[octal] enable line ending processing, specifies line teminator");
1106 printf("\n -[mM][-]module.. executes `use/no module...' before executing your script.");
1107 printf("\n -n assume 'while (<>) { ... }' loop arround your script");
1108 printf("\n -p assume loop like -n but print line also like sed");
1109 printf("\n -P run script through C preprocessor before compilation");
1110 printf("\n -s enable some switch parsing for switches after script name");
1111 printf("\n -S look for the script using PATH environment variable");
1112 printf("\n -T turn on tainting checks");
1113 printf("\n -u dump core after parsing script");
1114 printf("\n -U allow unsafe operations");
1115 printf("\n -v print version number and patchlevel of perl");
1116 printf("\n -V[:variable] print perl configuration information");
1117 printf("\n -w TURN WARNINGS ON FOR COMPILATION OF YOUR SCRIPT.");
1118 printf("\n -x[directory] strip off text before #!perl line and perhaps cd to directory\n");
1121 /* This routine handles any switches that can be given during run */
1132 rschar = scan_oct(s, 4, &numlen);
1134 if (rschar & ~((U8)~0))
1136 else if (!rschar && numlen >= 2)
1137 nrs = newSVpv("", 0);
1140 nrs = newSVpv(&ch, 1);
1145 splitstr = savepv(s + 1);
1159 if (*s == ':' || *s == '=') {
1160 sprintf(buf, "use Devel::%s;", ++s);
1162 my_setenv("PERL5DB",buf);
1172 if (isALPHA(s[1])) {
1173 static char debopts[] = "psltocPmfrxuLHXD";
1176 for (s++; *s && (d = strchr(debopts,*s)); s++)
1177 debug |= 1 << (d - debopts);
1181 for (s++; isDIGIT(*s); s++) ;
1183 debug |= 0x80000000;
1185 warn("Recompile perl with -DDEBUGGING to use -D switch\n");
1186 for (s++; isALNUM(*s); s++) ;
1196 inplace = savepv(s+1);
1198 for (s = inplace; *s && !isSPACE(*s); s++) ;
1205 for (e = s; *e && !isSPACE(*e); e++) ;
1206 av_push(GvAVn(incgv),newSVpv(s,e-s));
1211 croak("No space allowed after -I");
1221 *ors = scan_oct(s, 3 + (*s == '0'), &numlen);
1230 ors = SvPV(nrs, orslen);
1231 ors = savepvn(ors, orslen);
1235 forbid_setid("-M"); /* XXX ? */
1238 forbid_setid("-m"); /* XXX ? */
1242 /* -M-foo == 'no foo' */
1243 if (*s == '-') { use = "no "; ++s; }
1244 Sv = newSVpv(use,0);
1246 /* We allow -M'Module qw(Foo Bar)' */
1247 while(isALNUM(*s) || *s==':') ++s;
1249 sv_catpv(Sv, start);
1250 if (*(start-1) == 'm') {
1252 croak("Can't use '%c' after -mname", *s);
1253 sv_catpv( Sv, " ()");
1256 sv_catpvn(Sv, start, s-start);
1257 sv_catpv(Sv, " split(/,/,q{");
1262 if (preambleav == NULL)
1263 preambleav = newAV();
1264 av_push(preambleav, Sv);
1267 croak("No space allowed after -%c", *(s-1));
1295 #if defined(SUBVERSION) && SUBVERSION > 0
1296 printf("\nThis is perl, version 5.%03d_%02d", PATCHLEVEL, SUBVERSION);
1298 printf("\nThis is perl, version %s",patchlevel);
1301 printf("\n\nCopyright 1987-1996, Larry Wall\n");
1302 printf("\n\t+ suidperl security patch");
1304 printf("\n\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1307 printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
1310 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1311 "Version 5 port Copyright (c) 1994-1996, Andreas Kaiser, Ilya Zakharevich\n");
1314 printf("atariST series port, ++jrb bammi@cadence.com\n");
1317 Perl may be copied only under the terms of either the Artistic License or the\n\
1318 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n");
1326 if (s[1] == '-') /* Additional switches on #! line. */
1339 croak("Can't emulate -%.1s on #! line",s);
1344 /* compliments of Tom Christiansen */
1346 /* unexec() can be found in the Gnu emacs distribution */
1355 sprintf (buf, "%s.perldump", origfilename);
1356 sprintf (tokenbuf, "%s/perl", BIN);
1358 status = unexec(buf, tokenbuf, &etext, sbrk(0), 0);
1360 PerlIO_printf(PerlIO_stderr(), "unexec of %s into %s failed!\n", tokenbuf, buf);
1364 # include <lib$routines.h>
1365 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
1367 ABORT(); /* for use with undump */
1377 /* Note that strtab is a rather special HV. Assumptions are made
1378 about not iterating on it, and not adding tie magic to it.
1379 It is properly deallocated in perl_destruct() */
1381 HvSHAREKEYS_off(strtab); /* mandatory */
1382 Newz(506,((XPVHV*)SvANY(strtab))->xhv_array,
1383 sizeof(HE*) * (((XPVHV*)SvANY(strtab))->xhv_max + 1), char);
1385 curstash = defstash = newHV();
1386 curstname = newSVpv("main",4);
1387 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1388 SvREFCNT_dec(GvHV(gv));
1389 GvHV(gv) = (HV*)SvREFCNT_inc(defstash);
1391 HvNAME(defstash) = savepv("main");
1392 incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1394 defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1395 errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1397 sv_setpvn(GvSV(errgv), "", 0);
1398 curstash = defstash;
1399 compiling.cop_stash = defstash;
1400 debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
1401 /* We must init $/ before switches are processed. */
1402 sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1);
1405 #ifdef CAN_PROTOTYPE
1407 open_script(char *scriptname, bool dosearch, SV *sv)
1410 open_script(scriptname,dosearch,sv)
1416 char *xfound = Nullch;
1417 char *xfailed = Nullch;
1421 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
1422 #define SEARCH_EXTS ".bat", ".cmd", NULL
1425 # define SEARCH_EXTS ".pl", ".com", NULL
1427 /* additional extensions to try in each dir if scriptname not found */
1429 char *ext[] = { SEARCH_EXTS };
1430 int extidx = (strchr(scriptname,'.')) ? -1 : 0; /* has ext already */
1435 int hasdir, idx = 0, deftypes = 1;
1437 hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
1438 /* The first time through, just add SEARCH_EXTS to whatever we
1439 * already have, so we can check for default file types. */
1440 while (deftypes || (!hasdir && my_trnlnm("DCL$PATH",tokenbuf,idx++)) ) {
1441 if (deftypes) { deftypes = 0; *tokenbuf = '\0'; }
1442 strcat(tokenbuf,scriptname);
1444 if (dosearch && !strchr(scriptname, '/') && (s = getenv("PATH"))) {
1446 bufend = s + strlen(s);
1449 s = cpytill(tokenbuf,s,bufend,':',&len);
1452 for (len = 0; *s && *s != ',' && *s != ';'; tokenbuf[len++] = *s++);
1453 tokenbuf[len] = '\0';
1455 for (len = 0; *s && *s != ';'; tokenbuf[len++] = *s++);
1456 tokenbuf[len] = '\0';
1462 if (len && tokenbuf[len-1] != '/')
1465 if (len && ((tokenbuf[len-1] != '\\') && (tokenbuf[len-1] != '/')))
1467 if (len && tokenbuf[len-1] != '\\')
1470 (void)strcat(tokenbuf+len,"/");
1471 (void)strcat(tokenbuf+len,scriptname);
1475 len = strlen(tokenbuf);
1476 if (extidx > 0) /* reset after previous loop */
1480 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tokenbuf));
1481 retval = Stat(tokenbuf,&statbuf);
1483 } while ( retval < 0 /* not there */
1484 && extidx>=0 && ext[extidx] /* try an extension? */
1485 && strcpy(tokenbuf+len, ext[extidx++])
1490 if (S_ISREG(statbuf.st_mode)
1491 && cando(S_IRUSR,TRUE,&statbuf) && cando(S_IXUSR,TRUE,&statbuf)) {
1492 xfound = tokenbuf; /* bingo! */
1496 xfailed = savepv(tokenbuf);
1499 croak("Can't execute %s", xfailed ? xfailed : scriptname );
1502 scriptname = xfound;
1505 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
1506 char *s = scriptname + 8;
1515 origfilename = savepv(e_tmpname ? "-e" : scriptname);
1516 curcop->cop_filegv = gv_fetchfile(origfilename);
1517 if (strEQ(origfilename,"-"))
1519 if (fdscript >= 0) {
1520 rsfp = PerlIO_fdopen(fdscript,"r");
1521 #if defined(HAS_FCNTL) && defined(F_SETFD)
1523 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
1526 else if (preprocess) {
1527 char *cpp = CPPSTDIN;
1529 if (strEQ(cpp,"cppstdin"))
1530 sprintf(tokenbuf, "%s/%s", SCRIPTDIR, cpp);
1532 sprintf(tokenbuf, "%s", cpp);
1534 sv_catpv(sv,PRIVLIB_EXP);
1536 (void)sprintf(buf, "\
1537 sed %s -e \"/^[^#]/b\" \
1538 -e \"/^#[ ]*include[ ]/b\" \
1539 -e \"/^#[ ]*define[ ]/b\" \
1540 -e \"/^#[ ]*if[ ]/b\" \
1541 -e \"/^#[ ]*ifdef[ ]/b\" \
1542 -e \"/^#[ ]*ifndef[ ]/b\" \
1543 -e \"/^#[ ]*else/b\" \
1544 -e \"/^#[ ]*elif[ ]/b\" \
1545 -e \"/^#[ ]*undef[ ]/b\" \
1546 -e \"/^#[ ]*endif/b\" \
1549 (doextract ? "-e \"1,/^#/d\n\"" : ""),
1551 (void)sprintf(buf, "\
1552 %s %s -e '/^[^#]/b' \
1553 -e '/^#[ ]*include[ ]/b' \
1554 -e '/^#[ ]*define[ ]/b' \
1555 -e '/^#[ ]*if[ ]/b' \
1556 -e '/^#[ ]*ifdef[ ]/b' \
1557 -e '/^#[ ]*ifndef[ ]/b' \
1558 -e '/^#[ ]*else/b' \
1559 -e '/^#[ ]*elif[ ]/b' \
1560 -e '/^#[ ]*undef[ ]/b' \
1561 -e '/^#[ ]*endif/b' \
1569 (doextract ? "-e '1,/^#/d\n'" : ""),
1571 scriptname, tokenbuf, SvPV(sv, na), CPPMINUS);
1573 #ifdef IAMSUID /* actually, this is caught earlier */
1574 if (euid != uid && !euid) { /* if running suidperl */
1576 (void)seteuid(uid); /* musn't stay setuid root */
1579 (void)setreuid((Uid_t)-1, uid);
1581 #ifdef HAS_SETRESUID
1582 (void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
1588 if (geteuid() != uid)
1589 croak("Can't do seteuid!\n");
1591 #endif /* IAMSUID */
1592 rsfp = my_popen(buf,"r");
1594 else if (!*scriptname) {
1595 forbid_setid("program input from stdin");
1596 rsfp = PerlIO_stdin();
1599 rsfp = PerlIO_open(scriptname,"r");
1600 #if defined(HAS_FCNTL) && defined(F_SETFD)
1602 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
1610 #ifndef IAMSUID /* in case script is not readable before setuid */
1611 if (euid && Stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
1612 statbuf.st_mode & (S_ISUID|S_ISGID)) {
1613 (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
1614 execv(buf, origargv); /* try again */
1615 croak("Can't do setuid\n");
1619 croak("Can't open perl script \"%s\": %s\n",
1620 SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno));
1625 validate_suid(validarg, scriptname)
1631 /* do we need to emulate setuid on scripts? */
1633 /* This code is for those BSD systems that have setuid #! scripts disabled
1634 * in the kernel because of a security problem. Merely defining DOSUID
1635 * in perl will not fix that problem, but if you have disabled setuid
1636 * scripts in the kernel, this will attempt to emulate setuid and setgid
1637 * on scripts that have those now-otherwise-useless bits set. The setuid
1638 * root version must be called suidperl or sperlN.NNN. If regular perl
1639 * discovers that it has opened a setuid script, it calls suidperl with
1640 * the same argv that it had. If suidperl finds that the script it has
1641 * just opened is NOT setuid root, it sets the effective uid back to the
1642 * uid. We don't just make perl setuid root because that loses the
1643 * effective uid we had before invoking perl, if it was different from the
1646 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
1647 * be defined in suidperl only. suidperl must be setuid root. The
1648 * Configure script will set this up for you if you want it.
1654 if (Fstat(PerlIO_fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
1655 croak("Can't stat script \"%s\"",origfilename);
1656 if (fdscript < 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) {
1660 #ifndef HAS_SETREUID
1661 /* On this access check to make sure the directories are readable,
1662 * there is actually a small window that the user could use to make
1663 * filename point to an accessible directory. So there is a faint
1664 * chance that someone could execute a setuid script down in a
1665 * non-accessible directory. I don't know what to do about that.
1666 * But I don't think it's too important. The manual lies when
1667 * it says access() is useful in setuid programs.
1669 if (access(SvPVX(GvSV(curcop->cop_filegv)),1)) /*double check*/
1670 croak("Permission denied");
1672 /* If we can swap euid and uid, then we can determine access rights
1673 * with a simple stat of the file, and then compare device and
1674 * inode to make sure we did stat() on the same file we opened.
1675 * Then we just have to make sure he or she can execute it.
1678 struct stat tmpstatbuf;
1682 setreuid(euid,uid) < 0
1685 setresuid(euid,uid,(Uid_t)-1) < 0
1688 || getuid() != euid || geteuid() != uid)
1689 croak("Can't swap uid and euid"); /* really paranoid */
1690 if (Stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
1691 croak("Permission denied"); /* testing full pathname here */
1692 if (tmpstatbuf.st_dev != statbuf.st_dev ||
1693 tmpstatbuf.st_ino != statbuf.st_ino) {
1694 (void)PerlIO_close(rsfp);
1695 if (rsfp = my_popen("/bin/mail root","w")) { /* heh, heh */
1697 "User %d tried to run dev %d ino %d in place of dev %d ino %d!\n\
1698 (Filename of set-id script was %s, uid %d gid %d.)\n\nSincerely,\nperl\n",
1699 uid,tmpstatbuf.st_dev, tmpstatbuf.st_ino,
1700 statbuf.st_dev, statbuf.st_ino,
1701 SvPVX(GvSV(curcop->cop_filegv)),
1702 statbuf.st_uid, statbuf.st_gid);
1703 (void)my_pclose(rsfp);
1705 croak("Permission denied\n");
1709 setreuid(uid,euid) < 0
1711 # if defined(HAS_SETRESUID)
1712 setresuid(uid,euid,(Uid_t)-1) < 0
1715 || getuid() != uid || geteuid() != euid)
1716 croak("Can't reswap uid and euid");
1717 if (!cando(S_IXUSR,FALSE,&statbuf)) /* can real uid exec? */
1718 croak("Permission denied\n");
1720 #endif /* HAS_SETREUID */
1721 #endif /* IAMSUID */
1723 if (!S_ISREG(statbuf.st_mode))
1724 croak("Permission denied");
1725 if (statbuf.st_mode & S_IWOTH)
1726 croak("Setuid/gid script is writable by world");
1727 doswitches = FALSE; /* -s is insecure in suid */
1729 if (sv_gets(linestr, rsfp, 0) == Nullch ||
1730 strnNE(SvPV(linestr,na),"#!",2) ) /* required even on Sys V */
1731 croak("No #! line");
1732 s = SvPV(linestr,na)+2;
1734 while (!isSPACE(*s)) s++;
1735 for (s2 = s; (s2 > SvPV(linestr,na)+2 &&
1736 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
1737 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
1738 croak("Not a perl script");
1739 while (*s == ' ' || *s == '\t') s++;
1741 * #! arg must be what we saw above. They can invoke it by
1742 * mentioning suidperl explicitly, but they may not add any strange
1743 * arguments beyond what #! says if they do invoke suidperl that way.
1745 len = strlen(validarg);
1746 if (strEQ(validarg," PHOOEY ") ||
1747 strnNE(s,validarg,len) || !isSPACE(s[len]))
1748 croak("Args must match #! line");
1751 if (euid != uid && (statbuf.st_mode & S_ISUID) &&
1752 euid == statbuf.st_uid)
1754 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
1755 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
1756 #endif /* IAMSUID */
1758 if (euid) { /* oops, we're not the setuid root perl */
1759 (void)PerlIO_close(rsfp);
1761 (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
1762 execv(buf, origargv); /* try again */
1764 croak("Can't do setuid\n");
1767 if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
1769 (void)setegid(statbuf.st_gid);
1772 (void)setregid((Gid_t)-1,statbuf.st_gid);
1774 #ifdef HAS_SETRESGID
1775 (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
1777 setgid(statbuf.st_gid);
1781 if (getegid() != statbuf.st_gid)
1782 croak("Can't do setegid!\n");
1784 if (statbuf.st_mode & S_ISUID) {
1785 if (statbuf.st_uid != euid)
1787 (void)seteuid(statbuf.st_uid); /* all that for this */
1790 (void)setreuid((Uid_t)-1,statbuf.st_uid);
1792 #ifdef HAS_SETRESUID
1793 (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
1795 setuid(statbuf.st_uid);
1799 if (geteuid() != statbuf.st_uid)
1800 croak("Can't do seteuid!\n");
1802 else if (uid) { /* oops, mustn't run as root */
1804 (void)seteuid((Uid_t)uid);
1807 (void)setreuid((Uid_t)-1,(Uid_t)uid);
1809 #ifdef HAS_SETRESUID
1810 (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
1816 if (geteuid() != uid)
1817 croak("Can't do seteuid!\n");
1820 if (!cando(S_IXUSR,TRUE,&statbuf))
1821 croak("Permission denied\n"); /* they can't do this */
1824 else if (preprocess)
1825 croak("-P not allowed for setuid/setgid script\n");
1826 else if (fdscript >= 0)
1827 croak("fd script not allowed in suidperl\n");
1829 croak("Script is not setuid/setgid in suidperl\n");
1831 /* We absolutely must clear out any saved ids here, so we */
1832 /* exec the real perl, substituting fd script for scriptname. */
1833 /* (We pass script name as "subdir" of fd, which perl will grok.) */
1834 PerlIO_rewind(rsfp);
1835 lseek(PerlIO_fileno(rsfp),(Off_t)0,0); /* just in case rewind didn't */
1836 for (which = 1; origargv[which] && origargv[which] != scriptname; which++) ;
1837 if (!origargv[which])
1838 croak("Permission denied");
1839 (void)sprintf(buf, "/dev/fd/%d/%.127s", PerlIO_fileno(rsfp), origargv[which]);
1840 origargv[which] = buf;
1842 #if defined(HAS_FCNTL) && defined(F_SETFD)
1843 fcntl(PerlIO_fileno(rsfp),F_SETFD,0); /* ensure no close-on-exec */
1846 (void)sprintf(tokenbuf, "%s/perl%s", BIN, patchlevel);
1847 execv(tokenbuf, origargv); /* try again */
1848 croak("Can't do setuid\n");
1849 #endif /* IAMSUID */
1851 if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */
1852 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
1853 Fstat(PerlIO_fileno(rsfp),&statbuf); /* may be either wrapped or real suid */
1854 if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
1856 (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
1859 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
1860 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
1861 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
1862 /* not set-id, must be wrapped */
1870 register char *s, *s2;
1872 /* skip forward in input to the real script? */
1876 if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
1877 croak("No Perl script found in input\n");
1878 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
1879 PerlIO_ungetc(rsfp, '\n'); /* to keep line count right */
1881 while (*s && !(isSPACE (*s) || *s == '#')) s++;
1883 while (*s == ' ' || *s == '\t') s++;
1885 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
1886 if (strnEQ(s2-4,"perl",4))
1888 while (s = moreswitches(s)) ;
1890 if (cddir && chdir(cddir) < 0)
1891 croak("Can't chdir to %s",cddir);
1899 uid = (int)getuid();
1900 euid = (int)geteuid();
1901 gid = (int)getgid();
1902 egid = (int)getegid();
1907 tainting |= (uid && (euid != uid || egid != gid));
1915 croak("No %s allowed while running setuid", s);
1917 croak("No %s allowed while running setgid", s);
1923 curstash = debstash;
1924 dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
1926 DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
1927 DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
1928 DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
1929 DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
1930 sv_setiv(DBsingle, 0);
1931 DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
1932 sv_setiv(DBtrace, 0);
1933 DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
1934 sv_setiv(DBsignal, 0);
1935 curstash = defstash;
1942 mainstack = curstack; /* remember in case we switch stacks */
1943 AvREAL_off(curstack); /* not a real array */
1944 av_extend(curstack,127);
1946 stack_base = AvARRAY(curstack);
1947 stack_sp = stack_base;
1948 stack_max = stack_base + 127;
1950 /* Shouldn't these stacks be per-interpreter? */
1952 markstack_ptr = markstack;
1954 New(54,markstack,64,I32);
1955 markstack_ptr = markstack;
1956 markstack_max = markstack + 64;
1962 New(54,scopestack,32,I32);
1964 scopestack_max = 32;
1970 New(54,savestack,128,ANY);
1972 savestack_max = 128;
1978 New(54,retstack,16,OP*);
1983 cxstack_max = 8192 / sizeof(CONTEXT) - 2; /* Use most of 8K. */
1984 New(50,cxstack,cxstack_max + 1,CONTEXT);
1987 New(50,tmps_stack,128,SV*);
1992 New(51,debname,128,char);
1993 New(52,debdelim,128,char);
2001 Safefree(tmps_stack);
2004 static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
2012 subname = newSVpv("main",4);
2016 init_predump_symbols()
2021 sv_setpvn(GvSV(gv_fetchpv("\"", TRUE, SVt_PV)), " ", 1);
2023 stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2024 GvMULTI_on(stdingv);
2025 IoIFP(GvIOp(stdingv)) = PerlIO_stdin();
2026 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2028 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv));
2030 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2032 IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
2034 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2036 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv));
2038 othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2039 GvMULTI_on(othergv);
2040 IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr();
2041 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2043 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
2045 statname = NEWSV(66,0); /* last filename we did stat on */
2048 osname = savepv(OSNAME);
2052 init_postdump_symbols(argc,argv,env)
2054 register char **argv;
2055 register char **env;
2061 argc--,argv++; /* skip name of script */
2063 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2066 if (argv[0][1] == '-') {
2070 if (s = strchr(argv[0], '=')) {
2072 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2075 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2078 toptarget = NEWSV(0,0);
2079 sv_upgrade(toptarget, SVt_PVFM);
2080 sv_setpvn(toptarget, "", 0);
2081 bodytarget = NEWSV(0,0);
2082 sv_upgrade(bodytarget, SVt_PVFM);
2083 sv_setpvn(bodytarget, "", 0);
2084 formtarget = bodytarget;
2087 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2088 sv_setpv(GvSV(tmpgv),origfilename);
2089 magicname("0", "0", 1);
2091 if (tmpgv = gv_fetchpv("\024",TRUE, SVt_PV))
2093 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2094 sv_setpv(GvSV(tmpgv),origargv[0]);
2095 if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2097 (void)gv_AVadd(argvgv);
2098 av_clear(GvAVn(argvgv));
2099 for (; argc > 0; argc--,argv++) {
2100 av_push(GvAVn(argvgv),newSVpv(argv[0],0));
2103 if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2108 #ifndef VMS /* VMS doesn't have environ array */
2109 /* Note that if the supplied env parameter is actually a copy
2110 of the global environ then it may now point to free'd memory
2111 if the environment has been modified since. To avoid this
2112 problem we treat env==NULL as meaning 'use the default'
2116 if (env != environ) {
2117 environ[0] = Nullch;
2118 hv_magic(hv, envgv, 'E');
2120 for (; *env; env++) {
2121 if (!(s = strchr(*env,'=')))
2124 sv = newSVpv(s--,0);
2125 sv_magic(sv, sv, 'e', *env, s - *env);
2126 (void)hv_store(hv, *env, s - *env, sv, 0);
2130 #ifdef DYNAMIC_ENV_FETCH
2131 HvNAME(hv) = savepv(ENV_HV_NAME);
2133 hv_magic(hv, envgv, 'E');
2136 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2137 sv_setiv(GvSV(tmpgv),(I32)getpid());
2146 s = getenv("PERL5LIB");
2150 incpush(getenv("PERLLIB"));
2152 /* Treat PERL5?LIB as a possible search list logical name -- the
2153 * "natural" VMS idiom for a Unix path string. We allow each
2154 * element to be a set of |-separated directories for compatibility.
2158 if (my_trnlnm("PERL5LIB",buf,0))
2159 do { incpush(buf); } while (my_trnlnm("PERL5LIB",buf,++idx));
2161 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf);
2165 /* Use the ~-expanded versions of APPLIB (undocumented),
2166 ARCHLIB PRIVLIB SITEARCH SITELIB and OLDARCHLIB
2169 incpush(APPLLIB_EXP);
2173 incpush(ARCHLIB_EXP);
2176 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2178 incpush(PRIVLIB_EXP);
2181 incpush(SITEARCH_EXP);
2184 incpush(SITELIB_EXP);
2186 #ifdef OLDARCHLIB_EXP /* 5.00[01] compatibility */
2187 incpush(OLDARCHLIB_EXP);
2200 line_t oldline = curcop->cop_line;
2202 Copy(top_env, oldtop, 1, Sigjmp_buf);
2204 while (AvFILL(list) >= 0) {
2205 CV *cv = (CV*)av_shift(list);
2209 switch (Sigsetjmp(top_env,1)) {
2211 SV* atsv = GvSV(errgv);
2213 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
2214 (void)SvPV(atsv, len);
2216 Copy(oldtop, top_env, 1, Sigjmp_buf);
2217 curcop = &compiling;
2218 curcop->cop_line = oldline;
2219 if (list == beginav)
2220 sv_catpv(atsv, "BEGIN failed--compilation aborted");
2222 sv_catpv(atsv, "END failed--cleanup aborted");
2223 croak("%s", SvPVX(atsv));
2229 statusvalue = 255; /* XXX I don't think we use 1 anymore. */
2235 /* my_exit() was called */
2236 curstash = defstash;
2240 Copy(oldtop, top_env, 1, Sigjmp_buf);
2241 curcop = &compiling;
2242 curcop->cop_line = oldline;
2244 if (list == beginav)
2245 croak("BEGIN failed--compilation aborted");
2247 croak("END failed--cleanup aborted");
2249 my_exit(statusvalue);
2254 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
2258 Copy(oldtop, top_env, 1, Sigjmp_buf);
2259 curcop = &compiling;
2260 curcop->cop_line = oldline;
2261 Siglongjmp(top_env, 3);
2265 Copy(oldtop, top_env, 1, Sigjmp_buf);