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: %ld more ENTERs than LEAVEs\n", (long)scopestack_ix);
353 if (savestack_ix != 0)
354 warn("Unbalanced saves: %ld more saves than restores\n", (long)savestack_ix);
355 if (tmps_floor != -1)
356 warn("Unbalanced tmps: %ld more allocs than frees\n", (long)tmps_floor + 1);
357 if (cxstack_ix != -1)
358 warn("Unbalanced context: %ld more PUSHes than POPs\n", (long)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: %ld\n", (long)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);
479 SvREFCNT_dec(main_cv);
483 main_start = main_root = 0;
487 switch (Sigsetjmp(top_env,1)) {
492 /* my_exit() was called */
496 return STATUS_NATIVE_EXPORT;
498 PerlIO_printf(PerlIO_stderr(), "panic: top_env\n");
502 sv_setpvn(linestr,"",0);
503 sv = newSVpv("",0); /* first used for -I flags */
506 for (argc--,argv++; argc > 0; argc--,argv++) {
507 if (argv[0][0] != '-' || !argv[0][1])
511 validarg = " PHOOEY ";
536 if (s = moreswitches(s))
546 if (euid != uid || egid != gid)
547 croak("No -e allowed in setuid scripts");
549 e_tmpname = savepv(TMPPATH);
550 (void)mktemp(e_tmpname);
552 croak("Can't mktemp()");
553 e_fp = PerlIO_open(e_tmpname,"w");
555 croak("Cannot open temporary file");
560 PerlIO_puts(e_fp,argv[1]);
564 croak("No code specified for -e");
565 (void)PerlIO_putc(e_fp,'\n');
576 incpush(argv[1], TRUE);
577 sv_catpv(sv,argv[1]);
594 preambleav = newAV();
595 av_push(preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
597 Sv = newSVpv("print myconfig();",0);
599 sv_catpv(Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
601 sv_catpv(Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
603 #if defined(DEBUGGING) || defined(NOEMBED) || defined(MULTIPLICITY)
604 strcpy(buf,"\" Compile-time options:");
606 strcat(buf," DEBUGGING");
609 strcat(buf," NOEMBED");
612 strcat(buf," MULTIPLICITY");
614 strcat(buf,"\\n\",");
617 #if defined(LOCAL_PATCH_COUNT)
618 if (LOCAL_PATCH_COUNT > 0)
620 sv_catpv(Sv,"print \" Locally applied patches:\\n\",");
621 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
622 if (localpatches[i]) {
623 sprintf(buf,"\" \\t%s\\n\",",localpatches[i]);
629 sprintf(buf,"\" Built under %s\\n\",",OSNAME);
633 sprintf(buf,"\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
635 sprintf(buf,"\" Compiled on %s\\n\"",__DATE__);
639 sv_catpv(Sv,"; $\"=\"\\n \"; print \" \\@INC:\\n @INC\\n\"");
642 Sv = newSVpv("config_vars(qw(",0);
647 av_push(preambleav, Sv);
648 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
662 croak("Unrecognized switch: -%s",s);
667 scriptname = argv[0];
669 if (PerlIO_flush(e_fp) || PerlIO_error(e_fp) || PerlIO_close(e_fp))
670 croak("Can't write to temp file for -e: %s", Strerror(errno));
673 scriptname = e_tmpname;
675 else if (scriptname == Nullch) {
677 if ( isatty(PerlIO_fileno(PerlIO_stdin())) )
685 open_script(scriptname,dosearch,sv);
687 validate_suid(validarg, scriptname);
692 main_cv = compcv = (CV*)NEWSV(1104,0);
693 sv_upgrade((SV *)compcv, SVt_PVCV);
697 av_push(comppad, Nullsv);
698 curpad = AvARRAY(comppad);
699 comppad_name = newAV();
700 comppad_name_fill = 0;
701 min_intro_pending = 0;
704 comppadlist = newAV();
705 AvREAL_off(comppadlist);
706 av_store(comppadlist, 0, (SV*)comppad_name);
707 av_store(comppadlist, 1, (SV*)comppad);
708 CvPADLIST(compcv) = comppadlist;
710 boot_core_UNIVERSAL();
712 (*xsinit)(); /* in case linked C routines want magical variables */
717 init_predump_symbols();
719 init_postdump_symbols(argc,argv,env);
723 /* now parse the script */
726 if (yyparse() || error_count) {
728 croak("%s had compilation errors.\n", origfilename);
730 croak("Execution of %s aborted due to compilation errors.\n",
734 curcop->cop_line = 0;
738 (void)UNLINK(e_tmpname);
743 /* now that script is parsed, we can modify record separator */
745 rs = SvREFCNT_inc(nrs);
746 sv_setsv(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), rs);
757 #ifdef DEBUGGING_MSTATS
758 if ((s=getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
759 dump_mstats("after compilation:");
769 PerlInterpreter *sv_interp;
771 if (!(curinterp = sv_interp))
773 switch (Sigsetjmp(top_env,1)) {
775 cxstack_ix = -1; /* start context stack again */
778 /* my_exit() was called */
783 #ifdef DEBUGGING_MSTATS
784 if (getenv("PERL_DEBUG_MSTATS"))
785 dump_mstats("after execution: ");
787 return STATUS_NATIVE_EXPORT;
790 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
794 if (curstack != mainstack) {
796 SWITCHSTACK(curstack, mainstack);
801 DEBUG_r(PerlIO_printf(PerlIO_stderr(), "%s $` $& $' support.\n",
802 sawampersand ? "Enabling" : "Omitting"));
806 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
809 PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", origfilename);
812 if (perldb && DBsingle)
813 sv_setiv(DBsingle, 1);
823 else if (main_start) {
824 CvDEPTH(main_cv) = 1;
834 perl_get_sv(name, create)
838 GV* gv = gv_fetchpv(name, create, SVt_PV);
845 perl_get_av(name, create)
849 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
858 perl_get_hv(name, create)
862 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
871 perl_get_cv(name, create)
875 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
876 if (create && !GvCVu(gv))
877 return newSUB(start_subparse(FALSE, 0),
878 newSVOP(OP_CONST, 0, newSVpv(name,0)),
886 /* Be sure to refetch the stack pointer after calling these routines. */
889 perl_call_argv(subname, flags, argv)
891 I32 flags; /* See G_* flags in cop.h */
892 register char **argv; /* null terminated arg list */
899 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
904 return perl_call_pv(subname, flags);
908 perl_call_pv(subname, flags)
909 char *subname; /* name of the subroutine */
910 I32 flags; /* See G_* flags in cop.h */
912 return perl_call_sv((SV*)perl_get_cv(subname, TRUE), flags);
916 perl_call_method(methname, flags)
917 char *methname; /* name of the subroutine */
918 I32 flags; /* See G_* flags in cop.h */
924 XPUSHs(sv_2mortal(newSVpv(methname,0)));
927 return perl_call_sv(*stack_sp--, flags);
930 /* May be called with any of a CV, a GV, or an SV containing the name. */
932 perl_call_sv(sv, flags)
934 I32 flags; /* See G_* flags in cop.h */
936 LOGOP myop; /* fake syntax tree node */
938 I32 oldmark = TOPMARK;
944 if (flags & G_DISCARD) {
954 oldscope = scopestack_ix;
956 if (!(flags & G_NOARGS))
957 myop.op_flags = OPf_STACKED;
958 myop.op_next = Nullop;
959 myop.op_flags |= OPf_KNOW;
961 myop.op_flags |= OPf_LIST;
963 if (perldb && curstash != debstash
964 /* Handle first BEGIN of -d. */
965 && (DBcv || (DBcv = GvCV(DBsub)))
966 /* Try harder, since this may have been a sighandler, thus
967 * curstash may be meaningless. */
968 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != debstash))
969 op->op_private |= OPpENTERSUB_DB;
971 if (flags & G_EVAL) {
972 Copy(top_env, oldtop, 1, Sigjmp_buf);
974 cLOGOP->op_other = op;
976 /* we're trying to emulate pp_entertry() here */
978 register CONTEXT *cx;
984 push_return(op->op_next);
985 PUSHBLOCK(cx, CXt_EVAL, stack_sp);
987 eval_root = op; /* Only needed so that goto works right. */
990 if (flags & G_KEEPERR)
993 sv_setpv(GvSV(errgv),"");
998 switch (Sigsetjmp(top_env,1)) {
1005 /* my_exit() was called */
1006 curstash = defstash;
1008 Copy(oldtop, top_env, 1, Sigjmp_buf);
1010 croak("Callback called exit");
1019 stack_sp = stack_base + oldmark;
1020 if (flags & G_ARRAY)
1024 *++stack_sp = &sv_undef;
1030 if (op == (OP*)&myop)
1034 retval = stack_sp - (stack_base + oldmark);
1035 if ((flags & G_EVAL) && !(flags & G_KEEPERR))
1036 sv_setpv(GvSV(errgv),"");
1039 if (flags & G_EVAL) {
1040 if (scopestack_ix > oldscope) {
1044 register CONTEXT *cx;
1053 Copy(oldtop, top_env, 1, Sigjmp_buf);
1055 if (flags & G_DISCARD) {
1056 stack_sp = stack_base + oldmark;
1064 /* Eval a string. The G_EVAL flag is always assumed. */
1067 perl_eval_sv(sv, flags)
1069 I32 flags; /* See G_* flags in cop.h */
1071 UNOP myop; /* fake syntax tree node */
1073 I32 oldmark = sp - stack_base;
1078 if (flags & G_DISCARD) {
1086 EXTEND(stack_sp, 1);
1088 oldscope = scopestack_ix;
1090 if (!(flags & G_NOARGS))
1091 myop.op_flags = OPf_STACKED;
1092 myop.op_next = Nullop;
1093 myop.op_type = OP_ENTEREVAL;
1094 myop.op_flags |= OPf_KNOW;
1095 if (flags & G_KEEPERR)
1096 myop.op_flags |= OPf_SPECIAL;
1097 if (flags & G_ARRAY)
1098 myop.op_flags |= OPf_LIST;
1100 Copy(top_env, oldtop, 1, Sigjmp_buf);
1103 switch (Sigsetjmp(top_env,1)) {
1110 /* my_exit() was called */
1111 curstash = defstash;
1113 Copy(oldtop, top_env, 1, Sigjmp_buf);
1115 croak("Callback called exit");
1124 stack_sp = stack_base + oldmark;
1125 if (flags & G_ARRAY)
1129 *++stack_sp = &sv_undef;
1134 if (op == (OP*)&myop)
1135 op = pp_entereval();
1138 retval = stack_sp - (stack_base + oldmark);
1139 if (!(flags & G_KEEPERR))
1140 sv_setpv(GvSV(errgv),"");
1143 Copy(oldtop, top_env, 1, Sigjmp_buf);
1144 if (flags & G_DISCARD) {
1145 stack_sp = stack_base + oldmark;
1153 /* Require a module. */
1159 SV* sv = sv_newmortal();
1160 sv_setpv(sv, "require '");
1163 perl_eval_sv(sv, G_DISCARD);
1167 magicname(sym,name,namlen)
1174 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1175 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1179 usage(name) /* XXX move this out into a module ? */
1182 /* This message really ought to be max 23 lines.
1183 * Removed -h because the user already knows that opton. Others? */
1184 printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1185 printf("\n -0[octal] specify record separator (\\0, if no argument)");
1186 printf("\n -a autosplit mode with -n or -p (splits $_ into @F)");
1187 printf("\n -c check syntax only (runs BEGIN and END blocks)");
1188 printf("\n -d[:debugger] run scripts under debugger");
1189 printf("\n -D[number/list] set debugging flags (argument is a bit mask or flags)");
1190 printf("\n -e 'command' one line of script. Several -e's allowed. Omit [programfile].");
1191 printf("\n -F/pattern/ split() pattern for autosplit (-a). The //'s are optional.");
1192 printf("\n -i[extension] edit <> files in place (make backup if extension supplied)");
1193 printf("\n -Idirectory specify @INC/#include directory (may be used more then once)");
1194 printf("\n -l[octal] enable line ending processing, specifies line teminator");
1195 printf("\n -[mM][-]module.. executes `use/no module...' before executing your script.");
1196 printf("\n -n assume 'while (<>) { ... }' loop arround your script");
1197 printf("\n -p assume loop like -n but print line also like sed");
1198 printf("\n -P run script through C preprocessor before compilation");
1199 printf("\n -s enable some switch parsing for switches after script name");
1200 printf("\n -S look for the script using PATH environment variable");
1201 printf("\n -T turn on tainting checks");
1202 printf("\n -u dump core after parsing script");
1203 printf("\n -U allow unsafe operations");
1204 printf("\n -v print version number and patchlevel of perl");
1205 printf("\n -V[:variable] print perl configuration information");
1206 printf("\n -w TURN WARNINGS ON FOR COMPILATION OF YOUR SCRIPT.");
1207 printf("\n -x[directory] strip off text before #!perl line and perhaps cd to directory\n");
1210 /* This routine handles any switches that can be given during run */
1221 rschar = scan_oct(s, 4, &numlen);
1223 if (rschar & ~((U8)~0))
1225 else if (!rschar && numlen >= 2)
1226 nrs = newSVpv("", 0);
1229 nrs = newSVpv(&ch, 1);
1234 splitstr = savepv(s + 1);
1248 if (*s == ':' || *s == '=') {
1249 sprintf(buf, "use Devel::%s;", ++s);
1251 my_setenv("PERL5DB",buf);
1261 if (isALPHA(s[1])) {
1262 static char debopts[] = "psltocPmfrxuLHXD";
1265 for (s++; *s && (d = strchr(debopts,*s)); s++)
1266 debug |= 1 << (d - debopts);
1270 for (s++; isDIGIT(*s); s++) ;
1272 debug |= 0x80000000;
1274 warn("Recompile perl with -DDEBUGGING to use -D switch\n");
1275 for (s++; isALNUM(*s); s++) ;
1285 inplace = savepv(s+1);
1287 for (s = inplace; *s && !isSPACE(*s); s++) ;
1294 for (e = s; *e && !isSPACE(*e); e++) ;
1295 p = savepvn(s, e-s);
1302 croak("No space allowed after -I");
1312 *ors = scan_oct(s, 3 + (*s == '0'), &numlen);
1321 ors = SvPV(nrs, orslen);
1322 ors = savepvn(ors, orslen);
1326 forbid_setid("-M"); /* XXX ? */
1329 forbid_setid("-m"); /* XXX ? */
1333 /* -M-foo == 'no foo' */
1334 if (*s == '-') { use = "no "; ++s; }
1335 Sv = newSVpv(use,0);
1337 /* We allow -M'Module qw(Foo Bar)' */
1338 while(isALNUM(*s) || *s==':') ++s;
1340 sv_catpv(Sv, start);
1341 if (*(start-1) == 'm') {
1343 croak("Can't use '%c' after -mname", *s);
1344 sv_catpv( Sv, " ()");
1347 sv_catpvn(Sv, start, s-start);
1348 sv_catpv(Sv, " split(/,/,q{");
1353 if (preambleav == NULL)
1354 preambleav = newAV();
1355 av_push(preambleav, Sv);
1358 croak("No space allowed after -%c", *(s-1));
1375 croak("Too late for \"-T\" option (try putting it first)");
1387 #if defined(SUBVERSION) && SUBVERSION > 0
1388 printf("\nThis is perl, version 5.%03d_%02d", PATCHLEVEL, SUBVERSION);
1390 printf("\nThis is perl, version %s",patchlevel);
1393 printf("\n\nCopyright 1987-1997, Larry Wall\n");
1395 printf("\n\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1398 printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
1401 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1402 "Version 5 port Copyright (c) 1994-1996, Andreas Kaiser, Ilya Zakharevich\n");
1405 printf("atariST series port, ++jrb bammi@cadence.com\n");
1408 Perl may be copied only under the terms of either the Artistic License or the\n\
1409 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n");
1417 if (s[1] == '-') /* Additional switches on #! line. */
1430 croak("Can't emulate -%.1s on #! line",s);
1435 /* compliments of Tom Christiansen */
1437 /* unexec() can be found in the Gnu emacs distribution */
1446 sprintf (buf, "%s.perldump", origfilename);
1447 sprintf (tokenbuf, "%s/perl", BIN);
1449 status = unexec(buf, tokenbuf, &etext, sbrk(0), 0);
1451 PerlIO_printf(PerlIO_stderr(), "unexec of %s into %s failed!\n", tokenbuf, buf);
1455 # include <lib$routines.h>
1456 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
1458 ABORT(); /* for use with undump */
1468 /* Note that strtab is a rather special HV. Assumptions are made
1469 about not iterating on it, and not adding tie magic to it.
1470 It is properly deallocated in perl_destruct() */
1472 HvSHAREKEYS_off(strtab); /* mandatory */
1473 Newz(506,((XPVHV*)SvANY(strtab))->xhv_array,
1474 sizeof(HE*) * (((XPVHV*)SvANY(strtab))->xhv_max + 1), char);
1476 curstash = defstash = newHV();
1477 curstname = newSVpv("main",4);
1478 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1479 SvREFCNT_dec(GvHV(gv));
1480 GvHV(gv) = (HV*)SvREFCNT_inc(defstash);
1482 HvNAME(defstash) = savepv("main");
1483 incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1485 defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1486 errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1488 sv_setpvn(GvSV(errgv), "", 0);
1489 curstash = defstash;
1490 compiling.cop_stash = defstash;
1491 debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
1492 /* We must init $/ before switches are processed. */
1493 sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1);
1496 #ifdef CAN_PROTOTYPE
1498 open_script(char *scriptname, bool dosearch, SV *sv)
1501 open_script(scriptname,dosearch,sv)
1507 char *xfound = Nullch;
1508 char *xfailed = Nullch;
1512 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
1513 #define SEARCH_EXTS ".bat", ".cmd", NULL
1516 # define SEARCH_EXTS ".pl", ".com", NULL
1518 /* additional extensions to try in each dir if scriptname not found */
1520 char *ext[] = { SEARCH_EXTS };
1521 int extidx = (strchr(scriptname,'.')) ? -1 : 0; /* has ext already */
1526 int hasdir, idx = 0, deftypes = 1;
1528 hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
1529 /* The first time through, just add SEARCH_EXTS to whatever we
1530 * already have, so we can check for default file types. */
1531 while (deftypes || (!hasdir && my_trnlnm("DCL$PATH",tokenbuf,idx++)) ) {
1532 if (deftypes) { deftypes = 0; *tokenbuf = '\0'; }
1533 strcat(tokenbuf,scriptname);
1535 if (dosearch && !strchr(scriptname, '/') && (s = getenv("PATH"))) {
1537 bufend = s + strlen(s);
1540 s = cpytill(tokenbuf,s,bufend,':',&len);
1543 for (len = 0; *s && *s != ',' && *s != ';'; tokenbuf[len++] = *s++);
1544 tokenbuf[len] = '\0';
1546 for (len = 0; *s && *s != ';'; tokenbuf[len++] = *s++);
1547 tokenbuf[len] = '\0';
1553 if (len && tokenbuf[len-1] != '/')
1556 if (len && ((tokenbuf[len-1] != '\\') && (tokenbuf[len-1] != '/')))
1558 if (len && tokenbuf[len-1] != '\\')
1561 (void)strcat(tokenbuf+len,"/");
1562 (void)strcat(tokenbuf+len,scriptname);
1566 len = strlen(tokenbuf);
1567 if (extidx > 0) /* reset after previous loop */
1571 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tokenbuf));
1572 retval = Stat(tokenbuf,&statbuf);
1574 } while ( retval < 0 /* not there */
1575 && extidx>=0 && ext[extidx] /* try an extension? */
1576 && strcpy(tokenbuf+len, ext[extidx++])
1581 if (S_ISREG(statbuf.st_mode)
1582 && cando(S_IRUSR,TRUE,&statbuf) && cando(S_IXUSR,TRUE,&statbuf)) {
1583 xfound = tokenbuf; /* bingo! */
1587 xfailed = savepv(tokenbuf);
1590 croak("Can't execute %s", xfailed ? xfailed : scriptname );
1593 scriptname = xfound;
1596 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
1597 char *s = scriptname + 8;
1606 origfilename = savepv(e_tmpname ? "-e" : scriptname);
1607 curcop->cop_filegv = gv_fetchfile(origfilename);
1608 if (strEQ(origfilename,"-"))
1610 if (fdscript >= 0) {
1611 rsfp = PerlIO_fdopen(fdscript,"r");
1612 #if defined(HAS_FCNTL) && defined(F_SETFD)
1614 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
1617 else if (preprocess) {
1618 char *cpp = CPPSTDIN;
1620 if (strEQ(cpp,"cppstdin"))
1621 sprintf(tokenbuf, "%s/%s", SCRIPTDIR, cpp);
1623 sprintf(tokenbuf, "%s", cpp);
1625 sv_catpv(sv,PRIVLIB_EXP);
1627 (void)sprintf(buf, "\
1628 sed %s -e \"/^[^#]/b\" \
1629 -e \"/^#[ ]*include[ ]/b\" \
1630 -e \"/^#[ ]*define[ ]/b\" \
1631 -e \"/^#[ ]*if[ ]/b\" \
1632 -e \"/^#[ ]*ifdef[ ]/b\" \
1633 -e \"/^#[ ]*ifndef[ ]/b\" \
1634 -e \"/^#[ ]*else/b\" \
1635 -e \"/^#[ ]*elif[ ]/b\" \
1636 -e \"/^#[ ]*undef[ ]/b\" \
1637 -e \"/^#[ ]*endif/b\" \
1640 (doextract ? "-e \"1,/^#/d\n\"" : ""),
1642 (void)sprintf(buf, "\
1643 %s %s -e '/^[^#]/b' \
1644 -e '/^#[ ]*include[ ]/b' \
1645 -e '/^#[ ]*define[ ]/b' \
1646 -e '/^#[ ]*if[ ]/b' \
1647 -e '/^#[ ]*ifdef[ ]/b' \
1648 -e '/^#[ ]*ifndef[ ]/b' \
1649 -e '/^#[ ]*else/b' \
1650 -e '/^#[ ]*elif[ ]/b' \
1651 -e '/^#[ ]*undef[ ]/b' \
1652 -e '/^#[ ]*endif/b' \
1660 (doextract ? "-e '1,/^#/d\n'" : ""),
1662 scriptname, tokenbuf, SvPV(sv, na), CPPMINUS);
1664 #ifdef IAMSUID /* actually, this is caught earlier */
1665 if (euid != uid && !euid) { /* if running suidperl */
1667 (void)seteuid(uid); /* musn't stay setuid root */
1670 (void)setreuid((Uid_t)-1, uid);
1672 #ifdef HAS_SETRESUID
1673 (void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
1679 if (geteuid() != uid)
1680 croak("Can't do seteuid!\n");
1682 #endif /* IAMSUID */
1683 rsfp = my_popen(buf,"r");
1685 else if (!*scriptname) {
1686 forbid_setid("program input from stdin");
1687 rsfp = PerlIO_stdin();
1690 rsfp = PerlIO_open(scriptname,"r");
1691 #if defined(HAS_FCNTL) && defined(F_SETFD)
1693 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
1701 #ifndef IAMSUID /* in case script is not readable before setuid */
1702 if (euid && Stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
1703 statbuf.st_mode & (S_ISUID|S_ISGID)) {
1704 (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
1705 execv(buf, origargv); /* try again */
1706 croak("Can't do setuid\n");
1710 croak("Can't open perl script \"%s\": %s\n",
1711 SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno));
1716 validate_suid(validarg, scriptname)
1722 /* do we need to emulate setuid on scripts? */
1724 /* This code is for those BSD systems that have setuid #! scripts disabled
1725 * in the kernel because of a security problem. Merely defining DOSUID
1726 * in perl will not fix that problem, but if you have disabled setuid
1727 * scripts in the kernel, this will attempt to emulate setuid and setgid
1728 * on scripts that have those now-otherwise-useless bits set. The setuid
1729 * root version must be called suidperl or sperlN.NNN. If regular perl
1730 * discovers that it has opened a setuid script, it calls suidperl with
1731 * the same argv that it had. If suidperl finds that the script it has
1732 * just opened is NOT setuid root, it sets the effective uid back to the
1733 * uid. We don't just make perl setuid root because that loses the
1734 * effective uid we had before invoking perl, if it was different from the
1737 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
1738 * be defined in suidperl only. suidperl must be setuid root. The
1739 * Configure script will set this up for you if you want it.
1745 if (Fstat(PerlIO_fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
1746 croak("Can't stat script \"%s\"",origfilename);
1747 if (fdscript < 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) {
1751 #ifndef HAS_SETREUID
1752 /* On this access check to make sure the directories are readable,
1753 * there is actually a small window that the user could use to make
1754 * filename point to an accessible directory. So there is a faint
1755 * chance that someone could execute a setuid script down in a
1756 * non-accessible directory. I don't know what to do about that.
1757 * But I don't think it's too important. The manual lies when
1758 * it says access() is useful in setuid programs.
1760 if (access(SvPVX(GvSV(curcop->cop_filegv)),1)) /*double check*/
1761 croak("Permission denied");
1763 /* If we can swap euid and uid, then we can determine access rights
1764 * with a simple stat of the file, and then compare device and
1765 * inode to make sure we did stat() on the same file we opened.
1766 * Then we just have to make sure he or she can execute it.
1769 struct stat tmpstatbuf;
1773 setreuid(euid,uid) < 0
1776 setresuid(euid,uid,(Uid_t)-1) < 0
1779 || getuid() != euid || geteuid() != uid)
1780 croak("Can't swap uid and euid"); /* really paranoid */
1781 if (Stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
1782 croak("Permission denied"); /* testing full pathname here */
1783 if (tmpstatbuf.st_dev != statbuf.st_dev ||
1784 tmpstatbuf.st_ino != statbuf.st_ino) {
1785 (void)PerlIO_close(rsfp);
1786 if (rsfp = my_popen("/bin/mail root","w")) { /* heh, heh */
1788 "User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
1789 (Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
1790 (long)uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
1791 (long)statbuf.st_dev, (long)statbuf.st_ino,
1792 SvPVX(GvSV(curcop->cop_filegv)),
1793 (long)statbuf.st_uid, (long)statbuf.st_gid);
1794 (void)my_pclose(rsfp);
1796 croak("Permission denied\n");
1800 setreuid(uid,euid) < 0
1802 # if defined(HAS_SETRESUID)
1803 setresuid(uid,euid,(Uid_t)-1) < 0
1806 || getuid() != uid || geteuid() != euid)
1807 croak("Can't reswap uid and euid");
1808 if (!cando(S_IXUSR,FALSE,&statbuf)) /* can real uid exec? */
1809 croak("Permission denied\n");
1811 #endif /* HAS_SETREUID */
1812 #endif /* IAMSUID */
1814 if (!S_ISREG(statbuf.st_mode))
1815 croak("Permission denied");
1816 if (statbuf.st_mode & S_IWOTH)
1817 croak("Setuid/gid script is writable by world");
1818 doswitches = FALSE; /* -s is insecure in suid */
1820 if (sv_gets(linestr, rsfp, 0) == Nullch ||
1821 strnNE(SvPV(linestr,na),"#!",2) ) /* required even on Sys V */
1822 croak("No #! line");
1823 s = SvPV(linestr,na)+2;
1825 while (!isSPACE(*s)) s++;
1826 for (s2 = s; (s2 > SvPV(linestr,na)+2 &&
1827 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
1828 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
1829 croak("Not a perl script");
1830 while (*s == ' ' || *s == '\t') s++;
1832 * #! arg must be what we saw above. They can invoke it by
1833 * mentioning suidperl explicitly, but they may not add any strange
1834 * arguments beyond what #! says if they do invoke suidperl that way.
1836 len = strlen(validarg);
1837 if (strEQ(validarg," PHOOEY ") ||
1838 strnNE(s,validarg,len) || !isSPACE(s[len]))
1839 croak("Args must match #! line");
1842 if (euid != uid && (statbuf.st_mode & S_ISUID) &&
1843 euid == statbuf.st_uid)
1845 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
1846 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
1847 #endif /* IAMSUID */
1849 if (euid) { /* oops, we're not the setuid root perl */
1850 (void)PerlIO_close(rsfp);
1852 (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
1853 execv(buf, origargv); /* try again */
1855 croak("Can't do setuid\n");
1858 if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
1860 (void)setegid(statbuf.st_gid);
1863 (void)setregid((Gid_t)-1,statbuf.st_gid);
1865 #ifdef HAS_SETRESGID
1866 (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
1868 setgid(statbuf.st_gid);
1872 if (getegid() != statbuf.st_gid)
1873 croak("Can't do setegid!\n");
1875 if (statbuf.st_mode & S_ISUID) {
1876 if (statbuf.st_uid != euid)
1878 (void)seteuid(statbuf.st_uid); /* all that for this */
1881 (void)setreuid((Uid_t)-1,statbuf.st_uid);
1883 #ifdef HAS_SETRESUID
1884 (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
1886 setuid(statbuf.st_uid);
1890 if (geteuid() != statbuf.st_uid)
1891 croak("Can't do seteuid!\n");
1893 else if (uid) { /* oops, mustn't run as root */
1895 (void)seteuid((Uid_t)uid);
1898 (void)setreuid((Uid_t)-1,(Uid_t)uid);
1900 #ifdef HAS_SETRESUID
1901 (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
1907 if (geteuid() != uid)
1908 croak("Can't do seteuid!\n");
1911 if (!cando(S_IXUSR,TRUE,&statbuf))
1912 croak("Permission denied\n"); /* they can't do this */
1915 else if (preprocess)
1916 croak("-P not allowed for setuid/setgid script\n");
1917 else if (fdscript >= 0)
1918 croak("fd script not allowed in suidperl\n");
1920 croak("Script is not setuid/setgid in suidperl\n");
1922 /* We absolutely must clear out any saved ids here, so we */
1923 /* exec the real perl, substituting fd script for scriptname. */
1924 /* (We pass script name as "subdir" of fd, which perl will grok.) */
1925 PerlIO_rewind(rsfp);
1926 lseek(PerlIO_fileno(rsfp),(Off_t)0,0); /* just in case rewind didn't */
1927 for (which = 1; origargv[which] && origargv[which] != scriptname; which++) ;
1928 if (!origargv[which])
1929 croak("Permission denied");
1930 (void)sprintf(buf, "/dev/fd/%d/%.127s", PerlIO_fileno(rsfp), origargv[which]);
1931 origargv[which] = buf;
1933 #if defined(HAS_FCNTL) && defined(F_SETFD)
1934 fcntl(PerlIO_fileno(rsfp),F_SETFD,0); /* ensure no close-on-exec */
1937 (void)sprintf(tokenbuf, "%s/perl%s", BIN, patchlevel);
1938 execv(tokenbuf, origargv); /* try again */
1939 croak("Can't do setuid\n");
1940 #endif /* IAMSUID */
1942 if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */
1943 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
1944 Fstat(PerlIO_fileno(rsfp),&statbuf); /* may be either wrapped or real suid */
1945 if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
1947 (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
1950 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
1951 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
1952 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
1953 /* not set-id, must be wrapped */
1961 register char *s, *s2;
1963 /* skip forward in input to the real script? */
1967 if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
1968 croak("No Perl script found in input\n");
1969 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
1970 PerlIO_ungetc(rsfp, '\n'); /* to keep line count right */
1972 while (*s && !(isSPACE (*s) || *s == '#')) s++;
1974 while (*s == ' ' || *s == '\t') s++;
1976 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
1977 if (strnEQ(s2-4,"perl",4))
1979 while (s = moreswitches(s)) ;
1981 if (cddir && chdir(cddir) < 0)
1982 croak("Can't chdir to %s",cddir);
1990 uid = (int)getuid();
1991 euid = (int)geteuid();
1992 gid = (int)getgid();
1993 egid = (int)getegid();
1998 tainting |= (uid && (euid != uid || egid != gid));
2006 croak("No %s allowed while running setuid", s);
2008 croak("No %s allowed while running setgid", s);
2014 curstash = debstash;
2015 dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2017 DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2018 DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2019 DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2020 DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2021 sv_setiv(DBsingle, 0);
2022 DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2023 sv_setiv(DBtrace, 0);
2024 DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2025 sv_setiv(DBsignal, 0);
2026 curstash = defstash;
2033 mainstack = curstack; /* remember in case we switch stacks */
2034 AvREAL_off(curstack); /* not a real array */
2035 av_extend(curstack,127);
2037 stack_base = AvARRAY(curstack);
2038 stack_sp = stack_base;
2039 stack_max = stack_base + 127;
2041 cxstack_max = 8192 / sizeof(CONTEXT) - 2; /* Use most of 8K. */
2042 New(50,cxstack,cxstack_max + 1,CONTEXT);
2045 New(50,tmps_stack,128,SV*);
2050 New(51,debname,128,char);
2051 New(52,debdelim,128,char);
2055 * The following stacks almost certainly should be per-interpreter,
2056 * but for now they're not. XXX
2060 markstack_ptr = markstack;
2062 New(54,markstack,64,I32);
2063 markstack_ptr = markstack;
2064 markstack_max = markstack + 64;
2070 New(54,scopestack,32,I32);
2072 scopestack_max = 32;
2078 New(54,savestack,128,ANY);
2080 savestack_max = 128;
2086 New(54,retstack,16,OP*);
2096 Safefree(tmps_stack);
2103 static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
2111 subname = newSVpv("main",4);
2115 init_predump_symbols()
2120 sv_setpvn(GvSV(gv_fetchpv("\"", TRUE, SVt_PV)), " ", 1);
2122 stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2123 GvMULTI_on(stdingv);
2124 IoIFP(GvIOp(stdingv)) = PerlIO_stdin();
2125 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2127 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv));
2129 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2131 IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
2133 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2135 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv));
2137 othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2138 GvMULTI_on(othergv);
2139 IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr();
2140 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2142 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
2144 statname = NEWSV(66,0); /* last filename we did stat on */
2147 osname = savepv(OSNAME);
2151 init_postdump_symbols(argc,argv,env)
2153 register char **argv;
2154 register char **env;
2160 argc--,argv++; /* skip name of script */
2162 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2165 if (argv[0][1] == '-') {
2169 if (s = strchr(argv[0], '=')) {
2171 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2174 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2177 toptarget = NEWSV(0,0);
2178 sv_upgrade(toptarget, SVt_PVFM);
2179 sv_setpvn(toptarget, "", 0);
2180 bodytarget = NEWSV(0,0);
2181 sv_upgrade(bodytarget, SVt_PVFM);
2182 sv_setpvn(bodytarget, "", 0);
2183 formtarget = bodytarget;
2186 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2187 sv_setpv(GvSV(tmpgv),origfilename);
2188 magicname("0", "0", 1);
2190 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2191 sv_setpv(GvSV(tmpgv),origargv[0]);
2192 if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2194 (void)gv_AVadd(argvgv);
2195 av_clear(GvAVn(argvgv));
2196 for (; argc > 0; argc--,argv++) {
2197 av_push(GvAVn(argvgv),newSVpv(argv[0],0));
2200 if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2205 #ifndef VMS /* VMS doesn't have environ array */
2206 /* Note that if the supplied env parameter is actually a copy
2207 of the global environ then it may now point to free'd memory
2208 if the environment has been modified since. To avoid this
2209 problem we treat env==NULL as meaning 'use the default'
2213 if (env != environ) {
2214 environ[0] = Nullch;
2215 hv_magic(hv, envgv, 'E');
2217 for (; *env; env++) {
2218 if (!(s = strchr(*env,'=')))
2221 sv = newSVpv(s--,0);
2222 sv_magic(sv, sv, 'e', *env, s - *env);
2223 (void)hv_store(hv, *env, s - *env, sv, 0);
2227 #ifdef DYNAMIC_ENV_FETCH
2228 HvNAME(hv) = savepv(ENV_HV_NAME);
2230 hv_magic(hv, envgv, 'E');
2233 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2234 sv_setiv(GvSV(tmpgv),(I32)getpid());
2243 s = getenv("PERL5LIB");
2247 incpush(getenv("PERLLIB"), FALSE);
2249 /* Treat PERL5?LIB as a possible search list logical name -- the
2250 * "natural" VMS idiom for a Unix path string. We allow each
2251 * element to be a set of |-separated directories for compatibility.
2255 if (my_trnlnm("PERL5LIB",buf,0))
2256 do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2258 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2262 /* Use the ~-expanded versions of APPLIB (undocumented),
2263 ARCHLIB PRIVLIB SITEARCH SITELIB and OLDARCHLIB
2266 incpush(APPLLIB_EXP, FALSE);
2270 incpush(ARCHLIB_EXP, FALSE);
2273 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2275 incpush(PRIVLIB_EXP, FALSE);
2278 incpush(SITEARCH_EXP, FALSE);
2281 incpush(SITELIB_EXP, FALSE);
2283 #ifdef OLDARCHLIB_EXP /* 5.00[01] compatibility */
2284 incpush(OLDARCHLIB_EXP, FALSE);
2288 incpush(".", FALSE);
2292 # define PERLLIB_SEP ';'
2295 # define PERLLIB_SEP '|'
2297 # define PERLLIB_SEP ':'
2300 #ifndef PERLLIB_MANGLE
2301 # define PERLLIB_MANGLE(s,n) (s)
2305 incpush(p, addsubdirs)
2309 SV *subdir = Nullsv;
2310 static char *archpat_auto;
2317 if (!archpat_auto) {
2318 STRLEN len = (sizeof(ARCHNAME) + strlen(patchlevel)
2319 + sizeof("//auto"));
2320 New(55, archpat_auto, len, char);
2321 sprintf(archpat_auto, "/%s/%s/auto", ARCHNAME, patchlevel);
2325 /* Break at all separators */
2327 SV *libdir = newSV(0);
2330 /* skip any consecutive separators */
2331 while ( *p == PERLLIB_SEP ) {
2332 /* Uncomment the next line for PATH semantics */
2333 /* av_push(GvAVn(incgv), newSVpv(".", 1)); */
2337 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2338 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2343 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2344 p = Nullch; /* break out */
2348 * BEFORE pushing libdir onto @INC we may first push version- and
2349 * archname-specific sub-directories.
2352 struct stat tmpstatbuf;
2354 /* .../archname/version if -d .../archname/version/auto */
2355 sv_setsv(subdir, libdir);
2356 sv_catpv(subdir, archpat_auto);
2357 if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2358 S_ISDIR(tmpstatbuf.st_mode))
2359 av_push(GvAVn(incgv),
2360 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2362 /* .../archname if -d .../archname/auto */
2363 sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
2364 strlen(patchlevel) + 1, "", 0);
2365 if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2366 S_ISDIR(tmpstatbuf.st_mode))
2367 av_push(GvAVn(incgv),
2368 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2371 /* finally push this lib directory on the end of @INC */
2372 av_push(GvAVn(incgv), libdir);
2375 SvREFCNT_dec(subdir);
2384 line_t oldline = curcop->cop_line;
2386 Copy(top_env, oldtop, 1, Sigjmp_buf);
2388 while (AvFILL(list) >= 0) {
2389 CV *cv = (CV*)av_shift(list);
2393 switch (Sigsetjmp(top_env,1)) {
2395 SV* atsv = GvSV(errgv);
2397 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
2398 (void)SvPV(atsv, len);
2400 Copy(oldtop, top_env, 1, Sigjmp_buf);
2401 curcop = &compiling;
2402 curcop->cop_line = oldline;
2403 if (list == beginav)
2404 sv_catpv(atsv, "BEGIN failed--compilation aborted");
2406 sv_catpv(atsv, "END failed--cleanup aborted");
2407 croak("%s", SvPVX(atsv));
2415 /* my_exit() was called */
2416 curstash = defstash;
2420 Copy(oldtop, top_env, 1, Sigjmp_buf);
2421 curcop = &compiling;
2422 curcop->cop_line = oldline;
2424 if (list == beginav)
2425 croak("BEGIN failed--compilation aborted");
2427 croak("END failed--cleanup aborted");
2433 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
2437 Copy(oldtop, top_env, 1, Sigjmp_buf);
2438 curcop = &compiling;
2439 curcop->cop_line = oldline;
2440 Siglongjmp(top_env, 3);
2444 Copy(oldtop, top_env, 1, Sigjmp_buf);
2459 STATUS_NATIVE_SET(status);
2469 if (vaxc$errno & 1) {
2470 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
2471 STATUS_NATIVE_SET(44);
2474 if (!vaxc$errno && errno) /* someone must have set $^E = 0 */
2475 STATUS_NATIVE_SET(44);
2477 STATUS_NATIVE_SET(vaxc$errno);
2481 STATUS_POSIX_SET(errno);
2482 else if (STATUS_POSIX == 0)
2483 STATUS_POSIX_SET(255);
2491 register CONTEXT *cx;
2500 (void)UNLINK(e_tmpname);
2501 Safefree(e_tmpname);
2505 if (cxstack_ix >= 0) {
2511 Siglongjmp(top_env, 2);