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);
124 SET_NUMERIC_STANDARD();
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 /* Handle first BEGIN of -d. */
831 && (DBcv || (DBcv = GvCV(DBsub)))
832 /* Try harder, since this may have been a sighandler, thus
833 * curstash may be meaningless. */
834 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != debstash))
835 op->op_private |= OPpENTERSUB_DB;
837 if (flags & G_EVAL) {
838 Copy(top_env, oldtop, 1, Sigjmp_buf);
840 cLOGOP->op_other = op;
842 /* we're trying to emulate pp_entertry() here */
844 register CONTEXT *cx;
850 push_return(op->op_next);
851 PUSHBLOCK(cx, CXt_EVAL, stack_sp);
853 eval_root = op; /* Only needed so that goto works right. */
856 if (flags & G_KEEPERR)
859 sv_setpv(GvSV(errgv),"");
864 switch (Sigsetjmp(top_env,1)) {
869 statusvalue = 255; /* XXX I don't think we use 1 anymore. */
875 /* my_exit() was called */
878 Copy(oldtop, top_env, 1, Sigjmp_buf);
880 croak("Callback called exit");
881 my_exit(statusvalue);
889 stack_sp = stack_base + oldmark;
894 *++stack_sp = &sv_undef;
900 if (op == (OP*)&myop)
904 retval = stack_sp - (stack_base + oldmark);
905 if ((flags & G_EVAL) && !(flags & G_KEEPERR))
906 sv_setpv(GvSV(errgv),"");
909 if (flags & G_EVAL) {
910 if (scopestack_ix > oldscope) {
914 register CONTEXT *cx;
923 Copy(oldtop, top_env, 1, Sigjmp_buf);
925 if (flags & G_DISCARD) {
926 stack_sp = stack_base + oldmark;
934 /* Eval a string. The G_EVAL flag is always assumed. */
937 perl_eval_sv(sv, flags)
939 I32 flags; /* See G_* flags in cop.h */
941 UNOP myop; /* fake syntax tree node */
943 I32 oldmark = sp - stack_base;
948 if (flags & G_DISCARD) {
958 oldscope = scopestack_ix;
960 if (!(flags & G_NOARGS))
961 myop.op_flags = OPf_STACKED;
962 myop.op_next = Nullop;
963 myop.op_type = OP_ENTEREVAL;
964 myop.op_flags |= OPf_KNOW;
965 if (flags & G_KEEPERR)
966 myop.op_flags |= OPf_SPECIAL;
968 myop.op_flags |= OPf_LIST;
970 Copy(top_env, oldtop, 1, Sigjmp_buf);
973 switch (Sigsetjmp(top_env,1)) {
978 statusvalue = 255; /* XXX I don't think we use 1 anymore. */
984 /* my_exit() was called */
987 Copy(oldtop, top_env, 1, Sigjmp_buf);
989 croak("Callback called exit");
990 my_exit(statusvalue);
998 stack_sp = stack_base + oldmark;
1003 *++stack_sp = &sv_undef;
1008 if (op == (OP*)&myop)
1009 op = pp_entereval();
1012 retval = stack_sp - (stack_base + oldmark);
1013 if (!(flags & G_KEEPERR))
1014 sv_setpv(GvSV(errgv),"");
1017 Copy(oldtop, top_env, 1, Sigjmp_buf);
1018 if (flags & G_DISCARD) {
1019 stack_sp = stack_base + oldmark;
1027 /* Require a module. */
1033 SV* sv = sv_newmortal();
1034 sv_setpv(sv, "require '");
1037 perl_eval_sv(sv, G_DISCARD);
1041 magicname(sym,name,namlen)
1048 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1049 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1053 # define PERLLIB_SEP ';'
1056 # define PERLLIB_SEP '|'
1058 # define PERLLIB_SEP ':'
1061 #ifndef PERLLIB_MANGLE
1062 # define PERLLIB_MANGLE(s,n) (s)
1074 /* Break at all separators */
1076 /* First, skip any consecutive separators */
1077 while ( *p == PERLLIB_SEP ) {
1078 /* Uncomment the next line for PATH semantics */
1079 /* av_push(GvAVn(incgv), newSVpv(".", 1)); */
1082 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
1083 av_push(GvAVn(incgv), newSVpv(PERLLIB_MANGLE(p, (STRLEN)(s - p)),
1087 av_push(GvAVn(incgv), newSVpv(PERLLIB_MANGLE(p, 0), 0));
1094 usage(name) /* XXX move this out into a module ? */
1097 /* This message really ought to be max 23 lines.
1098 * Removed -h because the user already knows that opton. Others? */
1099 printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1100 printf("\n -0[octal] specify record separator (\\0, if no argument)");
1101 printf("\n -a autosplit mode with -n or -p (splits $_ into @F)");
1102 printf("\n -c check syntax only (runs BEGIN and END blocks)");
1103 printf("\n -d[:debugger] run scripts under debugger");
1104 printf("\n -D[number/list] set debugging flags (argument is a bit mask or flags)");
1105 printf("\n -e 'command' one line of script. Several -e's allowed. Omit [programfile].");
1106 printf("\n -F/pattern/ split() pattern for autosplit (-a). The //'s are optional.");
1107 printf("\n -i[extension] edit <> files in place (make backup if extension supplied)");
1108 printf("\n -Idirectory specify @INC/#include directory (may be used more then once)");
1109 printf("\n -l[octal] enable line ending processing, specifies line teminator");
1110 printf("\n -[mM][-]module.. executes `use/no module...' before executing your script.");
1111 printf("\n -n assume 'while (<>) { ... }' loop arround your script");
1112 printf("\n -p assume loop like -n but print line also like sed");
1113 printf("\n -P run script through C preprocessor before compilation");
1114 printf("\n -s enable some switch parsing for switches after script name");
1115 printf("\n -S look for the script using PATH environment variable");
1116 printf("\n -T turn on tainting checks");
1117 printf("\n -u dump core after parsing script");
1118 printf("\n -U allow unsafe operations");
1119 printf("\n -v print version number and patchlevel of perl");
1120 printf("\n -V[:variable] print perl configuration information");
1121 printf("\n -w TURN WARNINGS ON FOR COMPILATION OF YOUR SCRIPT.");
1122 printf("\n -x[directory] strip off text before #!perl line and perhaps cd to directory\n");
1125 /* This routine handles any switches that can be given during run */
1136 rschar = scan_oct(s, 4, &numlen);
1138 if (rschar & ~((U8)~0))
1140 else if (!rschar && numlen >= 2)
1141 nrs = newSVpv("", 0);
1144 nrs = newSVpv(&ch, 1);
1149 splitstr = savepv(s + 1);
1163 if (*s == ':' || *s == '=') {
1164 sprintf(buf, "use Devel::%s;", ++s);
1166 my_setenv("PERL5DB",buf);
1176 if (isALPHA(s[1])) {
1177 static char debopts[] = "psltocPmfrxuLHXD";
1180 for (s++; *s && (d = strchr(debopts,*s)); s++)
1181 debug |= 1 << (d - debopts);
1185 for (s++; isDIGIT(*s); s++) ;
1187 debug |= 0x80000000;
1189 warn("Recompile perl with -DDEBUGGING to use -D switch\n");
1190 for (s++; isALNUM(*s); s++) ;
1200 inplace = savepv(s+1);
1202 for (s = inplace; *s && !isSPACE(*s); s++) ;
1209 for (e = s; *e && !isSPACE(*e); e++) ;
1210 av_push(GvAVn(incgv),newSVpv(s,e-s));
1215 croak("No space allowed after -I");
1225 *ors = scan_oct(s, 3 + (*s == '0'), &numlen);
1234 ors = SvPV(nrs, orslen);
1235 ors = savepvn(ors, orslen);
1239 forbid_setid("-M"); /* XXX ? */
1242 forbid_setid("-m"); /* XXX ? */
1246 /* -M-foo == 'no foo' */
1247 if (*s == '-') { use = "no "; ++s; }
1248 Sv = newSVpv(use,0);
1250 /* We allow -M'Module qw(Foo Bar)' */
1251 while(isALNUM(*s) || *s==':') ++s;
1253 sv_catpv(Sv, start);
1254 if (*(start-1) == 'm') {
1256 croak("Can't use '%c' after -mname", *s);
1257 sv_catpv( Sv, " ()");
1260 sv_catpvn(Sv, start, s-start);
1261 sv_catpv(Sv, " split(/,/,q{");
1266 if (preambleav == NULL)
1267 preambleav = newAV();
1268 av_push(preambleav, Sv);
1271 croak("No space allowed after -%c", *(s-1));
1299 #if defined(SUBVERSION) && SUBVERSION > 0
1300 printf("\nThis is perl, version 5.%03d_%02d", PATCHLEVEL, SUBVERSION);
1302 printf("\nThis is perl, version %s",patchlevel);
1305 printf("\n\nCopyright 1987-1996, Larry Wall\n");
1306 printf("\n\t+ suidperl security patch");
1308 printf("\n\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1311 printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
1314 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1315 "Version 5 port Copyright (c) 1994-1996, Andreas Kaiser, Ilya Zakharevich\n");
1318 printf("atariST series port, ++jrb bammi@cadence.com\n");
1321 Perl may be copied only under the terms of either the Artistic License or the\n\
1322 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n");
1330 if (s[1] == '-') /* Additional switches on #! line. */
1343 croak("Can't emulate -%.1s on #! line",s);
1348 /* compliments of Tom Christiansen */
1350 /* unexec() can be found in the Gnu emacs distribution */
1359 sprintf (buf, "%s.perldump", origfilename);
1360 sprintf (tokenbuf, "%s/perl", BIN);
1362 status = unexec(buf, tokenbuf, &etext, sbrk(0), 0);
1364 PerlIO_printf(PerlIO_stderr(), "unexec of %s into %s failed!\n", tokenbuf, buf);
1368 # include <lib$routines.h>
1369 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
1371 ABORT(); /* for use with undump */
1381 /* Note that strtab is a rather special HV. Assumptions are made
1382 about not iterating on it, and not adding tie magic to it.
1383 It is properly deallocated in perl_destruct() */
1385 HvSHAREKEYS_off(strtab); /* mandatory */
1386 Newz(506,((XPVHV*)SvANY(strtab))->xhv_array,
1387 sizeof(HE*) * (((XPVHV*)SvANY(strtab))->xhv_max + 1), char);
1389 curstash = defstash = newHV();
1390 curstname = newSVpv("main",4);
1391 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1392 SvREFCNT_dec(GvHV(gv));
1393 GvHV(gv) = (HV*)SvREFCNT_inc(defstash);
1395 HvNAME(defstash) = savepv("main");
1396 incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1398 defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1399 errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1401 sv_setpvn(GvSV(errgv), "", 0);
1402 curstash = defstash;
1403 compiling.cop_stash = defstash;
1404 debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
1405 /* We must init $/ before switches are processed. */
1406 sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1);
1409 #ifdef CAN_PROTOTYPE
1411 open_script(char *scriptname, bool dosearch, SV *sv)
1414 open_script(scriptname,dosearch,sv)
1420 char *xfound = Nullch;
1421 char *xfailed = Nullch;
1425 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
1426 #define SEARCH_EXTS ".bat", ".cmd", NULL
1429 # define SEARCH_EXTS ".pl", ".com", NULL
1431 /* additional extensions to try in each dir if scriptname not found */
1433 char *ext[] = { SEARCH_EXTS };
1434 int extidx = (strchr(scriptname,'.')) ? -1 : 0; /* has ext already */
1439 int hasdir, idx = 0, deftypes = 1;
1441 hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
1442 /* The first time through, just add SEARCH_EXTS to whatever we
1443 * already have, so we can check for default file types. */
1444 while (deftypes || (!hasdir && my_trnlnm("DCL$PATH",tokenbuf,idx++)) ) {
1445 if (deftypes) { deftypes = 0; *tokenbuf = '\0'; }
1446 strcat(tokenbuf,scriptname);
1448 if (dosearch && !strchr(scriptname, '/') && (s = getenv("PATH"))) {
1450 bufend = s + strlen(s);
1453 s = cpytill(tokenbuf,s,bufend,':',&len);
1456 for (len = 0; *s && *s != ',' && *s != ';'; tokenbuf[len++] = *s++);
1457 tokenbuf[len] = '\0';
1459 for (len = 0; *s && *s != ';'; tokenbuf[len++] = *s++);
1460 tokenbuf[len] = '\0';
1466 if (len && tokenbuf[len-1] != '/')
1469 if (len && ((tokenbuf[len-1] != '\\') && (tokenbuf[len-1] != '/')))
1471 if (len && tokenbuf[len-1] != '\\')
1474 (void)strcat(tokenbuf+len,"/");
1475 (void)strcat(tokenbuf+len,scriptname);
1479 len = strlen(tokenbuf);
1480 if (extidx > 0) /* reset after previous loop */
1484 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tokenbuf));
1485 retval = Stat(tokenbuf,&statbuf);
1487 } while ( retval < 0 /* not there */
1488 && extidx>=0 && ext[extidx] /* try an extension? */
1489 && strcpy(tokenbuf+len, ext[extidx++])
1494 if (S_ISREG(statbuf.st_mode)
1495 && cando(S_IRUSR,TRUE,&statbuf) && cando(S_IXUSR,TRUE,&statbuf)) {
1496 xfound = tokenbuf; /* bingo! */
1500 xfailed = savepv(tokenbuf);
1503 croak("Can't execute %s", xfailed ? xfailed : scriptname );
1506 scriptname = xfound;
1509 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
1510 char *s = scriptname + 8;
1519 origfilename = savepv(e_tmpname ? "-e" : scriptname);
1520 curcop->cop_filegv = gv_fetchfile(origfilename);
1521 if (strEQ(origfilename,"-"))
1523 if (fdscript >= 0) {
1524 rsfp = PerlIO_fdopen(fdscript,"r");
1525 #if defined(HAS_FCNTL) && defined(F_SETFD)
1527 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
1530 else if (preprocess) {
1531 char *cpp = CPPSTDIN;
1533 if (strEQ(cpp,"cppstdin"))
1534 sprintf(tokenbuf, "%s/%s", SCRIPTDIR, cpp);
1536 sprintf(tokenbuf, "%s", cpp);
1538 sv_catpv(sv,PRIVLIB_EXP);
1540 (void)sprintf(buf, "\
1541 sed %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\" \
1553 (doextract ? "-e \"1,/^#/d\n\"" : ""),
1555 (void)sprintf(buf, "\
1556 %s %s -e '/^[^#]/b' \
1557 -e '/^#[ ]*include[ ]/b' \
1558 -e '/^#[ ]*define[ ]/b' \
1559 -e '/^#[ ]*if[ ]/b' \
1560 -e '/^#[ ]*ifdef[ ]/b' \
1561 -e '/^#[ ]*ifndef[ ]/b' \
1562 -e '/^#[ ]*else/b' \
1563 -e '/^#[ ]*elif[ ]/b' \
1564 -e '/^#[ ]*undef[ ]/b' \
1565 -e '/^#[ ]*endif/b' \
1573 (doextract ? "-e '1,/^#/d\n'" : ""),
1575 scriptname, tokenbuf, SvPV(sv, na), CPPMINUS);
1577 #ifdef IAMSUID /* actually, this is caught earlier */
1578 if (euid != uid && !euid) { /* if running suidperl */
1580 (void)seteuid(uid); /* musn't stay setuid root */
1583 (void)setreuid((Uid_t)-1, uid);
1585 #ifdef HAS_SETRESUID
1586 (void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
1592 if (geteuid() != uid)
1593 croak("Can't do seteuid!\n");
1595 #endif /* IAMSUID */
1596 rsfp = my_popen(buf,"r");
1598 else if (!*scriptname) {
1599 forbid_setid("program input from stdin");
1600 rsfp = PerlIO_stdin();
1603 rsfp = PerlIO_open(scriptname,"r");
1604 #if defined(HAS_FCNTL) && defined(F_SETFD)
1606 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
1614 #ifndef IAMSUID /* in case script is not readable before setuid */
1615 if (euid && Stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
1616 statbuf.st_mode & (S_ISUID|S_ISGID)) {
1617 (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
1618 execv(buf, origargv); /* try again */
1619 croak("Can't do setuid\n");
1623 croak("Can't open perl script \"%s\": %s\n",
1624 SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno));
1629 validate_suid(validarg, scriptname)
1635 /* do we need to emulate setuid on scripts? */
1637 /* This code is for those BSD systems that have setuid #! scripts disabled
1638 * in the kernel because of a security problem. Merely defining DOSUID
1639 * in perl will not fix that problem, but if you have disabled setuid
1640 * scripts in the kernel, this will attempt to emulate setuid and setgid
1641 * on scripts that have those now-otherwise-useless bits set. The setuid
1642 * root version must be called suidperl or sperlN.NNN. If regular perl
1643 * discovers that it has opened a setuid script, it calls suidperl with
1644 * the same argv that it had. If suidperl finds that the script it has
1645 * just opened is NOT setuid root, it sets the effective uid back to the
1646 * uid. We don't just make perl setuid root because that loses the
1647 * effective uid we had before invoking perl, if it was different from the
1650 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
1651 * be defined in suidperl only. suidperl must be setuid root. The
1652 * Configure script will set this up for you if you want it.
1658 if (Fstat(PerlIO_fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
1659 croak("Can't stat script \"%s\"",origfilename);
1660 if (fdscript < 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) {
1664 #ifndef HAS_SETREUID
1665 /* On this access check to make sure the directories are readable,
1666 * there is actually a small window that the user could use to make
1667 * filename point to an accessible directory. So there is a faint
1668 * chance that someone could execute a setuid script down in a
1669 * non-accessible directory. I don't know what to do about that.
1670 * But I don't think it's too important. The manual lies when
1671 * it says access() is useful in setuid programs.
1673 if (access(SvPVX(GvSV(curcop->cop_filegv)),1)) /*double check*/
1674 croak("Permission denied");
1676 /* If we can swap euid and uid, then we can determine access rights
1677 * with a simple stat of the file, and then compare device and
1678 * inode to make sure we did stat() on the same file we opened.
1679 * Then we just have to make sure he or she can execute it.
1682 struct stat tmpstatbuf;
1686 setreuid(euid,uid) < 0
1689 setresuid(euid,uid,(Uid_t)-1) < 0
1692 || getuid() != euid || geteuid() != uid)
1693 croak("Can't swap uid and euid"); /* really paranoid */
1694 if (Stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
1695 croak("Permission denied"); /* testing full pathname here */
1696 if (tmpstatbuf.st_dev != statbuf.st_dev ||
1697 tmpstatbuf.st_ino != statbuf.st_ino) {
1698 (void)PerlIO_close(rsfp);
1699 if (rsfp = my_popen("/bin/mail root","w")) { /* heh, heh */
1701 "User %d tried to run dev %d ino %d in place of dev %d ino %d!\n\
1702 (Filename of set-id script was %s, uid %d gid %d.)\n\nSincerely,\nperl\n",
1703 uid,tmpstatbuf.st_dev, tmpstatbuf.st_ino,
1704 statbuf.st_dev, statbuf.st_ino,
1705 SvPVX(GvSV(curcop->cop_filegv)),
1706 statbuf.st_uid, statbuf.st_gid);
1707 (void)my_pclose(rsfp);
1709 croak("Permission denied\n");
1713 setreuid(uid,euid) < 0
1715 # if defined(HAS_SETRESUID)
1716 setresuid(uid,euid,(Uid_t)-1) < 0
1719 || getuid() != uid || geteuid() != euid)
1720 croak("Can't reswap uid and euid");
1721 if (!cando(S_IXUSR,FALSE,&statbuf)) /* can real uid exec? */
1722 croak("Permission denied\n");
1724 #endif /* HAS_SETREUID */
1725 #endif /* IAMSUID */
1727 if (!S_ISREG(statbuf.st_mode))
1728 croak("Permission denied");
1729 if (statbuf.st_mode & S_IWOTH)
1730 croak("Setuid/gid script is writable by world");
1731 doswitches = FALSE; /* -s is insecure in suid */
1733 if (sv_gets(linestr, rsfp, 0) == Nullch ||
1734 strnNE(SvPV(linestr,na),"#!",2) ) /* required even on Sys V */
1735 croak("No #! line");
1736 s = SvPV(linestr,na)+2;
1738 while (!isSPACE(*s)) s++;
1739 for (s2 = s; (s2 > SvPV(linestr,na)+2 &&
1740 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
1741 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
1742 croak("Not a perl script");
1743 while (*s == ' ' || *s == '\t') s++;
1745 * #! arg must be what we saw above. They can invoke it by
1746 * mentioning suidperl explicitly, but they may not add any strange
1747 * arguments beyond what #! says if they do invoke suidperl that way.
1749 len = strlen(validarg);
1750 if (strEQ(validarg," PHOOEY ") ||
1751 strnNE(s,validarg,len) || !isSPACE(s[len]))
1752 croak("Args must match #! line");
1755 if (euid != uid && (statbuf.st_mode & S_ISUID) &&
1756 euid == statbuf.st_uid)
1758 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
1759 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
1760 #endif /* IAMSUID */
1762 if (euid) { /* oops, we're not the setuid root perl */
1763 (void)PerlIO_close(rsfp);
1765 (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
1766 execv(buf, origargv); /* try again */
1768 croak("Can't do setuid\n");
1771 if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
1773 (void)setegid(statbuf.st_gid);
1776 (void)setregid((Gid_t)-1,statbuf.st_gid);
1778 #ifdef HAS_SETRESGID
1779 (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
1781 setgid(statbuf.st_gid);
1785 if (getegid() != statbuf.st_gid)
1786 croak("Can't do setegid!\n");
1788 if (statbuf.st_mode & S_ISUID) {
1789 if (statbuf.st_uid != euid)
1791 (void)seteuid(statbuf.st_uid); /* all that for this */
1794 (void)setreuid((Uid_t)-1,statbuf.st_uid);
1796 #ifdef HAS_SETRESUID
1797 (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
1799 setuid(statbuf.st_uid);
1803 if (geteuid() != statbuf.st_uid)
1804 croak("Can't do seteuid!\n");
1806 else if (uid) { /* oops, mustn't run as root */
1808 (void)seteuid((Uid_t)uid);
1811 (void)setreuid((Uid_t)-1,(Uid_t)uid);
1813 #ifdef HAS_SETRESUID
1814 (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
1820 if (geteuid() != uid)
1821 croak("Can't do seteuid!\n");
1824 if (!cando(S_IXUSR,TRUE,&statbuf))
1825 croak("Permission denied\n"); /* they can't do this */
1828 else if (preprocess)
1829 croak("-P not allowed for setuid/setgid script\n");
1830 else if (fdscript >= 0)
1831 croak("fd script not allowed in suidperl\n");
1833 croak("Script is not setuid/setgid in suidperl\n");
1835 /* We absolutely must clear out any saved ids here, so we */
1836 /* exec the real perl, substituting fd script for scriptname. */
1837 /* (We pass script name as "subdir" of fd, which perl will grok.) */
1838 PerlIO_rewind(rsfp);
1839 lseek(PerlIO_fileno(rsfp),(Off_t)0,0); /* just in case rewind didn't */
1840 for (which = 1; origargv[which] && origargv[which] != scriptname; which++) ;
1841 if (!origargv[which])
1842 croak("Permission denied");
1843 (void)sprintf(buf, "/dev/fd/%d/%.127s", PerlIO_fileno(rsfp), origargv[which]);
1844 origargv[which] = buf;
1846 #if defined(HAS_FCNTL) && defined(F_SETFD)
1847 fcntl(PerlIO_fileno(rsfp),F_SETFD,0); /* ensure no close-on-exec */
1850 (void)sprintf(tokenbuf, "%s/perl%s", BIN, patchlevel);
1851 execv(tokenbuf, origargv); /* try again */
1852 croak("Can't do setuid\n");
1853 #endif /* IAMSUID */
1855 if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */
1856 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
1857 Fstat(PerlIO_fileno(rsfp),&statbuf); /* may be either wrapped or real suid */
1858 if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
1860 (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
1863 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
1864 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
1865 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
1866 /* not set-id, must be wrapped */
1874 register char *s, *s2;
1876 /* skip forward in input to the real script? */
1880 if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
1881 croak("No Perl script found in input\n");
1882 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
1883 PerlIO_ungetc(rsfp, '\n'); /* to keep line count right */
1885 while (*s && !(isSPACE (*s) || *s == '#')) s++;
1887 while (*s == ' ' || *s == '\t') s++;
1889 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
1890 if (strnEQ(s2-4,"perl",4))
1892 while (s = moreswitches(s)) ;
1894 if (cddir && chdir(cddir) < 0)
1895 croak("Can't chdir to %s",cddir);
1903 uid = (int)getuid();
1904 euid = (int)geteuid();
1905 gid = (int)getgid();
1906 egid = (int)getegid();
1911 tainting |= (uid && (euid != uid || egid != gid));
1919 croak("No %s allowed while running setuid", s);
1921 croak("No %s allowed while running setgid", s);
1927 curstash = debstash;
1928 dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
1930 DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
1931 DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
1932 DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
1933 DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
1934 sv_setiv(DBsingle, 0);
1935 DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
1936 sv_setiv(DBtrace, 0);
1937 DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
1938 sv_setiv(DBsignal, 0);
1939 curstash = defstash;
1946 mainstack = curstack; /* remember in case we switch stacks */
1947 AvREAL_off(curstack); /* not a real array */
1948 av_extend(curstack,127);
1950 stack_base = AvARRAY(curstack);
1951 stack_sp = stack_base;
1952 stack_max = stack_base + 127;
1954 /* Shouldn't these stacks be per-interpreter? */
1956 markstack_ptr = markstack;
1958 New(54,markstack,64,I32);
1959 markstack_ptr = markstack;
1960 markstack_max = markstack + 64;
1966 New(54,scopestack,32,I32);
1968 scopestack_max = 32;
1974 New(54,savestack,128,ANY);
1976 savestack_max = 128;
1982 New(54,retstack,16,OP*);
1987 cxstack_max = 8192 / sizeof(CONTEXT) - 2; /* Use most of 8K. */
1988 New(50,cxstack,cxstack_max + 1,CONTEXT);
1991 New(50,tmps_stack,128,SV*);
1996 New(51,debname,128,char);
1997 New(52,debdelim,128,char);
2005 Safefree(tmps_stack);
2008 static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
2016 subname = newSVpv("main",4);
2020 init_predump_symbols()
2025 sv_setpvn(GvSV(gv_fetchpv("\"", TRUE, SVt_PV)), " ", 1);
2027 stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2028 GvMULTI_on(stdingv);
2029 IoIFP(GvIOp(stdingv)) = PerlIO_stdin();
2030 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2032 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv));
2034 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2036 IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
2038 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2040 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv));
2042 othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2043 GvMULTI_on(othergv);
2044 IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr();
2045 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2047 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
2049 statname = NEWSV(66,0); /* last filename we did stat on */
2052 osname = savepv(OSNAME);
2056 init_postdump_symbols(argc,argv,env)
2058 register char **argv;
2059 register char **env;
2065 argc--,argv++; /* skip name of script */
2067 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2070 if (argv[0][1] == '-') {
2074 if (s = strchr(argv[0], '=')) {
2076 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2079 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2082 toptarget = NEWSV(0,0);
2083 sv_upgrade(toptarget, SVt_PVFM);
2084 sv_setpvn(toptarget, "", 0);
2085 bodytarget = NEWSV(0,0);
2086 sv_upgrade(bodytarget, SVt_PVFM);
2087 sv_setpvn(bodytarget, "", 0);
2088 formtarget = bodytarget;
2091 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2092 sv_setpv(GvSV(tmpgv),origfilename);
2093 magicname("0", "0", 1);
2095 if (tmpgv = gv_fetchpv("\024",TRUE, SVt_PV))
2097 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2098 sv_setpv(GvSV(tmpgv),origargv[0]);
2099 if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2101 (void)gv_AVadd(argvgv);
2102 av_clear(GvAVn(argvgv));
2103 for (; argc > 0; argc--,argv++) {
2104 av_push(GvAVn(argvgv),newSVpv(argv[0],0));
2107 if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2112 #ifndef VMS /* VMS doesn't have environ array */
2113 /* Note that if the supplied env parameter is actually a copy
2114 of the global environ then it may now point to free'd memory
2115 if the environment has been modified since. To avoid this
2116 problem we treat env==NULL as meaning 'use the default'
2120 if (env != environ) {
2121 environ[0] = Nullch;
2122 hv_magic(hv, envgv, 'E');
2124 for (; *env; env++) {
2125 if (!(s = strchr(*env,'=')))
2128 sv = newSVpv(s--,0);
2129 sv_magic(sv, sv, 'e', *env, s - *env);
2130 (void)hv_store(hv, *env, s - *env, sv, 0);
2134 #ifdef DYNAMIC_ENV_FETCH
2135 HvNAME(hv) = savepv(ENV_HV_NAME);
2137 hv_magic(hv, envgv, 'E');
2140 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2141 sv_setiv(GvSV(tmpgv),(I32)getpid());
2150 s = getenv("PERL5LIB");
2154 incpush(getenv("PERLLIB"));
2156 /* Treat PERL5?LIB as a possible search list logical name -- the
2157 * "natural" VMS idiom for a Unix path string. We allow each
2158 * element to be a set of |-separated directories for compatibility.
2162 if (my_trnlnm("PERL5LIB",buf,0))
2163 do { incpush(buf); } while (my_trnlnm("PERL5LIB",buf,++idx));
2165 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf);
2169 /* Use the ~-expanded versions of APPLIB (undocumented),
2170 ARCHLIB PRIVLIB SITEARCH SITELIB and OLDARCHLIB
2173 incpush(APPLLIB_EXP);
2177 incpush(ARCHLIB_EXP);
2180 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2182 incpush(PRIVLIB_EXP);
2185 incpush(SITEARCH_EXP);
2188 incpush(SITELIB_EXP);
2190 #ifdef OLDARCHLIB_EXP /* 5.00[01] compatibility */
2191 incpush(OLDARCHLIB_EXP);
2204 line_t oldline = curcop->cop_line;
2206 Copy(top_env, oldtop, 1, Sigjmp_buf);
2208 while (AvFILL(list) >= 0) {
2209 CV *cv = (CV*)av_shift(list);
2213 switch (Sigsetjmp(top_env,1)) {
2215 SV* atsv = GvSV(errgv);
2217 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
2218 (void)SvPV(atsv, len);
2220 Copy(oldtop, top_env, 1, Sigjmp_buf);
2221 curcop = &compiling;
2222 curcop->cop_line = oldline;
2223 if (list == beginav)
2224 sv_catpv(atsv, "BEGIN failed--compilation aborted");
2226 sv_catpv(atsv, "END failed--cleanup aborted");
2227 croak("%s", SvPVX(atsv));
2233 statusvalue = 255; /* XXX I don't think we use 1 anymore. */
2239 /* my_exit() was called */
2240 curstash = defstash;
2244 Copy(oldtop, top_env, 1, Sigjmp_buf);
2245 curcop = &compiling;
2246 curcop->cop_line = oldline;
2248 if (list == beginav)
2249 croak("BEGIN failed--compilation aborted");
2251 croak("END failed--cleanup aborted");
2253 my_exit(statusvalue);
2258 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
2262 Copy(oldtop, top_env, 1, Sigjmp_buf);
2263 curcop = &compiling;
2264 curcop->cop_line = oldline;
2265 Siglongjmp(top_env, 3);
2269 Copy(oldtop, top_env, 1, Sigjmp_buf);