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)
1522 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
1525 else if (preprocess) {
1526 char *cpp = CPPSTDIN;
1528 if (strEQ(cpp,"cppstdin"))
1529 sprintf(tokenbuf, "%s/%s", SCRIPTDIR, cpp);
1531 sprintf(tokenbuf, "%s", cpp);
1533 sv_catpv(sv,PRIVLIB_EXP);
1535 (void)sprintf(buf, "\
1536 sed %s -e \"/^[^#]/b\" \
1537 -e \"/^#[ ]*include[ ]/b\" \
1538 -e \"/^#[ ]*define[ ]/b\" \
1539 -e \"/^#[ ]*if[ ]/b\" \
1540 -e \"/^#[ ]*ifdef[ ]/b\" \
1541 -e \"/^#[ ]*ifndef[ ]/b\" \
1542 -e \"/^#[ ]*else/b\" \
1543 -e \"/^#[ ]*elif[ ]/b\" \
1544 -e \"/^#[ ]*undef[ ]/b\" \
1545 -e \"/^#[ ]*endif/b\" \
1548 (doextract ? "-e \"1,/^#/d\n\"" : ""),
1550 (void)sprintf(buf, "\
1551 %s %s -e '/^[^#]/b' \
1552 -e '/^#[ ]*include[ ]/b' \
1553 -e '/^#[ ]*define[ ]/b' \
1554 -e '/^#[ ]*if[ ]/b' \
1555 -e '/^#[ ]*ifdef[ ]/b' \
1556 -e '/^#[ ]*ifndef[ ]/b' \
1557 -e '/^#[ ]*else/b' \
1558 -e '/^#[ ]*elif[ ]/b' \
1559 -e '/^#[ ]*undef[ ]/b' \
1560 -e '/^#[ ]*endif/b' \
1568 (doextract ? "-e '1,/^#/d\n'" : ""),
1570 scriptname, tokenbuf, SvPV(sv, na), CPPMINUS);
1572 #ifdef IAMSUID /* actually, this is caught earlier */
1573 if (euid != uid && !euid) { /* if running suidperl */
1575 (void)seteuid(uid); /* musn't stay setuid root */
1578 (void)setreuid((Uid_t)-1, uid);
1580 #ifdef HAS_SETRESUID
1581 (void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
1587 if (geteuid() != uid)
1588 croak("Can't do seteuid!\n");
1590 #endif /* IAMSUID */
1591 rsfp = my_popen(buf,"r");
1593 else if (!*scriptname) {
1594 forbid_setid("program input from stdin");
1595 rsfp = PerlIO_stdin();
1598 rsfp = PerlIO_open(scriptname,"r");
1599 #if defined(HAS_FCNTL) && defined(F_SETFD)
1600 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
1606 if ((PerlIO*)rsfp == Nullfp) {
1608 #ifndef IAMSUID /* in case script is not readable before setuid */
1609 if (euid && Stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
1610 statbuf.st_mode & (S_ISUID|S_ISGID)) {
1611 (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
1612 execv(buf, origargv); /* try again */
1613 croak("Can't do setuid\n");
1617 croak("Can't open perl script \"%s\": %s\n",
1618 SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno));
1623 validate_suid(validarg, scriptname)
1629 /* do we need to emulate setuid on scripts? */
1631 /* This code is for those BSD systems that have setuid #! scripts disabled
1632 * in the kernel because of a security problem. Merely defining DOSUID
1633 * in perl will not fix that problem, but if you have disabled setuid
1634 * scripts in the kernel, this will attempt to emulate setuid and setgid
1635 * on scripts that have those now-otherwise-useless bits set. The setuid
1636 * root version must be called suidperl or sperlN.NNN. If regular perl
1637 * discovers that it has opened a setuid script, it calls suidperl with
1638 * the same argv that it had. If suidperl finds that the script it has
1639 * just opened is NOT setuid root, it sets the effective uid back to the
1640 * uid. We don't just make perl setuid root because that loses the
1641 * effective uid we had before invoking perl, if it was different from the
1644 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
1645 * be defined in suidperl only. suidperl must be setuid root. The
1646 * Configure script will set this up for you if you want it.
1652 if (Fstat(PerlIO_fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
1653 croak("Can't stat script \"%s\"",origfilename);
1654 if (fdscript < 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) {
1658 #ifndef HAS_SETREUID
1659 /* On this access check to make sure the directories are readable,
1660 * there is actually a small window that the user could use to make
1661 * filename point to an accessible directory. So there is a faint
1662 * chance that someone could execute a setuid script down in a
1663 * non-accessible directory. I don't know what to do about that.
1664 * But I don't think it's too important. The manual lies when
1665 * it says access() is useful in setuid programs.
1667 if (access(SvPVX(GvSV(curcop->cop_filegv)),1)) /*double check*/
1668 croak("Permission denied");
1670 /* If we can swap euid and uid, then we can determine access rights
1671 * with a simple stat of the file, and then compare device and
1672 * inode to make sure we did stat() on the same file we opened.
1673 * Then we just have to make sure he or she can execute it.
1676 struct stat tmpstatbuf;
1680 setreuid(euid,uid) < 0
1683 setresuid(euid,uid,(Uid_t)-1) < 0
1686 || getuid() != euid || geteuid() != uid)
1687 croak("Can't swap uid and euid"); /* really paranoid */
1688 if (Stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
1689 croak("Permission denied"); /* testing full pathname here */
1690 if (tmpstatbuf.st_dev != statbuf.st_dev ||
1691 tmpstatbuf.st_ino != statbuf.st_ino) {
1692 (void)PerlIO_close(rsfp);
1693 if (rsfp = my_popen("/bin/mail root","w")) { /* heh, heh */
1695 "User %d tried to run dev %d ino %d in place of dev %d ino %d!\n\
1696 (Filename of set-id script was %s, uid %d gid %d.)\n\nSincerely,\nperl\n",
1697 uid,tmpstatbuf.st_dev, tmpstatbuf.st_ino,
1698 statbuf.st_dev, statbuf.st_ino,
1699 SvPVX(GvSV(curcop->cop_filegv)),
1700 statbuf.st_uid, statbuf.st_gid);
1701 (void)my_pclose(rsfp);
1703 croak("Permission denied\n");
1707 setreuid(uid,euid) < 0
1709 # if defined(HAS_SETRESUID)
1710 setresuid(uid,euid,(Uid_t)-1) < 0
1713 || getuid() != uid || geteuid() != euid)
1714 croak("Can't reswap uid and euid");
1715 if (!cando(S_IXUSR,FALSE,&statbuf)) /* can real uid exec? */
1716 croak("Permission denied\n");
1718 #endif /* HAS_SETREUID */
1719 #endif /* IAMSUID */
1721 if (!S_ISREG(statbuf.st_mode))
1722 croak("Permission denied");
1723 if (statbuf.st_mode & S_IWOTH)
1724 croak("Setuid/gid script is writable by world");
1725 doswitches = FALSE; /* -s is insecure in suid */
1727 if (sv_gets(linestr, rsfp, 0) == Nullch ||
1728 strnNE(SvPV(linestr,na),"#!",2) ) /* required even on Sys V */
1729 croak("No #! line");
1730 s = SvPV(linestr,na)+2;
1732 while (!isSPACE(*s)) s++;
1733 for (s2 = s; (s2 > SvPV(linestr,na)+2 &&
1734 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
1735 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
1736 croak("Not a perl script");
1737 while (*s == ' ' || *s == '\t') s++;
1739 * #! arg must be what we saw above. They can invoke it by
1740 * mentioning suidperl explicitly, but they may not add any strange
1741 * arguments beyond what #! says if they do invoke suidperl that way.
1743 len = strlen(validarg);
1744 if (strEQ(validarg," PHOOEY ") ||
1745 strnNE(s,validarg,len) || !isSPACE(s[len]))
1746 croak("Args must match #! line");
1749 if (euid != uid && (statbuf.st_mode & S_ISUID) &&
1750 euid == statbuf.st_uid)
1752 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
1753 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
1754 #endif /* IAMSUID */
1756 if (euid) { /* oops, we're not the setuid root perl */
1757 (void)PerlIO_close(rsfp);
1759 (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
1760 execv(buf, origargv); /* try again */
1762 croak("Can't do setuid\n");
1765 if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
1767 (void)setegid(statbuf.st_gid);
1770 (void)setregid((Gid_t)-1,statbuf.st_gid);
1772 #ifdef HAS_SETRESGID
1773 (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
1775 setgid(statbuf.st_gid);
1779 if (getegid() != statbuf.st_gid)
1780 croak("Can't do setegid!\n");
1782 if (statbuf.st_mode & S_ISUID) {
1783 if (statbuf.st_uid != euid)
1785 (void)seteuid(statbuf.st_uid); /* all that for this */
1788 (void)setreuid((Uid_t)-1,statbuf.st_uid);
1790 #ifdef HAS_SETRESUID
1791 (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
1793 setuid(statbuf.st_uid);
1797 if (geteuid() != statbuf.st_uid)
1798 croak("Can't do seteuid!\n");
1800 else if (uid) { /* oops, mustn't run as root */
1802 (void)seteuid((Uid_t)uid);
1805 (void)setreuid((Uid_t)-1,(Uid_t)uid);
1807 #ifdef HAS_SETRESUID
1808 (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
1814 if (geteuid() != uid)
1815 croak("Can't do seteuid!\n");
1818 if (!cando(S_IXUSR,TRUE,&statbuf))
1819 croak("Permission denied\n"); /* they can't do this */
1822 else if (preprocess)
1823 croak("-P not allowed for setuid/setgid script\n");
1824 else if (fdscript >= 0)
1825 croak("fd script not allowed in suidperl\n");
1827 croak("Script is not setuid/setgid in suidperl\n");
1829 /* We absolutely must clear out any saved ids here, so we */
1830 /* exec the real perl, substituting fd script for scriptname. */
1831 /* (We pass script name as "subdir" of fd, which perl will grok.) */
1832 PerlIO_rewind(rsfp);
1833 lseek(PerlIO_fileno(rsfp),(Off_t)0,0); /* just in case rewind didn't */
1834 for (which = 1; origargv[which] && origargv[which] != scriptname; which++) ;
1835 if (!origargv[which])
1836 croak("Permission denied");
1837 (void)sprintf(buf, "/dev/fd/%d/%.127s", PerlIO_fileno(rsfp), origargv[which]);
1838 origargv[which] = buf;
1840 #if defined(HAS_FCNTL) && defined(F_SETFD)
1841 fcntl(PerlIO_fileno(rsfp),F_SETFD,0); /* ensure no close-on-exec */
1844 (void)sprintf(tokenbuf, "%s/perl%s", BIN, patchlevel);
1845 execv(tokenbuf, origargv); /* try again */
1846 croak("Can't do setuid\n");
1847 #endif /* IAMSUID */
1849 if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */
1850 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
1851 Fstat(PerlIO_fileno(rsfp),&statbuf); /* may be either wrapped or real suid */
1852 if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
1854 (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
1857 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
1858 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
1859 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
1860 /* not set-id, must be wrapped */
1868 register char *s, *s2;
1870 /* skip forward in input to the real script? */
1874 if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
1875 croak("No Perl script found in input\n");
1876 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
1877 PerlIO_ungetc(rsfp, '\n'); /* to keep line count right */
1879 while (*s && !(isSPACE (*s) || *s == '#')) s++;
1881 while (*s == ' ' || *s == '\t') s++;
1883 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
1884 if (strnEQ(s2-4,"perl",4))
1886 while (s = moreswitches(s)) ;
1888 if (cddir && chdir(cddir) < 0)
1889 croak("Can't chdir to %s",cddir);
1897 uid = (int)getuid();
1898 euid = (int)geteuid();
1899 gid = (int)getgid();
1900 egid = (int)getegid();
1905 tainting |= (uid && (euid != uid || egid != gid));
1913 croak("No %s allowed while running setuid", s);
1915 croak("No %s allowed while running setgid", s);
1921 curstash = debstash;
1922 dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
1924 DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
1925 DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
1926 DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
1927 DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
1928 sv_setiv(DBsingle, 0);
1929 DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
1930 sv_setiv(DBtrace, 0);
1931 DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
1932 sv_setiv(DBsignal, 0);
1933 curstash = defstash;
1940 mainstack = curstack; /* remember in case we switch stacks */
1941 AvREAL_off(curstack); /* not a real array */
1942 av_extend(curstack,127);
1944 stack_base = AvARRAY(curstack);
1945 stack_sp = stack_base;
1946 stack_max = stack_base + 127;
1948 /* Shouldn't these stacks be per-interpreter? */
1950 markstack_ptr = markstack;
1952 New(54,markstack,64,I32);
1953 markstack_ptr = markstack;
1954 markstack_max = markstack + 64;
1960 New(54,scopestack,32,I32);
1962 scopestack_max = 32;
1968 New(54,savestack,128,ANY);
1970 savestack_max = 128;
1976 New(54,retstack,16,OP*);
1981 cxstack_max = 8192 / sizeof(CONTEXT) - 2; /* Use most of 8K. */
1982 New(50,cxstack,cxstack_max + 1,CONTEXT);
1985 New(50,tmps_stack,128,SV*);
1990 New(51,debname,128,char);
1991 New(52,debdelim,128,char);
1999 Safefree(tmps_stack);
2002 static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
2010 subname = newSVpv("main",4);
2014 init_predump_symbols()
2019 sv_setpvn(GvSV(gv_fetchpv("\"", TRUE, SVt_PV)), " ", 1);
2021 stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2022 GvMULTI_on(stdingv);
2023 IoIFP(GvIOp(stdingv)) = PerlIO_stdin();
2024 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2026 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv));
2028 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2030 IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
2032 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2034 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv));
2036 othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2037 GvMULTI_on(othergv);
2038 IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr();
2039 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2041 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
2043 statname = NEWSV(66,0); /* last filename we did stat on */
2046 osname = savepv(OSNAME);
2050 init_postdump_symbols(argc,argv,env)
2052 register char **argv;
2053 register char **env;
2059 argc--,argv++; /* skip name of script */
2061 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2064 if (argv[0][1] == '-') {
2068 if (s = strchr(argv[0], '=')) {
2070 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2073 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2076 toptarget = NEWSV(0,0);
2077 sv_upgrade(toptarget, SVt_PVFM);
2078 sv_setpvn(toptarget, "", 0);
2079 bodytarget = NEWSV(0,0);
2080 sv_upgrade(bodytarget, SVt_PVFM);
2081 sv_setpvn(bodytarget, "", 0);
2082 formtarget = bodytarget;
2085 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2086 sv_setpv(GvSV(tmpgv),origfilename);
2087 magicname("0", "0", 1);
2089 if (tmpgv = gv_fetchpv("\024",TRUE, SVt_PV))
2091 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2092 sv_setpv(GvSV(tmpgv),origargv[0]);
2093 if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2095 (void)gv_AVadd(argvgv);
2096 av_clear(GvAVn(argvgv));
2097 for (; argc > 0; argc--,argv++) {
2098 av_push(GvAVn(argvgv),newSVpv(argv[0],0));
2101 if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2106 #ifndef VMS /* VMS doesn't have environ array */
2107 /* Note that if the supplied env parameter is actually a copy
2108 of the global environ then it may now point to free'd memory
2109 if the environment has been modified since. To avoid this
2110 problem we treat env==NULL as meaning 'use the default'
2114 if (env != environ) {
2115 environ[0] = Nullch;
2116 hv_magic(hv, envgv, 'E');
2118 for (; *env; env++) {
2119 if (!(s = strchr(*env,'=')))
2122 sv = newSVpv(s--,0);
2123 sv_magic(sv, sv, 'e', *env, s - *env);
2124 (void)hv_store(hv, *env, s - *env, sv, 0);
2128 #ifdef DYNAMIC_ENV_FETCH
2129 HvNAME(hv) = savepv(ENV_HV_NAME);
2131 hv_magic(hv, envgv, 'E');
2134 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2135 sv_setiv(GvSV(tmpgv),(I32)getpid());
2144 s = getenv("PERL5LIB");
2148 incpush(getenv("PERLLIB"));
2150 /* Treat PERL5?LIB as a possible search list logical name -- the
2151 * "natural" VMS idiom for a Unix path string. We allow each
2152 * element to be a set of |-separated directories for compatibility.
2156 if (my_trnlnm("PERL5LIB",buf,0))
2157 do { incpush(buf); } while (my_trnlnm("PERL5LIB",buf,++idx));
2159 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf);
2163 /* Use the ~-expanded versions of APPLIB (undocumented),
2164 ARCHLIB PRIVLIB SITEARCH SITELIB and OLDARCHLIB
2167 incpush(APPLLIB_EXP);
2171 incpush(ARCHLIB_EXP);
2174 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2176 incpush(PRIVLIB_EXP);
2179 incpush(SITEARCH_EXP);
2182 incpush(SITELIB_EXP);
2184 #ifdef OLDARCHLIB_EXP /* 5.00[01] compatibility */
2185 incpush(OLDARCHLIB_EXP);
2198 line_t oldline = curcop->cop_line;
2200 Copy(top_env, oldtop, 1, Sigjmp_buf);
2202 while (AvFILL(list) >= 0) {
2203 CV *cv = (CV*)av_shift(list);
2207 switch (Sigsetjmp(top_env,1)) {
2209 SV* atsv = GvSV(errgv);
2211 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
2212 (void)SvPV(atsv, len);
2214 Copy(oldtop, top_env, 1, Sigjmp_buf);
2215 curcop = &compiling;
2216 curcop->cop_line = oldline;
2217 if (list == beginav)
2218 sv_catpv(atsv, "BEGIN failed--compilation aborted");
2220 sv_catpv(atsv, "END failed--cleanup aborted");
2221 croak("%s", SvPVX(atsv));
2227 statusvalue = 255; /* XXX I don't think we use 1 anymore. */
2233 /* my_exit() was called */
2234 curstash = defstash;
2238 Copy(oldtop, top_env, 1, Sigjmp_buf);
2239 curcop = &compiling;
2240 curcop->cop_line = oldline;
2242 if (list == beginav)
2243 croak("BEGIN failed--compilation aborted");
2245 croak("END failed--cleanup aborted");
2247 my_exit(statusvalue);
2252 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
2256 Copy(oldtop, top_env, 1, Sigjmp_buf);
2257 curcop = &compiling;
2258 curcop->cop_line = oldline;
2259 Siglongjmp(top_env, 3);
2263 Copy(oldtop, top_env, 1, Sigjmp_buf);