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;
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;
513 PerlIO_printf(PerlIO_stderr(), "panic: top_env\n");
517 sv_setpvn(linestr,"",0);
518 sv = newSVpv("",0); /* first used for -I flags */
521 for (argc--,argv++; argc > 0; argc--,argv++) {
522 if (argv[0][0] != '-' || !argv[0][1])
526 validarg = " PHOOEY ";
551 if (s = moreswitches(s))
561 if (euid != uid || egid != gid)
562 croak("No -e allowed in setuid scripts");
564 e_tmpname = savepv(TMPPATH);
565 (void)mktemp(e_tmpname);
567 croak("Can't mktemp()");
568 e_fp = PerlIO_open(e_tmpname,"w");
570 croak("Cannot open temporary file");
575 PerlIO_puts(e_fp,argv[1]);
579 croak("No code specified for -e");
580 (void)PerlIO_putc(e_fp,'\n');
591 incpush(argv[1], TRUE);
592 sv_catpv(sv,argv[1]);
609 preambleav = newAV();
610 av_push(preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
612 Sv = newSVpv("print myconfig();",0);
614 sv_catpv(Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
616 sv_catpv(Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
618 #if defined(DEBUGGING) || defined(NOEMBED) || defined(MULTIPLICITY)
619 strcpy(buf,"\" Compile-time options:");
621 strcat(buf," DEBUGGING");
624 strcat(buf," NOEMBED");
627 strcat(buf," MULTIPLICITY");
629 strcat(buf,"\\n\",");
632 #if defined(LOCAL_PATCH_COUNT)
633 if (LOCAL_PATCH_COUNT > 0)
635 sv_catpv(Sv,"print \" Locally applied patches:\\n\",");
636 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
637 if (localpatches[i]) {
638 sprintf(buf,"\" \\t%s\\n\",",localpatches[i]);
644 sprintf(buf,"\" Built under %s\\n\",",OSNAME);
648 sprintf(buf,"\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
650 sprintf(buf,"\" Compiled on %s\\n\"",__DATE__);
654 sv_catpv(Sv,"; $\"=\"\\n \"; print \" \\@INC:\\n @INC\\n\"");
657 Sv = newSVpv("config_vars(qw(",0);
662 av_push(preambleav, Sv);
663 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
677 croak("Unrecognized switch: -%s",s);
682 scriptname = argv[0];
684 if (PerlIO_flush(e_fp) || PerlIO_error(e_fp) || PerlIO_close(e_fp))
685 croak("Can't write to temp file for -e: %s", Strerror(errno));
688 scriptname = e_tmpname;
690 else if (scriptname == Nullch) {
692 if ( isatty(PerlIO_fileno(PerlIO_stdin())) )
700 open_script(scriptname,dosearch,sv);
702 validate_suid(validarg, scriptname);
707 main_cv = compcv = (CV*)NEWSV(1104,0);
708 sv_upgrade((SV *)compcv, SVt_PVCV);
712 av_push(comppad, Nullsv);
713 curpad = AvARRAY(comppad);
714 comppad_name = newAV();
715 comppad_name_fill = 0;
716 min_intro_pending = 0;
719 comppadlist = newAV();
720 AvREAL_off(comppadlist);
721 av_store(comppadlist, 0, (SV*)comppad_name);
722 av_store(comppadlist, 1, (SV*)comppad);
723 CvPADLIST(compcv) = comppadlist;
725 boot_core_UNIVERSAL();
727 (*xsinit)(); /* in case linked C routines want magical variables */
732 init_predump_symbols();
734 init_postdump_symbols(argc,argv,env);
738 /* now parse the script */
741 if (yyparse() || error_count) {
743 croak("%s had compilation errors.\n", origfilename);
745 croak("Execution of %s aborted due to compilation errors.\n",
749 curcop->cop_line = 0;
753 (void)UNLINK(e_tmpname);
758 /* now that script is parsed, we can modify record separator */
760 rs = SvREFCNT_inc(nrs);
761 sv_setsv(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), rs);
772 #ifdef DEBUGGING_MSTATS
773 if ((s=getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
774 dump_mstats("after compilation:");
784 PerlInterpreter *sv_interp;
786 if (!(curinterp = sv_interp))
788 switch (Sigsetjmp(top_env,1)) {
790 cxstack_ix = -1; /* start context stack again */
793 /* my_exit() was called */
798 #ifdef DEBUGGING_MSTATS
799 if (getenv("PERL_DEBUG_MSTATS"))
800 dump_mstats("after execution: ");
802 return STATUS_NATIVE_EXPORT;
806 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
810 if (curstack != mainstack) {
812 SWITCHSTACK(curstack, mainstack);
817 DEBUG_r(PerlIO_printf(PerlIO_stderr(), "%s $` $& $' support.\n",
818 sawampersand ? "Enabling" : "Omitting"));
822 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
825 PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", origfilename);
828 if (perldb && DBsingle)
829 sv_setiv(DBsingle, 1);
839 else if (main_start) {
840 CvDEPTH(main_cv) = 1;
850 perl_get_sv(name, create)
854 GV* gv = gv_fetchpv(name, create, SVt_PV);
861 perl_get_av(name, create)
865 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
874 perl_get_hv(name, create)
878 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
887 perl_get_cv(name, create)
891 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
892 if (create && !GvCVu(gv))
893 return newSUB(start_subparse(FALSE, 0),
894 newSVOP(OP_CONST, 0, newSVpv(name,0)),
902 /* Be sure to refetch the stack pointer after calling these routines. */
905 perl_call_argv(subname, flags, argv)
907 I32 flags; /* See G_* flags in cop.h */
908 register char **argv; /* null terminated arg list */
915 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
920 return perl_call_pv(subname, flags);
924 perl_call_pv(subname, flags)
925 char *subname; /* name of the subroutine */
926 I32 flags; /* See G_* flags in cop.h */
928 return perl_call_sv((SV*)perl_get_cv(subname, TRUE), flags);
932 perl_call_method(methname, flags)
933 char *methname; /* name of the subroutine */
934 I32 flags; /* See G_* flags in cop.h */
940 XPUSHs(sv_2mortal(newSVpv(methname,0)));
943 return perl_call_sv(*stack_sp--, flags);
946 /* May be called with any of a CV, a GV, or an SV containing the name. */
948 perl_call_sv(sv, flags)
950 I32 flags; /* See G_* flags in cop.h */
952 LOGOP myop; /* fake syntax tree node */
959 bool oldmustcatch = mustcatch;
961 if (flags & G_DISCARD) {
966 Zero(&myop, 1, LOGOP);
967 if (flags & G_NOARGS) {
971 myop.op_flags |= OPf_STACKED;
972 myop.op_next = Nullop;
973 myop.op_flags |= OPf_KNOW;
975 myop.op_flags |= OPf_LIST;
982 oldscope = scopestack_ix;
984 if (perldb && curstash != debstash
985 /* Handle first BEGIN of -d. */
986 && (DBcv || (DBcv = GvCV(DBsub)))
987 /* Try harder, since this may have been a sighandler, thus
988 * curstash may be meaningless. */
989 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != debstash))
990 op->op_private |= OPpENTERSUB_DB;
992 if (flags & G_EVAL) {
993 Copy(top_env, oldtop, 1, Sigjmp_buf);
995 cLOGOP->op_other = op;
997 /* we're trying to emulate pp_entertry() here */
999 register CONTEXT *cx;
1005 push_return(op->op_next);
1006 PUSHBLOCK(cx, CXt_EVAL, stack_sp);
1008 eval_root = op; /* Only needed so that goto works right. */
1011 if (flags & G_KEEPERR)
1014 sv_setpv(GvSV(errgv),"");
1019 switch (Sigsetjmp(top_env,1)) {
1026 /* my_exit() was called */
1027 curstash = defstash;
1029 Copy(oldtop, top_env, 1, Sigjmp_buf);
1031 croak("Callback called exit");
1041 stack_sp = stack_base + oldmark;
1042 if (flags & G_ARRAY)
1046 *++stack_sp = &sv_undef;
1054 if (op == (OP*)&myop)
1058 retval = stack_sp - (stack_base + oldmark);
1059 if ((flags & G_EVAL) && !(flags & G_KEEPERR))
1060 sv_setpv(GvSV(errgv),"");
1063 if (flags & G_EVAL) {
1064 if (scopestack_ix > oldscope) {
1068 register CONTEXT *cx;
1077 Copy(oldtop, top_env, 1, Sigjmp_buf);
1080 mustcatch = oldmustcatch;
1082 if (flags & G_DISCARD) {
1083 stack_sp = stack_base + oldmark;
1091 /* Eval a string. The G_EVAL flag is always assumed. */
1094 perl_eval_sv(sv, flags)
1096 I32 flags; /* See G_* flags in cop.h */
1098 UNOP myop; /* fake syntax tree node */
1100 I32 oldmark = sp - stack_base;
1105 if (flags & G_DISCARD) {
1113 EXTEND(stack_sp, 1);
1115 oldscope = scopestack_ix;
1117 if (!(flags & G_NOARGS))
1118 myop.op_flags = OPf_STACKED;
1119 myop.op_next = Nullop;
1120 myop.op_type = OP_ENTEREVAL;
1121 myop.op_flags |= OPf_KNOW;
1122 if (flags & G_KEEPERR)
1123 myop.op_flags |= OPf_SPECIAL;
1124 if (flags & G_ARRAY)
1125 myop.op_flags |= OPf_LIST;
1127 Copy(top_env, oldtop, 1, Sigjmp_buf);
1130 switch (Sigsetjmp(top_env,1)) {
1137 /* my_exit() was called */
1138 curstash = defstash;
1140 Copy(oldtop, top_env, 1, Sigjmp_buf);
1142 croak("Callback called exit");
1152 stack_sp = stack_base + oldmark;
1153 if (flags & G_ARRAY)
1157 *++stack_sp = &sv_undef;
1162 if (op == (OP*)&myop)
1163 op = pp_entereval();
1166 retval = stack_sp - (stack_base + oldmark);
1167 if (!(flags & G_KEEPERR))
1168 sv_setpv(GvSV(errgv),"");
1171 Copy(oldtop, top_env, 1, Sigjmp_buf);
1172 if (flags & G_DISCARD) {
1173 stack_sp = stack_base + oldmark;
1181 /* Require a module. */
1187 SV* sv = sv_newmortal();
1188 sv_setpv(sv, "require '");
1191 perl_eval_sv(sv, G_DISCARD);
1195 magicname(sym,name,namlen)
1202 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1203 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1207 usage(name) /* XXX move this out into a module ? */
1210 /* This message really ought to be max 23 lines.
1211 * Removed -h because the user already knows that opton. Others? */
1212 printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1213 printf("\n -0[octal] specify record separator (\\0, if no argument)");
1214 printf("\n -a autosplit mode with -n or -p (splits $_ into @F)");
1215 printf("\n -c check syntax only (runs BEGIN and END blocks)");
1216 printf("\n -d[:debugger] run scripts under debugger");
1217 printf("\n -D[number/list] set debugging flags (argument is a bit mask or flags)");
1218 printf("\n -e 'command' one line of script. Several -e's allowed. Omit [programfile].");
1219 printf("\n -F/pattern/ split() pattern for autosplit (-a). The //'s are optional.");
1220 printf("\n -i[extension] edit <> files in place (make backup if extension supplied)");
1221 printf("\n -Idirectory specify @INC/#include directory (may be used more then once)");
1222 printf("\n -l[octal] enable line ending processing, specifies line teminator");
1223 printf("\n -[mM][-]module.. executes `use/no module...' before executing your script.");
1224 printf("\n -n assume 'while (<>) { ... }' loop arround your script");
1225 printf("\n -p assume loop like -n but print line also like sed");
1226 printf("\n -P run script through C preprocessor before compilation");
1227 printf("\n -s enable some switch parsing for switches after script name");
1228 printf("\n -S look for the script using PATH environment variable");
1229 printf("\n -T turn on tainting checks");
1230 printf("\n -u dump core after parsing script");
1231 printf("\n -U allow unsafe operations");
1232 printf("\n -v print version number and patchlevel of perl");
1233 printf("\n -V[:variable] print perl configuration information");
1234 printf("\n -w TURN WARNINGS ON FOR COMPILATION OF YOUR SCRIPT.");
1235 printf("\n -x[directory] strip off text before #!perl line and perhaps cd to directory\n");
1238 /* This routine handles any switches that can be given during run */
1249 rschar = scan_oct(s, 4, &numlen);
1251 if (rschar & ~((U8)~0))
1253 else if (!rschar && numlen >= 2)
1254 nrs = newSVpv("", 0);
1257 nrs = newSVpv(&ch, 1);
1262 splitstr = savepv(s + 1);
1276 if (*s == ':' || *s == '=') {
1277 sprintf(buf, "use Devel::%s;", ++s);
1279 my_setenv("PERL5DB",buf);
1289 if (isALPHA(s[1])) {
1290 static char debopts[] = "psltocPmfrxuLHXD";
1293 for (s++; *s && (d = strchr(debopts,*s)); s++)
1294 debug |= 1 << (d - debopts);
1298 for (s++; isDIGIT(*s); s++) ;
1300 debug |= 0x80000000;
1302 warn("Recompile perl with -DDEBUGGING to use -D switch\n");
1303 for (s++; isALNUM(*s); s++) ;
1313 inplace = savepv(s+1);
1315 for (s = inplace; *s && !isSPACE(*s); s++) ;
1322 for (e = s; *e && !isSPACE(*e); e++) ;
1323 p = savepvn(s, e-s);
1330 croak("No space allowed after -I");
1340 *ors = scan_oct(s, 3 + (*s == '0'), &numlen);
1349 ors = SvPV(nrs, orslen);
1350 ors = savepvn(ors, orslen);
1354 forbid_setid("-M"); /* XXX ? */
1357 forbid_setid("-m"); /* XXX ? */
1361 /* -M-foo == 'no foo' */
1362 if (*s == '-') { use = "no "; ++s; }
1363 Sv = newSVpv(use,0);
1365 /* We allow -M'Module qw(Foo Bar)' */
1366 while(isALNUM(*s) || *s==':') ++s;
1368 sv_catpv(Sv, start);
1369 if (*(start-1) == 'm') {
1371 croak("Can't use '%c' after -mname", *s);
1372 sv_catpv( Sv, " ()");
1375 sv_catpvn(Sv, start, s-start);
1376 sv_catpv(Sv, " split(/,/,q{");
1381 if (preambleav == NULL)
1382 preambleav = newAV();
1383 av_push(preambleav, Sv);
1386 croak("No space allowed after -%c", *(s-1));
1403 croak("Too late for \"-T\" option");
1415 #if defined(SUBVERSION) && SUBVERSION > 0
1416 printf("\nThis is perl, version 5.%03d_%02d", PATCHLEVEL, SUBVERSION);
1418 printf("\nThis is perl, version %s",patchlevel);
1421 printf("\n\nCopyright 1987-1997, Larry Wall\n");
1423 printf("\n\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1426 printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
1429 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1430 "Version 5 port Copyright (c) 1994-1997, Andreas Kaiser, Ilya Zakharevich\n");
1433 printf("atariST series port, ++jrb bammi@cadence.com\n");
1436 Perl may be copied only under the terms of either the Artistic License or the\n\
1437 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n");
1445 if (s[1] == '-') /* Additional switches on #! line. */
1453 #ifdef ALTERNATE_SHEBANG
1454 case 'S': /* OS/2 needs -S on "extproc" line. */
1462 croak("Can't emulate -%.1s on #! line",s);
1467 /* compliments of Tom Christiansen */
1469 /* unexec() can be found in the Gnu emacs distribution */
1478 sprintf (buf, "%s.perldump", origfilename);
1479 sprintf (tokenbuf, "%s/perl", BIN);
1481 status = unexec(buf, tokenbuf, &etext, sbrk(0), 0);
1483 PerlIO_printf(PerlIO_stderr(), "unexec of %s into %s failed!\n", tokenbuf, buf);
1487 # include <lib$routines.h>
1488 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
1490 ABORT(); /* for use with undump */
1500 /* Note that strtab is a rather special HV. Assumptions are made
1501 about not iterating on it, and not adding tie magic to it.
1502 It is properly deallocated in perl_destruct() */
1504 HvSHAREKEYS_off(strtab); /* mandatory */
1505 Newz(506,((XPVHV*)SvANY(strtab))->xhv_array,
1506 sizeof(HE*) * (((XPVHV*)SvANY(strtab))->xhv_max + 1), char);
1508 curstash = defstash = newHV();
1509 curstname = newSVpv("main",4);
1510 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1511 SvREFCNT_dec(GvHV(gv));
1512 GvHV(gv) = (HV*)SvREFCNT_inc(defstash);
1514 HvNAME(defstash) = savepv("main");
1515 incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1517 defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1518 errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1520 sv_setpvn(GvSV(errgv), "", 0);
1521 curstash = defstash;
1522 compiling.cop_stash = defstash;
1523 debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
1524 /* We must init $/ before switches are processed. */
1525 sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1);
1528 #ifdef CAN_PROTOTYPE
1530 open_script(char *scriptname, bool dosearch, SV *sv)
1533 open_script(scriptname,dosearch,sv)
1539 char *xfound = Nullch;
1540 char *xfailed = Nullch;
1544 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
1545 #define SEARCH_EXTS ".bat", ".cmd", NULL
1548 # define SEARCH_EXTS ".pl", ".com", NULL
1550 /* additional extensions to try in each dir if scriptname not found */
1552 char *ext[] = { SEARCH_EXTS };
1553 int extidx = (strchr(scriptname,'.')) ? -1 : 0; /* has ext already */
1558 int hasdir, idx = 0, deftypes = 1;
1560 hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
1561 /* The first time through, just add SEARCH_EXTS to whatever we
1562 * already have, so we can check for default file types. */
1563 while (deftypes || (!hasdir && my_trnlnm("DCL$PATH",tokenbuf,idx++)) ) {
1564 if (deftypes) { deftypes = 0; *tokenbuf = '\0'; }
1565 strcat(tokenbuf,scriptname);
1567 if (dosearch && !strchr(scriptname, '/') && (s = getenv("PATH"))) {
1569 bufend = s + strlen(s);
1572 s = cpytill(tokenbuf,s,bufend,':',&len);
1575 for (len = 0; *s && *s != ',' && *s != ';'; tokenbuf[len++] = *s++);
1576 tokenbuf[len] = '\0';
1578 for (len = 0; *s && *s != ';'; tokenbuf[len++] = *s++);
1579 tokenbuf[len] = '\0';
1585 if (len && tokenbuf[len-1] != '/')
1588 if (len && ((tokenbuf[len-1] != '\\') && (tokenbuf[len-1] != '/')))
1590 if (len && tokenbuf[len-1] != '\\')
1593 (void)strcat(tokenbuf+len,"/");
1594 (void)strcat(tokenbuf+len,scriptname);
1598 len = strlen(tokenbuf);
1599 if (extidx > 0) /* reset after previous loop */
1603 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tokenbuf));
1604 retval = Stat(tokenbuf,&statbuf);
1606 } while ( retval < 0 /* not there */
1607 && extidx>=0 && ext[extidx] /* try an extension? */
1608 && strcpy(tokenbuf+len, ext[extidx++])
1613 if (S_ISREG(statbuf.st_mode)
1614 && cando(S_IRUSR,TRUE,&statbuf) && cando(S_IXUSR,TRUE,&statbuf)) {
1615 xfound = tokenbuf; /* bingo! */
1619 xfailed = savepv(tokenbuf);
1622 croak("Can't execute %s", xfailed ? xfailed : scriptname );
1625 scriptname = xfound;
1628 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
1629 char *s = scriptname + 8;
1638 origfilename = savepv(e_tmpname ? "-e" : scriptname);
1639 curcop->cop_filegv = gv_fetchfile(origfilename);
1640 if (strEQ(origfilename,"-"))
1642 if (fdscript >= 0) {
1643 rsfp = PerlIO_fdopen(fdscript,"r");
1644 #if defined(HAS_FCNTL) && defined(F_SETFD)
1646 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
1649 else if (preprocess) {
1650 char *cpp = CPPSTDIN;
1652 if (strEQ(cpp,"cppstdin"))
1653 sprintf(tokenbuf, "%s/%s", SCRIPTDIR, cpp);
1655 sprintf(tokenbuf, "%s", cpp);
1657 sv_catpv(sv,PRIVLIB_EXP);
1659 (void)sprintf(buf, "\
1660 sed %s -e \"/^[^#]/b\" \
1661 -e \"/^#[ ]*include[ ]/b\" \
1662 -e \"/^#[ ]*define[ ]/b\" \
1663 -e \"/^#[ ]*if[ ]/b\" \
1664 -e \"/^#[ ]*ifdef[ ]/b\" \
1665 -e \"/^#[ ]*ifndef[ ]/b\" \
1666 -e \"/^#[ ]*else/b\" \
1667 -e \"/^#[ ]*elif[ ]/b\" \
1668 -e \"/^#[ ]*undef[ ]/b\" \
1669 -e \"/^#[ ]*endif/b\" \
1672 (doextract ? "-e \"1,/^#/d\n\"" : ""),
1674 (void)sprintf(buf, "\
1675 %s %s -e '/^[^#]/b' \
1676 -e '/^#[ ]*include[ ]/b' \
1677 -e '/^#[ ]*define[ ]/b' \
1678 -e '/^#[ ]*if[ ]/b' \
1679 -e '/^#[ ]*ifdef[ ]/b' \
1680 -e '/^#[ ]*ifndef[ ]/b' \
1681 -e '/^#[ ]*else/b' \
1682 -e '/^#[ ]*elif[ ]/b' \
1683 -e '/^#[ ]*undef[ ]/b' \
1684 -e '/^#[ ]*endif/b' \
1692 (doextract ? "-e '1,/^#/d\n'" : ""),
1694 scriptname, tokenbuf, SvPV(sv, na), CPPMINUS);
1696 #ifdef IAMSUID /* actually, this is caught earlier */
1697 if (euid != uid && !euid) { /* if running suidperl */
1699 (void)seteuid(uid); /* musn't stay setuid root */
1702 (void)setreuid((Uid_t)-1, uid);
1704 #ifdef HAS_SETRESUID
1705 (void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
1711 if (geteuid() != uid)
1712 croak("Can't do seteuid!\n");
1714 #endif /* IAMSUID */
1715 rsfp = my_popen(buf,"r");
1717 else if (!*scriptname) {
1718 forbid_setid("program input from stdin");
1719 rsfp = PerlIO_stdin();
1722 rsfp = PerlIO_open(scriptname,"r");
1723 #if defined(HAS_FCNTL) && defined(F_SETFD)
1725 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
1733 #ifndef IAMSUID /* in case script is not readable before setuid */
1734 if (euid && Stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
1735 statbuf.st_mode & (S_ISUID|S_ISGID)) {
1736 (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
1737 execv(buf, origargv); /* try again */
1738 croak("Can't do setuid\n");
1742 croak("Can't open perl script \"%s\": %s\n",
1743 SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno));
1748 validate_suid(validarg, scriptname)
1754 /* do we need to emulate setuid on scripts? */
1756 /* This code is for those BSD systems that have setuid #! scripts disabled
1757 * in the kernel because of a security problem. Merely defining DOSUID
1758 * in perl will not fix that problem, but if you have disabled setuid
1759 * scripts in the kernel, this will attempt to emulate setuid and setgid
1760 * on scripts that have those now-otherwise-useless bits set. The setuid
1761 * root version must be called suidperl or sperlN.NNN. If regular perl
1762 * discovers that it has opened a setuid script, it calls suidperl with
1763 * the same argv that it had. If suidperl finds that the script it has
1764 * just opened is NOT setuid root, it sets the effective uid back to the
1765 * uid. We don't just make perl setuid root because that loses the
1766 * effective uid we had before invoking perl, if it was different from the
1769 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
1770 * be defined in suidperl only. suidperl must be setuid root. The
1771 * Configure script will set this up for you if you want it.
1777 if (Fstat(PerlIO_fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
1778 croak("Can't stat script \"%s\"",origfilename);
1779 if (fdscript < 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) {
1783 #ifndef HAS_SETREUID
1784 /* On this access check to make sure the directories are readable,
1785 * there is actually a small window that the user could use to make
1786 * filename point to an accessible directory. So there is a faint
1787 * chance that someone could execute a setuid script down in a
1788 * non-accessible directory. I don't know what to do about that.
1789 * But I don't think it's too important. The manual lies when
1790 * it says access() is useful in setuid programs.
1792 if (access(SvPVX(GvSV(curcop->cop_filegv)),1)) /*double check*/
1793 croak("Permission denied");
1795 /* If we can swap euid and uid, then we can determine access rights
1796 * with a simple stat of the file, and then compare device and
1797 * inode to make sure we did stat() on the same file we opened.
1798 * Then we just have to make sure he or she can execute it.
1801 struct stat tmpstatbuf;
1805 setreuid(euid,uid) < 0
1808 setresuid(euid,uid,(Uid_t)-1) < 0
1811 || getuid() != euid || geteuid() != uid)
1812 croak("Can't swap uid and euid"); /* really paranoid */
1813 if (Stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
1814 croak("Permission denied"); /* testing full pathname here */
1815 if (tmpstatbuf.st_dev != statbuf.st_dev ||
1816 tmpstatbuf.st_ino != statbuf.st_ino) {
1817 (void)PerlIO_close(rsfp);
1818 if (rsfp = my_popen("/bin/mail root","w")) { /* heh, heh */
1820 "User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
1821 (Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
1822 (long)uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
1823 (long)statbuf.st_dev, (long)statbuf.st_ino,
1824 SvPVX(GvSV(curcop->cop_filegv)),
1825 (long)statbuf.st_uid, (long)statbuf.st_gid);
1826 (void)my_pclose(rsfp);
1828 croak("Permission denied\n");
1832 setreuid(uid,euid) < 0
1834 # if defined(HAS_SETRESUID)
1835 setresuid(uid,euid,(Uid_t)-1) < 0
1838 || getuid() != uid || geteuid() != euid)
1839 croak("Can't reswap uid and euid");
1840 if (!cando(S_IXUSR,FALSE,&statbuf)) /* can real uid exec? */
1841 croak("Permission denied\n");
1843 #endif /* HAS_SETREUID */
1844 #endif /* IAMSUID */
1846 if (!S_ISREG(statbuf.st_mode))
1847 croak("Permission denied");
1848 if (statbuf.st_mode & S_IWOTH)
1849 croak("Setuid/gid script is writable by world");
1850 doswitches = FALSE; /* -s is insecure in suid */
1852 if (sv_gets(linestr, rsfp, 0) == Nullch ||
1853 strnNE(SvPV(linestr,na),"#!",2) ) /* required even on Sys V */
1854 croak("No #! line");
1855 s = SvPV(linestr,na)+2;
1857 while (!isSPACE(*s)) s++;
1858 for (s2 = s; (s2 > SvPV(linestr,na)+2 &&
1859 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
1860 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
1861 croak("Not a perl script");
1862 while (*s == ' ' || *s == '\t') s++;
1864 * #! arg must be what we saw above. They can invoke it by
1865 * mentioning suidperl explicitly, but they may not add any strange
1866 * arguments beyond what #! says if they do invoke suidperl that way.
1868 len = strlen(validarg);
1869 if (strEQ(validarg," PHOOEY ") ||
1870 strnNE(s,validarg,len) || !isSPACE(s[len]))
1871 croak("Args must match #! line");
1874 if (euid != uid && (statbuf.st_mode & S_ISUID) &&
1875 euid == statbuf.st_uid)
1877 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
1878 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
1879 #endif /* IAMSUID */
1881 if (euid) { /* oops, we're not the setuid root perl */
1882 (void)PerlIO_close(rsfp);
1884 (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
1885 execv(buf, origargv); /* try again */
1887 croak("Can't do setuid\n");
1890 if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
1892 (void)setegid(statbuf.st_gid);
1895 (void)setregid((Gid_t)-1,statbuf.st_gid);
1897 #ifdef HAS_SETRESGID
1898 (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
1900 setgid(statbuf.st_gid);
1904 if (getegid() != statbuf.st_gid)
1905 croak("Can't do setegid!\n");
1907 if (statbuf.st_mode & S_ISUID) {
1908 if (statbuf.st_uid != euid)
1910 (void)seteuid(statbuf.st_uid); /* all that for this */
1913 (void)setreuid((Uid_t)-1,statbuf.st_uid);
1915 #ifdef HAS_SETRESUID
1916 (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
1918 setuid(statbuf.st_uid);
1922 if (geteuid() != statbuf.st_uid)
1923 croak("Can't do seteuid!\n");
1925 else if (uid) { /* oops, mustn't run as root */
1927 (void)seteuid((Uid_t)uid);
1930 (void)setreuid((Uid_t)-1,(Uid_t)uid);
1932 #ifdef HAS_SETRESUID
1933 (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
1939 if (geteuid() != uid)
1940 croak("Can't do seteuid!\n");
1943 if (!cando(S_IXUSR,TRUE,&statbuf))
1944 croak("Permission denied\n"); /* they can't do this */
1947 else if (preprocess)
1948 croak("-P not allowed for setuid/setgid script\n");
1949 else if (fdscript >= 0)
1950 croak("fd script not allowed in suidperl\n");
1952 croak("Script is not setuid/setgid in suidperl\n");
1954 /* We absolutely must clear out any saved ids here, so we */
1955 /* exec the real perl, substituting fd script for scriptname. */
1956 /* (We pass script name as "subdir" of fd, which perl will grok.) */
1957 PerlIO_rewind(rsfp);
1958 lseek(PerlIO_fileno(rsfp),(Off_t)0,0); /* just in case rewind didn't */
1959 for (which = 1; origargv[which] && origargv[which] != scriptname; which++) ;
1960 if (!origargv[which])
1961 croak("Permission denied");
1962 (void)sprintf(buf, "/dev/fd/%d/%.127s", PerlIO_fileno(rsfp), origargv[which]);
1963 origargv[which] = buf;
1965 #if defined(HAS_FCNTL) && defined(F_SETFD)
1966 fcntl(PerlIO_fileno(rsfp),F_SETFD,0); /* ensure no close-on-exec */
1969 (void)sprintf(tokenbuf, "%s/perl%s", BIN, patchlevel);
1970 execv(tokenbuf, origargv); /* try again */
1971 croak("Can't do setuid\n");
1972 #endif /* IAMSUID */
1974 if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */
1975 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
1976 Fstat(PerlIO_fileno(rsfp),&statbuf); /* may be either wrapped or real suid */
1977 if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
1979 (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
1982 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
1983 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
1984 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
1985 /* not set-id, must be wrapped */
1993 register char *s, *s2;
1995 /* skip forward in input to the real script? */
1999 if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
2000 croak("No Perl script found in input\n");
2001 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2002 PerlIO_ungetc(rsfp, '\n'); /* to keep line count right */
2004 while (*s && !(isSPACE (*s) || *s == '#')) s++;
2006 while (*s == ' ' || *s == '\t') s++;
2008 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2009 if (strnEQ(s2-4,"perl",4))
2011 while (s = moreswitches(s)) ;
2013 if (cddir && chdir(cddir) < 0)
2014 croak("Can't chdir to %s",cddir);
2022 uid = (int)getuid();
2023 euid = (int)geteuid();
2024 gid = (int)getgid();
2025 egid = (int)getegid();
2030 tainting |= (uid && (euid != uid || egid != gid));
2038 croak("No %s allowed while running setuid", s);
2040 croak("No %s allowed while running setgid", s);
2046 curstash = debstash;
2047 dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2049 DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2050 DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2051 DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2052 DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2053 sv_setiv(DBsingle, 0);
2054 DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2055 sv_setiv(DBtrace, 0);
2056 DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2057 sv_setiv(DBsignal, 0);
2058 curstash = defstash;
2065 mainstack = curstack; /* remember in case we switch stacks */
2066 AvREAL_off(curstack); /* not a real array */
2067 av_extend(curstack,127);
2069 stack_base = AvARRAY(curstack);
2070 stack_sp = stack_base;
2071 stack_max = stack_base + 127;
2073 cxstack_max = 8192 / sizeof(CONTEXT) - 2; /* Use most of 8K. */
2074 New(50,cxstack,cxstack_max + 1,CONTEXT);
2077 New(50,tmps_stack,128,SV*);
2082 New(51,debname,128,char);
2083 New(52,debdelim,128,char);
2087 * The following stacks almost certainly should be per-interpreter,
2088 * but for now they're not. XXX
2092 markstack_ptr = markstack;
2094 New(54,markstack,64,I32);
2095 markstack_ptr = markstack;
2096 markstack_max = markstack + 64;
2102 New(54,scopestack,32,I32);
2104 scopestack_max = 32;
2110 New(54,savestack,128,ANY);
2112 savestack_max = 128;
2118 New(54,retstack,16,OP*);
2128 Safefree(tmps_stack);
2135 static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
2143 subname = newSVpv("main",4);
2147 init_predump_symbols()
2152 sv_setpvn(GvSV(gv_fetchpv("\"", TRUE, SVt_PV)), " ", 1);
2154 stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2155 GvMULTI_on(stdingv);
2156 IoIFP(GvIOp(stdingv)) = PerlIO_stdin();
2157 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2159 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv));
2161 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2163 IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
2165 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2167 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv));
2169 othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2170 GvMULTI_on(othergv);
2171 IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr();
2172 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2174 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
2176 statname = NEWSV(66,0); /* last filename we did stat on */
2179 osname = savepv(OSNAME);
2183 init_postdump_symbols(argc,argv,env)
2185 register char **argv;
2186 register char **env;
2192 argc--,argv++; /* skip name of script */
2194 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2197 if (argv[0][1] == '-') {
2201 if (s = strchr(argv[0], '=')) {
2203 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2206 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2209 toptarget = NEWSV(0,0);
2210 sv_upgrade(toptarget, SVt_PVFM);
2211 sv_setpvn(toptarget, "", 0);
2212 bodytarget = NEWSV(0,0);
2213 sv_upgrade(bodytarget, SVt_PVFM);
2214 sv_setpvn(bodytarget, "", 0);
2215 formtarget = bodytarget;
2218 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2219 sv_setpv(GvSV(tmpgv),origfilename);
2220 magicname("0", "0", 1);
2222 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2223 sv_setpv(GvSV(tmpgv),origargv[0]);
2224 if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2226 (void)gv_AVadd(argvgv);
2227 av_clear(GvAVn(argvgv));
2228 for (; argc > 0; argc--,argv++) {
2229 av_push(GvAVn(argvgv),newSVpv(argv[0],0));
2232 if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2237 #ifndef VMS /* VMS doesn't have environ array */
2238 /* Note that if the supplied env parameter is actually a copy
2239 of the global environ then it may now point to free'd memory
2240 if the environment has been modified since. To avoid this
2241 problem we treat env==NULL as meaning 'use the default'
2245 if (env != environ) {
2246 environ[0] = Nullch;
2247 hv_magic(hv, envgv, 'E');
2249 for (; *env; env++) {
2250 if (!(s = strchr(*env,'=')))
2253 sv = newSVpv(s--,0);
2254 sv_magic(sv, sv, 'e', *env, s - *env);
2255 (void)hv_store(hv, *env, s - *env, sv, 0);
2259 #ifdef DYNAMIC_ENV_FETCH
2260 HvNAME(hv) = savepv(ENV_HV_NAME);
2262 hv_magic(hv, envgv, 'E');
2265 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2266 sv_setiv(GvSV(tmpgv), (IV)getpid());
2275 s = getenv("PERL5LIB");
2279 incpush(getenv("PERLLIB"), FALSE);
2281 /* Treat PERL5?LIB as a possible search list logical name -- the
2282 * "natural" VMS idiom for a Unix path string. We allow each
2283 * element to be a set of |-separated directories for compatibility.
2287 if (my_trnlnm("PERL5LIB",buf,0))
2288 do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2290 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2294 /* Use the ~-expanded versions of APPLIB (undocumented),
2295 ARCHLIB PRIVLIB SITEARCH SITELIB and OLDARCHLIB
2298 incpush(APPLLIB_EXP, FALSE);
2302 incpush(ARCHLIB_EXP, FALSE);
2305 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2307 incpush(PRIVLIB_EXP, FALSE);
2310 incpush(SITEARCH_EXP, FALSE);
2313 incpush(SITELIB_EXP, FALSE);
2315 #ifdef OLDARCHLIB_EXP /* 5.00[01] compatibility */
2316 incpush(OLDARCHLIB_EXP, FALSE);
2320 incpush(".", FALSE);
2324 # define PERLLIB_SEP ';'
2327 # define PERLLIB_SEP '|'
2329 # define PERLLIB_SEP ':'
2332 #ifndef PERLLIB_MANGLE
2333 # define PERLLIB_MANGLE(s,n) (s)
2337 incpush(p, addsubdirs)
2341 SV *subdir = Nullsv;
2342 static char *archpat_auto;
2349 if (!archpat_auto) {
2350 STRLEN len = (sizeof(ARCHNAME) + strlen(patchlevel)
2351 + sizeof("//auto"));
2352 New(55, archpat_auto, len, char);
2353 sprintf(archpat_auto, "/%s/%s/auto", ARCHNAME, patchlevel);
2355 for (len = sizeof(ARCHNAME) + 2;
2356 archpat_auto[len] != '\0' && archpat_auto[len] != '/'; len++)
2357 if (archpat_auto[len] == '.') archpat_auto[len] = '_';
2362 /* Break at all separators */
2364 SV *libdir = newSV(0);
2367 /* skip any consecutive separators */
2368 while ( *p == PERLLIB_SEP ) {
2369 /* Uncomment the next line for PATH semantics */
2370 /* av_push(GvAVn(incgv), newSVpv(".", 1)); */
2374 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2375 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2380 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2381 p = Nullch; /* break out */
2385 * BEFORE pushing libdir onto @INC we may first push version- and
2386 * archname-specific sub-directories.
2389 struct stat tmpstatbuf;
2394 if ((unix = tounixspec_ts(SvPV(libdir,na),Nullch)) != Nullch) {
2396 while (unix[len-1] == '/') len--; /* Cosmetic */
2397 sv_usepvn(libdir,unix,len);
2400 PerlIO_printf(PerlIO_stderr(),
2401 "Failed to unixify @INC element \"%s\"\n",
2404 /* .../archname/version if -d .../archname/version/auto */
2405 sv_setsv(subdir, libdir);
2406 sv_catpv(subdir, archpat_auto);
2407 if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2408 S_ISDIR(tmpstatbuf.st_mode))
2409 av_push(GvAVn(incgv),
2410 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2412 /* .../archname if -d .../archname/auto */
2413 sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
2414 strlen(patchlevel) + 1, "", 0);
2415 if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2416 S_ISDIR(tmpstatbuf.st_mode))
2417 av_push(GvAVn(incgv),
2418 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2421 /* finally push this lib directory on the end of @INC */
2422 av_push(GvAVn(incgv), libdir);
2425 SvREFCNT_dec(subdir);
2434 line_t oldline = curcop->cop_line;
2436 Copy(top_env, oldtop, 1, Sigjmp_buf);
2438 while (AvFILL(list) >= 0) {
2439 CV *cv = (CV*)av_shift(list);
2443 switch (Sigsetjmp(top_env,1)) {
2445 SV* atsv = GvSV(errgv);
2447 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
2448 (void)SvPV(atsv, len);
2450 Copy(oldtop, top_env, 1, Sigjmp_buf);
2451 curcop = &compiling;
2452 curcop->cop_line = oldline;
2453 if (list == beginav)
2454 sv_catpv(atsv, "BEGIN failed--compilation aborted");
2456 sv_catpv(atsv, "END failed--cleanup aborted");
2457 croak("%s", SvPVX(atsv));
2465 /* my_exit() was called */
2466 curstash = defstash;
2470 Copy(oldtop, top_env, 1, Sigjmp_buf);
2471 curcop = &compiling;
2472 curcop->cop_line = oldline;
2474 if (list == beginav)
2475 croak("BEGIN failed--compilation aborted");
2477 croak("END failed--cleanup aborted");
2483 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
2487 Copy(oldtop, top_env, 1, Sigjmp_buf);
2488 curcop = &compiling;
2489 curcop->cop_line = oldline;
2490 Siglongjmp(top_env, 3);
2494 Copy(oldtop, top_env, 1, Sigjmp_buf);
2509 STATUS_NATIVE_SET(status);
2519 if (vaxc$errno & 1) {
2520 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
2521 STATUS_NATIVE_SET(44);
2524 if (!vaxc$errno && errno) /* unlikely */
2525 STATUS_NATIVE_SET(44);
2527 STATUS_NATIVE_SET(vaxc$errno);
2531 STATUS_POSIX_SET(errno);
2532 else if (STATUS_POSIX == 0)
2533 STATUS_POSIX_SET(255);
2541 register CONTEXT *cx;
2550 (void)UNLINK(e_tmpname);
2551 Safefree(e_tmpname);
2555 if (cxstack_ix >= 0) {
2562 Siglongjmp(top_env, 2);