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. First the syntax tree. */
203 curpad = AvARRAY(comppad);
209 * Try to destruct global references. We do this first so that the
210 * destructors and destructees still exist. Some sv's might remain.
211 * Non-referenced objects are on their own.
218 if (destruct_level == 0){
220 DEBUG_P(debprofdump());
222 /* The exit() function will do everything that needs doing. */
226 /* loosen bonds of global variables */
229 (void)PerlIO_close(rsfp);
233 /* Filters for program text */
234 SvREFCNT_dec(rsfp_filters);
235 rsfp_filters = Nullav;
247 sawampersand = FALSE; /* must save all match strings */
248 sawstudy = FALSE; /* do fbm_instr on all strings */
263 /* magical thingies */
265 Safefree(ofs); /* $, */
268 Safefree(ors); /* $\ */
271 SvREFCNT_dec(nrs); /* $\ helper */
274 multiline = 0; /* $* */
276 SvREFCNT_dec(statname);
280 /* defgv, aka *_ should be taken care of elsewhere */
282 #if 0 /* just about all regexp stuff, seems to be ok */
284 /* shortcuts to regexp stuff */
289 SAVEFREEOP(oldlastpm); /* for saving regexp context during debugger */
291 regprecomp = NULL; /* uncompiled string. */
292 regparse = NULL; /* Input-scan pointer. */
293 regxend = NULL; /* End of input for compile */
294 regnpar = 0; /* () count. */
295 regcode = NULL; /* Code-emit pointer; ®dummy = don't. */
296 regsize = 0; /* Code size. */
297 regnaughty = 0; /* How bad is this pattern? */
298 regsawback = 0; /* Did we see \1, ...? */
300 reginput = NULL; /* String-input pointer. */
301 regbol = NULL; /* Beginning of input, for ^ check. */
302 regeol = NULL; /* End of input, for $ check. */
303 regstartp = (char **)NULL; /* Pointer to startp array. */
304 regendp = (char **)NULL; /* Ditto for endp. */
305 reglastparen = 0; /* Similarly for lastparen. */
306 regtill = NULL; /* How far we are required to go. */
307 regflags = 0; /* are we folding, multilining? */
308 regprev = (char)NULL; /* char before regbol, \n if none */
312 /* clean up after study() */
313 SvREFCNT_dec(lastscream);
315 Safefree(screamfirst);
317 Safefree(screamnext);
320 /* startup and shutdown function lists */
321 SvREFCNT_dec(beginav);
326 /* temp stack during pp_sort() */
327 SvREFCNT_dec(sortstack);
330 /* shortcuts just get cleared */
340 /* reset so print() ends up where we expect */
343 /* Prepare to destruct main symbol table. */
350 if (destruct_level >= 2) {
351 if (scopestack_ix != 0)
352 warn("Unbalanced scopes: %d more ENTERs than LEAVEs\n", scopestack_ix);
353 if (savestack_ix != 0)
354 warn("Unbalanced saves: %d more saves than restores\n", savestack_ix);
355 if (tmps_floor != -1)
356 warn("Unbalanced tmps: %d more allocs than frees\n", tmps_floor + 1);
357 if (cxstack_ix != -1)
358 warn("Unbalanced context: %d more PUSHes than POPs\n", cxstack_ix + 1);
361 /* Now absolutely destruct everything, somehow or other, loops or no. */
363 SvFLAGS(strtab) |= SVTYPEMASK; /* don't clean out strtab now */
364 while (sv_count != 0 && sv_count != last_sv_count) {
365 last_sv_count = sv_count;
368 SvFLAGS(strtab) &= ~SVTYPEMASK;
369 SvFLAGS(strtab) |= SVt_PVHV;
371 /* Destruct the global string table. */
373 /* Yell and reset the HeVAL() slots that are still holding refcounts,
374 * so that sv_free() won't fail on them.
383 array = HvARRAY(strtab);
387 warn("Unbalanced string table refcount: (%d) for \"%s\"",
388 HeVAL(hent) - Nullsv, HeKEY(hent));
389 HeVAL(hent) = Nullsv;
399 SvREFCNT_dec(strtab);
402 warn("Scalars leaked: %d\n", sv_count);
406 /* No SVs have survived, need to clean out */
410 Safefree(origfilename);
412 hints = 0; /* Reset hints. Should hints be per-interpreter ? */
414 DEBUG_P(debprofdump());
419 PerlInterpreter *sv_interp;
421 if (!(curinterp = sv_interp))
425 #if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE)
426 char *getenv _((char *)); /* Usually in <stdlib.h> */
430 perl_parse(sv_interp, xsinit, argc, argv, env)
431 PerlInterpreter *sv_interp;
432 void (*xsinit)_((void));
439 char *scriptname = NULL;
440 VOL bool dosearch = FALSE;
444 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
447 croak("suidperl is no longer needed since the kernel can now execute\n\
448 setuid perl scripts securely.\n");
452 if (!(curinterp = sv_interp))
455 #if defined(NeXT) && defined(__DYNAMIC__)
456 _dyld_lookup_and_bind
457 ("__environ", (unsigned long *) &environ_pointer, NULL);
462 #ifndef VMS /* VMS doesn't have environ array */
463 origenviron = environ;
469 /* Come here if running an undumped a.out. */
471 origfilename = savepv(argv[0]);
473 cxstack_ix = -1; /* start label stack again */
475 init_postdump_symbols(argc,argv,env);
485 switch (Sigsetjmp(top_env,1)) {
490 /* my_exit() was called */
494 return STATUS_NATIVE_EXPORT;
496 PerlIO_printf(PerlIO_stderr(), "panic: top_env\n");
500 sv_setpvn(linestr,"",0);
501 sv = newSVpv("",0); /* first used for -I flags */
504 for (argc--,argv++; argc > 0; argc--,argv++) {
505 if (argv[0][0] != '-' || !argv[0][1])
509 validarg = " PHOOEY ";
534 if (s = moreswitches(s))
544 if (euid != uid || egid != gid)
545 croak("No -e allowed in setuid scripts");
547 e_tmpname = savepv(TMPPATH);
548 (void)mktemp(e_tmpname);
550 croak("Can't mktemp()");
551 e_fp = PerlIO_open(e_tmpname,"w");
553 croak("Cannot open temporary file");
558 PerlIO_puts(e_fp,argv[1]);
562 croak("No code specified for -e");
563 (void)PerlIO_putc(e_fp,'\n');
574 incpush(argv[1], TRUE);
575 sv_catpv(sv,argv[1]);
592 preambleav = newAV();
593 av_push(preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
595 Sv = newSVpv("print myconfig();",0);
597 sv_catpv(Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
599 sv_catpv(Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
601 #if defined(DEBUGGING) || defined(NOEMBED) || defined(MULTIPLICITY)
602 strcpy(buf,"\" Compile-time options:");
604 strcat(buf," DEBUGGING");
607 strcat(buf," NOEMBED");
610 strcat(buf," MULTIPLICITY");
612 strcat(buf,"\\n\",");
615 #if defined(LOCAL_PATCH_COUNT)
616 if (LOCAL_PATCH_COUNT > 0)
618 sv_catpv(Sv,"print \" Locally applied patches:\\n\",");
619 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
620 if (localpatches[i]) {
621 sprintf(buf,"\" \\t%s\\n\",",localpatches[i]);
627 sprintf(buf,"\" Built under %s\\n\",",OSNAME);
631 sprintf(buf,"\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
633 sprintf(buf,"\" Compiled on %s\\n\"",__DATE__);
637 sv_catpv(Sv,"; $\"=\"\\n \"; print \" \\@INC:\\n @INC\\n\"");
640 Sv = newSVpv("config_vars(qw(",0);
645 av_push(preambleav, Sv);
646 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
660 croak("Unrecognized switch: -%s",s);
665 scriptname = argv[0];
667 if (PerlIO_flush(e_fp) || PerlIO_error(e_fp) || PerlIO_close(e_fp))
668 croak("Can't write to temp file for -e: %s", Strerror(errno));
671 scriptname = e_tmpname;
673 else if (scriptname == Nullch) {
675 if ( isatty(PerlIO_fileno(PerlIO_stdin())) )
683 open_script(scriptname,dosearch,sv);
685 validate_suid(validarg, scriptname);
690 compcv = (CV*)NEWSV(1104,0);
691 sv_upgrade((SV *)compcv, SVt_PVCV);
695 av_push(comppad, Nullsv);
696 curpad = AvARRAY(comppad);
697 comppad_name = newAV();
698 comppad_name_fill = 0;
699 min_intro_pending = 0;
702 comppadlist = newAV();
703 AvREAL_off(comppadlist);
704 av_store(comppadlist, 0, (SV*)comppad_name);
705 av_store(comppadlist, 1, (SV*)comppad);
706 CvPADLIST(compcv) = comppadlist;
708 boot_core_UNIVERSAL();
710 (*xsinit)(); /* in case linked C routines want magical variables */
715 init_predump_symbols();
717 init_postdump_symbols(argc,argv,env);
721 /* now parse the script */
724 if (yyparse() || error_count) {
726 croak("%s had compilation errors.\n", origfilename);
728 croak("Execution of %s aborted due to compilation errors.\n",
732 curcop->cop_line = 0;
736 (void)UNLINK(e_tmpname);
741 /* now that script is parsed, we can modify record separator */
743 rs = SvREFCNT_inc(nrs);
744 sv_setsv(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), rs);
755 #ifdef DEBUGGING_MSTATS
756 if ((s=getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
757 dump_mstats("after compilation:");
767 PerlInterpreter *sv_interp;
769 if (!(curinterp = sv_interp))
771 switch (Sigsetjmp(top_env,1)) {
773 cxstack_ix = -1; /* start context stack again */
776 /* my_exit() was called */
781 #ifdef DEBUGGING_MSTATS
782 if (getenv("PERL_DEBUG_MSTATS"))
783 dump_mstats("after execution: ");
785 return STATUS_NATIVE_EXPORT;
788 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
792 if (curstack != mainstack) {
794 SWITCHSTACK(curstack, mainstack);
799 DEBUG_r(PerlIO_printf(PerlIO_stderr(), "%s $` $& $' support.\n",
800 sawampersand ? "Enabling" : "Omitting"));
804 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
807 PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", origfilename);
810 if (perldb && DBsingle)
811 sv_setiv(DBsingle, 1);
821 else if (main_start) {
831 perl_get_sv(name, create)
835 GV* gv = gv_fetchpv(name, create, SVt_PV);
842 perl_get_av(name, create)
846 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
855 perl_get_hv(name, create)
859 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
868 perl_get_cv(name, create)
872 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
873 if (create && !GvCVu(gv))
874 return newSUB(start_subparse(FALSE, 0),
875 newSVOP(OP_CONST, 0, newSVpv(name,0)),
883 /* Be sure to refetch the stack pointer after calling these routines. */
886 perl_call_argv(subname, flags, argv)
888 I32 flags; /* See G_* flags in cop.h */
889 register char **argv; /* null terminated arg list */
896 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
901 return perl_call_pv(subname, flags);
905 perl_call_pv(subname, flags)
906 char *subname; /* name of the subroutine */
907 I32 flags; /* See G_* flags in cop.h */
909 return perl_call_sv((SV*)perl_get_cv(subname, TRUE), flags);
913 perl_call_method(methname, flags)
914 char *methname; /* name of the subroutine */
915 I32 flags; /* See G_* flags in cop.h */
921 XPUSHs(sv_2mortal(newSVpv(methname,0)));
924 return perl_call_sv(*stack_sp--, flags);
927 /* May be called with any of a CV, a GV, or an SV containing the name. */
929 perl_call_sv(sv, flags)
931 I32 flags; /* See G_* flags in cop.h */
933 LOGOP myop; /* fake syntax tree node */
935 I32 oldmark = TOPMARK;
941 if (flags & G_DISCARD) {
951 oldscope = scopestack_ix;
953 if (!(flags & G_NOARGS))
954 myop.op_flags = OPf_STACKED;
955 myop.op_next = Nullop;
956 myop.op_flags |= OPf_KNOW;
958 myop.op_flags |= OPf_LIST;
960 if (perldb && curstash != debstash
961 /* Handle first BEGIN of -d. */
962 && (DBcv || (DBcv = GvCV(DBsub)))
963 /* Try harder, since this may have been a sighandler, thus
964 * curstash may be meaningless. */
965 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != debstash))
966 op->op_private |= OPpENTERSUB_DB;
968 if (flags & G_EVAL) {
969 Copy(top_env, oldtop, 1, Sigjmp_buf);
971 cLOGOP->op_other = op;
973 /* we're trying to emulate pp_entertry() here */
975 register CONTEXT *cx;
981 push_return(op->op_next);
982 PUSHBLOCK(cx, CXt_EVAL, stack_sp);
984 eval_root = op; /* Only needed so that goto works right. */
987 if (flags & G_KEEPERR)
990 sv_setpv(GvSV(errgv),"");
995 switch (Sigsetjmp(top_env,1)) {
1002 /* my_exit() was called */
1003 curstash = defstash;
1005 Copy(oldtop, top_env, 1, Sigjmp_buf);
1007 croak("Callback called exit");
1016 stack_sp = stack_base + oldmark;
1017 if (flags & G_ARRAY)
1021 *++stack_sp = &sv_undef;
1027 if (op == (OP*)&myop)
1031 retval = stack_sp - (stack_base + oldmark);
1032 if ((flags & G_EVAL) && !(flags & G_KEEPERR))
1033 sv_setpv(GvSV(errgv),"");
1036 if (flags & G_EVAL) {
1037 if (scopestack_ix > oldscope) {
1041 register CONTEXT *cx;
1050 Copy(oldtop, top_env, 1, Sigjmp_buf);
1052 if (flags & G_DISCARD) {
1053 stack_sp = stack_base + oldmark;
1061 /* Eval a string. The G_EVAL flag is always assumed. */
1064 perl_eval_sv(sv, flags)
1066 I32 flags; /* See G_* flags in cop.h */
1068 UNOP myop; /* fake syntax tree node */
1070 I32 oldmark = sp - stack_base;
1075 if (flags & G_DISCARD) {
1083 EXTEND(stack_sp, 1);
1085 oldscope = scopestack_ix;
1087 if (!(flags & G_NOARGS))
1088 myop.op_flags = OPf_STACKED;
1089 myop.op_next = Nullop;
1090 myop.op_type = OP_ENTEREVAL;
1091 myop.op_flags |= OPf_KNOW;
1092 if (flags & G_KEEPERR)
1093 myop.op_flags |= OPf_SPECIAL;
1094 if (flags & G_ARRAY)
1095 myop.op_flags |= OPf_LIST;
1097 Copy(top_env, oldtop, 1, Sigjmp_buf);
1100 switch (Sigsetjmp(top_env,1)) {
1107 /* my_exit() was called */
1108 curstash = defstash;
1110 Copy(oldtop, top_env, 1, Sigjmp_buf);
1112 croak("Callback called exit");
1121 stack_sp = stack_base + oldmark;
1122 if (flags & G_ARRAY)
1126 *++stack_sp = &sv_undef;
1131 if (op == (OP*)&myop)
1132 op = pp_entereval();
1135 retval = stack_sp - (stack_base + oldmark);
1136 if (!(flags & G_KEEPERR))
1137 sv_setpv(GvSV(errgv),"");
1140 Copy(oldtop, top_env, 1, Sigjmp_buf);
1141 if (flags & G_DISCARD) {
1142 stack_sp = stack_base + oldmark;
1150 /* Require a module. */
1156 SV* sv = sv_newmortal();
1157 sv_setpv(sv, "require '");
1160 perl_eval_sv(sv, G_DISCARD);
1164 magicname(sym,name,namlen)
1171 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1172 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1176 usage(name) /* XXX move this out into a module ? */
1179 /* This message really ought to be max 23 lines.
1180 * Removed -h because the user already knows that opton. Others? */
1181 printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1182 printf("\n -0[octal] specify record separator (\\0, if no argument)");
1183 printf("\n -a autosplit mode with -n or -p (splits $_ into @F)");
1184 printf("\n -c check syntax only (runs BEGIN and END blocks)");
1185 printf("\n -d[:debugger] run scripts under debugger");
1186 printf("\n -D[number/list] set debugging flags (argument is a bit mask or flags)");
1187 printf("\n -e 'command' one line of script. Several -e's allowed. Omit [programfile].");
1188 printf("\n -F/pattern/ split() pattern for autosplit (-a). The //'s are optional.");
1189 printf("\n -i[extension] edit <> files in place (make backup if extension supplied)");
1190 printf("\n -Idirectory specify @INC/#include directory (may be used more then once)");
1191 printf("\n -l[octal] enable line ending processing, specifies line teminator");
1192 printf("\n -[mM][-]module.. executes `use/no module...' before executing your script.");
1193 printf("\n -n assume 'while (<>) { ... }' loop arround your script");
1194 printf("\n -p assume loop like -n but print line also like sed");
1195 printf("\n -P run script through C preprocessor before compilation");
1196 printf("\n -s enable some switch parsing for switches after script name");
1197 printf("\n -S look for the script using PATH environment variable");
1198 printf("\n -T turn on tainting checks");
1199 printf("\n -u dump core after parsing script");
1200 printf("\n -U allow unsafe operations");
1201 printf("\n -v print version number and patchlevel of perl");
1202 printf("\n -V[:variable] print perl configuration information");
1203 printf("\n -w TURN WARNINGS ON FOR COMPILATION OF YOUR SCRIPT.");
1204 printf("\n -x[directory] strip off text before #!perl line and perhaps cd to directory\n");
1207 /* This routine handles any switches that can be given during run */
1218 rschar = scan_oct(s, 4, &numlen);
1220 if (rschar & ~((U8)~0))
1222 else if (!rschar && numlen >= 2)
1223 nrs = newSVpv("", 0);
1226 nrs = newSVpv(&ch, 1);
1231 splitstr = savepv(s + 1);
1245 if (*s == ':' || *s == '=') {
1246 sprintf(buf, "use Devel::%s;", ++s);
1248 my_setenv("PERL5DB",buf);
1258 if (isALPHA(s[1])) {
1259 static char debopts[] = "psltocPmfrxuLHXD";
1262 for (s++; *s && (d = strchr(debopts,*s)); s++)
1263 debug |= 1 << (d - debopts);
1267 for (s++; isDIGIT(*s); s++) ;
1269 debug |= 0x80000000;
1271 warn("Recompile perl with -DDEBUGGING to use -D switch\n");
1272 for (s++; isALNUM(*s); s++) ;
1282 inplace = savepv(s+1);
1284 for (s = inplace; *s && !isSPACE(*s); s++) ;
1291 for (e = s; *e && !isSPACE(*e); e++) ;
1292 p = savepvn(s, e-s);
1299 croak("No space allowed after -I");
1309 *ors = scan_oct(s, 3 + (*s == '0'), &numlen);
1318 ors = SvPV(nrs, orslen);
1319 ors = savepvn(ors, orslen);
1323 forbid_setid("-M"); /* XXX ? */
1326 forbid_setid("-m"); /* XXX ? */
1330 /* -M-foo == 'no foo' */
1331 if (*s == '-') { use = "no "; ++s; }
1332 Sv = newSVpv(use,0);
1334 /* We allow -M'Module qw(Foo Bar)' */
1335 while(isALNUM(*s) || *s==':') ++s;
1337 sv_catpv(Sv, start);
1338 if (*(start-1) == 'm') {
1340 croak("Can't use '%c' after -mname", *s);
1341 sv_catpv( Sv, " ()");
1344 sv_catpvn(Sv, start, s-start);
1345 sv_catpv(Sv, " split(/,/,q{");
1350 if (preambleav == NULL)
1351 preambleav = newAV();
1352 av_push(preambleav, Sv);
1355 croak("No space allowed after -%c", *(s-1));
1372 croak("Too late for \"-T\" option (try putting it first)");
1384 #if defined(SUBVERSION) && SUBVERSION > 0
1385 printf("\nThis is perl, version 5.%03d_%02d", PATCHLEVEL, SUBVERSION);
1387 printf("\nThis is perl, version %s",patchlevel);
1390 printf("\n\nCopyright 1987-1997, Larry Wall\n");
1392 printf("\n\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1395 printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
1398 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1399 "Version 5 port Copyright (c) 1994-1996, Andreas Kaiser, Ilya Zakharevich\n");
1402 printf("atariST series port, ++jrb bammi@cadence.com\n");
1405 Perl may be copied only under the terms of either the Artistic License or the\n\
1406 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n");
1414 if (s[1] == '-') /* Additional switches on #! line. */
1427 croak("Can't emulate -%.1s on #! line",s);
1432 /* compliments of Tom Christiansen */
1434 /* unexec() can be found in the Gnu emacs distribution */
1443 sprintf (buf, "%s.perldump", origfilename);
1444 sprintf (tokenbuf, "%s/perl", BIN);
1446 status = unexec(buf, tokenbuf, &etext, sbrk(0), 0);
1448 PerlIO_printf(PerlIO_stderr(), "unexec of %s into %s failed!\n", tokenbuf, buf);
1452 # include <lib$routines.h>
1453 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
1455 ABORT(); /* for use with undump */
1465 /* Note that strtab is a rather special HV. Assumptions are made
1466 about not iterating on it, and not adding tie magic to it.
1467 It is properly deallocated in perl_destruct() */
1469 HvSHAREKEYS_off(strtab); /* mandatory */
1470 Newz(506,((XPVHV*)SvANY(strtab))->xhv_array,
1471 sizeof(HE*) * (((XPVHV*)SvANY(strtab))->xhv_max + 1), char);
1473 curstash = defstash = newHV();
1474 curstname = newSVpv("main",4);
1475 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1476 SvREFCNT_dec(GvHV(gv));
1477 GvHV(gv) = (HV*)SvREFCNT_inc(defstash);
1479 HvNAME(defstash) = savepv("main");
1480 incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1482 defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1483 errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1485 sv_setpvn(GvSV(errgv), "", 0);
1486 curstash = defstash;
1487 compiling.cop_stash = defstash;
1488 debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
1489 /* We must init $/ before switches are processed. */
1490 sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1);
1493 #ifdef CAN_PROTOTYPE
1495 open_script(char *scriptname, bool dosearch, SV *sv)
1498 open_script(scriptname,dosearch,sv)
1504 char *xfound = Nullch;
1505 char *xfailed = Nullch;
1509 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
1510 #define SEARCH_EXTS ".bat", ".cmd", NULL
1513 # define SEARCH_EXTS ".pl", ".com", NULL
1515 /* additional extensions to try in each dir if scriptname not found */
1517 char *ext[] = { SEARCH_EXTS };
1518 int extidx = (strchr(scriptname,'.')) ? -1 : 0; /* has ext already */
1523 int hasdir, idx = 0, deftypes = 1;
1525 hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
1526 /* The first time through, just add SEARCH_EXTS to whatever we
1527 * already have, so we can check for default file types. */
1528 while (deftypes || (!hasdir && my_trnlnm("DCL$PATH",tokenbuf,idx++)) ) {
1529 if (deftypes) { deftypes = 0; *tokenbuf = '\0'; }
1530 strcat(tokenbuf,scriptname);
1532 if (dosearch && !strchr(scriptname, '/') && (s = getenv("PATH"))) {
1534 bufend = s + strlen(s);
1537 s = cpytill(tokenbuf,s,bufend,':',&len);
1540 for (len = 0; *s && *s != ',' && *s != ';'; tokenbuf[len++] = *s++);
1541 tokenbuf[len] = '\0';
1543 for (len = 0; *s && *s != ';'; tokenbuf[len++] = *s++);
1544 tokenbuf[len] = '\0';
1550 if (len && tokenbuf[len-1] != '/')
1553 if (len && ((tokenbuf[len-1] != '\\') && (tokenbuf[len-1] != '/')))
1555 if (len && tokenbuf[len-1] != '\\')
1558 (void)strcat(tokenbuf+len,"/");
1559 (void)strcat(tokenbuf+len,scriptname);
1563 len = strlen(tokenbuf);
1564 if (extidx > 0) /* reset after previous loop */
1568 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tokenbuf));
1569 retval = Stat(tokenbuf,&statbuf);
1571 } while ( retval < 0 /* not there */
1572 && extidx>=0 && ext[extidx] /* try an extension? */
1573 && strcpy(tokenbuf+len, ext[extidx++])
1578 if (S_ISREG(statbuf.st_mode)
1579 && cando(S_IRUSR,TRUE,&statbuf) && cando(S_IXUSR,TRUE,&statbuf)) {
1580 xfound = tokenbuf; /* bingo! */
1584 xfailed = savepv(tokenbuf);
1587 croak("Can't execute %s", xfailed ? xfailed : scriptname );
1590 scriptname = xfound;
1593 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
1594 char *s = scriptname + 8;
1603 origfilename = savepv(e_tmpname ? "-e" : scriptname);
1604 curcop->cop_filegv = gv_fetchfile(origfilename);
1605 if (strEQ(origfilename,"-"))
1607 if (fdscript >= 0) {
1608 rsfp = PerlIO_fdopen(fdscript,"r");
1609 #if defined(HAS_FCNTL) && defined(F_SETFD)
1611 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
1614 else if (preprocess) {
1615 char *cpp = CPPSTDIN;
1617 if (strEQ(cpp,"cppstdin"))
1618 sprintf(tokenbuf, "%s/%s", SCRIPTDIR, cpp);
1620 sprintf(tokenbuf, "%s", cpp);
1622 sv_catpv(sv,PRIVLIB_EXP);
1624 (void)sprintf(buf, "\
1625 sed %s -e \"/^[^#]/b\" \
1626 -e \"/^#[ ]*include[ ]/b\" \
1627 -e \"/^#[ ]*define[ ]/b\" \
1628 -e \"/^#[ ]*if[ ]/b\" \
1629 -e \"/^#[ ]*ifdef[ ]/b\" \
1630 -e \"/^#[ ]*ifndef[ ]/b\" \
1631 -e \"/^#[ ]*else/b\" \
1632 -e \"/^#[ ]*elif[ ]/b\" \
1633 -e \"/^#[ ]*undef[ ]/b\" \
1634 -e \"/^#[ ]*endif/b\" \
1637 (doextract ? "-e \"1,/^#/d\n\"" : ""),
1639 (void)sprintf(buf, "\
1640 %s %s -e '/^[^#]/b' \
1641 -e '/^#[ ]*include[ ]/b' \
1642 -e '/^#[ ]*define[ ]/b' \
1643 -e '/^#[ ]*if[ ]/b' \
1644 -e '/^#[ ]*ifdef[ ]/b' \
1645 -e '/^#[ ]*ifndef[ ]/b' \
1646 -e '/^#[ ]*else/b' \
1647 -e '/^#[ ]*elif[ ]/b' \
1648 -e '/^#[ ]*undef[ ]/b' \
1649 -e '/^#[ ]*endif/b' \
1657 (doextract ? "-e '1,/^#/d\n'" : ""),
1659 scriptname, tokenbuf, SvPV(sv, na), CPPMINUS);
1661 #ifdef IAMSUID /* actually, this is caught earlier */
1662 if (euid != uid && !euid) { /* if running suidperl */
1664 (void)seteuid(uid); /* musn't stay setuid root */
1667 (void)setreuid((Uid_t)-1, uid);
1669 #ifdef HAS_SETRESUID
1670 (void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
1676 if (geteuid() != uid)
1677 croak("Can't do seteuid!\n");
1679 #endif /* IAMSUID */
1680 rsfp = my_popen(buf,"r");
1682 else if (!*scriptname) {
1683 forbid_setid("program input from stdin");
1684 rsfp = PerlIO_stdin();
1687 rsfp = PerlIO_open(scriptname,"r");
1688 #if defined(HAS_FCNTL) && defined(F_SETFD)
1690 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
1698 #ifndef IAMSUID /* in case script is not readable before setuid */
1699 if (euid && Stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
1700 statbuf.st_mode & (S_ISUID|S_ISGID)) {
1701 (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
1702 execv(buf, origargv); /* try again */
1703 croak("Can't do setuid\n");
1707 croak("Can't open perl script \"%s\": %s\n",
1708 SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno));
1713 validate_suid(validarg, scriptname)
1719 /* do we need to emulate setuid on scripts? */
1721 /* This code is for those BSD systems that have setuid #! scripts disabled
1722 * in the kernel because of a security problem. Merely defining DOSUID
1723 * in perl will not fix that problem, but if you have disabled setuid
1724 * scripts in the kernel, this will attempt to emulate setuid and setgid
1725 * on scripts that have those now-otherwise-useless bits set. The setuid
1726 * root version must be called suidperl or sperlN.NNN. If regular perl
1727 * discovers that it has opened a setuid script, it calls suidperl with
1728 * the same argv that it had. If suidperl finds that the script it has
1729 * just opened is NOT setuid root, it sets the effective uid back to the
1730 * uid. We don't just make perl setuid root because that loses the
1731 * effective uid we had before invoking perl, if it was different from the
1734 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
1735 * be defined in suidperl only. suidperl must be setuid root. The
1736 * Configure script will set this up for you if you want it.
1742 if (Fstat(PerlIO_fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
1743 croak("Can't stat script \"%s\"",origfilename);
1744 if (fdscript < 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) {
1748 #ifndef HAS_SETREUID
1749 /* On this access check to make sure the directories are readable,
1750 * there is actually a small window that the user could use to make
1751 * filename point to an accessible directory. So there is a faint
1752 * chance that someone could execute a setuid script down in a
1753 * non-accessible directory. I don't know what to do about that.
1754 * But I don't think it's too important. The manual lies when
1755 * it says access() is useful in setuid programs.
1757 if (access(SvPVX(GvSV(curcop->cop_filegv)),1)) /*double check*/
1758 croak("Permission denied");
1760 /* If we can swap euid and uid, then we can determine access rights
1761 * with a simple stat of the file, and then compare device and
1762 * inode to make sure we did stat() on the same file we opened.
1763 * Then we just have to make sure he or she can execute it.
1766 struct stat tmpstatbuf;
1770 setreuid(euid,uid) < 0
1773 setresuid(euid,uid,(Uid_t)-1) < 0
1776 || getuid() != euid || geteuid() != uid)
1777 croak("Can't swap uid and euid"); /* really paranoid */
1778 if (Stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
1779 croak("Permission denied"); /* testing full pathname here */
1780 if (tmpstatbuf.st_dev != statbuf.st_dev ||
1781 tmpstatbuf.st_ino != statbuf.st_ino) {
1782 (void)PerlIO_close(rsfp);
1783 if (rsfp = my_popen("/bin/mail root","w")) { /* heh, heh */
1785 "User %d tried to run dev %d ino %d in place of dev %d ino %d!\n\
1786 (Filename of set-id script was %s, uid %d gid %d.)\n\nSincerely,\nperl\n",
1787 uid,tmpstatbuf.st_dev, tmpstatbuf.st_ino,
1788 statbuf.st_dev, statbuf.st_ino,
1789 SvPVX(GvSV(curcop->cop_filegv)),
1790 statbuf.st_uid, statbuf.st_gid);
1791 (void)my_pclose(rsfp);
1793 croak("Permission denied\n");
1797 setreuid(uid,euid) < 0
1799 # if defined(HAS_SETRESUID)
1800 setresuid(uid,euid,(Uid_t)-1) < 0
1803 || getuid() != uid || geteuid() != euid)
1804 croak("Can't reswap uid and euid");
1805 if (!cando(S_IXUSR,FALSE,&statbuf)) /* can real uid exec? */
1806 croak("Permission denied\n");
1808 #endif /* HAS_SETREUID */
1809 #endif /* IAMSUID */
1811 if (!S_ISREG(statbuf.st_mode))
1812 croak("Permission denied");
1813 if (statbuf.st_mode & S_IWOTH)
1814 croak("Setuid/gid script is writable by world");
1815 doswitches = FALSE; /* -s is insecure in suid */
1817 if (sv_gets(linestr, rsfp, 0) == Nullch ||
1818 strnNE(SvPV(linestr,na),"#!",2) ) /* required even on Sys V */
1819 croak("No #! line");
1820 s = SvPV(linestr,na)+2;
1822 while (!isSPACE(*s)) s++;
1823 for (s2 = s; (s2 > SvPV(linestr,na)+2 &&
1824 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
1825 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
1826 croak("Not a perl script");
1827 while (*s == ' ' || *s == '\t') s++;
1829 * #! arg must be what we saw above. They can invoke it by
1830 * mentioning suidperl explicitly, but they may not add any strange
1831 * arguments beyond what #! says if they do invoke suidperl that way.
1833 len = strlen(validarg);
1834 if (strEQ(validarg," PHOOEY ") ||
1835 strnNE(s,validarg,len) || !isSPACE(s[len]))
1836 croak("Args must match #! line");
1839 if (euid != uid && (statbuf.st_mode & S_ISUID) &&
1840 euid == statbuf.st_uid)
1842 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
1843 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
1844 #endif /* IAMSUID */
1846 if (euid) { /* oops, we're not the setuid root perl */
1847 (void)PerlIO_close(rsfp);
1849 (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
1850 execv(buf, origargv); /* try again */
1852 croak("Can't do setuid\n");
1855 if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
1857 (void)setegid(statbuf.st_gid);
1860 (void)setregid((Gid_t)-1,statbuf.st_gid);
1862 #ifdef HAS_SETRESGID
1863 (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
1865 setgid(statbuf.st_gid);
1869 if (getegid() != statbuf.st_gid)
1870 croak("Can't do setegid!\n");
1872 if (statbuf.st_mode & S_ISUID) {
1873 if (statbuf.st_uid != euid)
1875 (void)seteuid(statbuf.st_uid); /* all that for this */
1878 (void)setreuid((Uid_t)-1,statbuf.st_uid);
1880 #ifdef HAS_SETRESUID
1881 (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
1883 setuid(statbuf.st_uid);
1887 if (geteuid() != statbuf.st_uid)
1888 croak("Can't do seteuid!\n");
1890 else if (uid) { /* oops, mustn't run as root */
1892 (void)seteuid((Uid_t)uid);
1895 (void)setreuid((Uid_t)-1,(Uid_t)uid);
1897 #ifdef HAS_SETRESUID
1898 (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
1904 if (geteuid() != uid)
1905 croak("Can't do seteuid!\n");
1908 if (!cando(S_IXUSR,TRUE,&statbuf))
1909 croak("Permission denied\n"); /* they can't do this */
1912 else if (preprocess)
1913 croak("-P not allowed for setuid/setgid script\n");
1914 else if (fdscript >= 0)
1915 croak("fd script not allowed in suidperl\n");
1917 croak("Script is not setuid/setgid in suidperl\n");
1919 /* We absolutely must clear out any saved ids here, so we */
1920 /* exec the real perl, substituting fd script for scriptname. */
1921 /* (We pass script name as "subdir" of fd, which perl will grok.) */
1922 PerlIO_rewind(rsfp);
1923 lseek(PerlIO_fileno(rsfp),(Off_t)0,0); /* just in case rewind didn't */
1924 for (which = 1; origargv[which] && origargv[which] != scriptname; which++) ;
1925 if (!origargv[which])
1926 croak("Permission denied");
1927 (void)sprintf(buf, "/dev/fd/%d/%.127s", PerlIO_fileno(rsfp), origargv[which]);
1928 origargv[which] = buf;
1930 #if defined(HAS_FCNTL) && defined(F_SETFD)
1931 fcntl(PerlIO_fileno(rsfp),F_SETFD,0); /* ensure no close-on-exec */
1934 (void)sprintf(tokenbuf, "%s/perl%s", BIN, patchlevel);
1935 execv(tokenbuf, origargv); /* try again */
1936 croak("Can't do setuid\n");
1937 #endif /* IAMSUID */
1939 if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */
1940 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
1941 Fstat(PerlIO_fileno(rsfp),&statbuf); /* may be either wrapped or real suid */
1942 if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
1944 (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
1947 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
1948 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
1949 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
1950 /* not set-id, must be wrapped */
1958 register char *s, *s2;
1960 /* skip forward in input to the real script? */
1964 if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
1965 croak("No Perl script found in input\n");
1966 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
1967 PerlIO_ungetc(rsfp, '\n'); /* to keep line count right */
1969 while (*s && !(isSPACE (*s) || *s == '#')) s++;
1971 while (*s == ' ' || *s == '\t') s++;
1973 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
1974 if (strnEQ(s2-4,"perl",4))
1976 while (s = moreswitches(s)) ;
1978 if (cddir && chdir(cddir) < 0)
1979 croak("Can't chdir to %s",cddir);
1987 uid = (int)getuid();
1988 euid = (int)geteuid();
1989 gid = (int)getgid();
1990 egid = (int)getegid();
1995 tainting |= (uid && (euid != uid || egid != gid));
2003 croak("No %s allowed while running setuid", s);
2005 croak("No %s allowed while running setgid", s);
2011 curstash = debstash;
2012 dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2014 DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2015 DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2016 DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2017 DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2018 sv_setiv(DBsingle, 0);
2019 DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2020 sv_setiv(DBtrace, 0);
2021 DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2022 sv_setiv(DBsignal, 0);
2023 curstash = defstash;
2030 mainstack = curstack; /* remember in case we switch stacks */
2031 AvREAL_off(curstack); /* not a real array */
2032 av_extend(curstack,127);
2034 stack_base = AvARRAY(curstack);
2035 stack_sp = stack_base;
2036 stack_max = stack_base + 127;
2038 cxstack_max = 8192 / sizeof(CONTEXT) - 2; /* Use most of 8K. */
2039 New(50,cxstack,cxstack_max + 1,CONTEXT);
2042 New(50,tmps_stack,128,SV*);
2047 New(51,debname,128,char);
2048 New(52,debdelim,128,char);
2052 * The following stacks almost certainly should be per-interpreter,
2053 * but for now they're not. XXX
2057 markstack_ptr = markstack;
2059 New(54,markstack,64,I32);
2060 markstack_ptr = markstack;
2061 markstack_max = markstack + 64;
2067 New(54,scopestack,32,I32);
2069 scopestack_max = 32;
2075 New(54,savestack,128,ANY);
2077 savestack_max = 128;
2083 New(54,retstack,16,OP*);
2093 Safefree(tmps_stack);
2100 static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
2108 subname = newSVpv("main",4);
2112 init_predump_symbols()
2117 sv_setpvn(GvSV(gv_fetchpv("\"", TRUE, SVt_PV)), " ", 1);
2119 stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2120 GvMULTI_on(stdingv);
2121 IoIFP(GvIOp(stdingv)) = PerlIO_stdin();
2122 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2124 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv));
2126 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2128 IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
2130 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2132 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv));
2134 othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2135 GvMULTI_on(othergv);
2136 IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr();
2137 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2139 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
2141 statname = NEWSV(66,0); /* last filename we did stat on */
2144 osname = savepv(OSNAME);
2148 init_postdump_symbols(argc,argv,env)
2150 register char **argv;
2151 register char **env;
2157 argc--,argv++; /* skip name of script */
2159 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2162 if (argv[0][1] == '-') {
2166 if (s = strchr(argv[0], '=')) {
2168 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2171 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2174 toptarget = NEWSV(0,0);
2175 sv_upgrade(toptarget, SVt_PVFM);
2176 sv_setpvn(toptarget, "", 0);
2177 bodytarget = NEWSV(0,0);
2178 sv_upgrade(bodytarget, SVt_PVFM);
2179 sv_setpvn(bodytarget, "", 0);
2180 formtarget = bodytarget;
2183 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2184 sv_setpv(GvSV(tmpgv),origfilename);
2185 magicname("0", "0", 1);
2187 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2188 sv_setpv(GvSV(tmpgv),origargv[0]);
2189 if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2191 (void)gv_AVadd(argvgv);
2192 av_clear(GvAVn(argvgv));
2193 for (; argc > 0; argc--,argv++) {
2194 av_push(GvAVn(argvgv),newSVpv(argv[0],0));
2197 if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2202 #ifndef VMS /* VMS doesn't have environ array */
2203 /* Note that if the supplied env parameter is actually a copy
2204 of the global environ then it may now point to free'd memory
2205 if the environment has been modified since. To avoid this
2206 problem we treat env==NULL as meaning 'use the default'
2210 if (env != environ) {
2211 environ[0] = Nullch;
2212 hv_magic(hv, envgv, 'E');
2214 for (; *env; env++) {
2215 if (!(s = strchr(*env,'=')))
2218 sv = newSVpv(s--,0);
2219 sv_magic(sv, sv, 'e', *env, s - *env);
2220 (void)hv_store(hv, *env, s - *env, sv, 0);
2224 #ifdef DYNAMIC_ENV_FETCH
2225 HvNAME(hv) = savepv(ENV_HV_NAME);
2227 hv_magic(hv, envgv, 'E');
2230 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2231 sv_setiv(GvSV(tmpgv),(I32)getpid());
2240 s = getenv("PERL5LIB");
2244 incpush(getenv("PERLLIB"), FALSE);
2246 /* Treat PERL5?LIB as a possible search list logical name -- the
2247 * "natural" VMS idiom for a Unix path string. We allow each
2248 * element to be a set of |-separated directories for compatibility.
2252 if (my_trnlnm("PERL5LIB",buf,0))
2253 do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2255 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2259 /* Use the ~-expanded versions of APPLIB (undocumented),
2260 ARCHLIB PRIVLIB SITEARCH SITELIB and OLDARCHLIB
2263 incpush(APPLLIB_EXP, FALSE);
2267 incpush(ARCHLIB_EXP, FALSE);
2270 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2272 incpush(PRIVLIB_EXP, FALSE);
2275 incpush(SITEARCH_EXP, FALSE);
2278 incpush(SITELIB_EXP, FALSE);
2280 #ifdef OLDARCHLIB_EXP /* 5.00[01] compatibility */
2281 incpush(OLDARCHLIB_EXP, FALSE);
2285 incpush(".", FALSE);
2289 # define PERLLIB_SEP ';'
2292 # define PERLLIB_SEP '|'
2294 # define PERLLIB_SEP ':'
2297 #ifndef PERLLIB_MANGLE
2298 # define PERLLIB_MANGLE(s,n) (s)
2302 incpush(p, addsubdirs)
2306 SV *subdir = Nullsv;
2307 static char *archpat_auto;
2314 if (!archpat_auto) {
2315 STRLEN len = (sizeof(ARCHNAME) + strlen(patchlevel)
2316 + sizeof("//auto"));
2317 New(55, archpat_auto, len, char);
2318 sprintf(archpat_auto, "/%s/%s/auto", ARCHNAME, patchlevel);
2322 /* Break at all separators */
2324 SV *libdir = newSV(0);
2327 /* skip any consecutive separators */
2328 while ( *p == PERLLIB_SEP ) {
2329 /* Uncomment the next line for PATH semantics */
2330 /* av_push(GvAVn(incgv), newSVpv(".", 1)); */
2334 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2335 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2340 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2341 p = Nullch; /* break out */
2345 * BEFORE pushing libdir onto @INC we may first push version- and
2346 * archname-specific sub-directories.
2349 struct stat tmpstatbuf;
2351 /* .../archname/version if -d .../archname/auto */
2352 sv_setsv(subdir, libdir);
2353 sv_catpv(subdir, archpat_auto);
2354 if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2355 S_ISDIR(tmpstatbuf.st_mode))
2356 av_push(GvAVn(incgv),
2357 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2359 /* .../archname/version if -d .../archname/version/auto */
2360 sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
2361 strlen(patchlevel) + 1, "", 0);
2362 if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2363 S_ISDIR(tmpstatbuf.st_mode))
2364 av_push(GvAVn(incgv),
2365 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2368 /* finally push this lib directory on the end of @INC */
2369 av_push(GvAVn(incgv), libdir);
2372 SvREFCNT_dec(subdir);
2381 line_t oldline = curcop->cop_line;
2383 Copy(top_env, oldtop, 1, Sigjmp_buf);
2385 while (AvFILL(list) >= 0) {
2386 CV *cv = (CV*)av_shift(list);
2390 switch (Sigsetjmp(top_env,1)) {
2392 SV* atsv = GvSV(errgv);
2394 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
2395 (void)SvPV(atsv, len);
2397 Copy(oldtop, top_env, 1, Sigjmp_buf);
2398 curcop = &compiling;
2399 curcop->cop_line = oldline;
2400 if (list == beginav)
2401 sv_catpv(atsv, "BEGIN failed--compilation aborted");
2403 sv_catpv(atsv, "END failed--cleanup aborted");
2404 croak("%s", SvPVX(atsv));
2412 /* my_exit() was called */
2413 curstash = defstash;
2417 Copy(oldtop, top_env, 1, Sigjmp_buf);
2418 curcop = &compiling;
2419 curcop->cop_line = oldline;
2421 if (list == beginav)
2422 croak("BEGIN failed--compilation aborted");
2424 croak("END failed--cleanup aborted");
2430 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
2434 Copy(oldtop, top_env, 1, Sigjmp_buf);
2435 curcop = &compiling;
2436 curcop->cop_line = oldline;
2437 Siglongjmp(top_env, 3);
2441 Copy(oldtop, top_env, 1, Sigjmp_buf);
2456 STATUS_NATIVE_SET(status);
2466 if (vaxc$errno & 1) {
2467 if (GETSTATUS_NATIVE & 1) /* fortuitiously includes "-1" */
2468 SETSTATUS_NATIVE(44);
2471 if (!vaxc$errno && errno) /* someone must have set $^E = 0 */
2472 SETSTATUS_NATIVE(44);
2474 SETSTATUS_NATIVE(vaxc$errno);
2478 STATUS_POSIX_SET(errno);
2479 else if (STATUS_POSIX == 0)
2480 STATUS_POSIX_SET(255);
2488 register CONTEXT *cx;
2497 (void)UNLINK(e_tmpname);
2498 Safefree(e_tmpname);
2502 if (cxstack_ix >= 0) {
2508 Siglongjmp(top_env, 2);