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 dEXTCONST 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);
120 perl_destruct_level = 1;
125 SET_NUMERIC_STANDARD();
126 #if defined(SUBVERSION) && SUBVERSION > 0
127 sprintf(patchlevel, "%7.5f", (double) 5
128 + ((double) PATCHLEVEL / (double) 1000)
129 + ((double) SUBVERSION / (double) 100000));
131 sprintf(patchlevel, "%5.3f", (double) 5 +
132 ((double) PATCHLEVEL / (double) 1000));
135 #if defined(LOCAL_PATCH_COUNT)
136 localpatches = local_patches; /* For possible -v */
139 PerlIO_init(); /* Hook to IO system */
141 fdpid = newAV(); /* for remembering popen pids by fd */
142 pidstatus = newHV();/* for remembering status of dead pids */
149 perl_destruct(sv_interp)
150 register PerlInterpreter *sv_interp;
152 int destruct_level; /* 0=none, 1=full, 2=full with checks */
156 if (!(curinterp = sv_interp))
159 destruct_level = perl_destruct_level;
163 if (s = getenv("PERL_DESTRUCT_LEVEL")) {
165 if (destruct_level < i)
171 /* unhook hooks which will soon be, or use, destroyed data */
172 SvREFCNT_dec(warnhook);
174 SvREFCNT_dec(diehook);
176 SvREFCNT_dec(parsehook);
182 /* We must account for everything. First the syntax tree. */
184 curpad = AvARRAY(comppad);
190 * Try to destruct global references. We do this first so that the
191 * destructors and destructees still exist. Some sv's might remain.
192 * Non-referenced objects are on their own.
199 if (destruct_level == 0){
201 DEBUG_P(debprofdump());
203 /* The exit() function will do everything that needs doing. */
207 /* loosen bonds of global variables */
222 /* Prepare to destruct main symbol table. */
229 if (destruct_level >= 2) {
230 if (scopestack_ix != 0)
231 warn("Unbalanced scopes: %d more ENTERs than LEAVEs\n", scopestack_ix);
232 if (savestack_ix != 0)
233 warn("Unbalanced saves: %d more saves than restores\n", savestack_ix);
234 if (tmps_floor != -1)
235 warn("Unbalanced tmps: %d more allocs than frees\n", tmps_floor + 1);
236 if (cxstack_ix != -1)
237 warn("Unbalanced context: %d more PUSHes than POPs\n", cxstack_ix + 1);
240 /* Now absolutely destruct everything, somehow or other, loops or no. */
242 SvFLAGS(strtab) |= SVTYPEMASK; /* don't clean out strtab now */
243 while (sv_count != 0 && sv_count != last_sv_count) {
244 last_sv_count = sv_count;
247 SvFLAGS(strtab) &= ~SVTYPEMASK;
248 SvFLAGS(strtab) |= SVt_PVHV;
250 /* Destruct the global string table. */
252 /* Yell and reset the HeVAL() slots that are still holding refcounts,
253 * so that sv_free() won't fail on them.
262 array = HvARRAY(strtab);
266 warn("Unbalanced string table refcount: (%d) for \"%s\"",
267 HeVAL(hent) - Nullsv, HeKEY(hent));
268 HeVAL(hent) = Nullsv;
278 SvREFCNT_dec(strtab);
281 warn("Scalars leaked: %d\n", sv_count);
285 linestr = NULL; /* No SVs have survived, need to clean out */
287 Safefree(origfilename);
289 hints = 0; /* Reset hints. Should hints be per-interpreter ? */
291 DEBUG_P(debprofdump());
296 PerlInterpreter *sv_interp;
298 if (!(curinterp = sv_interp))
302 #if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE)
303 char *getenv _((char *)); /* Usually in <stdlib.h> */
307 perl_parse(sv_interp, xsinit, argc, argv, env)
308 PerlInterpreter *sv_interp;
309 void (*xsinit)_((void));
316 char *scriptname = NULL;
317 VOL bool dosearch = FALSE;
321 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
324 croak("suidperl is no longer needed since the kernel can now execute\n\
325 setuid perl scripts securely.\n");
329 if (!(curinterp = sv_interp))
332 #if defined(NeXT) && defined(__DYNAMIC__)
333 _dyld_lookup_and_bind
334 ("__environ", (unsigned long *) &environ_pointer, NULL);
339 #ifndef VMS /* VMS doesn't have environ array */
340 origenviron = environ;
346 /* Come here if running an undumped a.out. */
348 origfilename = savepv(argv[0]);
350 cxstack_ix = -1; /* start label stack again */
352 init_postdump_symbols(argc,argv,env);
360 switch (Sigsetjmp(top_env,1)) {
371 return(statusvalue); /* my_exit() was called */
373 PerlIO_printf(PerlIO_stderr(), "panic: top_env\n");
377 sv_setpvn(linestr,"",0);
378 sv = newSVpv("",0); /* first used for -I flags */
381 for (argc--,argv++; argc > 0; argc--,argv++) {
382 if (argv[0][0] != '-' || !argv[0][1])
386 validarg = " PHOOEY ";
412 if (s = moreswitches(s))
417 if (euid != uid || egid != gid)
418 croak("No -e allowed in setuid scripts");
420 e_tmpname = savepv(TMPPATH);
421 (void)mktemp(e_tmpname);
423 croak("Can't mktemp()");
424 e_fp = PerlIO_open(e_tmpname,"w");
426 croak("Cannot open temporary file");
431 PerlIO_puts(e_fp,argv[1]);
435 croak("No code specified for -e");
436 (void)PerlIO_putc(e_fp,'\n');
444 av_push(GvAVn(incgv),newSVpv(s,0));
447 av_push(GvAVn(incgv),newSVpv(argv[1],0));
448 sv_catpv(sv,argv[1]);
465 preambleav = newAV();
466 av_push(preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
468 Sv = newSVpv("print myconfig();",0);
470 sv_catpv(Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
472 sv_catpv(Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
474 #if defined(DEBUGGING) || defined(NOEMBED) || defined(MULTIPLICITY)
475 strcpy(buf,"\" Compile-time options:");
477 strcat(buf," DEBUGGING");
480 strcat(buf," NOEMBED");
483 strcat(buf," MULTIPLICITY");
485 strcat(buf,"\\n\",");
488 #if defined(LOCAL_PATCH_COUNT)
489 if (LOCAL_PATCH_COUNT > 0)
491 sv_catpv(Sv,"print \" Locally applied patches:\\n\",");
492 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
493 if (localpatches[i]) {
494 sprintf(buf,"\" \\t%s\\n\",",localpatches[i]);
500 sprintf(buf,"\" Built under %s\\n\",",OSNAME);
504 sprintf(buf,"\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
506 sprintf(buf,"\" Compiled on %s\\n\"",__DATE__);
510 sv_catpv(Sv,"; $\"=\"\\n \"; print \" \\@INC:\\n @INC\\n\"");
513 Sv = newSVpv("config_vars(qw(",0);
518 av_push(preambleav, Sv);
519 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
533 croak("Unrecognized switch: -%s",s);
538 scriptname = argv[0];
540 if (PerlIO_flush(e_fp) || PerlIO_error(e_fp) || PerlIO_close(e_fp))
541 croak("Can't write to temp file for -e: %s", Strerror(errno));
544 scriptname = e_tmpname;
546 else if (scriptname == Nullch) {
548 if ( isatty(PerlIO_fileno(PerlIO_stdin())) )
556 open_script(scriptname,dosearch,sv);
558 validate_suid(validarg, scriptname);
563 compcv = (CV*)NEWSV(1104,0);
564 sv_upgrade((SV *)compcv, SVt_PVCV);
567 av_push(comppad, Nullsv);
568 curpad = AvARRAY(comppad);
569 comppad_name = newAV();
570 comppad_name_fill = 0;
571 min_intro_pending = 0;
574 comppadlist = newAV();
575 AvREAL_off(comppadlist);
576 av_store(comppadlist, 0, (SV*)comppad_name);
577 av_store(comppadlist, 1, (SV*)comppad);
578 CvPADLIST(compcv) = comppadlist;
580 boot_core_UNIVERSAL();
582 (*xsinit)(); /* in case linked C routines want magical variables */
587 init_predump_symbols();
589 init_postdump_symbols(argc,argv,env);
593 /* now parse the script */
596 if (yyparse() || error_count) {
598 croak("%s had compilation errors.\n", origfilename);
600 croak("Execution of %s aborted due to compilation errors.\n",
604 curcop->cop_line = 0;
608 (void)UNLINK(e_tmpname);
613 /* now that script is parsed, we can modify record separator */
615 rs = SvREFCNT_inc(nrs);
616 sv_setsv(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), rs);
627 #ifdef DEBUGGING_MSTATS
628 if ((s=getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
629 dump_mstats("after compilation:");
639 PerlInterpreter *sv_interp;
641 if (!(curinterp = sv_interp))
643 switch (Sigsetjmp(top_env,1)) {
645 cxstack_ix = -1; /* start context stack again */
652 #ifdef DEBUGGING_MSTATS
653 if (getenv("PERL_DEBUG_MSTATS"))
654 dump_mstats("after execution: ");
656 return(statusvalue); /* my_exit() was called */
659 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
663 if (curstack != mainstack) {
665 SWITCHSTACK(curstack, mainstack);
670 DEBUG_r(PerlIO_printf(PerlIO_stderr(), "%s $` $& $' support.\n",
671 sawampersand ? "Enabling" : "Omitting"));
675 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
678 PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", origfilename);
681 if (perldb && DBsingle)
682 sv_setiv(DBsingle, 1);
692 else if (main_start) {
705 register CONTEXT *cx;
709 statusvalue = FIXSTATUS(status);
710 if (cxstack_ix >= 0) {
716 Siglongjmp(top_env, 2);
720 perl_get_sv(name, create)
724 GV* gv = gv_fetchpv(name, create, SVt_PV);
731 perl_get_av(name, create)
735 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
744 perl_get_hv(name, create)
748 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
757 perl_get_cv(name, create)
761 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
762 if (create && !GvCV(gv))
763 return newSUB(start_subparse(),
764 newSVOP(OP_CONST, 0, newSVpv(name,0)),
772 /* Be sure to refetch the stack pointer after calling these routines. */
775 perl_call_argv(subname, flags, argv)
777 I32 flags; /* See G_* flags in cop.h */
778 register char **argv; /* null terminated arg list */
785 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
790 return perl_call_pv(subname, flags);
794 perl_call_pv(subname, flags)
795 char *subname; /* name of the subroutine */
796 I32 flags; /* See G_* flags in cop.h */
798 return perl_call_sv((SV*)perl_get_cv(subname, TRUE), flags);
802 perl_call_method(methname, flags)
803 char *methname; /* name of the subroutine */
804 I32 flags; /* See G_* flags in cop.h */
810 XPUSHs(sv_2mortal(newSVpv(methname,0)));
813 return perl_call_sv(*stack_sp--, flags);
816 /* May be called with any of a CV, a GV, or an SV containing the name. */
818 perl_call_sv(sv, flags)
820 I32 flags; /* See G_* flags in cop.h */
822 LOGOP myop; /* fake syntax tree node */
824 I32 oldmark = TOPMARK;
830 if (flags & G_DISCARD) {
840 oldscope = scopestack_ix;
842 if (!(flags & G_NOARGS))
843 myop.op_flags = OPf_STACKED;
844 myop.op_next = Nullop;
845 myop.op_flags |= OPf_KNOW;
847 myop.op_flags |= OPf_LIST;
849 if (perldb && curstash != debstash
850 /* Handle first BEGIN of -d. */
851 && (DBcv || (DBcv = GvCV(DBsub)))
852 /* Try harder, since this may have been a sighandler, thus
853 * curstash may be meaningless. */
854 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != debstash))
855 op->op_private |= OPpENTERSUB_DB;
857 if (flags & G_EVAL) {
858 Copy(top_env, oldtop, 1, Sigjmp_buf);
860 cLOGOP->op_other = op;
862 /* we're trying to emulate pp_entertry() here */
864 register CONTEXT *cx;
870 push_return(op->op_next);
871 PUSHBLOCK(cx, CXt_EVAL, stack_sp);
873 eval_root = op; /* Only needed so that goto works right. */
876 if (flags & G_KEEPERR)
879 sv_setpv(GvSV(errgv),"");
884 switch (Sigsetjmp(top_env,1)) {
889 statusvalue = 255; /* XXX I don't think we use 1 anymore. */
895 /* my_exit() was called */
898 Copy(oldtop, top_env, 1, Sigjmp_buf);
900 croak("Callback called exit");
901 my_exit(statusvalue);
909 stack_sp = stack_base + oldmark;
914 *++stack_sp = &sv_undef;
920 if (op == (OP*)&myop)
924 retval = stack_sp - (stack_base + oldmark);
925 if ((flags & G_EVAL) && !(flags & G_KEEPERR))
926 sv_setpv(GvSV(errgv),"");
929 if (flags & G_EVAL) {
930 if (scopestack_ix > oldscope) {
934 register CONTEXT *cx;
943 Copy(oldtop, top_env, 1, Sigjmp_buf);
945 if (flags & G_DISCARD) {
946 stack_sp = stack_base + oldmark;
954 /* Eval a string. The G_EVAL flag is always assumed. */
957 perl_eval_sv(sv, flags)
959 I32 flags; /* See G_* flags in cop.h */
961 UNOP myop; /* fake syntax tree node */
963 I32 oldmark = sp - stack_base;
968 if (flags & G_DISCARD) {
978 oldscope = scopestack_ix;
980 if (!(flags & G_NOARGS))
981 myop.op_flags = OPf_STACKED;
982 myop.op_next = Nullop;
983 myop.op_type = OP_ENTEREVAL;
984 myop.op_flags |= OPf_KNOW;
985 if (flags & G_KEEPERR)
986 myop.op_flags |= OPf_SPECIAL;
988 myop.op_flags |= OPf_LIST;
990 Copy(top_env, oldtop, 1, Sigjmp_buf);
993 switch (Sigsetjmp(top_env,1)) {
998 statusvalue = 255; /* XXX I don't think we use 1 anymore. */
1004 /* my_exit() was called */
1005 curstash = defstash;
1007 Copy(oldtop, top_env, 1, Sigjmp_buf);
1009 croak("Callback called exit");
1010 my_exit(statusvalue);
1018 stack_sp = stack_base + oldmark;
1019 if (flags & G_ARRAY)
1023 *++stack_sp = &sv_undef;
1028 if (op == (OP*)&myop)
1029 op = pp_entereval();
1032 retval = stack_sp - (stack_base + oldmark);
1033 if (!(flags & G_KEEPERR))
1034 sv_setpv(GvSV(errgv),"");
1037 Copy(oldtop, top_env, 1, Sigjmp_buf);
1038 if (flags & G_DISCARD) {
1039 stack_sp = stack_base + oldmark;
1047 /* Require a module. */
1053 SV* sv = sv_newmortal();
1054 sv_setpv(sv, "require '");
1057 perl_eval_sv(sv, G_DISCARD);
1061 magicname(sym,name,namlen)
1068 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1069 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1073 # define PERLLIB_SEP ';'
1076 # define PERLLIB_SEP '|'
1078 # define PERLLIB_SEP ':'
1081 #ifndef PERLLIB_MANGLE
1082 # define PERLLIB_MANGLE(s,n) (s)
1094 /* Break at all separators */
1096 /* First, skip any consecutive separators */
1097 while ( *p == PERLLIB_SEP ) {
1098 /* Uncomment the next line for PATH semantics */
1099 /* av_push(GvAVn(incgv), newSVpv(".", 1)); */
1102 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
1103 av_push(GvAVn(incgv), newSVpv(PERLLIB_MANGLE(p, (STRLEN)(s - p)),
1107 av_push(GvAVn(incgv), newSVpv(PERLLIB_MANGLE(p, 0), 0));
1114 usage(name) /* XXX move this out into a module ? */
1117 /* This message really ought to be max 23 lines.
1118 * Removed -h because the user already knows that opton. Others? */
1119 printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1120 printf("\n -0[octal] specify record separator (\\0, if no argument)");
1121 printf("\n -a autosplit mode with -n or -p (splits $_ into @F)");
1122 printf("\n -c check syntax only (runs BEGIN and END blocks)");
1123 printf("\n -d[:debugger] run scripts under debugger");
1124 printf("\n -D[number/list] set debugging flags (argument is a bit mask or flags)");
1125 printf("\n -e 'command' one line of script. Several -e's allowed. Omit [programfile].");
1126 printf("\n -F/pattern/ split() pattern for autosplit (-a). The //'s are optional.");
1127 printf("\n -i[extension] edit <> files in place (make backup if extension supplied)");
1128 printf("\n -Idirectory specify @INC/#include directory (may be used more then once)");
1129 printf("\n -l[octal] enable line ending processing, specifies line teminator");
1130 printf("\n -[mM][-]module.. executes `use/no module...' before executing your script.");
1131 printf("\n -n assume 'while (<>) { ... }' loop arround your script");
1132 printf("\n -p assume loop like -n but print line also like sed");
1133 printf("\n -P run script through C preprocessor before compilation");
1134 printf("\n -s enable some switch parsing for switches after script name");
1135 printf("\n -S look for the script using PATH environment variable");
1136 printf("\n -T turn on tainting checks");
1137 printf("\n -u dump core after parsing script");
1138 printf("\n -U allow unsafe operations");
1139 printf("\n -v print version number and patchlevel of perl");
1140 printf("\n -V[:variable] print perl configuration information");
1141 printf("\n -w TURN WARNINGS ON FOR COMPILATION OF YOUR SCRIPT.");
1142 printf("\n -x[directory] strip off text before #!perl line and perhaps cd to directory\n");
1145 /* This routine handles any switches that can be given during run */
1156 rschar = scan_oct(s, 4, &numlen);
1158 if (rschar & ~((U8)~0))
1160 else if (!rschar && numlen >= 2)
1161 nrs = newSVpv("", 0);
1164 nrs = newSVpv(&ch, 1);
1169 splitstr = savepv(s + 1);
1183 if (*s == ':' || *s == '=') {
1184 sprintf(buf, "use Devel::%s;", ++s);
1186 my_setenv("PERL5DB",buf);
1196 if (isALPHA(s[1])) {
1197 static char debopts[] = "psltocPmfrxuLHXD";
1200 for (s++; *s && (d = strchr(debopts,*s)); s++)
1201 debug |= 1 << (d - debopts);
1205 for (s++; isDIGIT(*s); s++) ;
1207 debug |= 0x80000000;
1209 warn("Recompile perl with -DDEBUGGING to use -D switch\n");
1210 for (s++; isALNUM(*s); s++) ;
1220 inplace = savepv(s+1);
1222 for (s = inplace; *s && !isSPACE(*s); s++) ;
1229 for (e = s; *e && !isSPACE(*e); e++) ;
1230 av_push(GvAVn(incgv),newSVpv(s,e-s));
1235 croak("No space allowed after -I");
1245 *ors = scan_oct(s, 3 + (*s == '0'), &numlen);
1254 ors = SvPV(nrs, orslen);
1255 ors = savepvn(ors, orslen);
1259 forbid_setid("-M"); /* XXX ? */
1262 forbid_setid("-m"); /* XXX ? */
1266 /* -M-foo == 'no foo' */
1267 if (*s == '-') { use = "no "; ++s; }
1268 Sv = newSVpv(use,0);
1270 /* We allow -M'Module qw(Foo Bar)' */
1271 while(isALNUM(*s) || *s==':') ++s;
1273 sv_catpv(Sv, start);
1274 if (*(start-1) == 'm') {
1276 croak("Can't use '%c' after -mname", *s);
1277 sv_catpv( Sv, " ()");
1280 sv_catpvn(Sv, start, s-start);
1281 sv_catpv(Sv, " split(/,/,q{");
1286 if (preambleav == NULL)
1287 preambleav = newAV();
1288 av_push(preambleav, Sv);
1291 croak("No space allowed after -%c", *(s-1));
1319 #if defined(SUBVERSION) && SUBVERSION > 0
1320 printf("\nThis is perl, version 5.%03d_%02d", PATCHLEVEL, SUBVERSION);
1322 printf("\nThis is perl, version %s",patchlevel);
1325 printf("\n\nCopyright 1987-1996, Larry Wall\n");
1326 printf("\n\t+ suidperl security patch");
1328 printf("\n\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1331 printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
1334 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1335 "Version 5 port Copyright (c) 1994-1996, Andreas Kaiser, Ilya Zakharevich\n");
1338 printf("atariST series port, ++jrb bammi@cadence.com\n");
1341 Perl may be copied only under the terms of either the Artistic License or the\n\
1342 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n");
1350 if (s[1] == '-') /* Additional switches on #! line. */
1363 croak("Can't emulate -%.1s on #! line",s);
1368 /* compliments of Tom Christiansen */
1370 /* unexec() can be found in the Gnu emacs distribution */
1379 sprintf (buf, "%s.perldump", origfilename);
1380 sprintf (tokenbuf, "%s/perl", BIN);
1382 status = unexec(buf, tokenbuf, &etext, sbrk(0), 0);
1384 PerlIO_printf(PerlIO_stderr(), "unexec of %s into %s failed!\n", tokenbuf, buf);
1388 # include <lib$routines.h>
1389 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
1391 ABORT(); /* for use with undump */
1401 /* Note that strtab is a rather special HV. Assumptions are made
1402 about not iterating on it, and not adding tie magic to it.
1403 It is properly deallocated in perl_destruct() */
1405 HvSHAREKEYS_off(strtab); /* mandatory */
1406 Newz(506,((XPVHV*)SvANY(strtab))->xhv_array,
1407 sizeof(HE*) * (((XPVHV*)SvANY(strtab))->xhv_max + 1), char);
1409 curstash = defstash = newHV();
1410 curstname = newSVpv("main",4);
1411 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1412 SvREFCNT_dec(GvHV(gv));
1413 GvHV(gv) = (HV*)SvREFCNT_inc(defstash);
1415 HvNAME(defstash) = savepv("main");
1416 incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1418 defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1419 errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1421 sv_setpvn(GvSV(errgv), "", 0);
1422 curstash = defstash;
1423 compiling.cop_stash = defstash;
1424 debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
1425 /* We must init $/ before switches are processed. */
1426 sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1);
1429 #ifdef CAN_PROTOTYPE
1431 open_script(char *scriptname, bool dosearch, SV *sv)
1434 open_script(scriptname,dosearch,sv)
1440 char *xfound = Nullch;
1441 char *xfailed = Nullch;
1445 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
1446 #define SEARCH_EXTS ".bat", ".cmd", NULL
1449 # define SEARCH_EXTS ".pl", ".com", NULL
1451 /* additional extensions to try in each dir if scriptname not found */
1453 char *ext[] = { SEARCH_EXTS };
1454 int extidx = (strchr(scriptname,'.')) ? -1 : 0; /* has ext already */
1459 int hasdir, idx = 0, deftypes = 1;
1461 hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
1462 /* The first time through, just add SEARCH_EXTS to whatever we
1463 * already have, so we can check for default file types. */
1464 while (deftypes || (!hasdir && my_trnlnm("DCL$PATH",tokenbuf,idx++)) ) {
1465 if (deftypes) { deftypes = 0; *tokenbuf = '\0'; }
1466 strcat(tokenbuf,scriptname);
1468 if (dosearch && !strchr(scriptname, '/') && (s = getenv("PATH"))) {
1470 bufend = s + strlen(s);
1473 s = cpytill(tokenbuf,s,bufend,':',&len);
1476 for (len = 0; *s && *s != ',' && *s != ';'; tokenbuf[len++] = *s++);
1477 tokenbuf[len] = '\0';
1479 for (len = 0; *s && *s != ';'; tokenbuf[len++] = *s++);
1480 tokenbuf[len] = '\0';
1486 if (len && tokenbuf[len-1] != '/')
1489 if (len && ((tokenbuf[len-1] != '\\') && (tokenbuf[len-1] != '/')))
1491 if (len && tokenbuf[len-1] != '\\')
1494 (void)strcat(tokenbuf+len,"/");
1495 (void)strcat(tokenbuf+len,scriptname);
1499 len = strlen(tokenbuf);
1500 if (extidx > 0) /* reset after previous loop */
1504 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tokenbuf));
1505 retval = Stat(tokenbuf,&statbuf);
1507 } while ( retval < 0 /* not there */
1508 && extidx>=0 && ext[extidx] /* try an extension? */
1509 && strcpy(tokenbuf+len, ext[extidx++])
1514 if (S_ISREG(statbuf.st_mode)
1515 && cando(S_IRUSR,TRUE,&statbuf) && cando(S_IXUSR,TRUE,&statbuf)) {
1516 xfound = tokenbuf; /* bingo! */
1520 xfailed = savepv(tokenbuf);
1523 croak("Can't execute %s", xfailed ? xfailed : scriptname );
1526 scriptname = xfound;
1529 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
1530 char *s = scriptname + 8;
1539 origfilename = savepv(e_tmpname ? "-e" : scriptname);
1540 curcop->cop_filegv = gv_fetchfile(origfilename);
1541 if (strEQ(origfilename,"-"))
1543 if (fdscript >= 0) {
1544 rsfp = PerlIO_fdopen(fdscript,"r");
1545 #if defined(HAS_FCNTL) && defined(F_SETFD)
1547 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
1550 else if (preprocess) {
1551 char *cpp = CPPSTDIN;
1553 if (strEQ(cpp,"cppstdin"))
1554 sprintf(tokenbuf, "%s/%s", SCRIPTDIR, cpp);
1556 sprintf(tokenbuf, "%s", cpp);
1558 sv_catpv(sv,PRIVLIB_EXP);
1560 (void)sprintf(buf, "\
1561 sed %s -e \"/^[^#]/b\" \
1562 -e \"/^#[ ]*include[ ]/b\" \
1563 -e \"/^#[ ]*define[ ]/b\" \
1564 -e \"/^#[ ]*if[ ]/b\" \
1565 -e \"/^#[ ]*ifdef[ ]/b\" \
1566 -e \"/^#[ ]*ifndef[ ]/b\" \
1567 -e \"/^#[ ]*else/b\" \
1568 -e \"/^#[ ]*elif[ ]/b\" \
1569 -e \"/^#[ ]*undef[ ]/b\" \
1570 -e \"/^#[ ]*endif/b\" \
1573 (doextract ? "-e \"1,/^#/d\n\"" : ""),
1575 (void)sprintf(buf, "\
1576 %s %s -e '/^[^#]/b' \
1577 -e '/^#[ ]*include[ ]/b' \
1578 -e '/^#[ ]*define[ ]/b' \
1579 -e '/^#[ ]*if[ ]/b' \
1580 -e '/^#[ ]*ifdef[ ]/b' \
1581 -e '/^#[ ]*ifndef[ ]/b' \
1582 -e '/^#[ ]*else/b' \
1583 -e '/^#[ ]*elif[ ]/b' \
1584 -e '/^#[ ]*undef[ ]/b' \
1585 -e '/^#[ ]*endif/b' \
1593 (doextract ? "-e '1,/^#/d\n'" : ""),
1595 scriptname, tokenbuf, SvPV(sv, na), CPPMINUS);
1597 #ifdef IAMSUID /* actually, this is caught earlier */
1598 if (euid != uid && !euid) { /* if running suidperl */
1600 (void)seteuid(uid); /* musn't stay setuid root */
1603 (void)setreuid((Uid_t)-1, uid);
1605 #ifdef HAS_SETRESUID
1606 (void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
1612 if (geteuid() != uid)
1613 croak("Can't do seteuid!\n");
1615 #endif /* IAMSUID */
1616 rsfp = my_popen(buf,"r");
1618 else if (!*scriptname) {
1619 forbid_setid("program input from stdin");
1620 rsfp = PerlIO_stdin();
1623 rsfp = PerlIO_open(scriptname,"r");
1624 #if defined(HAS_FCNTL) && defined(F_SETFD)
1626 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
1634 #ifndef IAMSUID /* in case script is not readable before setuid */
1635 if (euid && Stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
1636 statbuf.st_mode & (S_ISUID|S_ISGID)) {
1637 (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
1638 execv(buf, origargv); /* try again */
1639 croak("Can't do setuid\n");
1643 croak("Can't open perl script \"%s\": %s\n",
1644 SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno));
1649 validate_suid(validarg, scriptname)
1655 /* do we need to emulate setuid on scripts? */
1657 /* This code is for those BSD systems that have setuid #! scripts disabled
1658 * in the kernel because of a security problem. Merely defining DOSUID
1659 * in perl will not fix that problem, but if you have disabled setuid
1660 * scripts in the kernel, this will attempt to emulate setuid and setgid
1661 * on scripts that have those now-otherwise-useless bits set. The setuid
1662 * root version must be called suidperl or sperlN.NNN. If regular perl
1663 * discovers that it has opened a setuid script, it calls suidperl with
1664 * the same argv that it had. If suidperl finds that the script it has
1665 * just opened is NOT setuid root, it sets the effective uid back to the
1666 * uid. We don't just make perl setuid root because that loses the
1667 * effective uid we had before invoking perl, if it was different from the
1670 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
1671 * be defined in suidperl only. suidperl must be setuid root. The
1672 * Configure script will set this up for you if you want it.
1678 if (Fstat(PerlIO_fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
1679 croak("Can't stat script \"%s\"",origfilename);
1680 if (fdscript < 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) {
1684 #ifndef HAS_SETREUID
1685 /* On this access check to make sure the directories are readable,
1686 * there is actually a small window that the user could use to make
1687 * filename point to an accessible directory. So there is a faint
1688 * chance that someone could execute a setuid script down in a
1689 * non-accessible directory. I don't know what to do about that.
1690 * But I don't think it's too important. The manual lies when
1691 * it says access() is useful in setuid programs.
1693 if (access(SvPVX(GvSV(curcop->cop_filegv)),1)) /*double check*/
1694 croak("Permission denied");
1696 /* If we can swap euid and uid, then we can determine access rights
1697 * with a simple stat of the file, and then compare device and
1698 * inode to make sure we did stat() on the same file we opened.
1699 * Then we just have to make sure he or she can execute it.
1702 struct stat tmpstatbuf;
1706 setreuid(euid,uid) < 0
1709 setresuid(euid,uid,(Uid_t)-1) < 0
1712 || getuid() != euid || geteuid() != uid)
1713 croak("Can't swap uid and euid"); /* really paranoid */
1714 if (Stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
1715 croak("Permission denied"); /* testing full pathname here */
1716 if (tmpstatbuf.st_dev != statbuf.st_dev ||
1717 tmpstatbuf.st_ino != statbuf.st_ino) {
1718 (void)PerlIO_close(rsfp);
1719 if (rsfp = my_popen("/bin/mail root","w")) { /* heh, heh */
1721 "User %d tried to run dev %d ino %d in place of dev %d ino %d!\n\
1722 (Filename of set-id script was %s, uid %d gid %d.)\n\nSincerely,\nperl\n",
1723 uid,tmpstatbuf.st_dev, tmpstatbuf.st_ino,
1724 statbuf.st_dev, statbuf.st_ino,
1725 SvPVX(GvSV(curcop->cop_filegv)),
1726 statbuf.st_uid, statbuf.st_gid);
1727 (void)my_pclose(rsfp);
1729 croak("Permission denied\n");
1733 setreuid(uid,euid) < 0
1735 # if defined(HAS_SETRESUID)
1736 setresuid(uid,euid,(Uid_t)-1) < 0
1739 || getuid() != uid || geteuid() != euid)
1740 croak("Can't reswap uid and euid");
1741 if (!cando(S_IXUSR,FALSE,&statbuf)) /* can real uid exec? */
1742 croak("Permission denied\n");
1744 #endif /* HAS_SETREUID */
1745 #endif /* IAMSUID */
1747 if (!S_ISREG(statbuf.st_mode))
1748 croak("Permission denied");
1749 if (statbuf.st_mode & S_IWOTH)
1750 croak("Setuid/gid script is writable by world");
1751 doswitches = FALSE; /* -s is insecure in suid */
1753 if (sv_gets(linestr, rsfp, 0) == Nullch ||
1754 strnNE(SvPV(linestr,na),"#!",2) ) /* required even on Sys V */
1755 croak("No #! line");
1756 s = SvPV(linestr,na)+2;
1758 while (!isSPACE(*s)) s++;
1759 for (s2 = s; (s2 > SvPV(linestr,na)+2 &&
1760 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
1761 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
1762 croak("Not a perl script");
1763 while (*s == ' ' || *s == '\t') s++;
1765 * #! arg must be what we saw above. They can invoke it by
1766 * mentioning suidperl explicitly, but they may not add any strange
1767 * arguments beyond what #! says if they do invoke suidperl that way.
1769 len = strlen(validarg);
1770 if (strEQ(validarg," PHOOEY ") ||
1771 strnNE(s,validarg,len) || !isSPACE(s[len]))
1772 croak("Args must match #! line");
1775 if (euid != uid && (statbuf.st_mode & S_ISUID) &&
1776 euid == statbuf.st_uid)
1778 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
1779 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
1780 #endif /* IAMSUID */
1782 if (euid) { /* oops, we're not the setuid root perl */
1783 (void)PerlIO_close(rsfp);
1785 (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
1786 execv(buf, origargv); /* try again */
1788 croak("Can't do setuid\n");
1791 if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
1793 (void)setegid(statbuf.st_gid);
1796 (void)setregid((Gid_t)-1,statbuf.st_gid);
1798 #ifdef HAS_SETRESGID
1799 (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
1801 setgid(statbuf.st_gid);
1805 if (getegid() != statbuf.st_gid)
1806 croak("Can't do setegid!\n");
1808 if (statbuf.st_mode & S_ISUID) {
1809 if (statbuf.st_uid != euid)
1811 (void)seteuid(statbuf.st_uid); /* all that for this */
1814 (void)setreuid((Uid_t)-1,statbuf.st_uid);
1816 #ifdef HAS_SETRESUID
1817 (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
1819 setuid(statbuf.st_uid);
1823 if (geteuid() != statbuf.st_uid)
1824 croak("Can't do seteuid!\n");
1826 else if (uid) { /* oops, mustn't run as root */
1828 (void)seteuid((Uid_t)uid);
1831 (void)setreuid((Uid_t)-1,(Uid_t)uid);
1833 #ifdef HAS_SETRESUID
1834 (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
1840 if (geteuid() != uid)
1841 croak("Can't do seteuid!\n");
1844 if (!cando(S_IXUSR,TRUE,&statbuf))
1845 croak("Permission denied\n"); /* they can't do this */
1848 else if (preprocess)
1849 croak("-P not allowed for setuid/setgid script\n");
1850 else if (fdscript >= 0)
1851 croak("fd script not allowed in suidperl\n");
1853 croak("Script is not setuid/setgid in suidperl\n");
1855 /* We absolutely must clear out any saved ids here, so we */
1856 /* exec the real perl, substituting fd script for scriptname. */
1857 /* (We pass script name as "subdir" of fd, which perl will grok.) */
1858 PerlIO_rewind(rsfp);
1859 lseek(PerlIO_fileno(rsfp),(Off_t)0,0); /* just in case rewind didn't */
1860 for (which = 1; origargv[which] && origargv[which] != scriptname; which++) ;
1861 if (!origargv[which])
1862 croak("Permission denied");
1863 (void)sprintf(buf, "/dev/fd/%d/%.127s", PerlIO_fileno(rsfp), origargv[which]);
1864 origargv[which] = buf;
1866 #if defined(HAS_FCNTL) && defined(F_SETFD)
1867 fcntl(PerlIO_fileno(rsfp),F_SETFD,0); /* ensure no close-on-exec */
1870 (void)sprintf(tokenbuf, "%s/perl%s", BIN, patchlevel);
1871 execv(tokenbuf, origargv); /* try again */
1872 croak("Can't do setuid\n");
1873 #endif /* IAMSUID */
1875 if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */
1876 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
1877 Fstat(PerlIO_fileno(rsfp),&statbuf); /* may be either wrapped or real suid */
1878 if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
1880 (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
1883 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
1884 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
1885 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
1886 /* not set-id, must be wrapped */
1894 register char *s, *s2;
1896 /* skip forward in input to the real script? */
1900 if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
1901 croak("No Perl script found in input\n");
1902 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
1903 PerlIO_ungetc(rsfp, '\n'); /* to keep line count right */
1905 while (*s && !(isSPACE (*s) || *s == '#')) s++;
1907 while (*s == ' ' || *s == '\t') s++;
1909 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
1910 if (strnEQ(s2-4,"perl",4))
1912 while (s = moreswitches(s)) ;
1914 if (cddir && chdir(cddir) < 0)
1915 croak("Can't chdir to %s",cddir);
1923 uid = (int)getuid();
1924 euid = (int)geteuid();
1925 gid = (int)getgid();
1926 egid = (int)getegid();
1931 tainting |= (uid && (euid != uid || egid != gid));
1939 croak("No %s allowed while running setuid", s);
1941 croak("No %s allowed while running setgid", s);
1947 curstash = debstash;
1948 dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
1950 DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
1951 DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
1952 DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
1953 DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
1954 sv_setiv(DBsingle, 0);
1955 DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
1956 sv_setiv(DBtrace, 0);
1957 DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
1958 sv_setiv(DBsignal, 0);
1959 curstash = defstash;
1966 mainstack = curstack; /* remember in case we switch stacks */
1967 AvREAL_off(curstack); /* not a real array */
1968 av_extend(curstack,127);
1970 stack_base = AvARRAY(curstack);
1971 stack_sp = stack_base;
1972 stack_max = stack_base + 127;
1974 cxstack_max = 8192 / sizeof(CONTEXT) - 2; /* Use most of 8K. */
1975 New(50,cxstack,cxstack_max + 1,CONTEXT);
1978 New(50,tmps_stack,128,SV*);
1983 New(51,debname,128,char);
1984 New(52,debdelim,128,char);
1988 * The following stacks almost certainly should be per-interpreter,
1989 * but for now they're not. XXX
1993 markstack_ptr = markstack;
1995 New(54,markstack,64,I32);
1996 markstack_ptr = markstack;
1997 markstack_max = markstack + 64;
2003 New(54,scopestack,32,I32);
2005 scopestack_max = 32;
2011 New(54,savestack,128,ANY);
2013 savestack_max = 128;
2019 New(54,retstack,16,OP*);
2029 Safefree(tmps_stack);
2036 static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
2044 subname = newSVpv("main",4);
2048 init_predump_symbols()
2053 sv_setpvn(GvSV(gv_fetchpv("\"", TRUE, SVt_PV)), " ", 1);
2055 stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2056 GvMULTI_on(stdingv);
2057 IoIFP(GvIOp(stdingv)) = PerlIO_stdin();
2058 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2060 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv));
2062 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2064 IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
2066 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2068 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv));
2070 othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2071 GvMULTI_on(othergv);
2072 IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr();
2073 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2075 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
2077 statname = NEWSV(66,0); /* last filename we did stat on */
2080 osname = savepv(OSNAME);
2084 init_postdump_symbols(argc,argv,env)
2086 register char **argv;
2087 register char **env;
2093 argc--,argv++; /* skip name of script */
2095 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2098 if (argv[0][1] == '-') {
2102 if (s = strchr(argv[0], '=')) {
2104 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2107 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2110 toptarget = NEWSV(0,0);
2111 sv_upgrade(toptarget, SVt_PVFM);
2112 sv_setpvn(toptarget, "", 0);
2113 bodytarget = NEWSV(0,0);
2114 sv_upgrade(bodytarget, SVt_PVFM);
2115 sv_setpvn(bodytarget, "", 0);
2116 formtarget = bodytarget;
2119 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2120 sv_setpv(GvSV(tmpgv),origfilename);
2121 magicname("0", "0", 1);
2123 if (tmpgv = gv_fetchpv("\024",TRUE, SVt_PV))
2125 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2126 sv_setpv(GvSV(tmpgv),origargv[0]);
2127 if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2129 (void)gv_AVadd(argvgv);
2130 av_clear(GvAVn(argvgv));
2131 for (; argc > 0; argc--,argv++) {
2132 av_push(GvAVn(argvgv),newSVpv(argv[0],0));
2135 if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2140 #ifndef VMS /* VMS doesn't have environ array */
2141 /* Note that if the supplied env parameter is actually a copy
2142 of the global environ then it may now point to free'd memory
2143 if the environment has been modified since. To avoid this
2144 problem we treat env==NULL as meaning 'use the default'
2148 if (env != environ) {
2149 environ[0] = Nullch;
2150 hv_magic(hv, envgv, 'E');
2152 for (; *env; env++) {
2153 if (!(s = strchr(*env,'=')))
2156 sv = newSVpv(s--,0);
2157 sv_magic(sv, sv, 'e', *env, s - *env);
2158 (void)hv_store(hv, *env, s - *env, sv, 0);
2162 #ifdef DYNAMIC_ENV_FETCH
2163 HvNAME(hv) = savepv(ENV_HV_NAME);
2165 hv_magic(hv, envgv, 'E');
2168 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2169 sv_setiv(GvSV(tmpgv),(I32)getpid());
2178 s = getenv("PERL5LIB");
2182 incpush(getenv("PERLLIB"));
2184 /* Treat PERL5?LIB as a possible search list logical name -- the
2185 * "natural" VMS idiom for a Unix path string. We allow each
2186 * element to be a set of |-separated directories for compatibility.
2190 if (my_trnlnm("PERL5LIB",buf,0))
2191 do { incpush(buf); } while (my_trnlnm("PERL5LIB",buf,++idx));
2193 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf);
2197 /* Use the ~-expanded versions of APPLIB (undocumented),
2198 ARCHLIB PRIVLIB SITEARCH SITELIB and OLDARCHLIB
2201 incpush(APPLLIB_EXP);
2205 incpush(ARCHLIB_EXP);
2208 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2210 incpush(PRIVLIB_EXP);
2213 incpush(SITEARCH_EXP);
2216 incpush(SITELIB_EXP);
2218 #ifdef OLDARCHLIB_EXP /* 5.00[01] compatibility */
2219 incpush(OLDARCHLIB_EXP);
2232 line_t oldline = curcop->cop_line;
2234 Copy(top_env, oldtop, 1, Sigjmp_buf);
2236 while (AvFILL(list) >= 0) {
2237 CV *cv = (CV*)av_shift(list);
2241 switch (Sigsetjmp(top_env,1)) {
2243 SV* atsv = GvSV(errgv);
2245 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
2246 (void)SvPV(atsv, len);
2248 Copy(oldtop, top_env, 1, Sigjmp_buf);
2249 curcop = &compiling;
2250 curcop->cop_line = oldline;
2251 if (list == beginav)
2252 sv_catpv(atsv, "BEGIN failed--compilation aborted");
2254 sv_catpv(atsv, "END failed--cleanup aborted");
2255 croak("%s", SvPVX(atsv));
2261 statusvalue = 255; /* XXX I don't think we use 1 anymore. */
2267 /* my_exit() was called */
2268 curstash = defstash;
2272 Copy(oldtop, top_env, 1, Sigjmp_buf);
2273 curcop = &compiling;
2274 curcop->cop_line = oldline;
2276 if (list == beginav)
2277 croak("BEGIN failed--compilation aborted");
2279 croak("END failed--cleanup aborted");
2281 my_exit(statusvalue);
2286 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
2290 Copy(oldtop, top_env, 1, Sigjmp_buf);
2291 curcop = &compiling;
2292 curcop->cop_line = oldline;
2293 Siglongjmp(top_env, 3);
2297 Copy(oldtop, top_env, 1, Sigjmp_buf);