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);
500 switch (Sigsetjmp(top_env,1)) {
505 /* my_exit() was called */
509 return STATUS_NATIVE_EXPORT;
511 PerlIO_printf(PerlIO_stderr(), "panic: top_env\n");
515 sv_setpvn(linestr,"",0);
516 sv = newSVpv("",0); /* first used for -I flags */
519 for (argc--,argv++; argc > 0; argc--,argv++) {
520 if (argv[0][0] != '-' || !argv[0][1])
524 validarg = " PHOOEY ";
549 if (s = moreswitches(s))
559 if (euid != uid || egid != gid)
560 croak("No -e allowed in setuid scripts");
562 e_tmpname = savepv(TMPPATH);
563 (void)mktemp(e_tmpname);
565 croak("Can't mktemp()");
566 e_fp = PerlIO_open(e_tmpname,"w");
568 croak("Cannot open temporary file");
573 PerlIO_puts(e_fp,argv[1]);
577 croak("No code specified for -e");
578 (void)PerlIO_putc(e_fp,'\n');
589 incpush(argv[1], TRUE);
590 sv_catpv(sv,argv[1]);
607 preambleav = newAV();
608 av_push(preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
610 Sv = newSVpv("print myconfig();",0);
612 sv_catpv(Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
614 sv_catpv(Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
616 #if defined(DEBUGGING) || defined(NOEMBED) || defined(MULTIPLICITY)
617 strcpy(buf,"\" Compile-time options:");
619 strcat(buf," DEBUGGING");
622 strcat(buf," NOEMBED");
625 strcat(buf," MULTIPLICITY");
627 strcat(buf,"\\n\",");
630 #if defined(LOCAL_PATCH_COUNT)
631 if (LOCAL_PATCH_COUNT > 0)
633 sv_catpv(Sv,"print \" Locally applied patches:\\n\",");
634 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
635 if (localpatches[i]) {
636 sprintf(buf,"\" \\t%s\\n\",",localpatches[i]);
642 sprintf(buf,"\" Built under %s\\n\",",OSNAME);
646 sprintf(buf,"\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
648 sprintf(buf,"\" Compiled on %s\\n\"",__DATE__);
652 sv_catpv(Sv,"; $\"=\"\\n \"; print \" \\@INC:\\n @INC\\n\"");
655 Sv = newSVpv("config_vars(qw(",0);
660 av_push(preambleav, Sv);
661 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
675 croak("Unrecognized switch: -%s",s);
680 scriptname = argv[0];
682 if (PerlIO_flush(e_fp) || PerlIO_error(e_fp) || PerlIO_close(e_fp))
683 croak("Can't write to temp file for -e: %s", Strerror(errno));
686 scriptname = e_tmpname;
688 else if (scriptname == Nullch) {
690 if ( isatty(PerlIO_fileno(PerlIO_stdin())) )
698 open_script(scriptname,dosearch,sv);
700 validate_suid(validarg, scriptname);
705 main_cv = compcv = (CV*)NEWSV(1104,0);
706 sv_upgrade((SV *)compcv, SVt_PVCV);
710 av_push(comppad, Nullsv);
711 curpad = AvARRAY(comppad);
712 comppad_name = newAV();
713 comppad_name_fill = 0;
714 min_intro_pending = 0;
717 comppadlist = newAV();
718 AvREAL_off(comppadlist);
719 av_store(comppadlist, 0, (SV*)comppad_name);
720 av_store(comppadlist, 1, (SV*)comppad);
721 CvPADLIST(compcv) = comppadlist;
723 boot_core_UNIVERSAL();
725 (*xsinit)(); /* in case linked C routines want magical variables */
730 init_predump_symbols();
732 init_postdump_symbols(argc,argv,env);
736 /* now parse the script */
739 if (yyparse() || error_count) {
741 croak("%s had compilation errors.\n", origfilename);
743 croak("Execution of %s aborted due to compilation errors.\n",
747 curcop->cop_line = 0;
751 (void)UNLINK(e_tmpname);
756 /* now that script is parsed, we can modify record separator */
758 rs = SvREFCNT_inc(nrs);
759 sv_setsv(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), rs);
770 #ifdef DEBUGGING_MSTATS
771 if ((s=getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
772 dump_mstats("after compilation:");
782 PerlInterpreter *sv_interp;
784 if (!(curinterp = sv_interp))
786 switch (Sigsetjmp(top_env,1)) {
788 cxstack_ix = -1; /* start context stack again */
791 /* my_exit() was called */
796 #ifdef DEBUGGING_MSTATS
797 if (getenv("PERL_DEBUG_MSTATS"))
798 dump_mstats("after execution: ");
800 return STATUS_NATIVE_EXPORT;
803 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
807 if (curstack != mainstack) {
809 SWITCHSTACK(curstack, mainstack);
814 DEBUG_r(PerlIO_printf(PerlIO_stderr(), "%s $` $& $' support.\n",
815 sawampersand ? "Enabling" : "Omitting"));
819 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
822 PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", origfilename);
825 if (perldb && DBsingle)
826 sv_setiv(DBsingle, 1);
836 else if (main_start) {
837 CvDEPTH(main_cv) = 1;
847 perl_get_sv(name, create)
851 GV* gv = gv_fetchpv(name, create, SVt_PV);
858 perl_get_av(name, create)
862 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
871 perl_get_hv(name, create)
875 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
884 perl_get_cv(name, create)
888 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
889 if (create && !GvCVu(gv))
890 return newSUB(start_subparse(FALSE, 0),
891 newSVOP(OP_CONST, 0, newSVpv(name,0)),
899 /* Be sure to refetch the stack pointer after calling these routines. */
902 perl_call_argv(subname, flags, argv)
904 I32 flags; /* See G_* flags in cop.h */
905 register char **argv; /* null terminated arg list */
912 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
917 return perl_call_pv(subname, flags);
921 perl_call_pv(subname, flags)
922 char *subname; /* name of the subroutine */
923 I32 flags; /* See G_* flags in cop.h */
925 return perl_call_sv((SV*)perl_get_cv(subname, TRUE), flags);
929 perl_call_method(methname, flags)
930 char *methname; /* name of the subroutine */
931 I32 flags; /* See G_* flags in cop.h */
937 XPUSHs(sv_2mortal(newSVpv(methname,0)));
940 return perl_call_sv(*stack_sp--, flags);
943 /* May be called with any of a CV, a GV, or an SV containing the name. */
945 perl_call_sv(sv, flags)
947 I32 flags; /* See G_* flags in cop.h */
949 LOGOP myop; /* fake syntax tree node */
951 I32 oldmark = TOPMARK;
957 if (flags & G_DISCARD) {
967 oldscope = scopestack_ix;
969 if (!(flags & G_NOARGS))
970 myop.op_flags = OPf_STACKED;
971 myop.op_next = Nullop;
972 myop.op_flags |= OPf_KNOW;
974 myop.op_flags |= OPf_LIST;
976 if (perldb && curstash != debstash
977 /* Handle first BEGIN of -d. */
978 && (DBcv || (DBcv = GvCV(DBsub)))
979 /* Try harder, since this may have been a sighandler, thus
980 * curstash may be meaningless. */
981 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != debstash))
982 op->op_private |= OPpENTERSUB_DB;
984 if (flags & G_EVAL) {
985 Copy(top_env, oldtop, 1, Sigjmp_buf);
987 cLOGOP->op_other = op;
989 /* we're trying to emulate pp_entertry() here */
991 register CONTEXT *cx;
997 push_return(op->op_next);
998 PUSHBLOCK(cx, CXt_EVAL, stack_sp);
1000 eval_root = op; /* Only needed so that goto works right. */
1003 if (flags & G_KEEPERR)
1006 sv_setpv(GvSV(errgv),"");
1011 switch (Sigsetjmp(top_env,1)) {
1018 /* my_exit() was called */
1019 curstash = defstash;
1021 Copy(oldtop, top_env, 1, Sigjmp_buf);
1023 croak("Callback called exit");
1032 stack_sp = stack_base + oldmark;
1033 if (flags & G_ARRAY)
1037 *++stack_sp = &sv_undef;
1043 if (op == (OP*)&myop)
1047 retval = stack_sp - (stack_base + oldmark);
1048 if ((flags & G_EVAL) && !(flags & G_KEEPERR))
1049 sv_setpv(GvSV(errgv),"");
1052 if (flags & G_EVAL) {
1053 if (scopestack_ix > oldscope) {
1057 register CONTEXT *cx;
1066 Copy(oldtop, top_env, 1, Sigjmp_buf);
1068 if (flags & G_DISCARD) {
1069 stack_sp = stack_base + oldmark;
1077 /* Eval a string. The G_EVAL flag is always assumed. */
1080 perl_eval_sv(sv, flags)
1082 I32 flags; /* See G_* flags in cop.h */
1084 UNOP myop; /* fake syntax tree node */
1086 I32 oldmark = sp - stack_base;
1091 if (flags & G_DISCARD) {
1099 EXTEND(stack_sp, 1);
1101 oldscope = scopestack_ix;
1103 if (!(flags & G_NOARGS))
1104 myop.op_flags = OPf_STACKED;
1105 myop.op_next = Nullop;
1106 myop.op_type = OP_ENTEREVAL;
1107 myop.op_flags |= OPf_KNOW;
1108 if (flags & G_KEEPERR)
1109 myop.op_flags |= OPf_SPECIAL;
1110 if (flags & G_ARRAY)
1111 myop.op_flags |= OPf_LIST;
1113 Copy(top_env, oldtop, 1, Sigjmp_buf);
1116 switch (Sigsetjmp(top_env,1)) {
1123 /* my_exit() was called */
1124 curstash = defstash;
1126 Copy(oldtop, top_env, 1, Sigjmp_buf);
1128 croak("Callback called exit");
1137 stack_sp = stack_base + oldmark;
1138 if (flags & G_ARRAY)
1142 *++stack_sp = &sv_undef;
1147 if (op == (OP*)&myop)
1148 op = pp_entereval();
1151 retval = stack_sp - (stack_base + oldmark);
1152 if (!(flags & G_KEEPERR))
1153 sv_setpv(GvSV(errgv),"");
1156 Copy(oldtop, top_env, 1, Sigjmp_buf);
1157 if (flags & G_DISCARD) {
1158 stack_sp = stack_base + oldmark;
1166 /* Require a module. */
1172 SV* sv = sv_newmortal();
1173 sv_setpv(sv, "require '");
1176 perl_eval_sv(sv, G_DISCARD);
1180 magicname(sym,name,namlen)
1187 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1188 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1192 usage(name) /* XXX move this out into a module ? */
1195 /* This message really ought to be max 23 lines.
1196 * Removed -h because the user already knows that opton. Others? */
1197 printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1198 printf("\n -0[octal] specify record separator (\\0, if no argument)");
1199 printf("\n -a autosplit mode with -n or -p (splits $_ into @F)");
1200 printf("\n -c check syntax only (runs BEGIN and END blocks)");
1201 printf("\n -d[:debugger] run scripts under debugger");
1202 printf("\n -D[number/list] set debugging flags (argument is a bit mask or flags)");
1203 printf("\n -e 'command' one line of script. Several -e's allowed. Omit [programfile].");
1204 printf("\n -F/pattern/ split() pattern for autosplit (-a). The //'s are optional.");
1205 printf("\n -i[extension] edit <> files in place (make backup if extension supplied)");
1206 printf("\n -Idirectory specify @INC/#include directory (may be used more then once)");
1207 printf("\n -l[octal] enable line ending processing, specifies line teminator");
1208 printf("\n -[mM][-]module.. executes `use/no module...' before executing your script.");
1209 printf("\n -n assume 'while (<>) { ... }' loop arround your script");
1210 printf("\n -p assume loop like -n but print line also like sed");
1211 printf("\n -P run script through C preprocessor before compilation");
1212 printf("\n -s enable some switch parsing for switches after script name");
1213 printf("\n -S look for the script using PATH environment variable");
1214 printf("\n -T turn on tainting checks");
1215 printf("\n -u dump core after parsing script");
1216 printf("\n -U allow unsafe operations");
1217 printf("\n -v print version number and patchlevel of perl");
1218 printf("\n -V[:variable] print perl configuration information");
1219 printf("\n -w TURN WARNINGS ON FOR COMPILATION OF YOUR SCRIPT.");
1220 printf("\n -x[directory] strip off text before #!perl line and perhaps cd to directory\n");
1223 /* This routine handles any switches that can be given during run */
1234 rschar = scan_oct(s, 4, &numlen);
1236 if (rschar & ~((U8)~0))
1238 else if (!rschar && numlen >= 2)
1239 nrs = newSVpv("", 0);
1242 nrs = newSVpv(&ch, 1);
1247 splitstr = savepv(s + 1);
1261 if (*s == ':' || *s == '=') {
1262 sprintf(buf, "use Devel::%s;", ++s);
1264 my_setenv("PERL5DB",buf);
1274 if (isALPHA(s[1])) {
1275 static char debopts[] = "psltocPmfrxuLHXD";
1278 for (s++; *s && (d = strchr(debopts,*s)); s++)
1279 debug |= 1 << (d - debopts);
1283 for (s++; isDIGIT(*s); s++) ;
1285 debug |= 0x80000000;
1287 warn("Recompile perl with -DDEBUGGING to use -D switch\n");
1288 for (s++; isALNUM(*s); s++) ;
1298 inplace = savepv(s+1);
1300 for (s = inplace; *s && !isSPACE(*s); s++) ;
1307 for (e = s; *e && !isSPACE(*e); e++) ;
1308 p = savepvn(s, e-s);
1315 croak("No space allowed after -I");
1325 *ors = scan_oct(s, 3 + (*s == '0'), &numlen);
1334 ors = SvPV(nrs, orslen);
1335 ors = savepvn(ors, orslen);
1339 forbid_setid("-M"); /* XXX ? */
1342 forbid_setid("-m"); /* XXX ? */
1346 /* -M-foo == 'no foo' */
1347 if (*s == '-') { use = "no "; ++s; }
1348 Sv = newSVpv(use,0);
1350 /* We allow -M'Module qw(Foo Bar)' */
1351 while(isALNUM(*s) || *s==':') ++s;
1353 sv_catpv(Sv, start);
1354 if (*(start-1) == 'm') {
1356 croak("Can't use '%c' after -mname", *s);
1357 sv_catpv( Sv, " ()");
1360 sv_catpvn(Sv, start, s-start);
1361 sv_catpv(Sv, " split(/,/,q{");
1366 if (preambleav == NULL)
1367 preambleav = newAV();
1368 av_push(preambleav, Sv);
1371 croak("No space allowed after -%c", *(s-1));
1388 croak("Too late for \"-T\" option (try putting it first)");
1400 #if defined(SUBVERSION) && SUBVERSION > 0
1401 printf("\nThis is perl, version 5.%03d_%02d", PATCHLEVEL, SUBVERSION);
1403 printf("\nThis is perl, version %s",patchlevel);
1406 printf("\n\nCopyright 1987-1997, Larry Wall\n");
1408 printf("\n\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1411 printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
1414 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1415 "Version 5 port Copyright (c) 1994-1996, Andreas Kaiser, Ilya Zakharevich\n");
1418 printf("atariST series port, ++jrb bammi@cadence.com\n");
1421 Perl may be copied only under the terms of either the Artistic License or the\n\
1422 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n");
1430 if (s[1] == '-') /* Additional switches on #! line. */
1443 croak("Can't emulate -%.1s on #! line",s);
1448 /* compliments of Tom Christiansen */
1450 /* unexec() can be found in the Gnu emacs distribution */
1459 sprintf (buf, "%s.perldump", origfilename);
1460 sprintf (tokenbuf, "%s/perl", BIN);
1462 status = unexec(buf, tokenbuf, &etext, sbrk(0), 0);
1464 PerlIO_printf(PerlIO_stderr(), "unexec of %s into %s failed!\n", tokenbuf, buf);
1468 # include <lib$routines.h>
1469 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
1471 ABORT(); /* for use with undump */
1481 /* Note that strtab is a rather special HV. Assumptions are made
1482 about not iterating on it, and not adding tie magic to it.
1483 It is properly deallocated in perl_destruct() */
1485 HvSHAREKEYS_off(strtab); /* mandatory */
1486 Newz(506,((XPVHV*)SvANY(strtab))->xhv_array,
1487 sizeof(HE*) * (((XPVHV*)SvANY(strtab))->xhv_max + 1), char);
1489 curstash = defstash = newHV();
1490 curstname = newSVpv("main",4);
1491 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1492 SvREFCNT_dec(GvHV(gv));
1493 GvHV(gv) = (HV*)SvREFCNT_inc(defstash);
1495 HvNAME(defstash) = savepv("main");
1496 incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1498 defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1499 errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1501 sv_setpvn(GvSV(errgv), "", 0);
1502 curstash = defstash;
1503 compiling.cop_stash = defstash;
1504 debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
1505 /* We must init $/ before switches are processed. */
1506 sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1);
1509 #ifdef CAN_PROTOTYPE
1511 open_script(char *scriptname, bool dosearch, SV *sv)
1514 open_script(scriptname,dosearch,sv)
1520 char *xfound = Nullch;
1521 char *xfailed = Nullch;
1525 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
1526 #define SEARCH_EXTS ".bat", ".cmd", NULL
1529 # define SEARCH_EXTS ".pl", ".com", NULL
1531 /* additional extensions to try in each dir if scriptname not found */
1533 char *ext[] = { SEARCH_EXTS };
1534 int extidx = (strchr(scriptname,'.')) ? -1 : 0; /* has ext already */
1539 int hasdir, idx = 0, deftypes = 1;
1541 hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
1542 /* The first time through, just add SEARCH_EXTS to whatever we
1543 * already have, so we can check for default file types. */
1544 while (deftypes || (!hasdir && my_trnlnm("DCL$PATH",tokenbuf,idx++)) ) {
1545 if (deftypes) { deftypes = 0; *tokenbuf = '\0'; }
1546 strcat(tokenbuf,scriptname);
1548 if (dosearch && !strchr(scriptname, '/') && (s = getenv("PATH"))) {
1550 bufend = s + strlen(s);
1553 s = cpytill(tokenbuf,s,bufend,':',&len);
1556 for (len = 0; *s && *s != ',' && *s != ';'; tokenbuf[len++] = *s++);
1557 tokenbuf[len] = '\0';
1559 for (len = 0; *s && *s != ';'; tokenbuf[len++] = *s++);
1560 tokenbuf[len] = '\0';
1566 if (len && tokenbuf[len-1] != '/')
1569 if (len && ((tokenbuf[len-1] != '\\') && (tokenbuf[len-1] != '/')))
1571 if (len && tokenbuf[len-1] != '\\')
1574 (void)strcat(tokenbuf+len,"/");
1575 (void)strcat(tokenbuf+len,scriptname);
1579 len = strlen(tokenbuf);
1580 if (extidx > 0) /* reset after previous loop */
1584 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tokenbuf));
1585 retval = Stat(tokenbuf,&statbuf);
1587 } while ( retval < 0 /* not there */
1588 && extidx>=0 && ext[extidx] /* try an extension? */
1589 && strcpy(tokenbuf+len, ext[extidx++])
1594 if (S_ISREG(statbuf.st_mode)
1595 && cando(S_IRUSR,TRUE,&statbuf) && cando(S_IXUSR,TRUE,&statbuf)) {
1596 xfound = tokenbuf; /* bingo! */
1600 xfailed = savepv(tokenbuf);
1603 croak("Can't execute %s", xfailed ? xfailed : scriptname );
1606 scriptname = xfound;
1609 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
1610 char *s = scriptname + 8;
1619 origfilename = savepv(e_tmpname ? "-e" : scriptname);
1620 curcop->cop_filegv = gv_fetchfile(origfilename);
1621 if (strEQ(origfilename,"-"))
1623 if (fdscript >= 0) {
1624 rsfp = PerlIO_fdopen(fdscript,"r");
1625 #if defined(HAS_FCNTL) && defined(F_SETFD)
1627 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
1630 else if (preprocess) {
1631 char *cpp = CPPSTDIN;
1633 if (strEQ(cpp,"cppstdin"))
1634 sprintf(tokenbuf, "%s/%s", SCRIPTDIR, cpp);
1636 sprintf(tokenbuf, "%s", cpp);
1638 sv_catpv(sv,PRIVLIB_EXP);
1640 (void)sprintf(buf, "\
1641 sed %s -e \"/^[^#]/b\" \
1642 -e \"/^#[ ]*include[ ]/b\" \
1643 -e \"/^#[ ]*define[ ]/b\" \
1644 -e \"/^#[ ]*if[ ]/b\" \
1645 -e \"/^#[ ]*ifdef[ ]/b\" \
1646 -e \"/^#[ ]*ifndef[ ]/b\" \
1647 -e \"/^#[ ]*else/b\" \
1648 -e \"/^#[ ]*elif[ ]/b\" \
1649 -e \"/^#[ ]*undef[ ]/b\" \
1650 -e \"/^#[ ]*endif/b\" \
1653 (doextract ? "-e \"1,/^#/d\n\"" : ""),
1655 (void)sprintf(buf, "\
1656 %s %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' \
1673 (doextract ? "-e '1,/^#/d\n'" : ""),
1675 scriptname, tokenbuf, SvPV(sv, na), CPPMINUS);
1677 #ifdef IAMSUID /* actually, this is caught earlier */
1678 if (euid != uid && !euid) { /* if running suidperl */
1680 (void)seteuid(uid); /* musn't stay setuid root */
1683 (void)setreuid((Uid_t)-1, uid);
1685 #ifdef HAS_SETRESUID
1686 (void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
1692 if (geteuid() != uid)
1693 croak("Can't do seteuid!\n");
1695 #endif /* IAMSUID */
1696 rsfp = my_popen(buf,"r");
1698 else if (!*scriptname) {
1699 forbid_setid("program input from stdin");
1700 rsfp = PerlIO_stdin();
1703 rsfp = PerlIO_open(scriptname,"r");
1704 #if defined(HAS_FCNTL) && defined(F_SETFD)
1706 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
1714 #ifndef IAMSUID /* in case script is not readable before setuid */
1715 if (euid && Stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
1716 statbuf.st_mode & (S_ISUID|S_ISGID)) {
1717 (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
1718 execv(buf, origargv); /* try again */
1719 croak("Can't do setuid\n");
1723 croak("Can't open perl script \"%s\": %s\n",
1724 SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno));
1729 validate_suid(validarg, scriptname)
1735 /* do we need to emulate setuid on scripts? */
1737 /* This code is for those BSD systems that have setuid #! scripts disabled
1738 * in the kernel because of a security problem. Merely defining DOSUID
1739 * in perl will not fix that problem, but if you have disabled setuid
1740 * scripts in the kernel, this will attempt to emulate setuid and setgid
1741 * on scripts that have those now-otherwise-useless bits set. The setuid
1742 * root version must be called suidperl or sperlN.NNN. If regular perl
1743 * discovers that it has opened a setuid script, it calls suidperl with
1744 * the same argv that it had. If suidperl finds that the script it has
1745 * just opened is NOT setuid root, it sets the effective uid back to the
1746 * uid. We don't just make perl setuid root because that loses the
1747 * effective uid we had before invoking perl, if it was different from the
1750 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
1751 * be defined in suidperl only. suidperl must be setuid root. The
1752 * Configure script will set this up for you if you want it.
1758 if (Fstat(PerlIO_fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
1759 croak("Can't stat script \"%s\"",origfilename);
1760 if (fdscript < 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) {
1764 #ifndef HAS_SETREUID
1765 /* On this access check to make sure the directories are readable,
1766 * there is actually a small window that the user could use to make
1767 * filename point to an accessible directory. So there is a faint
1768 * chance that someone could execute a setuid script down in a
1769 * non-accessible directory. I don't know what to do about that.
1770 * But I don't think it's too important. The manual lies when
1771 * it says access() is useful in setuid programs.
1773 if (access(SvPVX(GvSV(curcop->cop_filegv)),1)) /*double check*/
1774 croak("Permission denied");
1776 /* If we can swap euid and uid, then we can determine access rights
1777 * with a simple stat of the file, and then compare device and
1778 * inode to make sure we did stat() on the same file we opened.
1779 * Then we just have to make sure he or she can execute it.
1782 struct stat tmpstatbuf;
1786 setreuid(euid,uid) < 0
1789 setresuid(euid,uid,(Uid_t)-1) < 0
1792 || getuid() != euid || geteuid() != uid)
1793 croak("Can't swap uid and euid"); /* really paranoid */
1794 if (Stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
1795 croak("Permission denied"); /* testing full pathname here */
1796 if (tmpstatbuf.st_dev != statbuf.st_dev ||
1797 tmpstatbuf.st_ino != statbuf.st_ino) {
1798 (void)PerlIO_close(rsfp);
1799 if (rsfp = my_popen("/bin/mail root","w")) { /* heh, heh */
1801 "User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
1802 (Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
1803 (long)uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
1804 (long)statbuf.st_dev, (long)statbuf.st_ino,
1805 SvPVX(GvSV(curcop->cop_filegv)),
1806 (long)statbuf.st_uid, (long)statbuf.st_gid);
1807 (void)my_pclose(rsfp);
1809 croak("Permission denied\n");
1813 setreuid(uid,euid) < 0
1815 # if defined(HAS_SETRESUID)
1816 setresuid(uid,euid,(Uid_t)-1) < 0
1819 || getuid() != uid || geteuid() != euid)
1820 croak("Can't reswap uid and euid");
1821 if (!cando(S_IXUSR,FALSE,&statbuf)) /* can real uid exec? */
1822 croak("Permission denied\n");
1824 #endif /* HAS_SETREUID */
1825 #endif /* IAMSUID */
1827 if (!S_ISREG(statbuf.st_mode))
1828 croak("Permission denied");
1829 if (statbuf.st_mode & S_IWOTH)
1830 croak("Setuid/gid script is writable by world");
1831 doswitches = FALSE; /* -s is insecure in suid */
1833 if (sv_gets(linestr, rsfp, 0) == Nullch ||
1834 strnNE(SvPV(linestr,na),"#!",2) ) /* required even on Sys V */
1835 croak("No #! line");
1836 s = SvPV(linestr,na)+2;
1838 while (!isSPACE(*s)) s++;
1839 for (s2 = s; (s2 > SvPV(linestr,na)+2 &&
1840 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
1841 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
1842 croak("Not a perl script");
1843 while (*s == ' ' || *s == '\t') s++;
1845 * #! arg must be what we saw above. They can invoke it by
1846 * mentioning suidperl explicitly, but they may not add any strange
1847 * arguments beyond what #! says if they do invoke suidperl that way.
1849 len = strlen(validarg);
1850 if (strEQ(validarg," PHOOEY ") ||
1851 strnNE(s,validarg,len) || !isSPACE(s[len]))
1852 croak("Args must match #! line");
1855 if (euid != uid && (statbuf.st_mode & S_ISUID) &&
1856 euid == statbuf.st_uid)
1858 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
1859 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
1860 #endif /* IAMSUID */
1862 if (euid) { /* oops, we're not the setuid root perl */
1863 (void)PerlIO_close(rsfp);
1865 (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
1866 execv(buf, origargv); /* try again */
1868 croak("Can't do setuid\n");
1871 if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
1873 (void)setegid(statbuf.st_gid);
1876 (void)setregid((Gid_t)-1,statbuf.st_gid);
1878 #ifdef HAS_SETRESGID
1879 (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
1881 setgid(statbuf.st_gid);
1885 if (getegid() != statbuf.st_gid)
1886 croak("Can't do setegid!\n");
1888 if (statbuf.st_mode & S_ISUID) {
1889 if (statbuf.st_uid != euid)
1891 (void)seteuid(statbuf.st_uid); /* all that for this */
1894 (void)setreuid((Uid_t)-1,statbuf.st_uid);
1896 #ifdef HAS_SETRESUID
1897 (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
1899 setuid(statbuf.st_uid);
1903 if (geteuid() != statbuf.st_uid)
1904 croak("Can't do seteuid!\n");
1906 else if (uid) { /* oops, mustn't run as root */
1908 (void)seteuid((Uid_t)uid);
1911 (void)setreuid((Uid_t)-1,(Uid_t)uid);
1913 #ifdef HAS_SETRESUID
1914 (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
1920 if (geteuid() != uid)
1921 croak("Can't do seteuid!\n");
1924 if (!cando(S_IXUSR,TRUE,&statbuf))
1925 croak("Permission denied\n"); /* they can't do this */
1928 else if (preprocess)
1929 croak("-P not allowed for setuid/setgid script\n");
1930 else if (fdscript >= 0)
1931 croak("fd script not allowed in suidperl\n");
1933 croak("Script is not setuid/setgid in suidperl\n");
1935 /* We absolutely must clear out any saved ids here, so we */
1936 /* exec the real perl, substituting fd script for scriptname. */
1937 /* (We pass script name as "subdir" of fd, which perl will grok.) */
1938 PerlIO_rewind(rsfp);
1939 lseek(PerlIO_fileno(rsfp),(Off_t)0,0); /* just in case rewind didn't */
1940 for (which = 1; origargv[which] && origargv[which] != scriptname; which++) ;
1941 if (!origargv[which])
1942 croak("Permission denied");
1943 (void)sprintf(buf, "/dev/fd/%d/%.127s", PerlIO_fileno(rsfp), origargv[which]);
1944 origargv[which] = buf;
1946 #if defined(HAS_FCNTL) && defined(F_SETFD)
1947 fcntl(PerlIO_fileno(rsfp),F_SETFD,0); /* ensure no close-on-exec */
1950 (void)sprintf(tokenbuf, "%s/perl%s", BIN, patchlevel);
1951 execv(tokenbuf, origargv); /* try again */
1952 croak("Can't do setuid\n");
1953 #endif /* IAMSUID */
1955 if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */
1956 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
1957 Fstat(PerlIO_fileno(rsfp),&statbuf); /* may be either wrapped or real suid */
1958 if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
1960 (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
1963 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
1964 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
1965 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
1966 /* not set-id, must be wrapped */
1974 register char *s, *s2;
1976 /* skip forward in input to the real script? */
1980 if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
1981 croak("No Perl script found in input\n");
1982 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
1983 PerlIO_ungetc(rsfp, '\n'); /* to keep line count right */
1985 while (*s && !(isSPACE (*s) || *s == '#')) s++;
1987 while (*s == ' ' || *s == '\t') s++;
1989 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
1990 if (strnEQ(s2-4,"perl",4))
1992 while (s = moreswitches(s)) ;
1994 if (cddir && chdir(cddir) < 0)
1995 croak("Can't chdir to %s",cddir);
2003 uid = (int)getuid();
2004 euid = (int)geteuid();
2005 gid = (int)getgid();
2006 egid = (int)getegid();
2011 tainting |= (uid && (euid != uid || egid != gid));
2019 croak("No %s allowed while running setuid", s);
2021 croak("No %s allowed while running setgid", s);
2027 curstash = debstash;
2028 dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2030 DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2031 DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2032 DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2033 DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2034 sv_setiv(DBsingle, 0);
2035 DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2036 sv_setiv(DBtrace, 0);
2037 DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2038 sv_setiv(DBsignal, 0);
2039 curstash = defstash;
2046 mainstack = curstack; /* remember in case we switch stacks */
2047 AvREAL_off(curstack); /* not a real array */
2048 av_extend(curstack,127);
2050 stack_base = AvARRAY(curstack);
2051 stack_sp = stack_base;
2052 stack_max = stack_base + 127;
2054 cxstack_max = 8192 / sizeof(CONTEXT) - 2; /* Use most of 8K. */
2055 New(50,cxstack,cxstack_max + 1,CONTEXT);
2058 New(50,tmps_stack,128,SV*);
2063 New(51,debname,128,char);
2064 New(52,debdelim,128,char);
2068 * The following stacks almost certainly should be per-interpreter,
2069 * but for now they're not. XXX
2073 markstack_ptr = markstack;
2075 New(54,markstack,64,I32);
2076 markstack_ptr = markstack;
2077 markstack_max = markstack + 64;
2083 New(54,scopestack,32,I32);
2085 scopestack_max = 32;
2091 New(54,savestack,128,ANY);
2093 savestack_max = 128;
2099 New(54,retstack,16,OP*);
2109 Safefree(tmps_stack);
2116 static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
2124 subname = newSVpv("main",4);
2128 init_predump_symbols()
2133 sv_setpvn(GvSV(gv_fetchpv("\"", TRUE, SVt_PV)), " ", 1);
2135 stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2136 GvMULTI_on(stdingv);
2137 IoIFP(GvIOp(stdingv)) = PerlIO_stdin();
2138 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2140 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv));
2142 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2144 IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
2146 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2148 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv));
2150 othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2151 GvMULTI_on(othergv);
2152 IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr();
2153 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2155 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
2157 statname = NEWSV(66,0); /* last filename we did stat on */
2160 osname = savepv(OSNAME);
2164 init_postdump_symbols(argc,argv,env)
2166 register char **argv;
2167 register char **env;
2173 argc--,argv++; /* skip name of script */
2175 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2178 if (argv[0][1] == '-') {
2182 if (s = strchr(argv[0], '=')) {
2184 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2187 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2190 toptarget = NEWSV(0,0);
2191 sv_upgrade(toptarget, SVt_PVFM);
2192 sv_setpvn(toptarget, "", 0);
2193 bodytarget = NEWSV(0,0);
2194 sv_upgrade(bodytarget, SVt_PVFM);
2195 sv_setpvn(bodytarget, "", 0);
2196 formtarget = bodytarget;
2199 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2200 sv_setpv(GvSV(tmpgv),origfilename);
2201 magicname("0", "0", 1);
2203 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2204 sv_setpv(GvSV(tmpgv),origargv[0]);
2205 if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2207 (void)gv_AVadd(argvgv);
2208 av_clear(GvAVn(argvgv));
2209 for (; argc > 0; argc--,argv++) {
2210 av_push(GvAVn(argvgv),newSVpv(argv[0],0));
2213 if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2218 #ifndef VMS /* VMS doesn't have environ array */
2219 /* Note that if the supplied env parameter is actually a copy
2220 of the global environ then it may now point to free'd memory
2221 if the environment has been modified since. To avoid this
2222 problem we treat env==NULL as meaning 'use the default'
2226 if (env != environ) {
2227 environ[0] = Nullch;
2228 hv_magic(hv, envgv, 'E');
2230 for (; *env; env++) {
2231 if (!(s = strchr(*env,'=')))
2234 sv = newSVpv(s--,0);
2235 sv_magic(sv, sv, 'e', *env, s - *env);
2236 (void)hv_store(hv, *env, s - *env, sv, 0);
2240 #ifdef DYNAMIC_ENV_FETCH
2241 HvNAME(hv) = savepv(ENV_HV_NAME);
2243 hv_magic(hv, envgv, 'E');
2246 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2247 sv_setiv(GvSV(tmpgv),(I32)getpid());
2256 s = getenv("PERL5LIB");
2260 incpush(getenv("PERLLIB"), FALSE);
2262 /* Treat PERL5?LIB as a possible search list logical name -- the
2263 * "natural" VMS idiom for a Unix path string. We allow each
2264 * element to be a set of |-separated directories for compatibility.
2268 if (my_trnlnm("PERL5LIB",buf,0))
2269 do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2271 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2275 /* Use the ~-expanded versions of APPLIB (undocumented),
2276 ARCHLIB PRIVLIB SITEARCH SITELIB and OLDARCHLIB
2279 incpush(APPLLIB_EXP, FALSE);
2283 incpush(ARCHLIB_EXP, FALSE);
2286 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2288 incpush(PRIVLIB_EXP, FALSE);
2291 incpush(SITEARCH_EXP, FALSE);
2294 incpush(SITELIB_EXP, FALSE);
2296 #ifdef OLDARCHLIB_EXP /* 5.00[01] compatibility */
2297 incpush(OLDARCHLIB_EXP, FALSE);
2301 incpush(".", FALSE);
2305 # define PERLLIB_SEP ';'
2308 # define PERLLIB_SEP '|'
2310 # define PERLLIB_SEP ':'
2313 #ifndef PERLLIB_MANGLE
2314 # define PERLLIB_MANGLE(s,n) (s)
2318 incpush(p, addsubdirs)
2322 SV *subdir = Nullsv;
2323 static char *archpat_auto;
2330 if (!archpat_auto) {
2331 STRLEN len = (sizeof(ARCHNAME) + strlen(patchlevel)
2332 + sizeof("//auto"));
2333 New(55, archpat_auto, len, char);
2334 sprintf(archpat_auto, "/%s/%s/auto", ARCHNAME, patchlevel);
2338 /* Break at all separators */
2340 SV *libdir = newSV(0);
2343 /* skip any consecutive separators */
2344 while ( *p == PERLLIB_SEP ) {
2345 /* Uncomment the next line for PATH semantics */
2346 /* av_push(GvAVn(incgv), newSVpv(".", 1)); */
2350 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2351 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2356 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2357 p = Nullch; /* break out */
2361 * BEFORE pushing libdir onto @INC we may first push version- and
2362 * archname-specific sub-directories.
2365 struct stat tmpstatbuf;
2367 /* .../archname/version if -d .../archname/version/auto */
2368 sv_setsv(subdir, libdir);
2369 sv_catpv(subdir, archpat_auto);
2370 if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2371 S_ISDIR(tmpstatbuf.st_mode))
2372 av_push(GvAVn(incgv),
2373 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2375 /* .../archname if -d .../archname/auto */
2376 sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
2377 strlen(patchlevel) + 1, "", 0);
2378 if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2379 S_ISDIR(tmpstatbuf.st_mode))
2380 av_push(GvAVn(incgv),
2381 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2384 /* finally push this lib directory on the end of @INC */
2385 av_push(GvAVn(incgv), libdir);
2388 SvREFCNT_dec(subdir);
2397 line_t oldline = curcop->cop_line;
2399 Copy(top_env, oldtop, 1, Sigjmp_buf);
2401 while (AvFILL(list) >= 0) {
2402 CV *cv = (CV*)av_shift(list);
2406 switch (Sigsetjmp(top_env,1)) {
2408 SV* atsv = GvSV(errgv);
2410 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
2411 (void)SvPV(atsv, len);
2413 Copy(oldtop, top_env, 1, Sigjmp_buf);
2414 curcop = &compiling;
2415 curcop->cop_line = oldline;
2416 if (list == beginav)
2417 sv_catpv(atsv, "BEGIN failed--compilation aborted");
2419 sv_catpv(atsv, "END failed--cleanup aborted");
2420 croak("%s", SvPVX(atsv));
2428 /* my_exit() was called */
2429 curstash = defstash;
2433 Copy(oldtop, top_env, 1, Sigjmp_buf);
2434 curcop = &compiling;
2435 curcop->cop_line = oldline;
2437 if (list == beginav)
2438 croak("BEGIN failed--compilation aborted");
2440 croak("END failed--cleanup aborted");
2446 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
2450 Copy(oldtop, top_env, 1, Sigjmp_buf);
2451 curcop = &compiling;
2452 curcop->cop_line = oldline;
2453 Siglongjmp(top_env, 3);
2457 Copy(oldtop, top_env, 1, Sigjmp_buf);
2472 STATUS_NATIVE_SET(status);
2482 if (vaxc$errno & 1) {
2483 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
2484 STATUS_NATIVE_SET(44);
2487 if (!vaxc$errno && errno) /* unlikely */
2488 STATUS_NATIVE_SET(44);
2490 STATUS_NATIVE_SET(vaxc$errno);
2494 STATUS_POSIX_SET(errno);
2495 else if (STATUS_POSIX == 0)
2496 STATUS_POSIX_SET(255);
2504 register CONTEXT *cx;
2513 (void)UNLINK(e_tmpname);
2514 Safefree(e_tmpname);
2518 if (cxstack_ix >= 0) {
2525 Siglongjmp(top_env, 2);