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 incpush _((char *));
39 static void init_ids _((void));
40 static void init_debugger _((void));
41 static void init_lexer _((void));
42 static void init_main_stash _((void));
43 static void init_perllib _((void));
44 static void init_postdump_symbols _((int, char **, char **));
45 static void init_predump_symbols _((void));
46 static void init_stacks _((void));
47 static void nuke_stacks _((void));
48 static void open_script _((char *, bool, SV *));
49 static void usage _((char *));
50 static void validate_suid _((char *, char*));
52 static int fdscript = -1;
57 PerlInterpreter *sv_interp;
60 New(53, sv_interp, 1, PerlInterpreter);
65 perl_construct( sv_interp )
66 register PerlInterpreter *sv_interp;
68 if (!(curinterp = sv_interp))
72 Zero(sv_interp, 1, PerlInterpreter);
75 /* Init the real globals? */
77 linestr = NEWSV(65,80);
78 sv_upgrade(linestr,SVt_PVIV);
80 if (!SvREADONLY(&sv_undef)) {
81 SvREADONLY_on(&sv_undef);
85 SvREADONLY_on(&sv_no);
87 sv_setpv(&sv_yes,Yes);
89 SvREADONLY_on(&sv_yes);
92 nrs = newSVpv("\n", 1);
93 rs = SvREFCNT_inc(nrs);
97 * There is no way we can refer to them from Perl so close them to save
98 * space. The other alternative would be to provide STDAUX and STDPRN
101 (void)fclose(stdaux);
102 (void)fclose(stdprn);
123 #if defined(SUBVERSION) && SUBVERSION > 0
124 sprintf(patchlevel, "%7.5f", (double) 5
125 + ((double) PATCHLEVEL / (double) 1000)
126 + ((double) SUBVERSION / (double) 100000));
128 sprintf(patchlevel, "%5.3f", (double) 5 +
129 ((double) PATCHLEVEL / (double) 1000));
132 #if defined(LOCAL_PATCH_COUNT)
133 localpatches = local_patches; /* For possible -v */
136 PerlIO_init(); /* Hook to IO system */
138 fdpid = newAV(); /* for remembering popen pids by fd */
139 pidstatus = newHV();/* for remembering status of dead pids */
146 perl_destruct(sv_interp)
147 register PerlInterpreter *sv_interp;
149 int destruct_level; /* 0=none, 1=full, 2=full with checks */
153 if (!(curinterp = sv_interp))
156 destruct_level = perl_destruct_level;
160 if (s = getenv("PERL_DESTRUCT_LEVEL"))
161 destruct_level = atoi(s);
168 /* We must account for everything. First the syntax tree. */
170 curpad = AvARRAY(comppad);
176 * Try to destruct global references. We do this first so that the
177 * destructors and destructees still exist. Some sv's might remain.
178 * Non-referenced objects are on their own.
185 if (destruct_level == 0){
187 DEBUG_P(debprofdump());
189 /* The exit() function will do everything that needs doing. */
193 /* unhook hooks which may now point to, or use, broken code */
194 if (warnhook && SvREFCNT(warnhook))
195 SvREFCNT_dec(warnhook);
196 if (diehook && SvREFCNT(diehook))
197 SvREFCNT_dec(diehook);
198 if (parsehook && SvREFCNT(parsehook))
199 SvREFCNT_dec(parsehook);
201 /* Prepare to destruct main symbol table. */
207 if (destruct_level >= 2) {
208 if (scopestack_ix != 0)
209 warn("Unbalanced scopes: %d more ENTERs than LEAVEs\n", scopestack_ix);
210 if (savestack_ix != 0)
211 warn("Unbalanced saves: %d more saves than restores\n", savestack_ix);
212 if (tmps_floor != -1)
213 warn("Unbalanced tmps: %d more allocs than frees\n", tmps_floor + 1);
214 if (cxstack_ix != -1)
215 warn("Unbalanced context: %d more PUSHes than POPs\n", cxstack_ix + 1);
218 /* Now absolutely destruct everything, somehow or other, loops or no. */
220 SvFLAGS(strtab) |= SVTYPEMASK; /* don't clean out strtab now */
221 while (sv_count != 0 && sv_count != last_sv_count) {
222 last_sv_count = sv_count;
225 SvFLAGS(strtab) &= ~SVTYPEMASK;
226 SvFLAGS(strtab) |= SVt_PVHV;
228 /* Destruct the global string table. */
230 /* Yell and reset the HeVAL() slots that are still holding refcounts,
231 * so that sv_free() won't fail on them.
240 array = HvARRAY(strtab);
244 warn("Unbalanced string table refcount: (%d) for \"%s\"",
245 HeVAL(hent) - Nullsv, HeKEY(hent));
246 HeVAL(hent) = Nullsv;
256 SvREFCNT_dec(strtab);
259 warn("Scalars leaked: %d\n", sv_count);
263 linestr = NULL; /* No SVs have survived, need to clean out */
265 Safefree(origfilename);
267 hints = 0; /* Reset hints. Should hints be per-interpreter ? */
269 DEBUG_P(debprofdump());
274 PerlInterpreter *sv_interp;
276 if (!(curinterp = sv_interp))
280 #if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE)
281 char *getenv _((char *)); /* Usually in <stdlib.h> */
285 perl_parse(sv_interp, xsinit, argc, argv, env)
286 PerlInterpreter *sv_interp;
287 void (*xsinit)_((void));
294 char *scriptname = NULL;
295 VOL bool dosearch = FALSE;
299 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
302 croak("suidperl is no longer needed since the kernel can now execute\n\
303 setuid perl scripts securely.\n");
307 if (!(curinterp = sv_interp))
310 #if defined(NeXT) && defined(__DYNAMIC__)
311 _dyld_lookup_and_bind
312 ("__environ", (unsigned long *) &environ_pointer, NULL);
317 #ifndef VMS /* VMS doesn't have environ array */
318 origenviron = environ;
324 /* Come here if running an undumped a.out. */
326 origfilename = savepv(argv[0]);
328 cxstack_ix = -1; /* start label stack again */
330 init_postdump_symbols(argc,argv,env);
338 switch (Sigsetjmp(top_env,1)) {
349 return(statusvalue); /* my_exit() was called */
351 PerlIO_printf(PerlIO_stderr(), "panic: top_env\n");
355 sv_setpvn(linestr,"",0);
356 sv = newSVpv("",0); /* first used for -I flags */
359 for (argc--,argv++; argc > 0; argc--,argv++) {
360 if (argv[0][0] != '-' || !argv[0][1])
364 validarg = " PHOOEY ";
390 if (s = moreswitches(s))
395 if (euid != uid || egid != gid)
396 croak("No -e allowed in setuid scripts");
398 e_tmpname = savepv(TMPPATH);
399 (void)mktemp(e_tmpname);
401 croak("Can't mktemp()");
402 e_fp = PerlIO_open(e_tmpname,"w");
404 croak("Cannot open temporary file");
409 PerlIO_puts(e_fp,argv[1]);
413 croak("No code specified for -e");
414 (void)PerlIO_putc(e_fp,'\n');
422 av_push(GvAVn(incgv),newSVpv(s,0));
425 av_push(GvAVn(incgv),newSVpv(argv[1],0));
426 sv_catpv(sv,argv[1]);
443 preambleav = newAV();
444 av_push(preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
446 Sv = newSVpv("print myconfig();",0);
448 sv_catpv(Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
450 sv_catpv(Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
452 #if defined(DEBUGGING) || defined(NOEMBED) || defined(MULTIPLICITY)
453 strcpy(buf,"\" Compile-time options:");
455 strcat(buf," DEBUGGING");
458 strcat(buf," NOEMBED");
461 strcat(buf," MULTIPLICITY");
463 strcat(buf,"\\n\",");
466 #if defined(LOCAL_PATCH_COUNT)
467 if (LOCAL_PATCH_COUNT > 0)
469 sv_catpv(Sv,"print \" Locally applied patches:\\n\",");
470 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
471 if (localpatches[i]) {
472 sprintf(buf,"\" \\t%s\\n\",",localpatches[i]);
478 sprintf(buf,"\" Built under %s\\n\",",OSNAME);
482 sprintf(buf,"\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
484 sprintf(buf,"\" Compiled on %s\\n\"",__DATE__);
488 sv_catpv(Sv,"; $\"=\"\\n \"; print \" \\@INC:\\n @INC\\n\"");
491 Sv = newSVpv("config_vars(qw(",0);
496 av_push(preambleav, Sv);
497 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
511 croak("Unrecognized switch: -%s",s);
516 scriptname = argv[0];
518 if (PerlIO_flush(e_fp) || PerlIO_error(e_fp) || PerlIO_close(e_fp))
519 croak("Can't write to temp file for -e: %s", Strerror(errno));
522 scriptname = e_tmpname;
524 else if (scriptname == Nullch) {
526 if ( isatty(PerlIO_fileno(PerlIO_stdin())) )
534 open_script(scriptname,dosearch,sv);
536 validate_suid(validarg, scriptname);
541 compcv = (CV*)NEWSV(1104,0);
542 sv_upgrade((SV *)compcv, SVt_PVCV);
545 av_push(comppad, Nullsv);
546 curpad = AvARRAY(comppad);
547 comppad_name = newAV();
548 comppad_name_fill = 0;
549 min_intro_pending = 0;
552 comppadlist = newAV();
553 AvREAL_off(comppadlist);
554 av_store(comppadlist, 0, (SV*)comppad_name);
555 av_store(comppadlist, 1, (SV*)comppad);
556 CvPADLIST(compcv) = comppadlist;
558 boot_core_UNIVERSAL();
560 (*xsinit)(); /* in case linked C routines want magical variables */
565 init_predump_symbols();
567 init_postdump_symbols(argc,argv,env);
571 /* now parse the script */
574 if (yyparse() || error_count) {
576 croak("%s had compilation errors.\n", origfilename);
578 croak("Execution of %s aborted due to compilation errors.\n",
582 curcop->cop_line = 0;
586 (void)UNLINK(e_tmpname);
591 /* now that script is parsed, we can modify record separator */
593 rs = SvREFCNT_inc(nrs);
594 sv_setsv(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), rs);
605 #ifdef DEBUGGING_MSTATS
606 if ((s=getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
607 dump_mstats("after compilation:");
617 PerlInterpreter *sv_interp;
619 if (!(curinterp = sv_interp))
621 switch (Sigsetjmp(top_env,1)) {
623 cxstack_ix = -1; /* start context stack again */
630 #ifdef DEBUGGING_MSTATS
631 if (getenv("PERL_DEBUG_MSTATS"))
632 dump_mstats("after execution: ");
634 return(statusvalue); /* my_exit() was called */
637 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
641 if (curstack != mainstack) {
643 SWITCHSTACK(curstack, mainstack);
648 DEBUG_r(PerlIO_printf(PerlIO_stderr(), "%s $` $& $' support.\n",
649 sawampersand ? "Enabling" : "Omitting"));
653 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
656 PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", origfilename);
659 if (perldb && DBsingle)
660 sv_setiv(DBsingle, 1);
670 else if (main_start) {
683 register CONTEXT *cx;
687 statusvalue = FIXSTATUS(status);
688 if (cxstack_ix >= 0) {
694 Siglongjmp(top_env, 2);
698 perl_get_sv(name, create)
702 GV* gv = gv_fetchpv(name, create, SVt_PV);
709 perl_get_av(name, create)
713 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
722 perl_get_hv(name, create)
726 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
735 perl_get_cv(name, create)
739 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
740 if (create && !GvCV(gv))
741 return newSUB(start_subparse(),
742 newSVOP(OP_CONST, 0, newSVpv(name,0)),
750 /* Be sure to refetch the stack pointer after calling these routines. */
753 perl_call_argv(subname, flags, argv)
755 I32 flags; /* See G_* flags in cop.h */
756 register char **argv; /* null terminated arg list */
763 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
768 return perl_call_pv(subname, flags);
772 perl_call_pv(subname, flags)
773 char *subname; /* name of the subroutine */
774 I32 flags; /* See G_* flags in cop.h */
776 return perl_call_sv((SV*)perl_get_cv(subname, TRUE), flags);
780 perl_call_method(methname, flags)
781 char *methname; /* name of the subroutine */
782 I32 flags; /* See G_* flags in cop.h */
788 XPUSHs(sv_2mortal(newSVpv(methname,0)));
791 return perl_call_sv(*stack_sp--, flags);
794 /* May be called with any of a CV, a GV, or an SV containing the name. */
796 perl_call_sv(sv, flags)
798 I32 flags; /* See G_* flags in cop.h */
800 LOGOP myop; /* fake syntax tree node */
802 I32 oldmark = TOPMARK;
808 if (flags & G_DISCARD) {
818 oldscope = scopestack_ix;
820 if (!(flags & G_NOARGS))
821 myop.op_flags = OPf_STACKED;
822 myop.op_next = Nullop;
823 myop.op_flags |= OPf_KNOW;
825 myop.op_flags |= OPf_LIST;
827 if (perldb && curstash != debstash
828 && (DBcv || (DBcv = GvCV(DBsub)))) /* to handle first BEGIN of -d */
829 op->op_private |= OPpENTERSUB_DB;
831 if (flags & G_EVAL) {
832 Copy(top_env, oldtop, 1, Sigjmp_buf);
834 cLOGOP->op_other = op;
836 /* we're trying to emulate pp_entertry() here */
838 register CONTEXT *cx;
844 push_return(op->op_next);
845 PUSHBLOCK(cx, CXt_EVAL, stack_sp);
847 eval_root = op; /* Only needed so that goto works right. */
850 if (flags & G_KEEPERR)
853 sv_setpv(GvSV(errgv),"");
858 switch (Sigsetjmp(top_env,1)) {
863 statusvalue = 255; /* XXX I don't think we use 1 anymore. */
869 /* my_exit() was called */
872 Copy(oldtop, top_env, 1, Sigjmp_buf);
874 croak("Callback called exit");
875 my_exit(statusvalue);
883 stack_sp = stack_base + oldmark;
888 *++stack_sp = &sv_undef;
894 if (op == (OP*)&myop)
898 retval = stack_sp - (stack_base + oldmark);
899 if ((flags & G_EVAL) && !(flags & G_KEEPERR))
900 sv_setpv(GvSV(errgv),"");
903 if (flags & G_EVAL) {
904 if (scopestack_ix > oldscope) {
908 register CONTEXT *cx;
917 Copy(oldtop, top_env, 1, Sigjmp_buf);
919 if (flags & G_DISCARD) {
920 stack_sp = stack_base + oldmark;
928 /* Eval a string. The G_EVAL flag is always assumed. */
931 perl_eval_sv(sv, flags)
933 I32 flags; /* See G_* flags in cop.h */
935 UNOP myop; /* fake syntax tree node */
937 I32 oldmark = sp - stack_base;
942 if (flags & G_DISCARD) {
952 oldscope = scopestack_ix;
954 if (!(flags & G_NOARGS))
955 myop.op_flags = OPf_STACKED;
956 myop.op_next = Nullop;
957 myop.op_type = OP_ENTEREVAL;
958 myop.op_flags |= OPf_KNOW;
959 if (flags & G_KEEPERR)
960 myop.op_flags |= OPf_SPECIAL;
962 myop.op_flags |= OPf_LIST;
964 Copy(top_env, oldtop, 1, Sigjmp_buf);
967 switch (Sigsetjmp(top_env,1)) {
972 statusvalue = 255; /* XXX I don't think we use 1 anymore. */
978 /* my_exit() was called */
981 Copy(oldtop, top_env, 1, Sigjmp_buf);
983 croak("Callback called exit");
984 my_exit(statusvalue);
992 stack_sp = stack_base + oldmark;
997 *++stack_sp = &sv_undef;
1002 if (op == (OP*)&myop)
1003 op = pp_entereval();
1006 retval = stack_sp - (stack_base + oldmark);
1007 if (!(flags & G_KEEPERR))
1008 sv_setpv(GvSV(errgv),"");
1011 Copy(oldtop, top_env, 1, Sigjmp_buf);
1012 if (flags & G_DISCARD) {
1013 stack_sp = stack_base + oldmark;
1021 /* Require a module. */
1027 SV* sv = sv_newmortal();
1028 sv_setpv(sv, "require '");
1031 perl_eval_sv(sv, G_DISCARD);
1035 magicname(sym,name,namlen)
1042 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1043 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1047 # define PERLLIB_SEP ';'
1050 # define PERLLIB_SEP '|'
1052 # define PERLLIB_SEP ':'
1055 #ifndef PERLLIB_MANGLE
1056 # define PERLLIB_MANGLE(s,n) (s)
1068 /* Break at all separators */
1070 /* First, skip any consecutive separators */
1071 while ( *p == PERLLIB_SEP ) {
1072 /* Uncomment the next line for PATH semantics */
1073 /* av_push(GvAVn(incgv), newSVpv(".", 1)); */
1076 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
1077 av_push(GvAVn(incgv), newSVpv(PERLLIB_MANGLE(p, (STRLEN)(s - p)),
1081 av_push(GvAVn(incgv), newSVpv(PERLLIB_MANGLE(p, 0), 0));
1088 usage(name) /* XXX move this out into a module ? */
1091 /* This message really ought to be max 23 lines.
1092 * Removed -h because the user already knows that opton. Others? */
1093 printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1094 printf("\n -0[octal] specify record separator (\\0, if no argument)");
1095 printf("\n -a autosplit mode with -n or -p (splits $_ into @F)");
1096 printf("\n -c check syntax only (runs BEGIN and END blocks)");
1097 printf("\n -d[:debugger] run scripts under debugger");
1098 printf("\n -D[number/list] set debugging flags (argument is a bit mask or flags)");
1099 printf("\n -e 'command' one line of script. Several -e's allowed. Omit [programfile].");
1100 printf("\n -F/pattern/ split() pattern for autosplit (-a). The //'s are optional.");
1101 printf("\n -i[extension] edit <> files in place (make backup if extension supplied)");
1102 printf("\n -Idirectory specify @INC/#include directory (may be used more then once)");
1103 printf("\n -l[octal] enable line ending processing, specifies line teminator");
1104 printf("\n -[mM][-]module.. executes `use/no module...' before executing your script.");
1105 printf("\n -n assume 'while (<>) { ... }' loop arround your script");
1106 printf("\n -p assume loop like -n but print line also like sed");
1107 printf("\n -P run script through C preprocessor before compilation");
1108 printf("\n -s enable some switch parsing for switches after script name");
1109 printf("\n -S look for the script using PATH environment variable");
1110 printf("\n -T turn on tainting checks");
1111 printf("\n -u dump core after parsing script");
1112 printf("\n -U allow unsafe operations");
1113 printf("\n -v print version number and patchlevel of perl");
1114 printf("\n -V[:variable] print perl configuration information");
1115 printf("\n -w TURN WARNINGS ON FOR COMPILATION OF YOUR SCRIPT.");
1116 printf("\n -x[directory] strip off text before #!perl line and perhaps cd to directory\n");
1119 /* This routine handles any switches that can be given during run */
1130 rschar = scan_oct(s, 4, &numlen);
1132 if (rschar & ~((U8)~0))
1134 else if (!rschar && numlen >= 2)
1135 nrs = newSVpv("", 0);
1138 nrs = newSVpv(&ch, 1);
1143 splitstr = savepv(s + 1);
1157 if (*s == ':' || *s == '=') {
1158 sprintf(buf, "use Devel::%s;", ++s);
1160 my_setenv("PERL5DB",buf);
1170 if (isALPHA(s[1])) {
1171 static char debopts[] = "psltocPmfrxuLHXD";
1174 for (s++; *s && (d = strchr(debopts,*s)); s++)
1175 debug |= 1 << (d - debopts);
1179 for (s++; isDIGIT(*s); s++) ;
1181 debug |= 0x80000000;
1183 warn("Recompile perl with -DDEBUGGING to use -D switch\n");
1184 for (s++; isALNUM(*s); s++) ;
1194 inplace = savepv(s+1);
1196 for (s = inplace; *s && !isSPACE(*s); s++) ;
1203 for (e = s; *e && !isSPACE(*e); e++) ;
1204 av_push(GvAVn(incgv),newSVpv(s,e-s));
1209 croak("No space allowed after -I");
1219 *ors = scan_oct(s, 3 + (*s == '0'), &numlen);
1228 ors = SvPV(nrs, orslen);
1229 ors = savepvn(ors, orslen);
1233 taint_not("-M"); /* XXX ? */
1236 taint_not("-m"); /* XXX ? */
1240 /* -M-foo == 'no foo' */
1241 if (*s == '-') { use = "no "; ++s; }
1242 Sv = newSVpv(use,0);
1244 /* We allow -M'Module qw(Foo Bar)' */
1245 while(isALNUM(*s) || *s==':') ++s;
1247 sv_catpv(Sv, start);
1248 if (*(start-1) == 'm') {
1250 croak("Can't use '%c' after -mname", *s);
1251 sv_catpv( Sv, " ()");
1254 sv_catpvn(Sv, start, s-start);
1255 sv_catpv(Sv, " split(/,/,q{");
1260 if (preambleav == NULL)
1261 preambleav = newAV();
1262 av_push(preambleav, Sv);
1265 croak("No space allowed after -%c", *(s-1));
1293 #if defined(SUBVERSION) && SUBVERSION > 0
1294 printf("\nThis is perl, version 5.%03d_%02d", PATCHLEVEL, SUBVERSION);
1296 printf("\nThis is perl, version %s",patchlevel);
1299 printf("\n\nCopyright 1987-1996, Larry Wall\n");
1300 printf("\n\t+ suidperl security patch");
1302 printf("\n\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1305 printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
1308 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1309 "Version 5 port Copyright (c) 1994-1996, Andreas Kaiser, Ilya Zakharevich\n");
1312 printf("atariST series port, ++jrb bammi@cadence.com\n");
1315 Perl may be copied only under the terms of either the Artistic License or the\n\
1316 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n");
1324 if (s[1] == '-') /* Additional switches on #! line. */
1337 croak("Can't emulate -%.1s on #! line",s);
1342 /* compliments of Tom Christiansen */
1344 /* unexec() can be found in the Gnu emacs distribution */
1353 sprintf (buf, "%s.perldump", origfilename);
1354 sprintf (tokenbuf, "%s/perl", BIN);
1356 status = unexec(buf, tokenbuf, &etext, sbrk(0), 0);
1358 PerlIO_printf(PerlIO_stderr(), "unexec of %s into %s failed!\n", tokenbuf, buf);
1362 # include <lib$routines.h>
1363 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
1365 ABORT(); /* for use with undump */
1375 /* Note that strtab is a rather special HV. Assumptions are made
1376 about not iterating on it, and not adding tie magic to it.
1377 It is properly deallocated in perl_destruct() */
1379 HvSHAREKEYS_off(strtab); /* mandatory */
1380 Newz(506,((XPVHV*)SvANY(strtab))->xhv_array,
1381 sizeof(HE*) * (((XPVHV*)SvANY(strtab))->xhv_max + 1), char);
1383 curstash = defstash = newHV();
1384 curstname = newSVpv("main",4);
1385 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1386 SvREFCNT_dec(GvHV(gv));
1387 GvHV(gv) = (HV*)SvREFCNT_inc(defstash);
1389 HvNAME(defstash) = savepv("main");
1390 incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1392 defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1393 errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1395 sv_setpvn(GvSV(errgv), "", 0);
1396 curstash = defstash;
1397 compiling.cop_stash = defstash;
1398 debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
1399 /* We must init $/ before switches are processed. */
1400 sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1);
1403 #ifdef CAN_PROTOTYPE
1405 open_script(char *scriptname, bool dosearch, SV *sv)
1408 open_script(scriptname,dosearch,sv)
1414 char *xfound = Nullch;
1415 char *xfailed = Nullch;
1419 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
1420 #define SEARCH_EXTS ".bat", ".cmd", NULL
1423 # define SEARCH_EXTS ".pl", ".com", NULL
1425 /* additional extensions to try in each dir if scriptname not found */
1427 char *ext[] = { SEARCH_EXTS };
1428 int extidx = (strchr(scriptname,'.')) ? -1 : 0; /* has ext already */
1433 int hasdir, idx = 0, deftypes = 1;
1435 hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
1436 /* The first time through, just add SEARCH_EXTS to whatever we
1437 * already have, so we can check for default file types. */
1438 while (deftypes || (!hasdir && my_trnlnm("DCL$PATH",tokenbuf,idx++)) ) {
1439 if (deftypes) { deftypes = 0; *tokenbuf = '\0'; }
1440 strcat(tokenbuf,scriptname);
1442 if (dosearch && !strchr(scriptname, '/') && (s = getenv("PATH"))) {
1444 bufend = s + strlen(s);
1447 s = cpytill(tokenbuf,s,bufend,':',&len);
1450 for (len = 0; *s && *s != ',' && *s != ';'; tokenbuf[len++] = *s++);
1451 tokenbuf[len] = '\0';
1453 for (len = 0; *s && *s != ';'; tokenbuf[len++] = *s++);
1454 tokenbuf[len] = '\0';
1460 if (len && tokenbuf[len-1] != '/')
1463 if (len && ((tokenbuf[len-1] != '\\') && (tokenbuf[len-1] != '/')))
1465 if (len && tokenbuf[len-1] != '\\')
1468 (void)strcat(tokenbuf+len,"/");
1469 (void)strcat(tokenbuf+len,scriptname);
1473 len = strlen(tokenbuf);
1474 if (extidx > 0) /* reset after previous loop */
1478 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tokenbuf));
1479 retval = Stat(tokenbuf,&statbuf);
1481 } while ( retval < 0 /* not there */
1482 && extidx>=0 && ext[extidx] /* try an extension? */
1483 && strcpy(tokenbuf+len, ext[extidx++])
1488 if (S_ISREG(statbuf.st_mode)
1489 && cando(S_IRUSR,TRUE,&statbuf) && cando(S_IXUSR,TRUE,&statbuf)) {
1490 xfound = tokenbuf; /* bingo! */
1494 xfailed = savepv(tokenbuf);
1497 croak("Can't execute %s", xfailed ? xfailed : scriptname );
1500 scriptname = xfound;
1503 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
1504 char *s = scriptname + 8;
1513 origfilename = savepv(e_tmpname ? "-e" : scriptname);
1514 curcop->cop_filegv = gv_fetchfile(origfilename);
1515 if (strEQ(origfilename,"-"))
1517 if (fdscript >= 0) {
1518 rsfp = PerlIO_fdopen(fdscript,"r");
1519 #if defined(HAS_FCNTL) && defined(F_SETFD)
1520 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
1523 else if (preprocess) {
1524 char *cpp = CPPSTDIN;
1526 if (strEQ(cpp,"cppstdin"))
1527 sprintf(tokenbuf, "%s/%s", SCRIPTDIR, cpp);
1529 sprintf(tokenbuf, "%s", cpp);
1531 sv_catpv(sv,PRIVLIB_EXP);
1533 (void)sprintf(buf, "\
1534 sed %s -e \"/^[^#]/b\" \
1535 -e \"/^#[ ]*include[ ]/b\" \
1536 -e \"/^#[ ]*define[ ]/b\" \
1537 -e \"/^#[ ]*if[ ]/b\" \
1538 -e \"/^#[ ]*ifdef[ ]/b\" \
1539 -e \"/^#[ ]*ifndef[ ]/b\" \
1540 -e \"/^#[ ]*else/b\" \
1541 -e \"/^#[ ]*elif[ ]/b\" \
1542 -e \"/^#[ ]*undef[ ]/b\" \
1543 -e \"/^#[ ]*endif/b\" \
1546 (doextract ? "-e \"1,/^#/d\n\"" : ""),
1548 (void)sprintf(buf, "\
1549 %s %s -e '/^[^#]/b' \
1550 -e '/^#[ ]*include[ ]/b' \
1551 -e '/^#[ ]*define[ ]/b' \
1552 -e '/^#[ ]*if[ ]/b' \
1553 -e '/^#[ ]*ifdef[ ]/b' \
1554 -e '/^#[ ]*ifndef[ ]/b' \
1555 -e '/^#[ ]*else/b' \
1556 -e '/^#[ ]*elif[ ]/b' \
1557 -e '/^#[ ]*undef[ ]/b' \
1558 -e '/^#[ ]*endif/b' \
1566 (doextract ? "-e '1,/^#/d\n'" : ""),
1568 scriptname, tokenbuf, SvPV(sv, na), CPPMINUS);
1570 #ifdef IAMSUID /* actually, this is caught earlier */
1571 if (euid != uid && !euid) { /* if running suidperl */
1573 (void)seteuid(uid); /* musn't stay setuid root */
1576 (void)setreuid((Uid_t)-1, uid);
1578 #ifdef HAS_SETRESUID
1579 (void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
1585 if (geteuid() != uid)
1586 croak("Can't do seteuid!\n");
1588 #endif /* IAMSUID */
1589 rsfp = my_popen(buf,"r");
1591 else if (!*scriptname) {
1592 taint_not("program input from stdin");
1593 rsfp = PerlIO_stdin();
1596 rsfp = PerlIO_open(scriptname,"r");
1597 #if defined(HAS_FCNTL) && defined(F_SETFD)
1598 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
1604 if ((PerlIO*)rsfp == Nullfp) {
1606 #ifndef IAMSUID /* in case script is not readable before setuid */
1607 if (euid && Stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
1608 statbuf.st_mode & (S_ISUID|S_ISGID)) {
1609 (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
1610 execv(buf, origargv); /* try again */
1611 croak("Can't do setuid\n");
1615 croak("Can't open perl script \"%s\": %s\n",
1616 SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno));
1621 validate_suid(validarg, scriptname)
1627 /* do we need to emulate setuid on scripts? */
1629 /* This code is for those BSD systems that have setuid #! scripts disabled
1630 * in the kernel because of a security problem. Merely defining DOSUID
1631 * in perl will not fix that problem, but if you have disabled setuid
1632 * scripts in the kernel, this will attempt to emulate setuid and setgid
1633 * on scripts that have those now-otherwise-useless bits set. The setuid
1634 * root version must be called suidperl or sperlN.NNN. If regular perl
1635 * discovers that it has opened a setuid script, it calls suidperl with
1636 * the same argv that it had. If suidperl finds that the script it has
1637 * just opened is NOT setuid root, it sets the effective uid back to the
1638 * uid. We don't just make perl setuid root because that loses the
1639 * effective uid we had before invoking perl, if it was different from the
1642 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
1643 * be defined in suidperl only. suidperl must be setuid root. The
1644 * Configure script will set this up for you if you want it.
1650 if (Fstat(PerlIO_fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
1651 croak("Can't stat script \"%s\"",origfilename);
1652 if (fdscript < 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) {
1656 #ifndef HAS_SETREUID
1657 /* On this access check to make sure the directories are readable,
1658 * there is actually a small window that the user could use to make
1659 * filename point to an accessible directory. So there is a faint
1660 * chance that someone could execute a setuid script down in a
1661 * non-accessible directory. I don't know what to do about that.
1662 * But I don't think it's too important. The manual lies when
1663 * it says access() is useful in setuid programs.
1665 if (access(SvPVX(GvSV(curcop->cop_filegv)),1)) /*double check*/
1666 croak("Permission denied");
1668 /* If we can swap euid and uid, then we can determine access rights
1669 * with a simple stat of the file, and then compare device and
1670 * inode to make sure we did stat() on the same file we opened.
1671 * Then we just have to make sure he or she can execute it.
1674 struct stat tmpstatbuf;
1678 setreuid(euid,uid) < 0
1681 setresuid(euid,uid,(Uid_t)-1) < 0
1684 || getuid() != euid || geteuid() != uid)
1685 croak("Can't swap uid and euid"); /* really paranoid */
1686 if (Stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
1687 croak("Permission denied"); /* testing full pathname here */
1688 if (tmpstatbuf.st_dev != statbuf.st_dev ||
1689 tmpstatbuf.st_ino != statbuf.st_ino) {
1690 (void)PerlIO_close(rsfp);
1691 if (rsfp = my_popen("/bin/mail root","w")) { /* heh, heh */
1693 "User %d tried to run dev %d ino %d in place of dev %d ino %d!\n\
1694 (Filename of set-id script was %s, uid %d gid %d.)\n\nSincerely,\nperl\n",
1695 uid,tmpstatbuf.st_dev, tmpstatbuf.st_ino,
1696 statbuf.st_dev, statbuf.st_ino,
1697 SvPVX(GvSV(curcop->cop_filegv)),
1698 statbuf.st_uid, statbuf.st_gid);
1699 (void)my_pclose(rsfp);
1701 croak("Permission denied\n");
1705 setreuid(uid,euid) < 0
1707 # if defined(HAS_SETRESUID)
1708 setresuid(uid,euid,(Uid_t)-1) < 0
1711 || getuid() != uid || geteuid() != euid)
1712 croak("Can't reswap uid and euid");
1713 if (!cando(S_IXUSR,FALSE,&statbuf)) /* can real uid exec? */
1714 croak("Permission denied\n");
1716 #endif /* HAS_SETREUID */
1717 #endif /* IAMSUID */
1719 if (!S_ISREG(statbuf.st_mode))
1720 croak("Permission denied");
1721 if (statbuf.st_mode & S_IWOTH)
1722 croak("Setuid/gid script is writable by world");
1723 doswitches = FALSE; /* -s is insecure in suid */
1725 if (sv_gets(linestr, rsfp, 0) == Nullch ||
1726 strnNE(SvPV(linestr,na),"#!",2) ) /* required even on Sys V */
1727 croak("No #! line");
1728 s = SvPV(linestr,na)+2;
1730 while (!isSPACE(*s)) s++;
1731 for (s2 = s; (s2 > SvPV(linestr,na)+2 &&
1732 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
1733 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
1734 croak("Not a perl script");
1735 while (*s == ' ' || *s == '\t') s++;
1737 * #! arg must be what we saw above. They can invoke it by
1738 * mentioning suidperl explicitly, but they may not add any strange
1739 * arguments beyond what #! says if they do invoke suidperl that way.
1741 len = strlen(validarg);
1742 if (strEQ(validarg," PHOOEY ") ||
1743 strnNE(s,validarg,len) || !isSPACE(s[len]))
1744 croak("Args must match #! line");
1747 if (euid != uid && (statbuf.st_mode & S_ISUID) &&
1748 euid == statbuf.st_uid)
1750 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
1751 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
1752 #endif /* IAMSUID */
1754 if (euid) { /* oops, we're not the setuid root perl */
1755 (void)PerlIO_close(rsfp);
1757 (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
1758 execv(buf, origargv); /* try again */
1760 croak("Can't do setuid\n");
1763 if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
1765 (void)setegid(statbuf.st_gid);
1768 (void)setregid((Gid_t)-1,statbuf.st_gid);
1770 #ifdef HAS_SETRESGID
1771 (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
1773 setgid(statbuf.st_gid);
1777 if (getegid() != statbuf.st_gid)
1778 croak("Can't do setegid!\n");
1780 if (statbuf.st_mode & S_ISUID) {
1781 if (statbuf.st_uid != euid)
1783 (void)seteuid(statbuf.st_uid); /* all that for this */
1786 (void)setreuid((Uid_t)-1,statbuf.st_uid);
1788 #ifdef HAS_SETRESUID
1789 (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
1791 setuid(statbuf.st_uid);
1795 if (geteuid() != statbuf.st_uid)
1796 croak("Can't do seteuid!\n");
1798 else if (uid) { /* oops, mustn't run as root */
1800 (void)seteuid((Uid_t)uid);
1803 (void)setreuid((Uid_t)-1,(Uid_t)uid);
1805 #ifdef HAS_SETRESUID
1806 (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
1812 if (geteuid() != uid)
1813 croak("Can't do seteuid!\n");
1816 if (!cando(S_IXUSR,TRUE,&statbuf))
1817 croak("Permission denied\n"); /* they can't do this */
1820 else if (preprocess)
1821 croak("-P not allowed for setuid/setgid script\n");
1822 else if (fdscript >= 0)
1823 croak("fd script not allowed in suidperl\n");
1825 croak("Script is not setuid/setgid in suidperl\n");
1827 /* We absolutely must clear out any saved ids here, so we */
1828 /* exec the real perl, substituting fd script for scriptname. */
1829 /* (We pass script name as "subdir" of fd, which perl will grok.) */
1830 PerlIO_rewind(rsfp);
1831 lseek(PerlIO_fileno(rsfp),(Off_t)0,0); /* just in case rewind didn't */
1832 for (which = 1; origargv[which] && origargv[which] != scriptname; which++) ;
1833 if (!origargv[which])
1834 croak("Permission denied");
1835 (void)sprintf(buf, "/dev/fd/%d/%.127s", PerlIO_fileno(rsfp), origargv[which]);
1836 origargv[which] = buf;
1838 #if defined(HAS_FCNTL) && defined(F_SETFD)
1839 fcntl(PerlIO_fileno(rsfp),F_SETFD,0); /* ensure no close-on-exec */
1842 (void)sprintf(tokenbuf, "%s/perl%s", BIN, patchlevel);
1843 execv(tokenbuf, origargv); /* try again */
1844 croak("Can't do setuid\n");
1845 #endif /* IAMSUID */
1847 if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */
1848 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
1849 Fstat(PerlIO_fileno(rsfp),&statbuf); /* may be either wrapped or real suid */
1850 if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
1852 (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
1855 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
1856 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
1857 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
1858 /* not set-id, must be wrapped */
1866 register char *s, *s2;
1868 /* skip forward in input to the real script? */
1872 if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
1873 croak("No Perl script found in input\n");
1874 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
1875 PerlIO_ungetc(rsfp, '\n'); /* to keep line count right */
1877 while (*s && !(isSPACE (*s) || *s == '#')) s++;
1879 while (*s == ' ' || *s == '\t') s++;
1881 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
1882 if (strnEQ(s2-4,"perl",4))
1884 while (s = moreswitches(s)) ;
1886 if (cddir && chdir(cddir) < 0)
1887 croak("Can't chdir to %s",cddir);
1895 uid = (int)getuid();
1896 euid = (int)geteuid();
1897 gid = (int)getgid();
1898 egid = (int)getegid();
1903 tainting |= (uid && (euid != uid || egid != gid));
1909 curstash = debstash;
1910 dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
1912 DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
1913 DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
1914 DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
1915 DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
1916 sv_setiv(DBsingle, 0);
1917 DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
1918 sv_setiv(DBtrace, 0);
1919 DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
1920 sv_setiv(DBsignal, 0);
1921 curstash = defstash;
1928 mainstack = curstack; /* remember in case we switch stacks */
1929 AvREAL_off(curstack); /* not a real array */
1930 av_extend(curstack,127);
1932 stack_base = AvARRAY(curstack);
1933 stack_sp = stack_base;
1934 stack_max = stack_base + 127;
1936 /* Shouldn't these stacks be per-interpreter? */
1938 markstack_ptr = markstack;
1940 New(54,markstack,64,I32);
1941 markstack_ptr = markstack;
1942 markstack_max = markstack + 64;
1948 New(54,scopestack,32,I32);
1950 scopestack_max = 32;
1956 New(54,savestack,128,ANY);
1958 savestack_max = 128;
1964 New(54,retstack,16,OP*);
1969 cxstack_max = 8192 / sizeof(CONTEXT) - 2; /* Use most of 8K. */
1970 New(50,cxstack,cxstack_max + 1,CONTEXT);
1973 New(50,tmps_stack,128,SV*);
1978 New(51,debname,128,char);
1979 New(52,debdelim,128,char);
1987 Safefree(tmps_stack);
1990 static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
1998 subname = newSVpv("main",4);
2002 init_predump_symbols()
2007 sv_setpvn(GvSV(gv_fetchpv("\"", TRUE, SVt_PV)), " ", 1);
2009 stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2010 GvMULTI_on(stdingv);
2011 IoIFP(GvIOp(stdingv)) = PerlIO_stdin();
2012 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2014 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv));
2016 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2018 IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
2020 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2022 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv));
2024 othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2025 GvMULTI_on(othergv);
2026 IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr();
2027 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2029 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
2031 statname = NEWSV(66,0); /* last filename we did stat on */
2034 osname = savepv(OSNAME);
2038 init_postdump_symbols(argc,argv,env)
2040 register char **argv;
2041 register char **env;
2047 argc--,argv++; /* skip name of script */
2049 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2052 if (argv[0][1] == '-') {
2056 if (s = strchr(argv[0], '=')) {
2058 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2061 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2064 toptarget = NEWSV(0,0);
2065 sv_upgrade(toptarget, SVt_PVFM);
2066 sv_setpvn(toptarget, "", 0);
2067 bodytarget = NEWSV(0,0);
2068 sv_upgrade(bodytarget, SVt_PVFM);
2069 sv_setpvn(bodytarget, "", 0);
2070 formtarget = bodytarget;
2073 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2074 sv_setpv(GvSV(tmpgv),origfilename);
2075 magicname("0", "0", 1);
2077 if (tmpgv = gv_fetchpv("\024",TRUE, SVt_PV))
2079 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2080 sv_setpv(GvSV(tmpgv),origargv[0]);
2081 if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2083 (void)gv_AVadd(argvgv);
2084 av_clear(GvAVn(argvgv));
2085 for (; argc > 0; argc--,argv++) {
2086 av_push(GvAVn(argvgv),newSVpv(argv[0],0));
2089 if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2094 #ifndef VMS /* VMS doesn't have environ array */
2095 /* Note that if the supplied env parameter is actually a copy
2096 of the global environ then it may now point to free'd memory
2097 if the environment has been modified since. To avoid this
2098 problem we treat env==NULL as meaning 'use the default'
2102 if (env != environ) {
2103 environ[0] = Nullch;
2104 hv_magic(hv, envgv, 'E');
2106 for (; *env; env++) {
2107 if (!(s = strchr(*env,'=')))
2110 sv = newSVpv(s--,0);
2111 sv_magic(sv, sv, 'e', *env, s - *env);
2112 (void)hv_store(hv, *env, s - *env, sv, 0);
2116 #ifdef DYNAMIC_ENV_FETCH
2117 HvNAME(hv) = savepv(ENV_HV_NAME);
2119 hv_magic(hv, envgv, 'E');
2122 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2123 sv_setiv(GvSV(tmpgv),(I32)getpid());
2133 s = getenv("PERL5LIB");
2137 incpush(getenv("PERLLIB"));
2139 /* Treat PERL5?LIB as a possible search list logical name -- the
2140 * "natural" VMS idiom for a Unix path string. We allow each
2141 * element to be a set of |-separated directories for compatibility.
2145 if (my_trnlnm("PERL5LIB",buf,0))
2146 do { incpush(buf); } while (my_trnlnm("PERL5LIB",buf,++idx));
2148 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf);
2152 /* Use the ~-expanded versions of APPLIB (undocumented),
2153 ARCHLIB PRIVLIB SITEARCH SITELIB and OLDARCHLIB
2156 incpush(APPLLIB_EXP);
2160 incpush(ARCHLIB_EXP);
2163 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2165 incpush(PRIVLIB_EXP);
2168 incpush(SITEARCH_EXP);
2171 incpush(SITELIB_EXP);
2173 #ifdef OLDARCHLIB_EXP /* 5.00[01] compatibility */
2174 incpush(OLDARCHLIB_EXP);
2187 line_t oldline = curcop->cop_line;
2189 Copy(top_env, oldtop, 1, Sigjmp_buf);
2191 while (AvFILL(list) >= 0) {
2192 CV *cv = (CV*)av_shift(list);
2196 switch (Sigsetjmp(top_env,1)) {
2198 SV* atsv = GvSV(errgv);
2200 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
2201 (void)SvPV(atsv, len);
2203 Copy(oldtop, top_env, 1, Sigjmp_buf);
2204 curcop = &compiling;
2205 curcop->cop_line = oldline;
2206 if (list == beginav)
2207 sv_catpv(atsv, "BEGIN failed--compilation aborted");
2209 sv_catpv(atsv, "END failed--cleanup aborted");
2210 croak("%s", SvPVX(atsv));
2216 statusvalue = 255; /* XXX I don't think we use 1 anymore. */
2222 /* my_exit() was called */
2223 curstash = defstash;
2227 Copy(oldtop, top_env, 1, Sigjmp_buf);
2228 curcop = &compiling;
2229 curcop->cop_line = oldline;
2231 if (list == beginav)
2232 croak("BEGIN failed--compilation aborted");
2234 croak("END failed--cleanup aborted");
2236 my_exit(statusvalue);
2241 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
2245 Copy(oldtop, top_env, 1, Sigjmp_buf);
2246 curcop = &compiling;
2247 curcop->cop_line = oldline;
2248 Siglongjmp(top_env, 3);
2252 Copy(oldtop, top_env, 1, Sigjmp_buf);