3 * Copyright (c) 1987-1997 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
41 curcop = &compiling; \
48 laststype = OP_STAT; \
50 maxsysfd = MAXSYSFD; \
57 laststype = OP_STAT; \
60 static void find_beginning _((void));
61 static void forbid_setid _((char *));
62 static void incpush _((char *, int));
63 static void init_ids _((void));
64 static void init_debugger _((void));
65 static void init_lexer _((void));
66 static void init_main_stash _((void));
67 static void init_perllib _((void));
68 static void init_postdump_symbols _((int, char **, char **));
69 static void init_predump_symbols _((void));
70 static void init_stacks _((void));
71 static void my_exit_jump _((void)) __attribute__((noreturn));
72 static void nuke_stacks _((void));
73 static void open_script _((char *, bool, SV *));
74 static void usage _((char *));
75 static void validate_suid _((char *, char*));
77 static int fdscript = -1;
82 PerlInterpreter *sv_interp;
85 New(53, sv_interp, 1, PerlInterpreter);
90 perl_construct( sv_interp )
91 register PerlInterpreter *sv_interp;
93 if (!(curinterp = sv_interp))
97 Zero(sv_interp, 1, PerlInterpreter);
100 /* Init the real globals? */
102 linestr = NEWSV(65,80);
103 sv_upgrade(linestr,SVt_PVIV);
105 if (!SvREADONLY(&sv_undef)) {
106 SvREADONLY_on(&sv_undef);
110 SvREADONLY_on(&sv_no);
112 sv_setpv(&sv_yes,Yes);
114 SvREADONLY_on(&sv_yes);
117 nrs = newSVpv("\n", 1);
118 rs = SvREFCNT_inc(nrs);
124 * There is no way we can refer to them from Perl so close them to save
125 * space. The other alternative would be to provide STDAUX and STDPRN
128 (void)fclose(stdaux);
129 (void)fclose(stdprn);
135 perl_destruct_level = 1;
137 if(perl_destruct_level > 0)
145 SET_NUMERIC_STANDARD();
146 #if defined(SUBVERSION) && SUBVERSION > 0
147 sprintf(patchlevel, "%7.5f", (double) 5
148 + ((double) PATCHLEVEL / (double) 1000)
149 + ((double) SUBVERSION / (double) 100000));
151 sprintf(patchlevel, "%5.3f", (double) 5 +
152 ((double) PATCHLEVEL / (double) 1000));
155 #if defined(LOCAL_PATCH_COUNT)
156 localpatches = local_patches; /* For possible -v */
159 PerlIO_init(); /* Hook to IO system */
161 fdpid = newAV(); /* for remembering popen pids by fd */
168 perl_destruct(sv_interp)
169 register PerlInterpreter *sv_interp;
171 int destruct_level; /* 0=none, 1=full, 2=full with checks */
175 if (!(curinterp = sv_interp))
178 destruct_level = perl_destruct_level;
182 if (s = getenv("PERL_DESTRUCT_LEVEL")) {
184 if (destruct_level < i)
190 /* unhook hooks which will soon be, or use, destroyed data */
191 SvREFCNT_dec(warnhook);
193 SvREFCNT_dec(diehook);
195 SvREFCNT_dec(parsehook);
201 /* We must account for everything. */
203 /* Destroy the main CV and syntax tree */
205 curpad = AvARRAY(comppad);
210 SvREFCNT_dec(main_cv);
215 * Try to destruct global references. We do this first so that the
216 * destructors and destructees still exist. Some sv's might remain.
217 * Non-referenced objects are on their own.
224 if (destruct_level == 0){
226 DEBUG_P(debprofdump());
228 /* The exit() function will do everything that needs doing. */
232 /* loosen bonds of global variables */
235 (void)PerlIO_close(rsfp);
239 /* Filters for program text */
240 SvREFCNT_dec(rsfp_filters);
241 rsfp_filters = Nullav;
253 sawampersand = FALSE; /* must save all match strings */
254 sawstudy = FALSE; /* do fbm_instr on all strings */
269 /* magical thingies */
271 Safefree(ofs); /* $, */
274 Safefree(ors); /* $\ */
277 SvREFCNT_dec(nrs); /* $\ helper */
280 multiline = 0; /* $* */
282 SvREFCNT_dec(statname);
286 /* defgv, aka *_ should be taken care of elsewhere */
288 #if 0 /* just about all regexp stuff, seems to be ok */
290 /* shortcuts to regexp stuff */
295 SAVEFREEOP(oldlastpm); /* for saving regexp context during debugger */
297 regprecomp = NULL; /* uncompiled string. */
298 regparse = NULL; /* Input-scan pointer. */
299 regxend = NULL; /* End of input for compile */
300 regnpar = 0; /* () count. */
301 regcode = NULL; /* Code-emit pointer; ®dummy = don't. */
302 regsize = 0; /* Code size. */
303 regnaughty = 0; /* How bad is this pattern? */
304 regsawback = 0; /* Did we see \1, ...? */
306 reginput = NULL; /* String-input pointer. */
307 regbol = NULL; /* Beginning of input, for ^ check. */
308 regeol = NULL; /* End of input, for $ check. */
309 regstartp = (char **)NULL; /* Pointer to startp array. */
310 regendp = (char **)NULL; /* Ditto for endp. */
311 reglastparen = 0; /* Similarly for lastparen. */
312 regtill = NULL; /* How far we are required to go. */
313 regflags = 0; /* are we folding, multilining? */
314 regprev = (char)NULL; /* char before regbol, \n if none */
318 /* clean up after study() */
319 SvREFCNT_dec(lastscream);
321 Safefree(screamfirst);
323 Safefree(screamnext);
326 /* startup and shutdown function lists */
327 SvREFCNT_dec(beginav);
332 /* temp stack during pp_sort() */
333 SvREFCNT_dec(sortstack);
336 /* shortcuts just get cleared */
346 /* reset so print() ends up where we expect */
349 /* Prepare to destruct main symbol table. */
356 if (destruct_level >= 2) {
357 if (scopestack_ix != 0)
358 warn("Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
359 (long)scopestack_ix);
360 if (savestack_ix != 0)
361 warn("Unbalanced saves: %ld more saves than restores\n",
363 if (tmps_floor != -1)
364 warn("Unbalanced tmps: %ld more allocs than frees\n",
365 (long)tmps_floor + 1);
366 if (cxstack_ix != -1)
367 warn("Unbalanced context: %ld more PUSHes than POPs\n",
368 (long)cxstack_ix + 1);
371 /* Now absolutely destruct everything, somehow or other, loops or no. */
373 SvFLAGS(strtab) |= SVTYPEMASK; /* don't clean out strtab now */
374 while (sv_count != 0 && sv_count != last_sv_count) {
375 last_sv_count = sv_count;
378 SvFLAGS(strtab) &= ~SVTYPEMASK;
379 SvFLAGS(strtab) |= SVt_PVHV;
381 /* Destruct the global string table. */
383 /* Yell and reset the HeVAL() slots that are still holding refcounts,
384 * so that sv_free() won't fail on them.
393 array = HvARRAY(strtab);
397 warn("Unbalanced string table refcount: (%d) for \"%s\"",
398 HeVAL(hent) - Nullsv, HeKEY(hent));
399 HeVAL(hent) = Nullsv;
409 SvREFCNT_dec(strtab);
412 warn("Scalars leaked: %ld\n", (long)sv_count);
416 /* No SVs have survived, need to clean out */
420 Safefree(origfilename);
422 hints = 0; /* Reset hints. Should hints be per-interpreter ? */
424 DEBUG_P(debprofdump());
429 PerlInterpreter *sv_interp;
431 if (!(curinterp = sv_interp))
435 #if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE)
436 char *getenv _((char *)); /* Usually in <stdlib.h> */
440 perl_parse(sv_interp, xsinit, argc, argv, env)
441 PerlInterpreter *sv_interp;
442 void (*xsinit)_((void));
449 char *scriptname = NULL;
450 VOL bool dosearch = FALSE;
455 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
458 croak("suidperl is no longer needed since the kernel can now execute\n\
459 setuid perl scripts securely.\n");
463 if (!(curinterp = sv_interp))
466 #if defined(NeXT) && defined(__DYNAMIC__)
467 _dyld_lookup_and_bind
468 ("__environ", (unsigned long *) &environ_pointer, NULL);
473 #ifndef VMS /* VMS doesn't have environ array */
474 origenviron = environ;
480 /* Come here if running an undumped a.out. */
482 origfilename = savepv(argv[0]);
484 cxstack_ix = -1; /* start label stack again */
486 init_postdump_symbols(argc,argv,env);
491 curpad = AvARRAY(comppad);
496 SvREFCNT_dec(main_cv);
500 oldscope = scopestack_ix;
503 switch (Sigsetjmp(top_env,1)) {
508 /* my_exit() was called */
509 while (scopestack_ix > oldscope)
513 calllist(oldscope, endav);
514 return STATUS_NATIVE_EXPORT;
517 PerlIO_printf(PerlIO_stderr(), "panic: top_env\n");
521 sv_setpvn(linestr,"",0);
522 sv = newSVpv("",0); /* first used for -I flags */
525 for (argc--,argv++; argc > 0; argc--,argv++) {
526 if (argv[0][0] != '-' || !argv[0][1])
530 validarg = " PHOOEY ";
555 if (s = moreswitches(s))
565 if (euid != uid || egid != gid)
566 croak("No -e allowed in setuid scripts");
568 e_tmpname = savepv(TMPPATH);
569 (void)mktemp(e_tmpname);
571 croak("Can't mktemp()");
572 e_fp = PerlIO_open(e_tmpname,"w");
574 croak("Cannot open temporary file");
579 PerlIO_puts(e_fp,argv[1]);
583 croak("No code specified for -e");
584 (void)PerlIO_putc(e_fp,'\n');
595 incpush(argv[1], TRUE);
596 sv_catpv(sv,argv[1]);
613 preambleav = newAV();
614 av_push(preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
616 Sv = newSVpv("print myconfig();",0);
618 sv_catpv(Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
620 sv_catpv(Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
622 #if defined(DEBUGGING) || defined(NOEMBED) || defined(MULTIPLICITY)
623 strcpy(buf,"\" Compile-time options:");
625 strcat(buf," DEBUGGING");
628 strcat(buf," NOEMBED");
631 strcat(buf," MULTIPLICITY");
633 strcat(buf,"\\n\",");
636 #if defined(LOCAL_PATCH_COUNT)
637 if (LOCAL_PATCH_COUNT > 0)
639 sv_catpv(Sv,"print \" Locally applied patches:\\n\",");
640 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
641 if (localpatches[i]) {
642 sprintf(buf,"\" \\t%s\\n\",",localpatches[i]);
648 sprintf(buf,"\" Built under %s\\n\",",OSNAME);
652 sprintf(buf,"\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
654 sprintf(buf,"\" Compiled on %s\\n\"",__DATE__);
658 sv_catpv(Sv,"; $\"=\"\\n \"; print \" \\@INC:\\n @INC\\n\"");
661 Sv = newSVpv("config_vars(qw(",0);
666 av_push(preambleav, Sv);
667 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
681 croak("Unrecognized switch: -%s",s);
686 scriptname = argv[0];
688 if (PerlIO_flush(e_fp) || PerlIO_error(e_fp) || PerlIO_close(e_fp))
689 croak("Can't write to temp file for -e: %s", Strerror(errno));
692 scriptname = e_tmpname;
694 else if (scriptname == Nullch) {
696 if ( isatty(PerlIO_fileno(PerlIO_stdin())) )
704 open_script(scriptname,dosearch,sv);
706 validate_suid(validarg, scriptname);
711 main_cv = compcv = (CV*)NEWSV(1104,0);
712 sv_upgrade((SV *)compcv, SVt_PVCV);
716 av_push(comppad, Nullsv);
717 curpad = AvARRAY(comppad);
718 comppad_name = newAV();
719 comppad_name_fill = 0;
720 min_intro_pending = 0;
723 comppadlist = newAV();
724 AvREAL_off(comppadlist);
725 av_store(comppadlist, 0, (SV*)comppad_name);
726 av_store(comppadlist, 1, (SV*)comppad);
727 CvPADLIST(compcv) = comppadlist;
729 boot_core_UNIVERSAL();
731 (*xsinit)(); /* in case linked C routines want magical variables */
736 init_predump_symbols();
738 init_postdump_symbols(argc,argv,env);
742 /* now parse the script */
745 if (yyparse() || error_count) {
747 croak("%s had compilation errors.\n", origfilename);
749 croak("Execution of %s aborted due to compilation errors.\n",
753 curcop->cop_line = 0;
757 (void)UNLINK(e_tmpname);
762 /* now that script is parsed, we can modify record separator */
764 rs = SvREFCNT_inc(nrs);
765 sv_setsv(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), rs);
776 #ifdef DEBUGGING_MSTATS
777 if ((s=getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
778 dump_mstats("after compilation:");
788 PerlInterpreter *sv_interp;
792 if (!(curinterp = sv_interp))
795 oldscope = scopestack_ix;
797 switch (Sigsetjmp(top_env,1)) {
799 cxstack_ix = -1; /* start context stack again */
802 /* my_exit() was called */
803 while (scopestack_ix > oldscope)
807 calllist(oldscope, endav);
809 #ifdef DEBUGGING_MSTATS
810 if (getenv("PERL_DEBUG_MSTATS"))
811 dump_mstats("after execution: ");
813 return STATUS_NATIVE_EXPORT;
817 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
821 if (curstack != mainstack) {
823 SWITCHSTACK(curstack, mainstack);
828 DEBUG_r(PerlIO_printf(PerlIO_stderr(), "%s $` $& $' support.\n",
829 sawampersand ? "Enabling" : "Omitting"));
833 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
836 PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", origfilename);
839 if (perldb && DBsingle)
840 sv_setiv(DBsingle, 1);
850 else if (main_start) {
851 CvDEPTH(main_cv) = 1;
861 perl_get_sv(name, create)
865 GV* gv = gv_fetchpv(name, create, SVt_PV);
872 perl_get_av(name, create)
876 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
885 perl_get_hv(name, create)
889 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
898 perl_get_cv(name, create)
902 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
903 if (create && !GvCVu(gv))
904 return newSUB(start_subparse(FALSE, 0),
905 newSVOP(OP_CONST, 0, newSVpv(name,0)),
913 /* Be sure to refetch the stack pointer after calling these routines. */
916 perl_call_argv(subname, flags, argv)
918 I32 flags; /* See G_* flags in cop.h */
919 register char **argv; /* null terminated arg list */
926 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
931 return perl_call_pv(subname, flags);
935 perl_call_pv(subname, flags)
936 char *subname; /* name of the subroutine */
937 I32 flags; /* See G_* flags in cop.h */
939 return perl_call_sv((SV*)perl_get_cv(subname, TRUE), flags);
943 perl_call_method(methname, flags)
944 char *methname; /* name of the subroutine */
945 I32 flags; /* See G_* flags in cop.h */
951 XPUSHs(sv_2mortal(newSVpv(methname,0)));
954 return perl_call_sv(*stack_sp--, flags);
957 /* May be called with any of a CV, a GV, or an SV containing the name. */
959 perl_call_sv(sv, flags)
961 I32 flags; /* See G_* flags in cop.h */
963 LOGOP myop; /* fake syntax tree node */
970 bool oldmustcatch = mustcatch;
972 if (flags & G_DISCARD) {
977 Zero(&myop, 1, LOGOP);
978 if (flags & G_NOARGS) {
982 myop.op_flags |= OPf_STACKED;
983 myop.op_next = Nullop;
984 myop.op_flags |= OPf_KNOW;
986 myop.op_flags |= OPf_LIST;
993 oldscope = scopestack_ix;
995 if (perldb && curstash != debstash
996 /* Handle first BEGIN of -d. */
997 && (DBcv || (DBcv = GvCV(DBsub)))
998 /* Try harder, since this may have been a sighandler, thus
999 * curstash may be meaningless. */
1000 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != debstash))
1001 op->op_private |= OPpENTERSUB_DB;
1003 if (flags & G_EVAL) {
1004 Copy(top_env, oldtop, 1, Sigjmp_buf);
1006 cLOGOP->op_other = op;
1008 /* we're trying to emulate pp_entertry() here */
1010 register CONTEXT *cx;
1016 push_return(op->op_next);
1017 PUSHBLOCK(cx, CXt_EVAL, stack_sp);
1019 eval_root = op; /* Only needed so that goto works right. */
1022 if (flags & G_KEEPERR)
1025 sv_setpv(GvSV(errgv),"");
1030 switch (Sigsetjmp(top_env,1)) {
1037 /* my_exit() was called */
1038 curstash = defstash;
1040 Copy(oldtop, top_env, 1, Sigjmp_buf);
1042 croak("Callback called exit");
1052 stack_sp = stack_base + oldmark;
1053 if (flags & G_ARRAY)
1057 *++stack_sp = &sv_undef;
1065 if (op == (OP*)&myop)
1069 retval = stack_sp - (stack_base + oldmark);
1070 if ((flags & G_EVAL) && !(flags & G_KEEPERR))
1071 sv_setpv(GvSV(errgv),"");
1074 if (flags & G_EVAL) {
1075 if (scopestack_ix > oldscope) {
1079 register CONTEXT *cx;
1088 Copy(oldtop, top_env, 1, Sigjmp_buf);
1091 mustcatch = oldmustcatch;
1093 if (flags & G_DISCARD) {
1094 stack_sp = stack_base + oldmark;
1102 /* Eval a string. The G_EVAL flag is always assumed. */
1105 perl_eval_sv(sv, flags)
1107 I32 flags; /* See G_* flags in cop.h */
1109 UNOP myop; /* fake syntax tree node */
1111 I32 oldmark = sp - stack_base;
1116 if (flags & G_DISCARD) {
1124 EXTEND(stack_sp, 1);
1126 oldscope = scopestack_ix;
1128 if (!(flags & G_NOARGS))
1129 myop.op_flags = OPf_STACKED;
1130 myop.op_next = Nullop;
1131 myop.op_type = OP_ENTEREVAL;
1132 myop.op_flags |= OPf_KNOW;
1133 if (flags & G_KEEPERR)
1134 myop.op_flags |= OPf_SPECIAL;
1135 if (flags & G_ARRAY)
1136 myop.op_flags |= OPf_LIST;
1138 Copy(top_env, oldtop, 1, Sigjmp_buf);
1141 switch (Sigsetjmp(top_env,1)) {
1148 /* my_exit() was called */
1149 curstash = defstash;
1151 Copy(oldtop, top_env, 1, Sigjmp_buf);
1153 croak("Callback called exit");
1163 stack_sp = stack_base + oldmark;
1164 if (flags & G_ARRAY)
1168 *++stack_sp = &sv_undef;
1173 if (op == (OP*)&myop)
1174 op = pp_entereval();
1177 retval = stack_sp - (stack_base + oldmark);
1178 if (!(flags & G_KEEPERR))
1179 sv_setpv(GvSV(errgv),"");
1182 Copy(oldtop, top_env, 1, Sigjmp_buf);
1183 if (flags & G_DISCARD) {
1184 stack_sp = stack_base + oldmark;
1192 /* Require a module. */
1198 SV* sv = sv_newmortal();
1199 sv_setpv(sv, "require '");
1202 perl_eval_sv(sv, G_DISCARD);
1206 magicname(sym,name,namlen)
1213 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1214 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1218 usage(name) /* XXX move this out into a module ? */
1221 /* This message really ought to be max 23 lines.
1222 * Removed -h because the user already knows that opton. Others? */
1223 printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1224 printf("\n -0[octal] specify record separator (\\0, if no argument)");
1225 printf("\n -a autosplit mode with -n or -p (splits $_ into @F)");
1226 printf("\n -c check syntax only (runs BEGIN and END blocks)");
1227 printf("\n -d[:debugger] run scripts under debugger");
1228 printf("\n -D[number/list] set debugging flags (argument is a bit mask or flags)");
1229 printf("\n -e 'command' one line of script. Several -e's allowed. Omit [programfile].");
1230 printf("\n -F/pattern/ split() pattern for autosplit (-a). The //'s are optional.");
1231 printf("\n -i[extension] edit <> files in place (make backup if extension supplied)");
1232 printf("\n -Idirectory specify @INC/#include directory (may be used more then once)");
1233 printf("\n -l[octal] enable line ending processing, specifies line teminator");
1234 printf("\n -[mM][-]module.. executes `use/no module...' before executing your script.");
1235 printf("\n -n assume 'while (<>) { ... }' loop arround your script");
1236 printf("\n -p assume loop like -n but print line also like sed");
1237 printf("\n -P run script through C preprocessor before compilation");
1238 printf("\n -s enable some switch parsing for switches after script name");
1239 printf("\n -S look for the script using PATH environment variable");
1240 printf("\n -T turn on tainting checks");
1241 printf("\n -u dump core after parsing script");
1242 printf("\n -U allow unsafe operations");
1243 printf("\n -v print version number and patchlevel of perl");
1244 printf("\n -V[:variable] print perl configuration information");
1245 printf("\n -w TURN WARNINGS ON FOR COMPILATION OF YOUR SCRIPT.");
1246 printf("\n -x[directory] strip off text before #!perl line and perhaps cd to directory\n");
1249 /* This routine handles any switches that can be given during run */
1260 rschar = scan_oct(s, 4, &numlen);
1262 if (rschar & ~((U8)~0))
1264 else if (!rschar && numlen >= 2)
1265 nrs = newSVpv("", 0);
1268 nrs = newSVpv(&ch, 1);
1273 splitstr = savepv(s + 1);
1287 if (*s == ':' || *s == '=') {
1288 sprintf(buf, "use Devel::%s;", ++s);
1290 my_setenv("PERL5DB",buf);
1300 if (isALPHA(s[1])) {
1301 static char debopts[] = "psltocPmfrxuLHXD";
1304 for (s++; *s && (d = strchr(debopts,*s)); s++)
1305 debug |= 1 << (d - debopts);
1309 for (s++; isDIGIT(*s); s++) ;
1311 debug |= 0x80000000;
1313 warn("Recompile perl with -DDEBUGGING to use -D switch\n");
1314 for (s++; isALNUM(*s); s++) ;
1324 inplace = savepv(s+1);
1326 for (s = inplace; *s && !isSPACE(*s); s++) ;
1333 for (e = s; *e && !isSPACE(*e); e++) ;
1334 p = savepvn(s, e-s);
1341 croak("No space allowed after -I");
1351 *ors = scan_oct(s, 3 + (*s == '0'), &numlen);
1360 ors = SvPV(nrs, orslen);
1361 ors = savepvn(ors, orslen);
1365 forbid_setid("-M"); /* XXX ? */
1368 forbid_setid("-m"); /* XXX ? */
1372 /* -M-foo == 'no foo' */
1373 if (*s == '-') { use = "no "; ++s; }
1374 Sv = newSVpv(use,0);
1376 /* We allow -M'Module qw(Foo Bar)' */
1377 while(isALNUM(*s) || *s==':') ++s;
1379 sv_catpv(Sv, start);
1380 if (*(start-1) == 'm') {
1382 croak("Can't use '%c' after -mname", *s);
1383 sv_catpv( Sv, " ()");
1386 sv_catpvn(Sv, start, s-start);
1387 sv_catpv(Sv, " split(/,/,q{");
1392 if (preambleav == NULL)
1393 preambleav = newAV();
1394 av_push(preambleav, Sv);
1397 croak("No space allowed after -%c", *(s-1));
1414 croak("Too late for \"-T\" option");
1426 #if defined(SUBVERSION) && SUBVERSION > 0
1427 printf("\nThis is perl, version 5.%03d_%02d", PATCHLEVEL, SUBVERSION);
1429 printf("\nThis is perl, version %s",patchlevel);
1432 printf("\n\nCopyright 1987-1997, Larry Wall\n");
1434 printf("\n\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1437 printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
1440 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1441 "Version 5 port Copyright (c) 1994-1997, Andreas Kaiser, Ilya Zakharevich\n");
1444 printf("atariST series port, ++jrb bammi@cadence.com\n");
1447 Perl may be copied only under the terms of either the Artistic License or the\n\
1448 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n");
1456 if (s[1] == '-') /* Additional switches on #! line. */
1464 #ifdef ALTERNATE_SHEBANG
1465 case 'S': /* OS/2 needs -S on "extproc" line. */
1473 croak("Can't emulate -%.1s on #! line",s);
1478 /* compliments of Tom Christiansen */
1480 /* unexec() can be found in the Gnu emacs distribution */
1489 sprintf (buf, "%s.perldump", origfilename);
1490 sprintf (tokenbuf, "%s/perl", BIN_EXP);
1492 status = unexec(buf, tokenbuf, &etext, sbrk(0), 0);
1494 PerlIO_printf(PerlIO_stderr(), "unexec of %s into %s failed!\n", tokenbuf, buf);
1498 # include <lib$routines.h>
1499 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
1501 ABORT(); /* for use with undump */
1511 /* Note that strtab is a rather special HV. Assumptions are made
1512 about not iterating on it, and not adding tie magic to it.
1513 It is properly deallocated in perl_destruct() */
1515 HvSHAREKEYS_off(strtab); /* mandatory */
1516 Newz(506,((XPVHV*)SvANY(strtab))->xhv_array,
1517 sizeof(HE*) * (((XPVHV*)SvANY(strtab))->xhv_max + 1), char);
1519 curstash = defstash = newHV();
1520 curstname = newSVpv("main",4);
1521 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1522 SvREFCNT_dec(GvHV(gv));
1523 GvHV(gv) = (HV*)SvREFCNT_inc(defstash);
1525 HvNAME(defstash) = savepv("main");
1526 incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1528 defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1529 errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1531 sv_setpvn(GvSV(errgv), "", 0);
1532 curstash = defstash;
1533 compiling.cop_stash = defstash;
1534 debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
1535 /* We must init $/ before switches are processed. */
1536 sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1);
1539 #ifdef CAN_PROTOTYPE
1541 open_script(char *scriptname, bool dosearch, SV *sv)
1544 open_script(scriptname,dosearch,sv)
1550 char *xfound = Nullch;
1551 char *xfailed = Nullch;
1555 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
1556 #define SEARCH_EXTS ".bat", ".cmd", NULL
1559 # define SEARCH_EXTS ".pl", ".com", NULL
1561 /* additional extensions to try in each dir if scriptname not found */
1563 char *ext[] = { SEARCH_EXTS };
1564 int extidx = (strchr(scriptname,'.')) ? -1 : 0; /* has ext already */
1569 int hasdir, idx = 0, deftypes = 1;
1571 hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
1572 /* The first time through, just add SEARCH_EXTS to whatever we
1573 * already have, so we can check for default file types. */
1574 while (deftypes || (!hasdir && my_trnlnm("DCL$PATH",tokenbuf,idx++)) ) {
1575 if (deftypes) { deftypes = 0; *tokenbuf = '\0'; }
1576 strcat(tokenbuf,scriptname);
1578 if (dosearch && !strchr(scriptname, '/') && (s = getenv("PATH"))) {
1580 bufend = s + strlen(s);
1583 s = cpytill(tokenbuf,s,bufend,':',&len);
1586 for (len = 0; *s && *s != ',' && *s != ';'; tokenbuf[len++] = *s++);
1587 tokenbuf[len] = '\0';
1589 for (len = 0; *s && *s != ';'; tokenbuf[len++] = *s++);
1590 tokenbuf[len] = '\0';
1596 if (len && tokenbuf[len-1] != '/')
1599 if (len && ((tokenbuf[len-1] != '\\') && (tokenbuf[len-1] != '/')))
1601 if (len && tokenbuf[len-1] != '\\')
1604 (void)strcat(tokenbuf+len,"/");
1605 (void)strcat(tokenbuf+len,scriptname);
1609 len = strlen(tokenbuf);
1610 if (extidx > 0) /* reset after previous loop */
1614 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tokenbuf));
1615 retval = Stat(tokenbuf,&statbuf);
1617 } while ( retval < 0 /* not there */
1618 && extidx>=0 && ext[extidx] /* try an extension? */
1619 && strcpy(tokenbuf+len, ext[extidx++])
1624 if (S_ISREG(statbuf.st_mode)
1625 && cando(S_IRUSR,TRUE,&statbuf) && cando(S_IXUSR,TRUE,&statbuf)) {
1626 xfound = tokenbuf; /* bingo! */
1630 xfailed = savepv(tokenbuf);
1633 croak("Can't execute %s", xfailed ? xfailed : scriptname );
1636 scriptname = xfound;
1639 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
1640 char *s = scriptname + 8;
1649 origfilename = savepv(e_tmpname ? "-e" : scriptname);
1650 curcop->cop_filegv = gv_fetchfile(origfilename);
1651 if (strEQ(origfilename,"-"))
1653 if (fdscript >= 0) {
1654 rsfp = PerlIO_fdopen(fdscript,"r");
1655 #if defined(HAS_FCNTL) && defined(F_SETFD)
1657 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
1660 else if (preprocess) {
1661 char *cpp = CPPSTDIN;
1663 if (strEQ(cpp,"cppstdin"))
1664 sprintf(tokenbuf, "%s/%s", BIN_EXP, cpp);
1666 sprintf(tokenbuf, "%s", cpp);
1668 sv_catpv(sv,PRIVLIB_EXP);
1670 (void)sprintf(buf, "\
1671 sed %s -e \"/^[^#]/b\" \
1672 -e \"/^#[ ]*include[ ]/b\" \
1673 -e \"/^#[ ]*define[ ]/b\" \
1674 -e \"/^#[ ]*if[ ]/b\" \
1675 -e \"/^#[ ]*ifdef[ ]/b\" \
1676 -e \"/^#[ ]*ifndef[ ]/b\" \
1677 -e \"/^#[ ]*else/b\" \
1678 -e \"/^#[ ]*elif[ ]/b\" \
1679 -e \"/^#[ ]*undef[ ]/b\" \
1680 -e \"/^#[ ]*endif/b\" \
1683 (doextract ? "-e \"1,/^#/d\n\"" : ""),
1685 (void)sprintf(buf, "\
1686 %s %s -e '/^[^#]/b' \
1687 -e '/^#[ ]*include[ ]/b' \
1688 -e '/^#[ ]*define[ ]/b' \
1689 -e '/^#[ ]*if[ ]/b' \
1690 -e '/^#[ ]*ifdef[ ]/b' \
1691 -e '/^#[ ]*ifndef[ ]/b' \
1692 -e '/^#[ ]*else/b' \
1693 -e '/^#[ ]*elif[ ]/b' \
1694 -e '/^#[ ]*undef[ ]/b' \
1695 -e '/^#[ ]*endif/b' \
1703 (doextract ? "-e '1,/^#/d\n'" : ""),
1705 scriptname, tokenbuf, SvPV(sv, na), CPPMINUS);
1707 #ifdef IAMSUID /* actually, this is caught earlier */
1708 if (euid != uid && !euid) { /* if running suidperl */
1710 (void)seteuid(uid); /* musn't stay setuid root */
1713 (void)setreuid((Uid_t)-1, uid);
1715 #ifdef HAS_SETRESUID
1716 (void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
1722 if (geteuid() != uid)
1723 croak("Can't do seteuid!\n");
1725 #endif /* IAMSUID */
1726 rsfp = my_popen(buf,"r");
1728 else if (!*scriptname) {
1729 forbid_setid("program input from stdin");
1730 rsfp = PerlIO_stdin();
1733 rsfp = PerlIO_open(scriptname,"r");
1734 #if defined(HAS_FCNTL) && defined(F_SETFD)
1736 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
1744 #ifndef IAMSUID /* in case script is not readable before setuid */
1745 if (euid && Stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
1746 statbuf.st_mode & (S_ISUID|S_ISGID)) {
1747 (void)sprintf(buf, "%s/sperl%s", BIN_EXP, patchlevel);
1748 execv(buf, origargv); /* try again */
1749 croak("Can't do setuid\n");
1753 croak("Can't open perl script \"%s\": %s\n",
1754 SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno));
1759 validate_suid(validarg, scriptname)
1765 /* do we need to emulate setuid on scripts? */
1767 /* This code is for those BSD systems that have setuid #! scripts disabled
1768 * in the kernel because of a security problem. Merely defining DOSUID
1769 * in perl will not fix that problem, but if you have disabled setuid
1770 * scripts in the kernel, this will attempt to emulate setuid and setgid
1771 * on scripts that have those now-otherwise-useless bits set. The setuid
1772 * root version must be called suidperl or sperlN.NNN. If regular perl
1773 * discovers that it has opened a setuid script, it calls suidperl with
1774 * the same argv that it had. If suidperl finds that the script it has
1775 * just opened is NOT setuid root, it sets the effective uid back to the
1776 * uid. We don't just make perl setuid root because that loses the
1777 * effective uid we had before invoking perl, if it was different from the
1780 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
1781 * be defined in suidperl only. suidperl must be setuid root. The
1782 * Configure script will set this up for you if you want it.
1788 if (Fstat(PerlIO_fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
1789 croak("Can't stat script \"%s\"",origfilename);
1790 if (fdscript < 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) {
1794 #ifndef HAS_SETREUID
1795 /* On this access check to make sure the directories are readable,
1796 * there is actually a small window that the user could use to make
1797 * filename point to an accessible directory. So there is a faint
1798 * chance that someone could execute a setuid script down in a
1799 * non-accessible directory. I don't know what to do about that.
1800 * But I don't think it's too important. The manual lies when
1801 * it says access() is useful in setuid programs.
1803 if (access(SvPVX(GvSV(curcop->cop_filegv)),1)) /*double check*/
1804 croak("Permission denied");
1806 /* If we can swap euid and uid, then we can determine access rights
1807 * with a simple stat of the file, and then compare device and
1808 * inode to make sure we did stat() on the same file we opened.
1809 * Then we just have to make sure he or she can execute it.
1812 struct stat tmpstatbuf;
1816 setreuid(euid,uid) < 0
1819 setresuid(euid,uid,(Uid_t)-1) < 0
1822 || getuid() != euid || geteuid() != uid)
1823 croak("Can't swap uid and euid"); /* really paranoid */
1824 if (Stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
1825 croak("Permission denied"); /* testing full pathname here */
1826 if (tmpstatbuf.st_dev != statbuf.st_dev ||
1827 tmpstatbuf.st_ino != statbuf.st_ino) {
1828 (void)PerlIO_close(rsfp);
1829 if (rsfp = my_popen("/bin/mail root","w")) { /* heh, heh */
1831 "User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
1832 (Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
1833 (long)uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
1834 (long)statbuf.st_dev, (long)statbuf.st_ino,
1835 SvPVX(GvSV(curcop->cop_filegv)),
1836 (long)statbuf.st_uid, (long)statbuf.st_gid);
1837 (void)my_pclose(rsfp);
1839 croak("Permission denied\n");
1843 setreuid(uid,euid) < 0
1845 # if defined(HAS_SETRESUID)
1846 setresuid(uid,euid,(Uid_t)-1) < 0
1849 || getuid() != uid || geteuid() != euid)
1850 croak("Can't reswap uid and euid");
1851 if (!cando(S_IXUSR,FALSE,&statbuf)) /* can real uid exec? */
1852 croak("Permission denied\n");
1854 #endif /* HAS_SETREUID */
1855 #endif /* IAMSUID */
1857 if (!S_ISREG(statbuf.st_mode))
1858 croak("Permission denied");
1859 if (statbuf.st_mode & S_IWOTH)
1860 croak("Setuid/gid script is writable by world");
1861 doswitches = FALSE; /* -s is insecure in suid */
1863 if (sv_gets(linestr, rsfp, 0) == Nullch ||
1864 strnNE(SvPV(linestr,na),"#!",2) ) /* required even on Sys V */
1865 croak("No #! line");
1866 s = SvPV(linestr,na)+2;
1868 while (!isSPACE(*s)) s++;
1869 for (s2 = s; (s2 > SvPV(linestr,na)+2 &&
1870 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
1871 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
1872 croak("Not a perl script");
1873 while (*s == ' ' || *s == '\t') s++;
1875 * #! arg must be what we saw above. They can invoke it by
1876 * mentioning suidperl explicitly, but they may not add any strange
1877 * arguments beyond what #! says if they do invoke suidperl that way.
1879 len = strlen(validarg);
1880 if (strEQ(validarg," PHOOEY ") ||
1881 strnNE(s,validarg,len) || !isSPACE(s[len]))
1882 croak("Args must match #! line");
1885 if (euid != uid && (statbuf.st_mode & S_ISUID) &&
1886 euid == statbuf.st_uid)
1888 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
1889 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
1890 #endif /* IAMSUID */
1892 if (euid) { /* oops, we're not the setuid root perl */
1893 (void)PerlIO_close(rsfp);
1895 (void)sprintf(buf, "%s/sperl%s", BIN_EXP, patchlevel);
1896 execv(buf, origargv); /* try again */
1898 croak("Can't do setuid\n");
1901 if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
1903 (void)setegid(statbuf.st_gid);
1906 (void)setregid((Gid_t)-1,statbuf.st_gid);
1908 #ifdef HAS_SETRESGID
1909 (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
1911 setgid(statbuf.st_gid);
1915 if (getegid() != statbuf.st_gid)
1916 croak("Can't do setegid!\n");
1918 if (statbuf.st_mode & S_ISUID) {
1919 if (statbuf.st_uid != euid)
1921 (void)seteuid(statbuf.st_uid); /* all that for this */
1924 (void)setreuid((Uid_t)-1,statbuf.st_uid);
1926 #ifdef HAS_SETRESUID
1927 (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
1929 setuid(statbuf.st_uid);
1933 if (geteuid() != statbuf.st_uid)
1934 croak("Can't do seteuid!\n");
1936 else if (uid) { /* oops, mustn't run as root */
1938 (void)seteuid((Uid_t)uid);
1941 (void)setreuid((Uid_t)-1,(Uid_t)uid);
1943 #ifdef HAS_SETRESUID
1944 (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
1950 if (geteuid() != uid)
1951 croak("Can't do seteuid!\n");
1954 if (!cando(S_IXUSR,TRUE,&statbuf))
1955 croak("Permission denied\n"); /* they can't do this */
1958 else if (preprocess)
1959 croak("-P not allowed for setuid/setgid script\n");
1960 else if (fdscript >= 0)
1961 croak("fd script not allowed in suidperl\n");
1963 croak("Script is not setuid/setgid in suidperl\n");
1965 /* We absolutely must clear out any saved ids here, so we */
1966 /* exec the real perl, substituting fd script for scriptname. */
1967 /* (We pass script name as "subdir" of fd, which perl will grok.) */
1968 PerlIO_rewind(rsfp);
1969 lseek(PerlIO_fileno(rsfp),(Off_t)0,0); /* just in case rewind didn't */
1970 for (which = 1; origargv[which] && origargv[which] != scriptname; which++) ;
1971 if (!origargv[which])
1972 croak("Permission denied");
1973 (void)sprintf(buf, "/dev/fd/%d/%.127s", PerlIO_fileno(rsfp), origargv[which]);
1974 origargv[which] = buf;
1976 #if defined(HAS_FCNTL) && defined(F_SETFD)
1977 fcntl(PerlIO_fileno(rsfp),F_SETFD,0); /* ensure no close-on-exec */
1980 (void)sprintf(tokenbuf, "%s/perl%s", BIN_EXP, patchlevel);
1981 execv(tokenbuf, origargv); /* try again */
1982 croak("Can't do setuid\n");
1983 #endif /* IAMSUID */
1985 if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */
1986 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
1987 Fstat(PerlIO_fileno(rsfp),&statbuf); /* may be either wrapped or real suid */
1988 if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
1990 (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
1993 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
1994 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
1995 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
1996 /* not set-id, must be wrapped */
2004 register char *s, *s2;
2006 /* skip forward in input to the real script? */
2010 if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
2011 croak("No Perl script found in input\n");
2012 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2013 PerlIO_ungetc(rsfp, '\n'); /* to keep line count right */
2015 while (*s && !(isSPACE (*s) || *s == '#')) s++;
2017 while (*s == ' ' || *s == '\t') s++;
2019 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2020 if (strnEQ(s2-4,"perl",4))
2022 while (s = moreswitches(s)) ;
2024 if (cddir && chdir(cddir) < 0)
2025 croak("Can't chdir to %s",cddir);
2033 uid = (int)getuid();
2034 euid = (int)geteuid();
2035 gid = (int)getgid();
2036 egid = (int)getegid();
2041 tainting |= (uid && (euid != uid || egid != gid));
2049 croak("No %s allowed while running setuid", s);
2051 croak("No %s allowed while running setgid", s);
2057 curstash = debstash;
2058 dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2060 DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2061 DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2062 DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2063 DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2064 sv_setiv(DBsingle, 0);
2065 DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2066 sv_setiv(DBtrace, 0);
2067 DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2068 sv_setiv(DBsignal, 0);
2069 curstash = defstash;
2076 mainstack = curstack; /* remember in case we switch stacks */
2077 AvREAL_off(curstack); /* not a real array */
2078 av_extend(curstack,127);
2080 stack_base = AvARRAY(curstack);
2081 stack_sp = stack_base;
2082 stack_max = stack_base + 127;
2084 cxstack_max = 8192 / sizeof(CONTEXT) - 2; /* Use most of 8K. */
2085 New(50,cxstack,cxstack_max + 1,CONTEXT);
2088 New(50,tmps_stack,128,SV*);
2093 New(51,debname,128,char);
2094 New(52,debdelim,128,char);
2098 * The following stacks almost certainly should be per-interpreter,
2099 * but for now they're not. XXX
2103 markstack_ptr = markstack;
2105 New(54,markstack,64,I32);
2106 markstack_ptr = markstack;
2107 markstack_max = markstack + 64;
2113 New(54,scopestack,32,I32);
2115 scopestack_max = 32;
2121 New(54,savestack,128,ANY);
2123 savestack_max = 128;
2129 New(54,retstack,16,OP*);
2139 Safefree(tmps_stack);
2146 static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
2154 subname = newSVpv("main",4);
2158 init_predump_symbols()
2163 sv_setpvn(GvSV(gv_fetchpv("\"", TRUE, SVt_PV)), " ", 1);
2165 stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2166 GvMULTI_on(stdingv);
2167 IoIFP(GvIOp(stdingv)) = PerlIO_stdin();
2168 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2170 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv));
2172 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2174 IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
2176 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2178 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv));
2180 othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2181 GvMULTI_on(othergv);
2182 IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr();
2183 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2185 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
2187 statname = NEWSV(66,0); /* last filename we did stat on */
2190 osname = savepv(OSNAME);
2194 init_postdump_symbols(argc,argv,env)
2196 register char **argv;
2197 register char **env;
2203 argc--,argv++; /* skip name of script */
2205 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2208 if (argv[0][1] == '-') {
2212 if (s = strchr(argv[0], '=')) {
2214 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2217 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2220 toptarget = NEWSV(0,0);
2221 sv_upgrade(toptarget, SVt_PVFM);
2222 sv_setpvn(toptarget, "", 0);
2223 bodytarget = NEWSV(0,0);
2224 sv_upgrade(bodytarget, SVt_PVFM);
2225 sv_setpvn(bodytarget, "", 0);
2226 formtarget = bodytarget;
2229 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2230 sv_setpv(GvSV(tmpgv),origfilename);
2231 magicname("0", "0", 1);
2233 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2234 sv_setpv(GvSV(tmpgv),origargv[0]);
2235 if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2237 (void)gv_AVadd(argvgv);
2238 av_clear(GvAVn(argvgv));
2239 for (; argc > 0; argc--,argv++) {
2240 av_push(GvAVn(argvgv),newSVpv(argv[0],0));
2243 if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2248 #ifndef VMS /* VMS doesn't have environ array */
2249 /* Note that if the supplied env parameter is actually a copy
2250 of the global environ then it may now point to free'd memory
2251 if the environment has been modified since. To avoid this
2252 problem we treat env==NULL as meaning 'use the default'
2256 if (env != environ) {
2257 environ[0] = Nullch;
2258 hv_magic(hv, envgv, 'E');
2260 for (; *env; env++) {
2261 if (!(s = strchr(*env,'=')))
2264 sv = newSVpv(s--,0);
2265 sv_magic(sv, sv, 'e', *env, s - *env);
2266 (void)hv_store(hv, *env, s - *env, sv, 0);
2270 #ifdef DYNAMIC_ENV_FETCH
2271 HvNAME(hv) = savepv(ENV_HV_NAME);
2273 hv_magic(hv, envgv, 'E');
2276 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2277 sv_setiv(GvSV(tmpgv), (IV)getpid());
2286 s = getenv("PERL5LIB");
2290 incpush(getenv("PERLLIB"), FALSE);
2292 /* Treat PERL5?LIB as a possible search list logical name -- the
2293 * "natural" VMS idiom for a Unix path string. We allow each
2294 * element to be a set of |-separated directories for compatibility.
2298 if (my_trnlnm("PERL5LIB",buf,0))
2299 do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2301 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2305 /* Use the ~-expanded versions of APPLIB (undocumented),
2306 ARCHLIB PRIVLIB SITEARCH SITELIB and OLDARCHLIB
2309 incpush(APPLLIB_EXP, FALSE);
2313 incpush(ARCHLIB_EXP, FALSE);
2316 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2318 incpush(PRIVLIB_EXP, FALSE);
2321 incpush(SITEARCH_EXP, FALSE);
2324 incpush(SITELIB_EXP, FALSE);
2326 #ifdef OLDARCHLIB_EXP /* 5.00[01] compatibility */
2327 incpush(OLDARCHLIB_EXP, FALSE);
2331 incpush(".", FALSE);
2335 # define PERLLIB_SEP ';'
2338 # define PERLLIB_SEP '|'
2340 # define PERLLIB_SEP ':'
2343 #ifndef PERLLIB_MANGLE
2344 # define PERLLIB_MANGLE(s,n) (s)
2348 incpush(p, addsubdirs)
2352 SV *subdir = Nullsv;
2353 static char *archpat_auto;
2360 if (!archpat_auto) {
2361 STRLEN len = (sizeof(ARCHNAME) + strlen(patchlevel)
2362 + sizeof("//auto"));
2363 New(55, archpat_auto, len, char);
2364 sprintf(archpat_auto, "/%s/%s/auto", ARCHNAME, patchlevel);
2366 for (len = sizeof(ARCHNAME) + 2;
2367 archpat_auto[len] != '\0' && archpat_auto[len] != '/'; len++)
2368 if (archpat_auto[len] == '.') archpat_auto[len] = '_';
2373 /* Break at all separators */
2375 SV *libdir = newSV(0);
2378 /* skip any consecutive separators */
2379 while ( *p == PERLLIB_SEP ) {
2380 /* Uncomment the next line for PATH semantics */
2381 /* av_push(GvAVn(incgv), newSVpv(".", 1)); */
2385 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2386 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2391 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2392 p = Nullch; /* break out */
2396 * BEFORE pushing libdir onto @INC we may first push version- and
2397 * archname-specific sub-directories.
2400 struct stat tmpstatbuf;
2405 if ((unix = tounixspec_ts(SvPV(libdir,na),Nullch)) != Nullch) {
2407 while (unix[len-1] == '/') len--; /* Cosmetic */
2408 sv_usepvn(libdir,unix,len);
2411 PerlIO_printf(PerlIO_stderr(),
2412 "Failed to unixify @INC element \"%s\"\n",
2415 /* .../archname/version if -d .../archname/version/auto */
2416 sv_setsv(subdir, libdir);
2417 sv_catpv(subdir, archpat_auto);
2418 if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2419 S_ISDIR(tmpstatbuf.st_mode))
2420 av_push(GvAVn(incgv),
2421 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2423 /* .../archname if -d .../archname/auto */
2424 sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
2425 strlen(patchlevel) + 1, "", 0);
2426 if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2427 S_ISDIR(tmpstatbuf.st_mode))
2428 av_push(GvAVn(incgv),
2429 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2432 /* finally push this lib directory on the end of @INC */
2433 av_push(GvAVn(incgv), libdir);
2436 SvREFCNT_dec(subdir);
2440 calllist(oldscope, list)
2446 line_t oldline = curcop->cop_line;
2448 Copy(top_env, oldtop, 1, Sigjmp_buf);
2450 while (AvFILL(list) >= 0) {
2451 CV *cv = (CV*)av_shift(list);
2455 switch (Sigsetjmp(top_env,1)) {
2457 SV* atsv = GvSV(errgv);
2459 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
2460 (void)SvPV(atsv, len);
2462 Copy(oldtop, top_env, 1, Sigjmp_buf);
2463 curcop = &compiling;
2464 curcop->cop_line = oldline;
2465 if (list == beginav)
2466 sv_catpv(atsv, "BEGIN failed--compilation aborted");
2468 sv_catpv(atsv, "END failed--cleanup aborted");
2469 while (scopestack_ix > oldscope)
2471 croak("%s", SvPVX(atsv));
2479 /* my_exit() was called */
2480 while (scopestack_ix > oldscope)
2482 curstash = defstash;
2484 calllist(oldscope, endav);
2486 Copy(oldtop, top_env, 1, Sigjmp_buf);
2487 curcop = &compiling;
2488 curcop->cop_line = oldline;
2490 if (list == beginav)
2491 croak("BEGIN failed--compilation aborted");
2493 croak("END failed--cleanup aborted");
2499 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
2503 Copy(oldtop, top_env, 1, Sigjmp_buf);
2504 curcop = &compiling;
2505 curcop->cop_line = oldline;
2506 Siglongjmp(top_env, 3);
2510 Copy(oldtop, top_env, 1, Sigjmp_buf);
2525 STATUS_NATIVE_SET(status);
2535 if (vaxc$errno & 1) {
2536 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
2537 STATUS_NATIVE_SET(44);
2540 if (!vaxc$errno && errno) /* unlikely */
2541 STATUS_NATIVE_SET(44);
2543 STATUS_NATIVE_SET(vaxc$errno);
2547 STATUS_POSIX_SET(errno);
2548 else if (STATUS_POSIX == 0)
2549 STATUS_POSIX_SET(255);
2557 register CONTEXT *cx;
2566 (void)UNLINK(e_tmpname);
2567 Safefree(e_tmpname);
2571 if (cxstack_ix >= 0) {
2578 Siglongjmp(top_env, 2);