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
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;
454 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
457 croak("suidperl is no longer needed since the kernel can now execute\n\
458 setuid perl scripts securely.\n");
462 if (!(curinterp = sv_interp))
465 #if defined(NeXT) && defined(__DYNAMIC__)
466 _dyld_lookup_and_bind
467 ("__environ", (unsigned long *) &environ_pointer, NULL);
472 #ifndef VMS /* VMS doesn't have environ array */
473 origenviron = environ;
479 /* Come here if running an undumped a.out. */
481 origfilename = savepv(argv[0]);
483 cxstack_ix = -1; /* start label stack again */
485 init_postdump_symbols(argc,argv,env);
490 curpad = AvARRAY(comppad);
495 SvREFCNT_dec(main_cv);
501 switch (Sigsetjmp(top_env,1)) {
506 /* my_exit() was called */
510 return STATUS_NATIVE_EXPORT;
512 PerlIO_printf(PerlIO_stderr(), "panic: top_env\n");
516 sv_setpvn(linestr,"",0);
517 sv = newSVpv("",0); /* first used for -I flags */
520 for (argc--,argv++; argc > 0; argc--,argv++) {
521 if (argv[0][0] != '-' || !argv[0][1])
525 validarg = " PHOOEY ";
550 if (s = moreswitches(s))
560 if (euid != uid || egid != gid)
561 croak("No -e allowed in setuid scripts");
563 e_tmpname = savepv(TMPPATH);
564 (void)mktemp(e_tmpname);
566 croak("Can't mktemp()");
567 e_fp = PerlIO_open(e_tmpname,"w");
569 croak("Cannot open temporary file");
574 PerlIO_puts(e_fp,argv[1]);
578 croak("No code specified for -e");
579 (void)PerlIO_putc(e_fp,'\n');
590 incpush(argv[1], TRUE);
591 sv_catpv(sv,argv[1]);
608 preambleav = newAV();
609 av_push(preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
611 Sv = newSVpv("print myconfig();",0);
613 sv_catpv(Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
615 sv_catpv(Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
617 #if defined(DEBUGGING) || defined(NOEMBED) || defined(MULTIPLICITY)
618 strcpy(buf,"\" Compile-time options:");
620 strcat(buf," DEBUGGING");
623 strcat(buf," NOEMBED");
626 strcat(buf," MULTIPLICITY");
628 strcat(buf,"\\n\",");
631 #if defined(LOCAL_PATCH_COUNT)
632 if (LOCAL_PATCH_COUNT > 0)
634 sv_catpv(Sv,"print \" Locally applied patches:\\n\",");
635 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
636 if (localpatches[i]) {
637 sprintf(buf,"\" \\t%s\\n\",",localpatches[i]);
643 sprintf(buf,"\" Built under %s\\n\",",OSNAME);
647 sprintf(buf,"\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
649 sprintf(buf,"\" Compiled on %s\\n\"",__DATE__);
653 sv_catpv(Sv,"; $\"=\"\\n \"; print \" \\@INC:\\n @INC\\n\"");
656 Sv = newSVpv("config_vars(qw(",0);
661 av_push(preambleav, Sv);
662 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
676 croak("Unrecognized switch: -%s",s);
681 scriptname = argv[0];
683 if (PerlIO_flush(e_fp) || PerlIO_error(e_fp) || PerlIO_close(e_fp))
684 croak("Can't write to temp file for -e: %s", Strerror(errno));
687 scriptname = e_tmpname;
689 else if (scriptname == Nullch) {
691 if ( isatty(PerlIO_fileno(PerlIO_stdin())) )
699 open_script(scriptname,dosearch,sv);
701 validate_suid(validarg, scriptname);
706 main_cv = compcv = (CV*)NEWSV(1104,0);
707 sv_upgrade((SV *)compcv, SVt_PVCV);
711 av_push(comppad, Nullsv);
712 curpad = AvARRAY(comppad);
713 comppad_name = newAV();
714 comppad_name_fill = 0;
715 min_intro_pending = 0;
718 comppadlist = newAV();
719 AvREAL_off(comppadlist);
720 av_store(comppadlist, 0, (SV*)comppad_name);
721 av_store(comppadlist, 1, (SV*)comppad);
722 CvPADLIST(compcv) = comppadlist;
724 boot_core_UNIVERSAL();
726 (*xsinit)(); /* in case linked C routines want magical variables */
731 init_predump_symbols();
733 init_postdump_symbols(argc,argv,env);
737 /* now parse the script */
740 if (yyparse() || error_count) {
742 croak("%s had compilation errors.\n", origfilename);
744 croak("Execution of %s aborted due to compilation errors.\n",
748 curcop->cop_line = 0;
752 (void)UNLINK(e_tmpname);
757 /* now that script is parsed, we can modify record separator */
759 rs = SvREFCNT_inc(nrs);
760 sv_setsv(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), rs);
771 #ifdef DEBUGGING_MSTATS
772 if ((s=getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
773 dump_mstats("after compilation:");
783 PerlInterpreter *sv_interp;
785 if (!(curinterp = sv_interp))
787 switch (Sigsetjmp(top_env,1)) {
789 cxstack_ix = -1; /* start context stack again */
792 /* my_exit() was called */
797 #ifdef DEBUGGING_MSTATS
798 if (getenv("PERL_DEBUG_MSTATS"))
799 dump_mstats("after execution: ");
801 return STATUS_NATIVE_EXPORT;
804 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
808 if (curstack != mainstack) {
810 SWITCHSTACK(curstack, mainstack);
815 DEBUG_r(PerlIO_printf(PerlIO_stderr(), "%s $` $& $' support.\n",
816 sawampersand ? "Enabling" : "Omitting"));
820 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
823 PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", origfilename);
826 if (perldb && DBsingle)
827 sv_setiv(DBsingle, 1);
837 else if (main_start) {
838 CvDEPTH(main_cv) = 1;
848 perl_get_sv(name, create)
852 GV* gv = gv_fetchpv(name, create, SVt_PV);
859 perl_get_av(name, create)
863 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
872 perl_get_hv(name, create)
876 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
885 perl_get_cv(name, create)
889 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
890 if (create && !GvCVu(gv))
891 return newSUB(start_subparse(FALSE, 0),
892 newSVOP(OP_CONST, 0, newSVpv(name,0)),
900 /* Be sure to refetch the stack pointer after calling these routines. */
903 perl_call_argv(subname, flags, argv)
905 I32 flags; /* See G_* flags in cop.h */
906 register char **argv; /* null terminated arg list */
913 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
918 return perl_call_pv(subname, flags);
922 perl_call_pv(subname, flags)
923 char *subname; /* name of the subroutine */
924 I32 flags; /* See G_* flags in cop.h */
926 return perl_call_sv((SV*)perl_get_cv(subname, TRUE), flags);
930 perl_call_method(methname, flags)
931 char *methname; /* name of the subroutine */
932 I32 flags; /* See G_* flags in cop.h */
938 XPUSHs(sv_2mortal(newSVpv(methname,0)));
941 return perl_call_sv(*stack_sp--, flags);
944 /* May be called with any of a CV, a GV, or an SV containing the name. */
946 perl_call_sv(sv, flags)
948 I32 flags; /* See G_* flags in cop.h */
950 LOGOP myop; /* fake syntax tree node */
957 bool oldmustcatch = mustcatch;
959 if (flags & G_DISCARD) {
964 Zero(&myop, 1, LOGOP);
965 if (flags & G_NOARGS) {
969 myop.op_flags |= OPf_STACKED;
970 myop.op_next = Nullop;
971 myop.op_flags |= OPf_KNOW;
973 myop.op_flags |= OPf_LIST;
980 oldscope = scopestack_ix;
982 if (perldb && curstash != debstash
983 /* Handle first BEGIN of -d. */
984 && (DBcv || (DBcv = GvCV(DBsub)))
985 /* Try harder, since this may have been a sighandler, thus
986 * curstash may be meaningless. */
987 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != debstash))
988 op->op_private |= OPpENTERSUB_DB;
990 if (flags & G_EVAL) {
991 Copy(top_env, oldtop, 1, Sigjmp_buf);
993 cLOGOP->op_other = op;
995 /* we're trying to emulate pp_entertry() here */
997 register CONTEXT *cx;
1003 push_return(op->op_next);
1004 PUSHBLOCK(cx, CXt_EVAL, stack_sp);
1006 eval_root = op; /* Only needed so that goto works right. */
1009 if (flags & G_KEEPERR)
1012 sv_setpv(GvSV(errgv),"");
1017 switch (Sigsetjmp(top_env,1)) {
1024 /* my_exit() was called */
1025 curstash = defstash;
1027 Copy(oldtop, top_env, 1, Sigjmp_buf);
1029 croak("Callback called exit");
1038 stack_sp = stack_base + oldmark;
1039 if (flags & G_ARRAY)
1043 *++stack_sp = &sv_undef;
1051 if (op == (OP*)&myop)
1055 retval = stack_sp - (stack_base + oldmark);
1056 if ((flags & G_EVAL) && !(flags & G_KEEPERR))
1057 sv_setpv(GvSV(errgv),"");
1060 if (flags & G_EVAL) {
1061 if (scopestack_ix > oldscope) {
1065 register CONTEXT *cx;
1074 Copy(oldtop, top_env, 1, Sigjmp_buf);
1077 mustcatch = oldmustcatch;
1079 if (flags & G_DISCARD) {
1080 stack_sp = stack_base + oldmark;
1088 /* Eval a string. The G_EVAL flag is always assumed. */
1091 perl_eval_sv(sv, flags)
1093 I32 flags; /* See G_* flags in cop.h */
1095 UNOP myop; /* fake syntax tree node */
1097 I32 oldmark = sp - stack_base;
1102 if (flags & G_DISCARD) {
1110 EXTEND(stack_sp, 1);
1112 oldscope = scopestack_ix;
1114 if (!(flags & G_NOARGS))
1115 myop.op_flags = OPf_STACKED;
1116 myop.op_next = Nullop;
1117 myop.op_type = OP_ENTEREVAL;
1118 myop.op_flags |= OPf_KNOW;
1119 if (flags & G_KEEPERR)
1120 myop.op_flags |= OPf_SPECIAL;
1121 if (flags & G_ARRAY)
1122 myop.op_flags |= OPf_LIST;
1124 Copy(top_env, oldtop, 1, Sigjmp_buf);
1127 switch (Sigsetjmp(top_env,1)) {
1134 /* my_exit() was called */
1135 curstash = defstash;
1137 Copy(oldtop, top_env, 1, Sigjmp_buf);
1139 croak("Callback called exit");
1148 stack_sp = stack_base + oldmark;
1149 if (flags & G_ARRAY)
1153 *++stack_sp = &sv_undef;
1158 if (op == (OP*)&myop)
1159 op = pp_entereval();
1162 retval = stack_sp - (stack_base + oldmark);
1163 if (!(flags & G_KEEPERR))
1164 sv_setpv(GvSV(errgv),"");
1167 Copy(oldtop, top_env, 1, Sigjmp_buf);
1168 if (flags & G_DISCARD) {
1169 stack_sp = stack_base + oldmark;
1177 /* Require a module. */
1183 SV* sv = sv_newmortal();
1184 sv_setpv(sv, "require '");
1187 perl_eval_sv(sv, G_DISCARD);
1191 magicname(sym,name,namlen)
1198 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1199 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1203 usage(name) /* XXX move this out into a module ? */
1206 /* This message really ought to be max 23 lines.
1207 * Removed -h because the user already knows that opton. Others? */
1208 printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1209 printf("\n -0[octal] specify record separator (\\0, if no argument)");
1210 printf("\n -a autosplit mode with -n or -p (splits $_ into @F)");
1211 printf("\n -c check syntax only (runs BEGIN and END blocks)");
1212 printf("\n -d[:debugger] run scripts under debugger");
1213 printf("\n -D[number/list] set debugging flags (argument is a bit mask or flags)");
1214 printf("\n -e 'command' one line of script. Several -e's allowed. Omit [programfile].");
1215 printf("\n -F/pattern/ split() pattern for autosplit (-a). The //'s are optional.");
1216 printf("\n -i[extension] edit <> files in place (make backup if extension supplied)");
1217 printf("\n -Idirectory specify @INC/#include directory (may be used more then once)");
1218 printf("\n -l[octal] enable line ending processing, specifies line teminator");
1219 printf("\n -[mM][-]module.. executes `use/no module...' before executing your script.");
1220 printf("\n -n assume 'while (<>) { ... }' loop arround your script");
1221 printf("\n -p assume loop like -n but print line also like sed");
1222 printf("\n -P run script through C preprocessor before compilation");
1223 printf("\n -s enable some switch parsing for switches after script name");
1224 printf("\n -S look for the script using PATH environment variable");
1225 printf("\n -T turn on tainting checks");
1226 printf("\n -u dump core after parsing script");
1227 printf("\n -U allow unsafe operations");
1228 printf("\n -v print version number and patchlevel of perl");
1229 printf("\n -V[:variable] print perl configuration information");
1230 printf("\n -w TURN WARNINGS ON FOR COMPILATION OF YOUR SCRIPT.");
1231 printf("\n -x[directory] strip off text before #!perl line and perhaps cd to directory\n");
1234 /* This routine handles any switches that can be given during run */
1245 rschar = scan_oct(s, 4, &numlen);
1247 if (rschar & ~((U8)~0))
1249 else if (!rschar && numlen >= 2)
1250 nrs = newSVpv("", 0);
1253 nrs = newSVpv(&ch, 1);
1258 splitstr = savepv(s + 1);
1272 if (*s == ':' || *s == '=') {
1273 sprintf(buf, "use Devel::%s;", ++s);
1275 my_setenv("PERL5DB",buf);
1285 if (isALPHA(s[1])) {
1286 static char debopts[] = "psltocPmfrxuLHXD";
1289 for (s++; *s && (d = strchr(debopts,*s)); s++)
1290 debug |= 1 << (d - debopts);
1294 for (s++; isDIGIT(*s); s++) ;
1296 debug |= 0x80000000;
1298 warn("Recompile perl with -DDEBUGGING to use -D switch\n");
1299 for (s++; isALNUM(*s); s++) ;
1309 inplace = savepv(s+1);
1311 for (s = inplace; *s && !isSPACE(*s); s++) ;
1318 for (e = s; *e && !isSPACE(*e); e++) ;
1319 p = savepvn(s, e-s);
1326 croak("No space allowed after -I");
1336 *ors = scan_oct(s, 3 + (*s == '0'), &numlen);
1345 ors = SvPV(nrs, orslen);
1346 ors = savepvn(ors, orslen);
1350 forbid_setid("-M"); /* XXX ? */
1353 forbid_setid("-m"); /* XXX ? */
1357 /* -M-foo == 'no foo' */
1358 if (*s == '-') { use = "no "; ++s; }
1359 Sv = newSVpv(use,0);
1361 /* We allow -M'Module qw(Foo Bar)' */
1362 while(isALNUM(*s) || *s==':') ++s;
1364 sv_catpv(Sv, start);
1365 if (*(start-1) == 'm') {
1367 croak("Can't use '%c' after -mname", *s);
1368 sv_catpv( Sv, " ()");
1371 sv_catpvn(Sv, start, s-start);
1372 sv_catpv(Sv, " split(/,/,q{");
1377 if (preambleav == NULL)
1378 preambleav = newAV();
1379 av_push(preambleav, Sv);
1382 croak("No space allowed after -%c", *(s-1));
1399 croak("Too late for \"-T\" option (try putting it first)");
1411 #if defined(SUBVERSION) && SUBVERSION > 0
1412 printf("\nThis is perl, version 5.%03d_%02d", PATCHLEVEL, SUBVERSION);
1414 printf("\nThis is perl, version %s",patchlevel);
1417 printf("\n\nCopyright 1987-1997, Larry Wall\n");
1419 printf("\n\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1422 printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
1425 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1426 "Version 5 port Copyright (c) 1994-1996, Andreas Kaiser, Ilya Zakharevich\n");
1429 printf("atariST series port, ++jrb bammi@cadence.com\n");
1432 Perl may be copied only under the terms of either the Artistic License or the\n\
1433 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n");
1441 if (s[1] == '-') /* Additional switches on #! line. */
1449 #ifdef ALTERNATE_SHEBANG
1450 case 'S': /* OS/2 needs -S on "extproc" line. */
1458 croak("Can't emulate -%.1s on #! line",s);
1463 /* compliments of Tom Christiansen */
1465 /* unexec() can be found in the Gnu emacs distribution */
1474 sprintf (buf, "%s.perldump", origfilename);
1475 sprintf (tokenbuf, "%s/perl", BIN);
1477 status = unexec(buf, tokenbuf, &etext, sbrk(0), 0);
1479 PerlIO_printf(PerlIO_stderr(), "unexec of %s into %s failed!\n", tokenbuf, buf);
1483 # include <lib$routines.h>
1484 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
1486 ABORT(); /* for use with undump */
1496 /* Note that strtab is a rather special HV. Assumptions are made
1497 about not iterating on it, and not adding tie magic to it.
1498 It is properly deallocated in perl_destruct() */
1500 HvSHAREKEYS_off(strtab); /* mandatory */
1501 Newz(506,((XPVHV*)SvANY(strtab))->xhv_array,
1502 sizeof(HE*) * (((XPVHV*)SvANY(strtab))->xhv_max + 1), char);
1504 curstash = defstash = newHV();
1505 curstname = newSVpv("main",4);
1506 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1507 SvREFCNT_dec(GvHV(gv));
1508 GvHV(gv) = (HV*)SvREFCNT_inc(defstash);
1510 HvNAME(defstash) = savepv("main");
1511 incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1513 defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1514 errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1516 sv_setpvn(GvSV(errgv), "", 0);
1517 curstash = defstash;
1518 compiling.cop_stash = defstash;
1519 debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
1520 /* We must init $/ before switches are processed. */
1521 sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1);
1524 #ifdef CAN_PROTOTYPE
1526 open_script(char *scriptname, bool dosearch, SV *sv)
1529 open_script(scriptname,dosearch,sv)
1535 char *xfound = Nullch;
1536 char *xfailed = Nullch;
1540 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
1541 #define SEARCH_EXTS ".bat", ".cmd", NULL
1544 # define SEARCH_EXTS ".pl", ".com", NULL
1546 /* additional extensions to try in each dir if scriptname not found */
1548 char *ext[] = { SEARCH_EXTS };
1549 int extidx = (strchr(scriptname,'.')) ? -1 : 0; /* has ext already */
1554 int hasdir, idx = 0, deftypes = 1;
1556 hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
1557 /* The first time through, just add SEARCH_EXTS to whatever we
1558 * already have, so we can check for default file types. */
1559 while (deftypes || (!hasdir && my_trnlnm("DCL$PATH",tokenbuf,idx++)) ) {
1560 if (deftypes) { deftypes = 0; *tokenbuf = '\0'; }
1561 strcat(tokenbuf,scriptname);
1563 if (dosearch && !strchr(scriptname, '/') && (s = getenv("PATH"))) {
1565 bufend = s + strlen(s);
1568 s = cpytill(tokenbuf,s,bufend,':',&len);
1571 for (len = 0; *s && *s != ',' && *s != ';'; tokenbuf[len++] = *s++);
1572 tokenbuf[len] = '\0';
1574 for (len = 0; *s && *s != ';'; tokenbuf[len++] = *s++);
1575 tokenbuf[len] = '\0';
1581 if (len && tokenbuf[len-1] != '/')
1584 if (len && ((tokenbuf[len-1] != '\\') && (tokenbuf[len-1] != '/')))
1586 if (len && tokenbuf[len-1] != '\\')
1589 (void)strcat(tokenbuf+len,"/");
1590 (void)strcat(tokenbuf+len,scriptname);
1594 len = strlen(tokenbuf);
1595 if (extidx > 0) /* reset after previous loop */
1599 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tokenbuf));
1600 retval = Stat(tokenbuf,&statbuf);
1602 } while ( retval < 0 /* not there */
1603 && extidx>=0 && ext[extidx] /* try an extension? */
1604 && strcpy(tokenbuf+len, ext[extidx++])
1609 if (S_ISREG(statbuf.st_mode)
1610 && cando(S_IRUSR,TRUE,&statbuf) && cando(S_IXUSR,TRUE,&statbuf)) {
1611 xfound = tokenbuf; /* bingo! */
1615 xfailed = savepv(tokenbuf);
1618 croak("Can't execute %s", xfailed ? xfailed : scriptname );
1621 scriptname = xfound;
1624 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
1625 char *s = scriptname + 8;
1634 origfilename = savepv(e_tmpname ? "-e" : scriptname);
1635 curcop->cop_filegv = gv_fetchfile(origfilename);
1636 if (strEQ(origfilename,"-"))
1638 if (fdscript >= 0) {
1639 rsfp = PerlIO_fdopen(fdscript,"r");
1640 #if defined(HAS_FCNTL) && defined(F_SETFD)
1642 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
1645 else if (preprocess) {
1646 char *cpp = CPPSTDIN;
1648 if (strEQ(cpp,"cppstdin"))
1649 sprintf(tokenbuf, "%s/%s", SCRIPTDIR, cpp);
1651 sprintf(tokenbuf, "%s", cpp);
1653 sv_catpv(sv,PRIVLIB_EXP);
1655 (void)sprintf(buf, "\
1656 sed %s -e \"/^[^#]/b\" \
1657 -e \"/^#[ ]*include[ ]/b\" \
1658 -e \"/^#[ ]*define[ ]/b\" \
1659 -e \"/^#[ ]*if[ ]/b\" \
1660 -e \"/^#[ ]*ifdef[ ]/b\" \
1661 -e \"/^#[ ]*ifndef[ ]/b\" \
1662 -e \"/^#[ ]*else/b\" \
1663 -e \"/^#[ ]*elif[ ]/b\" \
1664 -e \"/^#[ ]*undef[ ]/b\" \
1665 -e \"/^#[ ]*endif/b\" \
1668 (doextract ? "-e \"1,/^#/d\n\"" : ""),
1670 (void)sprintf(buf, "\
1671 %s %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' \
1688 (doextract ? "-e '1,/^#/d\n'" : ""),
1690 scriptname, tokenbuf, SvPV(sv, na), CPPMINUS);
1692 #ifdef IAMSUID /* actually, this is caught earlier */
1693 if (euid != uid && !euid) { /* if running suidperl */
1695 (void)seteuid(uid); /* musn't stay setuid root */
1698 (void)setreuid((Uid_t)-1, uid);
1700 #ifdef HAS_SETRESUID
1701 (void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
1707 if (geteuid() != uid)
1708 croak("Can't do seteuid!\n");
1710 #endif /* IAMSUID */
1711 rsfp = my_popen(buf,"r");
1713 else if (!*scriptname) {
1714 forbid_setid("program input from stdin");
1715 rsfp = PerlIO_stdin();
1718 rsfp = PerlIO_open(scriptname,"r");
1719 #if defined(HAS_FCNTL) && defined(F_SETFD)
1721 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
1729 #ifndef IAMSUID /* in case script is not readable before setuid */
1730 if (euid && Stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
1731 statbuf.st_mode & (S_ISUID|S_ISGID)) {
1732 (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
1733 execv(buf, origargv); /* try again */
1734 croak("Can't do setuid\n");
1738 croak("Can't open perl script \"%s\": %s\n",
1739 SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno));
1744 validate_suid(validarg, scriptname)
1750 /* do we need to emulate setuid on scripts? */
1752 /* This code is for those BSD systems that have setuid #! scripts disabled
1753 * in the kernel because of a security problem. Merely defining DOSUID
1754 * in perl will not fix that problem, but if you have disabled setuid
1755 * scripts in the kernel, this will attempt to emulate setuid and setgid
1756 * on scripts that have those now-otherwise-useless bits set. The setuid
1757 * root version must be called suidperl or sperlN.NNN. If regular perl
1758 * discovers that it has opened a setuid script, it calls suidperl with
1759 * the same argv that it had. If suidperl finds that the script it has
1760 * just opened is NOT setuid root, it sets the effective uid back to the
1761 * uid. We don't just make perl setuid root because that loses the
1762 * effective uid we had before invoking perl, if it was different from the
1765 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
1766 * be defined in suidperl only. suidperl must be setuid root. The
1767 * Configure script will set this up for you if you want it.
1773 if (Fstat(PerlIO_fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
1774 croak("Can't stat script \"%s\"",origfilename);
1775 if (fdscript < 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) {
1779 #ifndef HAS_SETREUID
1780 /* On this access check to make sure the directories are readable,
1781 * there is actually a small window that the user could use to make
1782 * filename point to an accessible directory. So there is a faint
1783 * chance that someone could execute a setuid script down in a
1784 * non-accessible directory. I don't know what to do about that.
1785 * But I don't think it's too important. The manual lies when
1786 * it says access() is useful in setuid programs.
1788 if (access(SvPVX(GvSV(curcop->cop_filegv)),1)) /*double check*/
1789 croak("Permission denied");
1791 /* If we can swap euid and uid, then we can determine access rights
1792 * with a simple stat of the file, and then compare device and
1793 * inode to make sure we did stat() on the same file we opened.
1794 * Then we just have to make sure he or she can execute it.
1797 struct stat tmpstatbuf;
1801 setreuid(euid,uid) < 0
1804 setresuid(euid,uid,(Uid_t)-1) < 0
1807 || getuid() != euid || geteuid() != uid)
1808 croak("Can't swap uid and euid"); /* really paranoid */
1809 if (Stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
1810 croak("Permission denied"); /* testing full pathname here */
1811 if (tmpstatbuf.st_dev != statbuf.st_dev ||
1812 tmpstatbuf.st_ino != statbuf.st_ino) {
1813 (void)PerlIO_close(rsfp);
1814 if (rsfp = my_popen("/bin/mail root","w")) { /* heh, heh */
1816 "User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
1817 (Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
1818 (long)uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
1819 (long)statbuf.st_dev, (long)statbuf.st_ino,
1820 SvPVX(GvSV(curcop->cop_filegv)),
1821 (long)statbuf.st_uid, (long)statbuf.st_gid);
1822 (void)my_pclose(rsfp);
1824 croak("Permission denied\n");
1828 setreuid(uid,euid) < 0
1830 # if defined(HAS_SETRESUID)
1831 setresuid(uid,euid,(Uid_t)-1) < 0
1834 || getuid() != uid || geteuid() != euid)
1835 croak("Can't reswap uid and euid");
1836 if (!cando(S_IXUSR,FALSE,&statbuf)) /* can real uid exec? */
1837 croak("Permission denied\n");
1839 #endif /* HAS_SETREUID */
1840 #endif /* IAMSUID */
1842 if (!S_ISREG(statbuf.st_mode))
1843 croak("Permission denied");
1844 if (statbuf.st_mode & S_IWOTH)
1845 croak("Setuid/gid script is writable by world");
1846 doswitches = FALSE; /* -s is insecure in suid */
1848 if (sv_gets(linestr, rsfp, 0) == Nullch ||
1849 strnNE(SvPV(linestr,na),"#!",2) ) /* required even on Sys V */
1850 croak("No #! line");
1851 s = SvPV(linestr,na)+2;
1853 while (!isSPACE(*s)) s++;
1854 for (s2 = s; (s2 > SvPV(linestr,na)+2 &&
1855 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
1856 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
1857 croak("Not a perl script");
1858 while (*s == ' ' || *s == '\t') s++;
1860 * #! arg must be what we saw above. They can invoke it by
1861 * mentioning suidperl explicitly, but they may not add any strange
1862 * arguments beyond what #! says if they do invoke suidperl that way.
1864 len = strlen(validarg);
1865 if (strEQ(validarg," PHOOEY ") ||
1866 strnNE(s,validarg,len) || !isSPACE(s[len]))
1867 croak("Args must match #! line");
1870 if (euid != uid && (statbuf.st_mode & S_ISUID) &&
1871 euid == statbuf.st_uid)
1873 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
1874 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
1875 #endif /* IAMSUID */
1877 if (euid) { /* oops, we're not the setuid root perl */
1878 (void)PerlIO_close(rsfp);
1880 (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
1881 execv(buf, origargv); /* try again */
1883 croak("Can't do setuid\n");
1886 if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
1888 (void)setegid(statbuf.st_gid);
1891 (void)setregid((Gid_t)-1,statbuf.st_gid);
1893 #ifdef HAS_SETRESGID
1894 (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
1896 setgid(statbuf.st_gid);
1900 if (getegid() != statbuf.st_gid)
1901 croak("Can't do setegid!\n");
1903 if (statbuf.st_mode & S_ISUID) {
1904 if (statbuf.st_uid != euid)
1906 (void)seteuid(statbuf.st_uid); /* all that for this */
1909 (void)setreuid((Uid_t)-1,statbuf.st_uid);
1911 #ifdef HAS_SETRESUID
1912 (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
1914 setuid(statbuf.st_uid);
1918 if (geteuid() != statbuf.st_uid)
1919 croak("Can't do seteuid!\n");
1921 else if (uid) { /* oops, mustn't run as root */
1923 (void)seteuid((Uid_t)uid);
1926 (void)setreuid((Uid_t)-1,(Uid_t)uid);
1928 #ifdef HAS_SETRESUID
1929 (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
1935 if (geteuid() != uid)
1936 croak("Can't do seteuid!\n");
1939 if (!cando(S_IXUSR,TRUE,&statbuf))
1940 croak("Permission denied\n"); /* they can't do this */
1943 else if (preprocess)
1944 croak("-P not allowed for setuid/setgid script\n");
1945 else if (fdscript >= 0)
1946 croak("fd script not allowed in suidperl\n");
1948 croak("Script is not setuid/setgid in suidperl\n");
1950 /* We absolutely must clear out any saved ids here, so we */
1951 /* exec the real perl, substituting fd script for scriptname. */
1952 /* (We pass script name as "subdir" of fd, which perl will grok.) */
1953 PerlIO_rewind(rsfp);
1954 lseek(PerlIO_fileno(rsfp),(Off_t)0,0); /* just in case rewind didn't */
1955 for (which = 1; origargv[which] && origargv[which] != scriptname; which++) ;
1956 if (!origargv[which])
1957 croak("Permission denied");
1958 (void)sprintf(buf, "/dev/fd/%d/%.127s", PerlIO_fileno(rsfp), origargv[which]);
1959 origargv[which] = buf;
1961 #if defined(HAS_FCNTL) && defined(F_SETFD)
1962 fcntl(PerlIO_fileno(rsfp),F_SETFD,0); /* ensure no close-on-exec */
1965 (void)sprintf(tokenbuf, "%s/perl%s", BIN, patchlevel);
1966 execv(tokenbuf, origargv); /* try again */
1967 croak("Can't do setuid\n");
1968 #endif /* IAMSUID */
1970 if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */
1971 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
1972 Fstat(PerlIO_fileno(rsfp),&statbuf); /* may be either wrapped or real suid */
1973 if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
1975 (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
1978 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
1979 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
1980 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
1981 /* not set-id, must be wrapped */
1989 register char *s, *s2;
1991 /* skip forward in input to the real script? */
1995 if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
1996 croak("No Perl script found in input\n");
1997 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
1998 PerlIO_ungetc(rsfp, '\n'); /* to keep line count right */
2000 while (*s && !(isSPACE (*s) || *s == '#')) s++;
2002 while (*s == ' ' || *s == '\t') s++;
2004 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2005 if (strnEQ(s2-4,"perl",4))
2007 while (s = moreswitches(s)) ;
2009 if (cddir && chdir(cddir) < 0)
2010 croak("Can't chdir to %s",cddir);
2018 uid = (int)getuid();
2019 euid = (int)geteuid();
2020 gid = (int)getgid();
2021 egid = (int)getegid();
2026 tainting |= (uid && (euid != uid || egid != gid));
2034 croak("No %s allowed while running setuid", s);
2036 croak("No %s allowed while running setgid", s);
2042 curstash = debstash;
2043 dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2045 DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2046 DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2047 DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2048 DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2049 sv_setiv(DBsingle, 0);
2050 DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2051 sv_setiv(DBtrace, 0);
2052 DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2053 sv_setiv(DBsignal, 0);
2054 curstash = defstash;
2061 mainstack = curstack; /* remember in case we switch stacks */
2062 AvREAL_off(curstack); /* not a real array */
2063 av_extend(curstack,127);
2065 stack_base = AvARRAY(curstack);
2066 stack_sp = stack_base;
2067 stack_max = stack_base + 127;
2069 cxstack_max = 8192 / sizeof(CONTEXT) - 2; /* Use most of 8K. */
2070 New(50,cxstack,cxstack_max + 1,CONTEXT);
2073 New(50,tmps_stack,128,SV*);
2078 New(51,debname,128,char);
2079 New(52,debdelim,128,char);
2083 * The following stacks almost certainly should be per-interpreter,
2084 * but for now they're not. XXX
2088 markstack_ptr = markstack;
2090 New(54,markstack,64,I32);
2091 markstack_ptr = markstack;
2092 markstack_max = markstack + 64;
2098 New(54,scopestack,32,I32);
2100 scopestack_max = 32;
2106 New(54,savestack,128,ANY);
2108 savestack_max = 128;
2114 New(54,retstack,16,OP*);
2124 Safefree(tmps_stack);
2131 static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
2139 subname = newSVpv("main",4);
2143 init_predump_symbols()
2148 sv_setpvn(GvSV(gv_fetchpv("\"", TRUE, SVt_PV)), " ", 1);
2150 stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2151 GvMULTI_on(stdingv);
2152 IoIFP(GvIOp(stdingv)) = PerlIO_stdin();
2153 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2155 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv));
2157 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2159 IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
2161 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2163 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv));
2165 othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2166 GvMULTI_on(othergv);
2167 IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr();
2168 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2170 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
2172 statname = NEWSV(66,0); /* last filename we did stat on */
2175 osname = savepv(OSNAME);
2179 init_postdump_symbols(argc,argv,env)
2181 register char **argv;
2182 register char **env;
2188 argc--,argv++; /* skip name of script */
2190 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2193 if (argv[0][1] == '-') {
2197 if (s = strchr(argv[0], '=')) {
2199 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2202 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2205 toptarget = NEWSV(0,0);
2206 sv_upgrade(toptarget, SVt_PVFM);
2207 sv_setpvn(toptarget, "", 0);
2208 bodytarget = NEWSV(0,0);
2209 sv_upgrade(bodytarget, SVt_PVFM);
2210 sv_setpvn(bodytarget, "", 0);
2211 formtarget = bodytarget;
2214 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2215 sv_setpv(GvSV(tmpgv),origfilename);
2216 magicname("0", "0", 1);
2218 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2219 sv_setpv(GvSV(tmpgv),origargv[0]);
2220 if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2222 (void)gv_AVadd(argvgv);
2223 av_clear(GvAVn(argvgv));
2224 for (; argc > 0; argc--,argv++) {
2225 av_push(GvAVn(argvgv),newSVpv(argv[0],0));
2228 if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2233 #ifndef VMS /* VMS doesn't have environ array */
2234 /* Note that if the supplied env parameter is actually a copy
2235 of the global environ then it may now point to free'd memory
2236 if the environment has been modified since. To avoid this
2237 problem we treat env==NULL as meaning 'use the default'
2241 if (env != environ) {
2242 environ[0] = Nullch;
2243 hv_magic(hv, envgv, 'E');
2245 for (; *env; env++) {
2246 if (!(s = strchr(*env,'=')))
2249 sv = newSVpv(s--,0);
2250 sv_magic(sv, sv, 'e', *env, s - *env);
2251 (void)hv_store(hv, *env, s - *env, sv, 0);
2255 #ifdef DYNAMIC_ENV_FETCH
2256 HvNAME(hv) = savepv(ENV_HV_NAME);
2258 hv_magic(hv, envgv, 'E');
2261 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2262 sv_setiv(GvSV(tmpgv),(I32)getpid());
2271 s = getenv("PERL5LIB");
2275 incpush(getenv("PERLLIB"), FALSE);
2277 /* Treat PERL5?LIB as a possible search list logical name -- the
2278 * "natural" VMS idiom for a Unix path string. We allow each
2279 * element to be a set of |-separated directories for compatibility.
2283 if (my_trnlnm("PERL5LIB",buf,0))
2284 do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2286 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2290 /* Use the ~-expanded versions of APPLIB (undocumented),
2291 ARCHLIB PRIVLIB SITEARCH SITELIB and OLDARCHLIB
2294 incpush(APPLLIB_EXP, FALSE);
2298 incpush(ARCHLIB_EXP, FALSE);
2301 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2303 incpush(PRIVLIB_EXP, FALSE);
2306 incpush(SITEARCH_EXP, FALSE);
2309 incpush(SITELIB_EXP, FALSE);
2311 #ifdef OLDARCHLIB_EXP /* 5.00[01] compatibility */
2312 incpush(OLDARCHLIB_EXP, FALSE);
2316 incpush(".", FALSE);
2320 # define PERLLIB_SEP ';'
2323 # define PERLLIB_SEP '|'
2325 # define PERLLIB_SEP ':'
2328 #ifndef PERLLIB_MANGLE
2329 # define PERLLIB_MANGLE(s,n) (s)
2333 incpush(p, addsubdirs)
2337 SV *subdir = Nullsv;
2338 static char *archpat_auto;
2345 if (!archpat_auto) {
2346 STRLEN len = (sizeof(ARCHNAME) + strlen(patchlevel)
2347 + sizeof("//auto"));
2348 New(55, archpat_auto, len, char);
2349 sprintf(archpat_auto, "/%s/%s/auto", ARCHNAME, patchlevel);
2351 for (len = sizeof(ARCHNAME) + 2;
2352 archpat_auto[len] != '\0' && archpat_auto[len] != '/'; len++)
2353 if (archpat_auto[len] == '.') archpat_auto[len] = '_';
2358 /* Break at all separators */
2360 SV *libdir = newSV(0);
2363 /* skip any consecutive separators */
2364 while ( *p == PERLLIB_SEP ) {
2365 /* Uncomment the next line for PATH semantics */
2366 /* av_push(GvAVn(incgv), newSVpv(".", 1)); */
2370 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2371 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2376 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2377 p = Nullch; /* break out */
2381 * BEFORE pushing libdir onto @INC we may first push version- and
2382 * archname-specific sub-directories.
2385 struct stat tmpstatbuf;
2390 if ((unix = tounixspec_ts(SvPV(libdir,na),Nullch)) != Nullch) {
2392 while (unix[len-1] == '/') len--; /* Cosmetic */
2393 sv_usepvn(libdir,unix,len);
2396 PerlIO_printf(PerlIO_stderr(),
2397 "Failed to unixify @INC element \"%s\"\n",
2400 /* .../archname/version if -d .../archname/version/auto */
2401 sv_setsv(subdir, libdir);
2402 sv_catpv(subdir, archpat_auto);
2403 if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2404 S_ISDIR(tmpstatbuf.st_mode))
2405 av_push(GvAVn(incgv),
2406 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2408 /* .../archname if -d .../archname/auto */
2409 sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
2410 strlen(patchlevel) + 1, "", 0);
2411 if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2412 S_ISDIR(tmpstatbuf.st_mode))
2413 av_push(GvAVn(incgv),
2414 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2417 /* finally push this lib directory on the end of @INC */
2418 av_push(GvAVn(incgv), libdir);
2421 SvREFCNT_dec(subdir);
2430 line_t oldline = curcop->cop_line;
2432 Copy(top_env, oldtop, 1, Sigjmp_buf);
2434 while (AvFILL(list) >= 0) {
2435 CV *cv = (CV*)av_shift(list);
2439 switch (Sigsetjmp(top_env,1)) {
2441 SV* atsv = GvSV(errgv);
2443 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
2444 (void)SvPV(atsv, len);
2446 Copy(oldtop, top_env, 1, Sigjmp_buf);
2447 curcop = &compiling;
2448 curcop->cop_line = oldline;
2449 if (list == beginav)
2450 sv_catpv(atsv, "BEGIN failed--compilation aborted");
2452 sv_catpv(atsv, "END failed--cleanup aborted");
2453 croak("%s", SvPVX(atsv));
2461 /* my_exit() was called */
2462 curstash = defstash;
2466 Copy(oldtop, top_env, 1, Sigjmp_buf);
2467 curcop = &compiling;
2468 curcop->cop_line = oldline;
2470 if (list == beginav)
2471 croak("BEGIN failed--compilation aborted");
2473 croak("END failed--cleanup aborted");
2479 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
2483 Copy(oldtop, top_env, 1, Sigjmp_buf);
2484 curcop = &compiling;
2485 curcop->cop_line = oldline;
2486 Siglongjmp(top_env, 3);
2490 Copy(oldtop, top_env, 1, Sigjmp_buf);
2505 STATUS_NATIVE_SET(status);
2515 if (vaxc$errno & 1) {
2516 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
2517 STATUS_NATIVE_SET(44);
2520 if (!vaxc$errno && errno) /* unlikely */
2521 STATUS_NATIVE_SET(44);
2523 STATUS_NATIVE_SET(vaxc$errno);
2527 STATUS_POSIX_SET(errno);
2528 else if (STATUS_POSIX == 0)
2529 STATUS_POSIX_SET(255);
2537 register CONTEXT *cx;
2546 (void)UNLINK(e_tmpname);
2547 Safefree(e_tmpname);
2551 if (cxstack_ix >= 0) {
2558 Siglongjmp(top_env, 2);