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);
568 av_push(comppad, Nullsv);
569 curpad = AvARRAY(comppad);
570 comppad_name = newAV();
571 comppad_name_fill = 0;
572 min_intro_pending = 0;
575 comppadlist = newAV();
576 AvREAL_off(comppadlist);
577 av_store(comppadlist, 0, (SV*)comppad_name);
578 av_store(comppadlist, 1, (SV*)comppad);
579 CvPADLIST(compcv) = comppadlist;
581 boot_core_UNIVERSAL();
583 (*xsinit)(); /* in case linked C routines want magical variables */
588 init_predump_symbols();
590 init_postdump_symbols(argc,argv,env);
594 /* now parse the script */
597 if (yyparse() || error_count) {
599 croak("%s had compilation errors.\n", origfilename);
601 croak("Execution of %s aborted due to compilation errors.\n",
605 curcop->cop_line = 0;
609 (void)UNLINK(e_tmpname);
614 /* now that script is parsed, we can modify record separator */
616 rs = SvREFCNT_inc(nrs);
617 sv_setsv(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), rs);
628 #ifdef DEBUGGING_MSTATS
629 if ((s=getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
630 dump_mstats("after compilation:");
640 PerlInterpreter *sv_interp;
642 if (!(curinterp = sv_interp))
644 switch (Sigsetjmp(top_env,1)) {
646 cxstack_ix = -1; /* start context stack again */
653 #ifdef DEBUGGING_MSTATS
654 if (getenv("PERL_DEBUG_MSTATS"))
655 dump_mstats("after execution: ");
657 return(statusvalue); /* my_exit() was called */
660 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
664 if (curstack != mainstack) {
666 SWITCHSTACK(curstack, mainstack);
671 DEBUG_r(PerlIO_printf(PerlIO_stderr(), "%s $` $& $' support.\n",
672 sawampersand ? "Enabling" : "Omitting"));
676 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
679 PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", origfilename);
682 if (perldb && DBsingle)
683 sv_setiv(DBsingle, 1);
693 else if (main_start) {
706 register CONTEXT *cx;
710 statusvalue = FIXSTATUS(status);
711 if (cxstack_ix >= 0) {
717 Siglongjmp(top_env, 2);
721 perl_get_sv(name, create)
725 GV* gv = gv_fetchpv(name, create, SVt_PV);
732 perl_get_av(name, create)
736 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
745 perl_get_hv(name, create)
749 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
758 perl_get_cv(name, create)
762 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
763 if (create && !GvCV(gv))
764 return newSUB(start_subparse(),
765 newSVOP(OP_CONST, 0, newSVpv(name,0)),
773 /* Be sure to refetch the stack pointer after calling these routines. */
776 perl_call_argv(subname, flags, argv)
778 I32 flags; /* See G_* flags in cop.h */
779 register char **argv; /* null terminated arg list */
786 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
791 return perl_call_pv(subname, flags);
795 perl_call_pv(subname, flags)
796 char *subname; /* name of the subroutine */
797 I32 flags; /* See G_* flags in cop.h */
799 return perl_call_sv((SV*)perl_get_cv(subname, TRUE), flags);
803 perl_call_method(methname, flags)
804 char *methname; /* name of the subroutine */
805 I32 flags; /* See G_* flags in cop.h */
811 XPUSHs(sv_2mortal(newSVpv(methname,0)));
814 return perl_call_sv(*stack_sp--, flags);
817 /* May be called with any of a CV, a GV, or an SV containing the name. */
819 perl_call_sv(sv, flags)
821 I32 flags; /* See G_* flags in cop.h */
823 LOGOP myop; /* fake syntax tree node */
825 I32 oldmark = TOPMARK;
831 if (flags & G_DISCARD) {
841 oldscope = scopestack_ix;
843 if (!(flags & G_NOARGS))
844 myop.op_flags = OPf_STACKED;
845 myop.op_next = Nullop;
846 myop.op_flags |= OPf_KNOW;
848 myop.op_flags |= OPf_LIST;
850 if (perldb && curstash != debstash
851 /* Handle first BEGIN of -d. */
852 && (DBcv || (DBcv = GvCV(DBsub)))
853 /* Try harder, since this may have been a sighandler, thus
854 * curstash may be meaningless. */
855 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != debstash))
856 op->op_private |= OPpENTERSUB_DB;
858 if (flags & G_EVAL) {
859 Copy(top_env, oldtop, 1, Sigjmp_buf);
861 cLOGOP->op_other = op;
863 /* we're trying to emulate pp_entertry() here */
865 register CONTEXT *cx;
871 push_return(op->op_next);
872 PUSHBLOCK(cx, CXt_EVAL, stack_sp);
874 eval_root = op; /* Only needed so that goto works right. */
877 if (flags & G_KEEPERR)
880 sv_setpv(GvSV(errgv),"");
885 switch (Sigsetjmp(top_env,1)) {
890 statusvalue = 255; /* XXX I don't think we use 1 anymore. */
896 /* my_exit() was called */
899 Copy(oldtop, top_env, 1, Sigjmp_buf);
901 croak("Callback called exit");
902 my_exit(statusvalue);
910 stack_sp = stack_base + oldmark;
915 *++stack_sp = &sv_undef;
921 if (op == (OP*)&myop)
925 retval = stack_sp - (stack_base + oldmark);
926 if ((flags & G_EVAL) && !(flags & G_KEEPERR))
927 sv_setpv(GvSV(errgv),"");
930 if (flags & G_EVAL) {
931 if (scopestack_ix > oldscope) {
935 register CONTEXT *cx;
944 Copy(oldtop, top_env, 1, Sigjmp_buf);
946 if (flags & G_DISCARD) {
947 stack_sp = stack_base + oldmark;
955 /* Eval a string. The G_EVAL flag is always assumed. */
958 perl_eval_sv(sv, flags)
960 I32 flags; /* See G_* flags in cop.h */
962 UNOP myop; /* fake syntax tree node */
964 I32 oldmark = sp - stack_base;
969 if (flags & G_DISCARD) {
979 oldscope = scopestack_ix;
981 if (!(flags & G_NOARGS))
982 myop.op_flags = OPf_STACKED;
983 myop.op_next = Nullop;
984 myop.op_type = OP_ENTEREVAL;
985 myop.op_flags |= OPf_KNOW;
986 if (flags & G_KEEPERR)
987 myop.op_flags |= OPf_SPECIAL;
989 myop.op_flags |= OPf_LIST;
991 Copy(top_env, oldtop, 1, Sigjmp_buf);
994 switch (Sigsetjmp(top_env,1)) {
999 statusvalue = 255; /* XXX I don't think we use 1 anymore. */
1005 /* my_exit() was called */
1006 curstash = defstash;
1008 Copy(oldtop, top_env, 1, Sigjmp_buf);
1010 croak("Callback called exit");
1011 my_exit(statusvalue);
1019 stack_sp = stack_base + oldmark;
1020 if (flags & G_ARRAY)
1024 *++stack_sp = &sv_undef;
1029 if (op == (OP*)&myop)
1030 op = pp_entereval();
1033 retval = stack_sp - (stack_base + oldmark);
1034 if (!(flags & G_KEEPERR))
1035 sv_setpv(GvSV(errgv),"");
1038 Copy(oldtop, top_env, 1, Sigjmp_buf);
1039 if (flags & G_DISCARD) {
1040 stack_sp = stack_base + oldmark;
1048 /* Require a module. */
1054 SV* sv = sv_newmortal();
1055 sv_setpv(sv, "require '");
1058 perl_eval_sv(sv, G_DISCARD);
1062 magicname(sym,name,namlen)
1069 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1070 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1074 # define PERLLIB_SEP ';'
1077 # define PERLLIB_SEP '|'
1079 # define PERLLIB_SEP ':'
1082 #ifndef PERLLIB_MANGLE
1083 # define PERLLIB_MANGLE(s,n) (s)
1095 /* Break at all separators */
1097 /* First, skip any consecutive separators */
1098 while ( *p == PERLLIB_SEP ) {
1099 /* Uncomment the next line for PATH semantics */
1100 /* av_push(GvAVn(incgv), newSVpv(".", 1)); */
1103 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
1104 av_push(GvAVn(incgv), newSVpv(PERLLIB_MANGLE(p, (STRLEN)(s - p)),
1108 av_push(GvAVn(incgv), newSVpv(PERLLIB_MANGLE(p, 0), 0));
1115 usage(name) /* XXX move this out into a module ? */
1118 /* This message really ought to be max 23 lines.
1119 * Removed -h because the user already knows that opton. Others? */
1120 printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1121 printf("\n -0[octal] specify record separator (\\0, if no argument)");
1122 printf("\n -a autosplit mode with -n or -p (splits $_ into @F)");
1123 printf("\n -c check syntax only (runs BEGIN and END blocks)");
1124 printf("\n -d[:debugger] run scripts under debugger");
1125 printf("\n -D[number/list] set debugging flags (argument is a bit mask or flags)");
1126 printf("\n -e 'command' one line of script. Several -e's allowed. Omit [programfile].");
1127 printf("\n -F/pattern/ split() pattern for autosplit (-a). The //'s are optional.");
1128 printf("\n -i[extension] edit <> files in place (make backup if extension supplied)");
1129 printf("\n -Idirectory specify @INC/#include directory (may be used more then once)");
1130 printf("\n -l[octal] enable line ending processing, specifies line teminator");
1131 printf("\n -[mM][-]module.. executes `use/no module...' before executing your script.");
1132 printf("\n -n assume 'while (<>) { ... }' loop arround your script");
1133 printf("\n -p assume loop like -n but print line also like sed");
1134 printf("\n -P run script through C preprocessor before compilation");
1135 printf("\n -s enable some switch parsing for switches after script name");
1136 printf("\n -S look for the script using PATH environment variable");
1137 printf("\n -T turn on tainting checks");
1138 printf("\n -u dump core after parsing script");
1139 printf("\n -U allow unsafe operations");
1140 printf("\n -v print version number and patchlevel of perl");
1141 printf("\n -V[:variable] print perl configuration information");
1142 printf("\n -w TURN WARNINGS ON FOR COMPILATION OF YOUR SCRIPT.");
1143 printf("\n -x[directory] strip off text before #!perl line and perhaps cd to directory\n");
1146 /* This routine handles any switches that can be given during run */
1157 rschar = scan_oct(s, 4, &numlen);
1159 if (rschar & ~((U8)~0))
1161 else if (!rschar && numlen >= 2)
1162 nrs = newSVpv("", 0);
1165 nrs = newSVpv(&ch, 1);
1170 splitstr = savepv(s + 1);
1184 if (*s == ':' || *s == '=') {
1185 sprintf(buf, "use Devel::%s;", ++s);
1187 my_setenv("PERL5DB",buf);
1197 if (isALPHA(s[1])) {
1198 static char debopts[] = "psltocPmfrxuLHXD";
1201 for (s++; *s && (d = strchr(debopts,*s)); s++)
1202 debug |= 1 << (d - debopts);
1206 for (s++; isDIGIT(*s); s++) ;
1208 debug |= 0x80000000;
1210 warn("Recompile perl with -DDEBUGGING to use -D switch\n");
1211 for (s++; isALNUM(*s); s++) ;
1221 inplace = savepv(s+1);
1223 for (s = inplace; *s && !isSPACE(*s); s++) ;
1230 for (e = s; *e && !isSPACE(*e); e++) ;
1231 av_push(GvAVn(incgv),newSVpv(s,e-s));
1236 croak("No space allowed after -I");
1246 *ors = scan_oct(s, 3 + (*s == '0'), &numlen);
1255 ors = SvPV(nrs, orslen);
1256 ors = savepvn(ors, orslen);
1260 forbid_setid("-M"); /* XXX ? */
1263 forbid_setid("-m"); /* XXX ? */
1267 /* -M-foo == 'no foo' */
1268 if (*s == '-') { use = "no "; ++s; }
1269 Sv = newSVpv(use,0);
1271 /* We allow -M'Module qw(Foo Bar)' */
1272 while(isALNUM(*s) || *s==':') ++s;
1274 sv_catpv(Sv, start);
1275 if (*(start-1) == 'm') {
1277 croak("Can't use '%c' after -mname", *s);
1278 sv_catpv( Sv, " ()");
1281 sv_catpvn(Sv, start, s-start);
1282 sv_catpv(Sv, " split(/,/,q{");
1287 if (preambleav == NULL)
1288 preambleav = newAV();
1289 av_push(preambleav, Sv);
1292 croak("No space allowed after -%c", *(s-1));
1320 #if defined(SUBVERSION) && SUBVERSION > 0
1321 printf("\nThis is perl, version 5.%03d_%02d", PATCHLEVEL, SUBVERSION);
1323 printf("\nThis is perl, version %s",patchlevel);
1326 printf("\n\nCopyright 1987-1996, Larry Wall\n");
1327 printf("\n\t+ suidperl security patch");
1329 printf("\n\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1332 printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
1335 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1336 "Version 5 port Copyright (c) 1994-1996, Andreas Kaiser, Ilya Zakharevich\n");
1339 printf("atariST series port, ++jrb bammi@cadence.com\n");
1342 Perl may be copied only under the terms of either the Artistic License or the\n\
1343 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n");
1351 if (s[1] == '-') /* Additional switches on #! line. */
1364 croak("Can't emulate -%.1s on #! line",s);
1369 /* compliments of Tom Christiansen */
1371 /* unexec() can be found in the Gnu emacs distribution */
1380 sprintf (buf, "%s.perldump", origfilename);
1381 sprintf (tokenbuf, "%s/perl", BIN);
1383 status = unexec(buf, tokenbuf, &etext, sbrk(0), 0);
1385 PerlIO_printf(PerlIO_stderr(), "unexec of %s into %s failed!\n", tokenbuf, buf);
1389 # include <lib$routines.h>
1390 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
1392 ABORT(); /* for use with undump */
1402 /* Note that strtab is a rather special HV. Assumptions are made
1403 about not iterating on it, and not adding tie magic to it.
1404 It is properly deallocated in perl_destruct() */
1406 HvSHAREKEYS_off(strtab); /* mandatory */
1407 Newz(506,((XPVHV*)SvANY(strtab))->xhv_array,
1408 sizeof(HE*) * (((XPVHV*)SvANY(strtab))->xhv_max + 1), char);
1410 curstash = defstash = newHV();
1411 curstname = newSVpv("main",4);
1412 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1413 SvREFCNT_dec(GvHV(gv));
1414 GvHV(gv) = (HV*)SvREFCNT_inc(defstash);
1416 HvNAME(defstash) = savepv("main");
1417 incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1419 defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1420 errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1422 sv_setpvn(GvSV(errgv), "", 0);
1423 curstash = defstash;
1424 compiling.cop_stash = defstash;
1425 debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
1426 /* We must init $/ before switches are processed. */
1427 sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1);
1430 #ifdef CAN_PROTOTYPE
1432 open_script(char *scriptname, bool dosearch, SV *sv)
1435 open_script(scriptname,dosearch,sv)
1441 char *xfound = Nullch;
1442 char *xfailed = Nullch;
1446 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
1447 #define SEARCH_EXTS ".bat", ".cmd", NULL
1450 # define SEARCH_EXTS ".pl", ".com", NULL
1452 /* additional extensions to try in each dir if scriptname not found */
1454 char *ext[] = { SEARCH_EXTS };
1455 int extidx = (strchr(scriptname,'.')) ? -1 : 0; /* has ext already */
1460 int hasdir, idx = 0, deftypes = 1;
1462 hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
1463 /* The first time through, just add SEARCH_EXTS to whatever we
1464 * already have, so we can check for default file types. */
1465 while (deftypes || (!hasdir && my_trnlnm("DCL$PATH",tokenbuf,idx++)) ) {
1466 if (deftypes) { deftypes = 0; *tokenbuf = '\0'; }
1467 strcat(tokenbuf,scriptname);
1469 if (dosearch && !strchr(scriptname, '/') && (s = getenv("PATH"))) {
1471 bufend = s + strlen(s);
1474 s = cpytill(tokenbuf,s,bufend,':',&len);
1477 for (len = 0; *s && *s != ',' && *s != ';'; tokenbuf[len++] = *s++);
1478 tokenbuf[len] = '\0';
1480 for (len = 0; *s && *s != ';'; tokenbuf[len++] = *s++);
1481 tokenbuf[len] = '\0';
1487 if (len && tokenbuf[len-1] != '/')
1490 if (len && ((tokenbuf[len-1] != '\\') && (tokenbuf[len-1] != '/')))
1492 if (len && tokenbuf[len-1] != '\\')
1495 (void)strcat(tokenbuf+len,"/");
1496 (void)strcat(tokenbuf+len,scriptname);
1500 len = strlen(tokenbuf);
1501 if (extidx > 0) /* reset after previous loop */
1505 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tokenbuf));
1506 retval = Stat(tokenbuf,&statbuf);
1508 } while ( retval < 0 /* not there */
1509 && extidx>=0 && ext[extidx] /* try an extension? */
1510 && strcpy(tokenbuf+len, ext[extidx++])
1515 if (S_ISREG(statbuf.st_mode)
1516 && cando(S_IRUSR,TRUE,&statbuf) && cando(S_IXUSR,TRUE,&statbuf)) {
1517 xfound = tokenbuf; /* bingo! */
1521 xfailed = savepv(tokenbuf);
1524 croak("Can't execute %s", xfailed ? xfailed : scriptname );
1527 scriptname = xfound;
1530 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
1531 char *s = scriptname + 8;
1540 origfilename = savepv(e_tmpname ? "-e" : scriptname);
1541 curcop->cop_filegv = gv_fetchfile(origfilename);
1542 if (strEQ(origfilename,"-"))
1544 if (fdscript >= 0) {
1545 rsfp = PerlIO_fdopen(fdscript,"r");
1546 #if defined(HAS_FCNTL) && defined(F_SETFD)
1548 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
1551 else if (preprocess) {
1552 char *cpp = CPPSTDIN;
1554 if (strEQ(cpp,"cppstdin"))
1555 sprintf(tokenbuf, "%s/%s", SCRIPTDIR, cpp);
1557 sprintf(tokenbuf, "%s", cpp);
1559 sv_catpv(sv,PRIVLIB_EXP);
1561 (void)sprintf(buf, "\
1562 sed %s -e \"/^[^#]/b\" \
1563 -e \"/^#[ ]*include[ ]/b\" \
1564 -e \"/^#[ ]*define[ ]/b\" \
1565 -e \"/^#[ ]*if[ ]/b\" \
1566 -e \"/^#[ ]*ifdef[ ]/b\" \
1567 -e \"/^#[ ]*ifndef[ ]/b\" \
1568 -e \"/^#[ ]*else/b\" \
1569 -e \"/^#[ ]*elif[ ]/b\" \
1570 -e \"/^#[ ]*undef[ ]/b\" \
1571 -e \"/^#[ ]*endif/b\" \
1574 (doextract ? "-e \"1,/^#/d\n\"" : ""),
1576 (void)sprintf(buf, "\
1577 %s %s -e '/^[^#]/b' \
1578 -e '/^#[ ]*include[ ]/b' \
1579 -e '/^#[ ]*define[ ]/b' \
1580 -e '/^#[ ]*if[ ]/b' \
1581 -e '/^#[ ]*ifdef[ ]/b' \
1582 -e '/^#[ ]*ifndef[ ]/b' \
1583 -e '/^#[ ]*else/b' \
1584 -e '/^#[ ]*elif[ ]/b' \
1585 -e '/^#[ ]*undef[ ]/b' \
1586 -e '/^#[ ]*endif/b' \
1594 (doextract ? "-e '1,/^#/d\n'" : ""),
1596 scriptname, tokenbuf, SvPV(sv, na), CPPMINUS);
1598 #ifdef IAMSUID /* actually, this is caught earlier */
1599 if (euid != uid && !euid) { /* if running suidperl */
1601 (void)seteuid(uid); /* musn't stay setuid root */
1604 (void)setreuid((Uid_t)-1, uid);
1606 #ifdef HAS_SETRESUID
1607 (void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
1613 if (geteuid() != uid)
1614 croak("Can't do seteuid!\n");
1616 #endif /* IAMSUID */
1617 rsfp = my_popen(buf,"r");
1619 else if (!*scriptname) {
1620 forbid_setid("program input from stdin");
1621 rsfp = PerlIO_stdin();
1624 rsfp = PerlIO_open(scriptname,"r");
1625 #if defined(HAS_FCNTL) && defined(F_SETFD)
1627 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
1635 #ifndef IAMSUID /* in case script is not readable before setuid */
1636 if (euid && Stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
1637 statbuf.st_mode & (S_ISUID|S_ISGID)) {
1638 (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
1639 execv(buf, origargv); /* try again */
1640 croak("Can't do setuid\n");
1644 croak("Can't open perl script \"%s\": %s\n",
1645 SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno));
1650 validate_suid(validarg, scriptname)
1656 /* do we need to emulate setuid on scripts? */
1658 /* This code is for those BSD systems that have setuid #! scripts disabled
1659 * in the kernel because of a security problem. Merely defining DOSUID
1660 * in perl will not fix that problem, but if you have disabled setuid
1661 * scripts in the kernel, this will attempt to emulate setuid and setgid
1662 * on scripts that have those now-otherwise-useless bits set. The setuid
1663 * root version must be called suidperl or sperlN.NNN. If regular perl
1664 * discovers that it has opened a setuid script, it calls suidperl with
1665 * the same argv that it had. If suidperl finds that the script it has
1666 * just opened is NOT setuid root, it sets the effective uid back to the
1667 * uid. We don't just make perl setuid root because that loses the
1668 * effective uid we had before invoking perl, if it was different from the
1671 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
1672 * be defined in suidperl only. suidperl must be setuid root. The
1673 * Configure script will set this up for you if you want it.
1679 if (Fstat(PerlIO_fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
1680 croak("Can't stat script \"%s\"",origfilename);
1681 if (fdscript < 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) {
1685 #ifndef HAS_SETREUID
1686 /* On this access check to make sure the directories are readable,
1687 * there is actually a small window that the user could use to make
1688 * filename point to an accessible directory. So there is a faint
1689 * chance that someone could execute a setuid script down in a
1690 * non-accessible directory. I don't know what to do about that.
1691 * But I don't think it's too important. The manual lies when
1692 * it says access() is useful in setuid programs.
1694 if (access(SvPVX(GvSV(curcop->cop_filegv)),1)) /*double check*/
1695 croak("Permission denied");
1697 /* If we can swap euid and uid, then we can determine access rights
1698 * with a simple stat of the file, and then compare device and
1699 * inode to make sure we did stat() on the same file we opened.
1700 * Then we just have to make sure he or she can execute it.
1703 struct stat tmpstatbuf;
1707 setreuid(euid,uid) < 0
1710 setresuid(euid,uid,(Uid_t)-1) < 0
1713 || getuid() != euid || geteuid() != uid)
1714 croak("Can't swap uid and euid"); /* really paranoid */
1715 if (Stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
1716 croak("Permission denied"); /* testing full pathname here */
1717 if (tmpstatbuf.st_dev != statbuf.st_dev ||
1718 tmpstatbuf.st_ino != statbuf.st_ino) {
1719 (void)PerlIO_close(rsfp);
1720 if (rsfp = my_popen("/bin/mail root","w")) { /* heh, heh */
1722 "User %d tried to run dev %d ino %d in place of dev %d ino %d!\n\
1723 (Filename of set-id script was %s, uid %d gid %d.)\n\nSincerely,\nperl\n",
1724 uid,tmpstatbuf.st_dev, tmpstatbuf.st_ino,
1725 statbuf.st_dev, statbuf.st_ino,
1726 SvPVX(GvSV(curcop->cop_filegv)),
1727 statbuf.st_uid, statbuf.st_gid);
1728 (void)my_pclose(rsfp);
1730 croak("Permission denied\n");
1734 setreuid(uid,euid) < 0
1736 # if defined(HAS_SETRESUID)
1737 setresuid(uid,euid,(Uid_t)-1) < 0
1740 || getuid() != uid || geteuid() != euid)
1741 croak("Can't reswap uid and euid");
1742 if (!cando(S_IXUSR,FALSE,&statbuf)) /* can real uid exec? */
1743 croak("Permission denied\n");
1745 #endif /* HAS_SETREUID */
1746 #endif /* IAMSUID */
1748 if (!S_ISREG(statbuf.st_mode))
1749 croak("Permission denied");
1750 if (statbuf.st_mode & S_IWOTH)
1751 croak("Setuid/gid script is writable by world");
1752 doswitches = FALSE; /* -s is insecure in suid */
1754 if (sv_gets(linestr, rsfp, 0) == Nullch ||
1755 strnNE(SvPV(linestr,na),"#!",2) ) /* required even on Sys V */
1756 croak("No #! line");
1757 s = SvPV(linestr,na)+2;
1759 while (!isSPACE(*s)) s++;
1760 for (s2 = s; (s2 > SvPV(linestr,na)+2 &&
1761 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
1762 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
1763 croak("Not a perl script");
1764 while (*s == ' ' || *s == '\t') s++;
1766 * #! arg must be what we saw above. They can invoke it by
1767 * mentioning suidperl explicitly, but they may not add any strange
1768 * arguments beyond what #! says if they do invoke suidperl that way.
1770 len = strlen(validarg);
1771 if (strEQ(validarg," PHOOEY ") ||
1772 strnNE(s,validarg,len) || !isSPACE(s[len]))
1773 croak("Args must match #! line");
1776 if (euid != uid && (statbuf.st_mode & S_ISUID) &&
1777 euid == statbuf.st_uid)
1779 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
1780 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
1781 #endif /* IAMSUID */
1783 if (euid) { /* oops, we're not the setuid root perl */
1784 (void)PerlIO_close(rsfp);
1786 (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
1787 execv(buf, origargv); /* try again */
1789 croak("Can't do setuid\n");
1792 if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
1794 (void)setegid(statbuf.st_gid);
1797 (void)setregid((Gid_t)-1,statbuf.st_gid);
1799 #ifdef HAS_SETRESGID
1800 (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
1802 setgid(statbuf.st_gid);
1806 if (getegid() != statbuf.st_gid)
1807 croak("Can't do setegid!\n");
1809 if (statbuf.st_mode & S_ISUID) {
1810 if (statbuf.st_uid != euid)
1812 (void)seteuid(statbuf.st_uid); /* all that for this */
1815 (void)setreuid((Uid_t)-1,statbuf.st_uid);
1817 #ifdef HAS_SETRESUID
1818 (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
1820 setuid(statbuf.st_uid);
1824 if (geteuid() != statbuf.st_uid)
1825 croak("Can't do seteuid!\n");
1827 else if (uid) { /* oops, mustn't run as root */
1829 (void)seteuid((Uid_t)uid);
1832 (void)setreuid((Uid_t)-1,(Uid_t)uid);
1834 #ifdef HAS_SETRESUID
1835 (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
1841 if (geteuid() != uid)
1842 croak("Can't do seteuid!\n");
1845 if (!cando(S_IXUSR,TRUE,&statbuf))
1846 croak("Permission denied\n"); /* they can't do this */
1849 else if (preprocess)
1850 croak("-P not allowed for setuid/setgid script\n");
1851 else if (fdscript >= 0)
1852 croak("fd script not allowed in suidperl\n");
1854 croak("Script is not setuid/setgid in suidperl\n");
1856 /* We absolutely must clear out any saved ids here, so we */
1857 /* exec the real perl, substituting fd script for scriptname. */
1858 /* (We pass script name as "subdir" of fd, which perl will grok.) */
1859 PerlIO_rewind(rsfp);
1860 lseek(PerlIO_fileno(rsfp),(Off_t)0,0); /* just in case rewind didn't */
1861 for (which = 1; origargv[which] && origargv[which] != scriptname; which++) ;
1862 if (!origargv[which])
1863 croak("Permission denied");
1864 (void)sprintf(buf, "/dev/fd/%d/%.127s", PerlIO_fileno(rsfp), origargv[which]);
1865 origargv[which] = buf;
1867 #if defined(HAS_FCNTL) && defined(F_SETFD)
1868 fcntl(PerlIO_fileno(rsfp),F_SETFD,0); /* ensure no close-on-exec */
1871 (void)sprintf(tokenbuf, "%s/perl%s", BIN, patchlevel);
1872 execv(tokenbuf, origargv); /* try again */
1873 croak("Can't do setuid\n");
1874 #endif /* IAMSUID */
1876 if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */
1877 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
1878 Fstat(PerlIO_fileno(rsfp),&statbuf); /* may be either wrapped or real suid */
1879 if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
1881 (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
1884 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
1885 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
1886 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
1887 /* not set-id, must be wrapped */
1895 register char *s, *s2;
1897 /* skip forward in input to the real script? */
1901 if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
1902 croak("No Perl script found in input\n");
1903 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
1904 PerlIO_ungetc(rsfp, '\n'); /* to keep line count right */
1906 while (*s && !(isSPACE (*s) || *s == '#')) s++;
1908 while (*s == ' ' || *s == '\t') s++;
1910 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
1911 if (strnEQ(s2-4,"perl",4))
1913 while (s = moreswitches(s)) ;
1915 if (cddir && chdir(cddir) < 0)
1916 croak("Can't chdir to %s",cddir);
1924 uid = (int)getuid();
1925 euid = (int)geteuid();
1926 gid = (int)getgid();
1927 egid = (int)getegid();
1932 tainting |= (uid && (euid != uid || egid != gid));
1940 croak("No %s allowed while running setuid", s);
1942 croak("No %s allowed while running setgid", s);
1948 curstash = debstash;
1949 dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
1951 DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
1952 DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
1953 DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
1954 DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
1955 sv_setiv(DBsingle, 0);
1956 DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
1957 sv_setiv(DBtrace, 0);
1958 DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
1959 sv_setiv(DBsignal, 0);
1960 curstash = defstash;
1967 mainstack = curstack; /* remember in case we switch stacks */
1968 AvREAL_off(curstack); /* not a real array */
1969 av_extend(curstack,127);
1971 stack_base = AvARRAY(curstack);
1972 stack_sp = stack_base;
1973 stack_max = stack_base + 127;
1975 cxstack_max = 8192 / sizeof(CONTEXT) - 2; /* Use most of 8K. */
1976 New(50,cxstack,cxstack_max + 1,CONTEXT);
1979 New(50,tmps_stack,128,SV*);
1984 New(51,debname,128,char);
1985 New(52,debdelim,128,char);
1989 * The following stacks almost certainly should be per-interpreter,
1990 * but for now they're not. XXX
1994 markstack_ptr = markstack;
1996 New(54,markstack,64,I32);
1997 markstack_ptr = markstack;
1998 markstack_max = markstack + 64;
2004 New(54,scopestack,32,I32);
2006 scopestack_max = 32;
2012 New(54,savestack,128,ANY);
2014 savestack_max = 128;
2020 New(54,retstack,16,OP*);
2030 Safefree(tmps_stack);
2037 static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
2045 subname = newSVpv("main",4);
2049 init_predump_symbols()
2054 sv_setpvn(GvSV(gv_fetchpv("\"", TRUE, SVt_PV)), " ", 1);
2056 stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2057 GvMULTI_on(stdingv);
2058 IoIFP(GvIOp(stdingv)) = PerlIO_stdin();
2059 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2061 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv));
2063 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2065 IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
2067 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2069 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv));
2071 othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2072 GvMULTI_on(othergv);
2073 IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr();
2074 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2076 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
2078 statname = NEWSV(66,0); /* last filename we did stat on */
2081 osname = savepv(OSNAME);
2085 init_postdump_symbols(argc,argv,env)
2087 register char **argv;
2088 register char **env;
2094 argc--,argv++; /* skip name of script */
2096 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2099 if (argv[0][1] == '-') {
2103 if (s = strchr(argv[0], '=')) {
2105 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2108 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2111 toptarget = NEWSV(0,0);
2112 sv_upgrade(toptarget, SVt_PVFM);
2113 sv_setpvn(toptarget, "", 0);
2114 bodytarget = NEWSV(0,0);
2115 sv_upgrade(bodytarget, SVt_PVFM);
2116 sv_setpvn(bodytarget, "", 0);
2117 formtarget = bodytarget;
2120 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2121 sv_setpv(GvSV(tmpgv),origfilename);
2122 magicname("0", "0", 1);
2124 if (tmpgv = gv_fetchpv("\024",TRUE, SVt_PV))
2126 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2127 sv_setpv(GvSV(tmpgv),origargv[0]);
2128 if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2130 (void)gv_AVadd(argvgv);
2131 av_clear(GvAVn(argvgv));
2132 for (; argc > 0; argc--,argv++) {
2133 av_push(GvAVn(argvgv),newSVpv(argv[0],0));
2136 if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2141 #ifndef VMS /* VMS doesn't have environ array */
2142 /* Note that if the supplied env parameter is actually a copy
2143 of the global environ then it may now point to free'd memory
2144 if the environment has been modified since. To avoid this
2145 problem we treat env==NULL as meaning 'use the default'
2149 if (env != environ) {
2150 environ[0] = Nullch;
2151 hv_magic(hv, envgv, 'E');
2153 for (; *env; env++) {
2154 if (!(s = strchr(*env,'=')))
2157 sv = newSVpv(s--,0);
2158 sv_magic(sv, sv, 'e', *env, s - *env);
2159 (void)hv_store(hv, *env, s - *env, sv, 0);
2163 #ifdef DYNAMIC_ENV_FETCH
2164 HvNAME(hv) = savepv(ENV_HV_NAME);
2166 hv_magic(hv, envgv, 'E');
2169 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2170 sv_setiv(GvSV(tmpgv),(I32)getpid());
2179 s = getenv("PERL5LIB");
2183 incpush(getenv("PERLLIB"));
2185 /* Treat PERL5?LIB as a possible search list logical name -- the
2186 * "natural" VMS idiom for a Unix path string. We allow each
2187 * element to be a set of |-separated directories for compatibility.
2191 if (my_trnlnm("PERL5LIB",buf,0))
2192 do { incpush(buf); } while (my_trnlnm("PERL5LIB",buf,++idx));
2194 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf);
2198 /* Use the ~-expanded versions of APPLIB (undocumented),
2199 ARCHLIB PRIVLIB SITEARCH SITELIB and OLDARCHLIB
2202 incpush(APPLLIB_EXP);
2206 incpush(ARCHLIB_EXP);
2209 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2211 incpush(PRIVLIB_EXP);
2214 incpush(SITEARCH_EXP);
2217 incpush(SITELIB_EXP);
2219 #ifdef OLDARCHLIB_EXP /* 5.00[01] compatibility */
2220 incpush(OLDARCHLIB_EXP);
2233 line_t oldline = curcop->cop_line;
2235 Copy(top_env, oldtop, 1, Sigjmp_buf);
2237 while (AvFILL(list) >= 0) {
2238 CV *cv = (CV*)av_shift(list);
2242 switch (Sigsetjmp(top_env,1)) {
2244 SV* atsv = GvSV(errgv);
2246 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
2247 (void)SvPV(atsv, len);
2249 Copy(oldtop, top_env, 1, Sigjmp_buf);
2250 curcop = &compiling;
2251 curcop->cop_line = oldline;
2252 if (list == beginav)
2253 sv_catpv(atsv, "BEGIN failed--compilation aborted");
2255 sv_catpv(atsv, "END failed--cleanup aborted");
2256 croak("%s", SvPVX(atsv));
2262 statusvalue = 255; /* XXX I don't think we use 1 anymore. */
2268 /* my_exit() was called */
2269 curstash = defstash;
2273 Copy(oldtop, top_env, 1, Sigjmp_buf);
2274 curcop = &compiling;
2275 curcop->cop_line = oldline;
2277 if (list == beginav)
2278 croak("BEGIN failed--compilation aborted");
2280 croak("END failed--cleanup aborted");
2282 my_exit(statusvalue);
2287 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
2291 Copy(oldtop, top_env, 1, Sigjmp_buf);
2292 curcop = &compiling;
2293 curcop->cop_line = oldline;
2294 Siglongjmp(top_env, 3);
2298 Copy(oldtop, top_env, 1, Sigjmp_buf);