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 nuke_stacks _((void));
72 static void open_script _((char *, bool, SV *));
73 static void usage _((char *));
74 static void validate_suid _((char *, char*));
76 static int fdscript = -1;
81 PerlInterpreter *sv_interp;
84 New(53, sv_interp, 1, PerlInterpreter);
89 perl_construct( sv_interp )
90 register PerlInterpreter *sv_interp;
92 if (!(curinterp = sv_interp))
96 Zero(sv_interp, 1, PerlInterpreter);
99 /* Init the real globals? */
101 linestr = NEWSV(65,80);
102 sv_upgrade(linestr,SVt_PVIV);
104 if (!SvREADONLY(&sv_undef)) {
105 SvREADONLY_on(&sv_undef);
109 SvREADONLY_on(&sv_no);
111 sv_setpv(&sv_yes,Yes);
113 SvREADONLY_on(&sv_yes);
116 nrs = newSVpv("\n", 1);
117 rs = SvREFCNT_inc(nrs);
123 * There is no way we can refer to them from Perl so close them to save
124 * space. The other alternative would be to provide STDAUX and STDPRN
127 (void)fclose(stdaux);
128 (void)fclose(stdprn);
134 perl_destruct_level = 1;
136 if(perl_destruct_level > 0)
142 SET_NUMERIC_STANDARD();
143 #if defined(SUBVERSION) && SUBVERSION > 0
144 sprintf(patchlevel, "%7.5f", (double) 5
145 + ((double) PATCHLEVEL / (double) 1000)
146 + ((double) SUBVERSION / (double) 100000));
148 sprintf(patchlevel, "%5.3f", (double) 5 +
149 ((double) PATCHLEVEL / (double) 1000));
152 #if defined(LOCAL_PATCH_COUNT)
153 localpatches = local_patches; /* For possible -v */
156 PerlIO_init(); /* Hook to IO system */
158 fdpid = newAV(); /* for remembering popen pids by fd */
165 perl_destruct(sv_interp)
166 register PerlInterpreter *sv_interp;
168 int destruct_level; /* 0=none, 1=full, 2=full with checks */
172 if (!(curinterp = sv_interp))
175 destruct_level = perl_destruct_level;
179 if (s = getenv("PERL_DESTRUCT_LEVEL")) {
181 if (destruct_level < i)
187 /* unhook hooks which will soon be, or use, destroyed data */
188 SvREFCNT_dec(warnhook);
190 SvREFCNT_dec(diehook);
192 SvREFCNT_dec(parsehook);
198 /* We must account for everything. First the syntax tree. */
200 curpad = AvARRAY(comppad);
206 * Try to destruct global references. We do this first so that the
207 * destructors and destructees still exist. Some sv's might remain.
208 * Non-referenced objects are on their own.
215 if (destruct_level == 0){
217 DEBUG_P(debprofdump());
219 /* The exit() function will do everything that needs doing. */
223 /* loosen bonds of global variables */
226 (void)PerlIO_close(rsfp);
230 /* Filters for program text */
231 SvREFCNT_dec(rsfp_filters);
232 rsfp_filters = Nullav;
244 sawampersand = FALSE; /* must save all match strings */
245 sawstudy = FALSE; /* do fbm_instr on all strings */
260 /* magical thingies */
262 Safefree(ofs); /* $, */
265 Safefree(ors); /* $\ */
268 SvREFCNT_dec(nrs); /* $\ helper */
271 multiline = 0; /* $* */
273 SvREFCNT_dec(statname);
277 /* defgv, aka *_ should be taken care of elsewhere */
279 #if 0 /* just about all regexp stuff, seems to be ok */
281 /* shortcuts to regexp stuff */
286 SAVEFREEOP(oldlastpm); /* for saving regexp context during debugger */
288 regprecomp = NULL; /* uncompiled string. */
289 regparse = NULL; /* Input-scan pointer. */
290 regxend = NULL; /* End of input for compile */
291 regnpar = 0; /* () count. */
292 regcode = NULL; /* Code-emit pointer; ®dummy = don't. */
293 regsize = 0; /* Code size. */
294 regnaughty = 0; /* How bad is this pattern? */
295 regsawback = 0; /* Did we see \1, ...? */
297 reginput = NULL; /* String-input pointer. */
298 regbol = NULL; /* Beginning of input, for ^ check. */
299 regeol = NULL; /* End of input, for $ check. */
300 regstartp = (char **)NULL; /* Pointer to startp array. */
301 regendp = (char **)NULL; /* Ditto for endp. */
302 reglastparen = 0; /* Similarly for lastparen. */
303 regtill = NULL; /* How far we are required to go. */
304 regflags = 0; /* are we folding, multilining? */
305 regprev = (char)NULL; /* char before regbol, \n if none */
309 /* clean up after study() */
310 SvREFCNT_dec(lastscream);
312 Safefree(screamfirst);
314 Safefree(screamnext);
317 /* startup and shutdown function lists */
318 SvREFCNT_dec(beginav);
323 /* temp stack during pp_sort() */
324 SvREFCNT_dec(sortstack);
327 /* shortcuts just get cleared */
337 /* reset so print() ends up where we expect */
340 /* Prepare to destruct main symbol table. */
347 if (destruct_level >= 2) {
348 if (scopestack_ix != 0)
349 warn("Unbalanced scopes: %d more ENTERs than LEAVEs\n", scopestack_ix);
350 if (savestack_ix != 0)
351 warn("Unbalanced saves: %d more saves than restores\n", savestack_ix);
352 if (tmps_floor != -1)
353 warn("Unbalanced tmps: %d more allocs than frees\n", tmps_floor + 1);
354 if (cxstack_ix != -1)
355 warn("Unbalanced context: %d more PUSHes than POPs\n", cxstack_ix + 1);
358 /* Now absolutely destruct everything, somehow or other, loops or no. */
360 SvFLAGS(strtab) |= SVTYPEMASK; /* don't clean out strtab now */
361 while (sv_count != 0 && sv_count != last_sv_count) {
362 last_sv_count = sv_count;
365 SvFLAGS(strtab) &= ~SVTYPEMASK;
366 SvFLAGS(strtab) |= SVt_PVHV;
368 /* Destruct the global string table. */
370 /* Yell and reset the HeVAL() slots that are still holding refcounts,
371 * so that sv_free() won't fail on them.
380 array = HvARRAY(strtab);
384 warn("Unbalanced string table refcount: (%d) for \"%s\"",
385 HeVAL(hent) - Nullsv, HeKEY(hent));
386 HeVAL(hent) = Nullsv;
396 SvREFCNT_dec(strtab);
399 warn("Scalars leaked: %d\n", sv_count);
403 /* No SVs have survived, need to clean out */
407 Safefree(origfilename);
409 hints = 0; /* Reset hints. Should hints be per-interpreter ? */
411 DEBUG_P(debprofdump());
416 PerlInterpreter *sv_interp;
418 if (!(curinterp = sv_interp))
422 #if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE)
423 char *getenv _((char *)); /* Usually in <stdlib.h> */
427 perl_parse(sv_interp, xsinit, argc, argv, env)
428 PerlInterpreter *sv_interp;
429 void (*xsinit)_((void));
436 char *scriptname = NULL;
437 VOL bool dosearch = FALSE;
441 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
444 croak("suidperl is no longer needed since the kernel can now execute\n\
445 setuid perl scripts securely.\n");
449 if (!(curinterp = sv_interp))
452 #if defined(NeXT) && defined(__DYNAMIC__)
453 _dyld_lookup_and_bind
454 ("__environ", (unsigned long *) &environ_pointer, NULL);
459 #ifndef VMS /* VMS doesn't have environ array */
460 origenviron = environ;
466 /* Come here if running an undumped a.out. */
468 origfilename = savepv(argv[0]);
470 cxstack_ix = -1; /* start label stack again */
472 init_postdump_symbols(argc,argv,env);
480 switch (Sigsetjmp(top_env,1)) {
491 return(statusvalue); /* my_exit() was called */
493 PerlIO_printf(PerlIO_stderr(), "panic: top_env\n");
497 sv_setpvn(linestr,"",0);
498 sv = newSVpv("",0); /* first used for -I flags */
501 for (argc--,argv++; argc > 0; argc--,argv++) {
502 if (argv[0][0] != '-' || !argv[0][1])
506 validarg = " PHOOEY ";
532 if (s = moreswitches(s))
537 if (euid != uid || egid != gid)
538 croak("No -e allowed in setuid scripts");
540 e_tmpname = savepv(TMPPATH);
541 (void)mktemp(e_tmpname);
543 croak("Can't mktemp()");
544 e_fp = PerlIO_open(e_tmpname,"w");
546 croak("Cannot open temporary file");
551 PerlIO_puts(e_fp,argv[1]);
555 croak("No code specified for -e");
556 (void)PerlIO_putc(e_fp,'\n');
567 incpush(argv[1], TRUE);
568 sv_catpv(sv,argv[1]);
585 preambleav = newAV();
586 av_push(preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
588 Sv = newSVpv("print myconfig();",0);
590 sv_catpv(Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
592 sv_catpv(Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
594 #if defined(DEBUGGING) || defined(NOEMBED) || defined(MULTIPLICITY)
595 strcpy(buf,"\" Compile-time options:");
597 strcat(buf," DEBUGGING");
600 strcat(buf," NOEMBED");
603 strcat(buf," MULTIPLICITY");
605 strcat(buf,"\\n\",");
608 #if defined(LOCAL_PATCH_COUNT)
609 if (LOCAL_PATCH_COUNT > 0)
611 sv_catpv(Sv,"print \" Locally applied patches:\\n\",");
612 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
613 if (localpatches[i]) {
614 sprintf(buf,"\" \\t%s\\n\",",localpatches[i]);
620 sprintf(buf,"\" Built under %s\\n\",",OSNAME);
624 sprintf(buf,"\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
626 sprintf(buf,"\" Compiled on %s\\n\"",__DATE__);
630 sv_catpv(Sv,"; $\"=\"\\n \"; print \" \\@INC:\\n @INC\\n\"");
633 Sv = newSVpv("config_vars(qw(",0);
638 av_push(preambleav, Sv);
639 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
653 croak("Unrecognized switch: -%s",s);
658 scriptname = argv[0];
660 if (PerlIO_flush(e_fp) || PerlIO_error(e_fp) || PerlIO_close(e_fp))
661 croak("Can't write to temp file for -e: %s", Strerror(errno));
664 scriptname = e_tmpname;
666 else if (scriptname == Nullch) {
668 if ( isatty(PerlIO_fileno(PerlIO_stdin())) )
676 open_script(scriptname,dosearch,sv);
678 validate_suid(validarg, scriptname);
683 compcv = (CV*)NEWSV(1104,0);
684 sv_upgrade((SV *)compcv, SVt_PVCV);
688 av_push(comppad, Nullsv);
689 curpad = AvARRAY(comppad);
690 comppad_name = newAV();
691 comppad_name_fill = 0;
692 min_intro_pending = 0;
695 comppadlist = newAV();
696 AvREAL_off(comppadlist);
697 av_store(comppadlist, 0, (SV*)comppad_name);
698 av_store(comppadlist, 1, (SV*)comppad);
699 CvPADLIST(compcv) = comppadlist;
701 boot_core_UNIVERSAL();
703 (*xsinit)(); /* in case linked C routines want magical variables */
708 init_predump_symbols();
710 init_postdump_symbols(argc,argv,env);
714 /* now parse the script */
717 if (yyparse() || error_count) {
719 croak("%s had compilation errors.\n", origfilename);
721 croak("Execution of %s aborted due to compilation errors.\n",
725 curcop->cop_line = 0;
729 (void)UNLINK(e_tmpname);
734 /* now that script is parsed, we can modify record separator */
736 rs = SvREFCNT_inc(nrs);
737 sv_setsv(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), rs);
748 #ifdef DEBUGGING_MSTATS
749 if ((s=getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
750 dump_mstats("after compilation:");
760 PerlInterpreter *sv_interp;
762 if (!(curinterp = sv_interp))
764 switch (Sigsetjmp(top_env,1)) {
766 cxstack_ix = -1; /* start context stack again */
773 #ifdef DEBUGGING_MSTATS
774 if (getenv("PERL_DEBUG_MSTATS"))
775 dump_mstats("after execution: ");
777 return(statusvalue); /* my_exit() was called */
780 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
784 if (curstack != mainstack) {
786 SWITCHSTACK(curstack, mainstack);
791 DEBUG_r(PerlIO_printf(PerlIO_stderr(), "%s $` $& $' support.\n",
792 sawampersand ? "Enabling" : "Omitting"));
796 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
799 PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", origfilename);
802 if (perldb && DBsingle)
803 sv_setiv(DBsingle, 1);
813 else if (main_start) {
826 register CONTEXT *cx;
830 statusvalue = FIXSTATUS(status);
831 if (cxstack_ix >= 0) {
837 Siglongjmp(top_env, 2);
841 perl_get_sv(name, create)
845 GV* gv = gv_fetchpv(name, create, SVt_PV);
852 perl_get_av(name, create)
856 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
865 perl_get_hv(name, create)
869 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
878 perl_get_cv(name, create)
882 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
883 if (create && !GvCVu(gv))
884 return newSUB(start_subparse(FALSE, 0),
885 newSVOP(OP_CONST, 0, newSVpv(name,0)),
893 /* Be sure to refetch the stack pointer after calling these routines. */
896 perl_call_argv(subname, flags, argv)
898 I32 flags; /* See G_* flags in cop.h */
899 register char **argv; /* null terminated arg list */
906 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
911 return perl_call_pv(subname, flags);
915 perl_call_pv(subname, flags)
916 char *subname; /* name of the subroutine */
917 I32 flags; /* See G_* flags in cop.h */
919 return perl_call_sv((SV*)perl_get_cv(subname, TRUE), flags);
923 perl_call_method(methname, flags)
924 char *methname; /* name of the subroutine */
925 I32 flags; /* See G_* flags in cop.h */
931 XPUSHs(sv_2mortal(newSVpv(methname,0)));
934 return perl_call_sv(*stack_sp--, flags);
937 /* May be called with any of a CV, a GV, or an SV containing the name. */
939 perl_call_sv(sv, flags)
941 I32 flags; /* See G_* flags in cop.h */
943 LOGOP myop; /* fake syntax tree node */
945 I32 oldmark = TOPMARK;
951 if (flags & G_DISCARD) {
961 oldscope = scopestack_ix;
963 if (!(flags & G_NOARGS))
964 myop.op_flags = OPf_STACKED;
965 myop.op_next = Nullop;
966 myop.op_flags |= OPf_KNOW;
968 myop.op_flags |= OPf_LIST;
970 if (perldb && curstash != debstash
971 /* Handle first BEGIN of -d. */
972 && (DBcv || (DBcv = GvCV(DBsub)))
973 /* Try harder, since this may have been a sighandler, thus
974 * curstash may be meaningless. */
975 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != debstash))
976 op->op_private |= OPpENTERSUB_DB;
978 if (flags & G_EVAL) {
979 Copy(top_env, oldtop, 1, Sigjmp_buf);
981 cLOGOP->op_other = op;
983 /* we're trying to emulate pp_entertry() here */
985 register CONTEXT *cx;
991 push_return(op->op_next);
992 PUSHBLOCK(cx, CXt_EVAL, stack_sp);
994 eval_root = op; /* Only needed so that goto works right. */
997 if (flags & G_KEEPERR)
1000 sv_setpv(GvSV(errgv),"");
1005 switch (Sigsetjmp(top_env,1)) {
1010 statusvalue = 255; /* XXX I don't think we use 1 anymore. */
1016 /* my_exit() was called */
1017 curstash = defstash;
1019 Copy(oldtop, top_env, 1, Sigjmp_buf);
1021 croak("Callback called exit");
1022 my_exit(statusvalue);
1030 stack_sp = stack_base + oldmark;
1031 if (flags & G_ARRAY)
1035 *++stack_sp = &sv_undef;
1041 if (op == (OP*)&myop)
1045 retval = stack_sp - (stack_base + oldmark);
1046 if ((flags & G_EVAL) && !(flags & G_KEEPERR))
1047 sv_setpv(GvSV(errgv),"");
1050 if (flags & G_EVAL) {
1051 if (scopestack_ix > oldscope) {
1055 register CONTEXT *cx;
1064 Copy(oldtop, top_env, 1, Sigjmp_buf);
1066 if (flags & G_DISCARD) {
1067 stack_sp = stack_base + oldmark;
1075 /* Eval a string. The G_EVAL flag is always assumed. */
1078 perl_eval_sv(sv, flags)
1080 I32 flags; /* See G_* flags in cop.h */
1082 UNOP myop; /* fake syntax tree node */
1084 I32 oldmark = sp - stack_base;
1089 if (flags & G_DISCARD) {
1097 EXTEND(stack_sp, 1);
1099 oldscope = scopestack_ix;
1101 if (!(flags & G_NOARGS))
1102 myop.op_flags = OPf_STACKED;
1103 myop.op_next = Nullop;
1104 myop.op_type = OP_ENTEREVAL;
1105 myop.op_flags |= OPf_KNOW;
1106 if (flags & G_KEEPERR)
1107 myop.op_flags |= OPf_SPECIAL;
1108 if (flags & G_ARRAY)
1109 myop.op_flags |= OPf_LIST;
1111 Copy(top_env, oldtop, 1, Sigjmp_buf);
1114 switch (Sigsetjmp(top_env,1)) {
1119 statusvalue = 255; /* XXX I don't think we use 1 anymore. */
1125 /* my_exit() was called */
1126 curstash = defstash;
1128 Copy(oldtop, top_env, 1, Sigjmp_buf);
1130 croak("Callback called exit");
1131 my_exit(statusvalue);
1139 stack_sp = stack_base + oldmark;
1140 if (flags & G_ARRAY)
1144 *++stack_sp = &sv_undef;
1149 if (op == (OP*)&myop)
1150 op = pp_entereval();
1153 retval = stack_sp - (stack_base + oldmark);
1154 if (!(flags & G_KEEPERR))
1155 sv_setpv(GvSV(errgv),"");
1158 Copy(oldtop, top_env, 1, Sigjmp_buf);
1159 if (flags & G_DISCARD) {
1160 stack_sp = stack_base + oldmark;
1168 /* Require a module. */
1174 SV* sv = sv_newmortal();
1175 sv_setpv(sv, "require '");
1178 perl_eval_sv(sv, G_DISCARD);
1182 magicname(sym,name,namlen)
1189 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1190 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1194 usage(name) /* XXX move this out into a module ? */
1197 /* This message really ought to be max 23 lines.
1198 * Removed -h because the user already knows that opton. Others? */
1199 printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1200 printf("\n -0[octal] specify record separator (\\0, if no argument)");
1201 printf("\n -a autosplit mode with -n or -p (splits $_ into @F)");
1202 printf("\n -c check syntax only (runs BEGIN and END blocks)");
1203 printf("\n -d[:debugger] run scripts under debugger");
1204 printf("\n -D[number/list] set debugging flags (argument is a bit mask or flags)");
1205 printf("\n -e 'command' one line of script. Several -e's allowed. Omit [programfile].");
1206 printf("\n -F/pattern/ split() pattern for autosplit (-a). The //'s are optional.");
1207 printf("\n -i[extension] edit <> files in place (make backup if extension supplied)");
1208 printf("\n -Idirectory specify @INC/#include directory (may be used more then once)");
1209 printf("\n -l[octal] enable line ending processing, specifies line teminator");
1210 printf("\n -[mM][-]module.. executes `use/no module...' before executing your script.");
1211 printf("\n -n assume 'while (<>) { ... }' loop arround your script");
1212 printf("\n -p assume loop like -n but print line also like sed");
1213 printf("\n -P run script through C preprocessor before compilation");
1214 printf("\n -s enable some switch parsing for switches after script name");
1215 printf("\n -S look for the script using PATH environment variable");
1216 printf("\n -T turn on tainting checks");
1217 printf("\n -u dump core after parsing script");
1218 printf("\n -U allow unsafe operations");
1219 printf("\n -v print version number and patchlevel of perl");
1220 printf("\n -V[:variable] print perl configuration information");
1221 printf("\n -w TURN WARNINGS ON FOR COMPILATION OF YOUR SCRIPT.");
1222 printf("\n -x[directory] strip off text before #!perl line and perhaps cd to directory\n");
1225 /* This routine handles any switches that can be given during run */
1236 rschar = scan_oct(s, 4, &numlen);
1238 if (rschar & ~((U8)~0))
1240 else if (!rschar && numlen >= 2)
1241 nrs = newSVpv("", 0);
1244 nrs = newSVpv(&ch, 1);
1249 splitstr = savepv(s + 1);
1263 if (*s == ':' || *s == '=') {
1264 sprintf(buf, "use Devel::%s;", ++s);
1266 my_setenv("PERL5DB",buf);
1276 if (isALPHA(s[1])) {
1277 static char debopts[] = "psltocPmfrxuLHXD";
1280 for (s++; *s && (d = strchr(debopts,*s)); s++)
1281 debug |= 1 << (d - debopts);
1285 for (s++; isDIGIT(*s); s++) ;
1287 debug |= 0x80000000;
1289 warn("Recompile perl with -DDEBUGGING to use -D switch\n");
1290 for (s++; isALNUM(*s); s++) ;
1300 inplace = savepv(s+1);
1302 for (s = inplace; *s && !isSPACE(*s); s++) ;
1309 for (e = s; *e && !isSPACE(*e); e++) ;
1310 p = savepvn(s, e-s);
1317 croak("No space allowed after -I");
1327 *ors = scan_oct(s, 3 + (*s == '0'), &numlen);
1336 ors = SvPV(nrs, orslen);
1337 ors = savepvn(ors, orslen);
1341 forbid_setid("-M"); /* XXX ? */
1344 forbid_setid("-m"); /* XXX ? */
1348 /* -M-foo == 'no foo' */
1349 if (*s == '-') { use = "no "; ++s; }
1350 Sv = newSVpv(use,0);
1352 /* We allow -M'Module qw(Foo Bar)' */
1353 while(isALNUM(*s) || *s==':') ++s;
1355 sv_catpv(Sv, start);
1356 if (*(start-1) == 'm') {
1358 croak("Can't use '%c' after -mname", *s);
1359 sv_catpv( Sv, " ()");
1362 sv_catpvn(Sv, start, s-start);
1363 sv_catpv(Sv, " split(/,/,q{");
1368 if (preambleav == NULL)
1369 preambleav = newAV();
1370 av_push(preambleav, Sv);
1373 croak("No space allowed after -%c", *(s-1));
1401 #if defined(SUBVERSION) && SUBVERSION > 0
1402 printf("\nThis is perl, version 5.%03d_%02d", PATCHLEVEL, SUBVERSION);
1404 printf("\nThis is perl, version %s",patchlevel);
1407 printf("\n\nCopyright 1987-1997, Larry Wall\n");
1409 printf("\n\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1412 printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
1415 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1416 "Version 5 port Copyright (c) 1994-1996, Andreas Kaiser, Ilya Zakharevich\n");
1419 printf("atariST series port, ++jrb bammi@cadence.com\n");
1422 Perl may be copied only under the terms of either the Artistic License or the\n\
1423 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n");
1431 if (s[1] == '-') /* Additional switches on #! line. */
1444 croak("Can't emulate -%.1s on #! line",s);
1449 /* compliments of Tom Christiansen */
1451 /* unexec() can be found in the Gnu emacs distribution */
1460 sprintf (buf, "%s.perldump", origfilename);
1461 sprintf (tokenbuf, "%s/perl", BIN);
1463 status = unexec(buf, tokenbuf, &etext, sbrk(0), 0);
1465 PerlIO_printf(PerlIO_stderr(), "unexec of %s into %s failed!\n", tokenbuf, buf);
1469 # include <lib$routines.h>
1470 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
1472 ABORT(); /* for use with undump */
1482 /* Note that strtab is a rather special HV. Assumptions are made
1483 about not iterating on it, and not adding tie magic to it.
1484 It is properly deallocated in perl_destruct() */
1486 HvSHAREKEYS_off(strtab); /* mandatory */
1487 Newz(506,((XPVHV*)SvANY(strtab))->xhv_array,
1488 sizeof(HE*) * (((XPVHV*)SvANY(strtab))->xhv_max + 1), char);
1490 curstash = defstash = newHV();
1491 curstname = newSVpv("main",4);
1492 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1493 SvREFCNT_dec(GvHV(gv));
1494 GvHV(gv) = (HV*)SvREFCNT_inc(defstash);
1496 HvNAME(defstash) = savepv("main");
1497 incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1499 defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1500 errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1502 sv_setpvn(GvSV(errgv), "", 0);
1503 curstash = defstash;
1504 compiling.cop_stash = defstash;
1505 debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
1506 /* We must init $/ before switches are processed. */
1507 sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1);
1510 #ifdef CAN_PROTOTYPE
1512 open_script(char *scriptname, bool dosearch, SV *sv)
1515 open_script(scriptname,dosearch,sv)
1521 char *xfound = Nullch;
1522 char *xfailed = Nullch;
1526 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
1527 #define SEARCH_EXTS ".bat", ".cmd", NULL
1530 # define SEARCH_EXTS ".pl", ".com", NULL
1532 /* additional extensions to try in each dir if scriptname not found */
1534 char *ext[] = { SEARCH_EXTS };
1535 int extidx = (strchr(scriptname,'.')) ? -1 : 0; /* has ext already */
1540 int hasdir, idx = 0, deftypes = 1;
1542 hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
1543 /* The first time through, just add SEARCH_EXTS to whatever we
1544 * already have, so we can check for default file types. */
1545 while (deftypes || (!hasdir && my_trnlnm("DCL$PATH",tokenbuf,idx++)) ) {
1546 if (deftypes) { deftypes = 0; *tokenbuf = '\0'; }
1547 strcat(tokenbuf,scriptname);
1549 if (dosearch && !strchr(scriptname, '/') && (s = getenv("PATH"))) {
1551 bufend = s + strlen(s);
1554 s = cpytill(tokenbuf,s,bufend,':',&len);
1557 for (len = 0; *s && *s != ',' && *s != ';'; tokenbuf[len++] = *s++);
1558 tokenbuf[len] = '\0';
1560 for (len = 0; *s && *s != ';'; tokenbuf[len++] = *s++);
1561 tokenbuf[len] = '\0';
1567 if (len && tokenbuf[len-1] != '/')
1570 if (len && ((tokenbuf[len-1] != '\\') && (tokenbuf[len-1] != '/')))
1572 if (len && tokenbuf[len-1] != '\\')
1575 (void)strcat(tokenbuf+len,"/");
1576 (void)strcat(tokenbuf+len,scriptname);
1580 len = strlen(tokenbuf);
1581 if (extidx > 0) /* reset after previous loop */
1585 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tokenbuf));
1586 retval = Stat(tokenbuf,&statbuf);
1588 } while ( retval < 0 /* not there */
1589 && extidx>=0 && ext[extidx] /* try an extension? */
1590 && strcpy(tokenbuf+len, ext[extidx++])
1595 if (S_ISREG(statbuf.st_mode)
1596 && cando(S_IRUSR,TRUE,&statbuf) && cando(S_IXUSR,TRUE,&statbuf)) {
1597 xfound = tokenbuf; /* bingo! */
1601 xfailed = savepv(tokenbuf);
1604 croak("Can't execute %s", xfailed ? xfailed : scriptname );
1607 scriptname = xfound;
1610 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
1611 char *s = scriptname + 8;
1620 origfilename = savepv(e_tmpname ? "-e" : scriptname);
1621 curcop->cop_filegv = gv_fetchfile(origfilename);
1622 if (strEQ(origfilename,"-"))
1624 if (fdscript >= 0) {
1625 rsfp = PerlIO_fdopen(fdscript,"r");
1626 #if defined(HAS_FCNTL) && defined(F_SETFD)
1628 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
1631 else if (preprocess) {
1632 char *cpp = CPPSTDIN;
1634 if (strEQ(cpp,"cppstdin"))
1635 sprintf(tokenbuf, "%s/%s", SCRIPTDIR, cpp);
1637 sprintf(tokenbuf, "%s", cpp);
1639 sv_catpv(sv,PRIVLIB_EXP);
1641 (void)sprintf(buf, "\
1642 sed %s -e \"/^[^#]/b\" \
1643 -e \"/^#[ ]*include[ ]/b\" \
1644 -e \"/^#[ ]*define[ ]/b\" \
1645 -e \"/^#[ ]*if[ ]/b\" \
1646 -e \"/^#[ ]*ifdef[ ]/b\" \
1647 -e \"/^#[ ]*ifndef[ ]/b\" \
1648 -e \"/^#[ ]*else/b\" \
1649 -e \"/^#[ ]*elif[ ]/b\" \
1650 -e \"/^#[ ]*undef[ ]/b\" \
1651 -e \"/^#[ ]*endif/b\" \
1654 (doextract ? "-e \"1,/^#/d\n\"" : ""),
1656 (void)sprintf(buf, "\
1657 %s %s -e '/^[^#]/b' \
1658 -e '/^#[ ]*include[ ]/b' \
1659 -e '/^#[ ]*define[ ]/b' \
1660 -e '/^#[ ]*if[ ]/b' \
1661 -e '/^#[ ]*ifdef[ ]/b' \
1662 -e '/^#[ ]*ifndef[ ]/b' \
1663 -e '/^#[ ]*else/b' \
1664 -e '/^#[ ]*elif[ ]/b' \
1665 -e '/^#[ ]*undef[ ]/b' \
1666 -e '/^#[ ]*endif/b' \
1674 (doextract ? "-e '1,/^#/d\n'" : ""),
1676 scriptname, tokenbuf, SvPV(sv, na), CPPMINUS);
1678 #ifdef IAMSUID /* actually, this is caught earlier */
1679 if (euid != uid && !euid) { /* if running suidperl */
1681 (void)seteuid(uid); /* musn't stay setuid root */
1684 (void)setreuid((Uid_t)-1, uid);
1686 #ifdef HAS_SETRESUID
1687 (void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
1693 if (geteuid() != uid)
1694 croak("Can't do seteuid!\n");
1696 #endif /* IAMSUID */
1697 rsfp = my_popen(buf,"r");
1699 else if (!*scriptname) {
1700 forbid_setid("program input from stdin");
1701 rsfp = PerlIO_stdin();
1704 rsfp = PerlIO_open(scriptname,"r");
1705 #if defined(HAS_FCNTL) && defined(F_SETFD)
1707 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
1715 #ifndef IAMSUID /* in case script is not readable before setuid */
1716 if (euid && Stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
1717 statbuf.st_mode & (S_ISUID|S_ISGID)) {
1718 (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
1719 execv(buf, origargv); /* try again */
1720 croak("Can't do setuid\n");
1724 croak("Can't open perl script \"%s\": %s\n",
1725 SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno));
1730 validate_suid(validarg, scriptname)
1736 /* do we need to emulate setuid on scripts? */
1738 /* This code is for those BSD systems that have setuid #! scripts disabled
1739 * in the kernel because of a security problem. Merely defining DOSUID
1740 * in perl will not fix that problem, but if you have disabled setuid
1741 * scripts in the kernel, this will attempt to emulate setuid and setgid
1742 * on scripts that have those now-otherwise-useless bits set. The setuid
1743 * root version must be called suidperl or sperlN.NNN. If regular perl
1744 * discovers that it has opened a setuid script, it calls suidperl with
1745 * the same argv that it had. If suidperl finds that the script it has
1746 * just opened is NOT setuid root, it sets the effective uid back to the
1747 * uid. We don't just make perl setuid root because that loses the
1748 * effective uid we had before invoking perl, if it was different from the
1751 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
1752 * be defined in suidperl only. suidperl must be setuid root. The
1753 * Configure script will set this up for you if you want it.
1759 if (Fstat(PerlIO_fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
1760 croak("Can't stat script \"%s\"",origfilename);
1761 if (fdscript < 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) {
1765 #ifndef HAS_SETREUID
1766 /* On this access check to make sure the directories are readable,
1767 * there is actually a small window that the user could use to make
1768 * filename point to an accessible directory. So there is a faint
1769 * chance that someone could execute a setuid script down in a
1770 * non-accessible directory. I don't know what to do about that.
1771 * But I don't think it's too important. The manual lies when
1772 * it says access() is useful in setuid programs.
1774 if (access(SvPVX(GvSV(curcop->cop_filegv)),1)) /*double check*/
1775 croak("Permission denied");
1777 /* If we can swap euid and uid, then we can determine access rights
1778 * with a simple stat of the file, and then compare device and
1779 * inode to make sure we did stat() on the same file we opened.
1780 * Then we just have to make sure he or she can execute it.
1783 struct stat tmpstatbuf;
1787 setreuid(euid,uid) < 0
1790 setresuid(euid,uid,(Uid_t)-1) < 0
1793 || getuid() != euid || geteuid() != uid)
1794 croak("Can't swap uid and euid"); /* really paranoid */
1795 if (Stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
1796 croak("Permission denied"); /* testing full pathname here */
1797 if (tmpstatbuf.st_dev != statbuf.st_dev ||
1798 tmpstatbuf.st_ino != statbuf.st_ino) {
1799 (void)PerlIO_close(rsfp);
1800 if (rsfp = my_popen("/bin/mail root","w")) { /* heh, heh */
1802 "User %d tried to run dev %d ino %d in place of dev %d ino %d!\n\
1803 (Filename of set-id script was %s, uid %d gid %d.)\n\nSincerely,\nperl\n",
1804 uid,tmpstatbuf.st_dev, tmpstatbuf.st_ino,
1805 statbuf.st_dev, statbuf.st_ino,
1806 SvPVX(GvSV(curcop->cop_filegv)),
1807 statbuf.st_uid, statbuf.st_gid);
1808 (void)my_pclose(rsfp);
1810 croak("Permission denied\n");
1814 setreuid(uid,euid) < 0
1816 # if defined(HAS_SETRESUID)
1817 setresuid(uid,euid,(Uid_t)-1) < 0
1820 || getuid() != uid || geteuid() != euid)
1821 croak("Can't reswap uid and euid");
1822 if (!cando(S_IXUSR,FALSE,&statbuf)) /* can real uid exec? */
1823 croak("Permission denied\n");
1825 #endif /* HAS_SETREUID */
1826 #endif /* IAMSUID */
1828 if (!S_ISREG(statbuf.st_mode))
1829 croak("Permission denied");
1830 if (statbuf.st_mode & S_IWOTH)
1831 croak("Setuid/gid script is writable by world");
1832 doswitches = FALSE; /* -s is insecure in suid */
1834 if (sv_gets(linestr, rsfp, 0) == Nullch ||
1835 strnNE(SvPV(linestr,na),"#!",2) ) /* required even on Sys V */
1836 croak("No #! line");
1837 s = SvPV(linestr,na)+2;
1839 while (!isSPACE(*s)) s++;
1840 for (s2 = s; (s2 > SvPV(linestr,na)+2 &&
1841 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
1842 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
1843 croak("Not a perl script");
1844 while (*s == ' ' || *s == '\t') s++;
1846 * #! arg must be what we saw above. They can invoke it by
1847 * mentioning suidperl explicitly, but they may not add any strange
1848 * arguments beyond what #! says if they do invoke suidperl that way.
1850 len = strlen(validarg);
1851 if (strEQ(validarg," PHOOEY ") ||
1852 strnNE(s,validarg,len) || !isSPACE(s[len]))
1853 croak("Args must match #! line");
1856 if (euid != uid && (statbuf.st_mode & S_ISUID) &&
1857 euid == statbuf.st_uid)
1859 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
1860 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
1861 #endif /* IAMSUID */
1863 if (euid) { /* oops, we're not the setuid root perl */
1864 (void)PerlIO_close(rsfp);
1866 (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
1867 execv(buf, origargv); /* try again */
1869 croak("Can't do setuid\n");
1872 if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
1874 (void)setegid(statbuf.st_gid);
1877 (void)setregid((Gid_t)-1,statbuf.st_gid);
1879 #ifdef HAS_SETRESGID
1880 (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
1882 setgid(statbuf.st_gid);
1886 if (getegid() != statbuf.st_gid)
1887 croak("Can't do setegid!\n");
1889 if (statbuf.st_mode & S_ISUID) {
1890 if (statbuf.st_uid != euid)
1892 (void)seteuid(statbuf.st_uid); /* all that for this */
1895 (void)setreuid((Uid_t)-1,statbuf.st_uid);
1897 #ifdef HAS_SETRESUID
1898 (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
1900 setuid(statbuf.st_uid);
1904 if (geteuid() != statbuf.st_uid)
1905 croak("Can't do seteuid!\n");
1907 else if (uid) { /* oops, mustn't run as root */
1909 (void)seteuid((Uid_t)uid);
1912 (void)setreuid((Uid_t)-1,(Uid_t)uid);
1914 #ifdef HAS_SETRESUID
1915 (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
1921 if (geteuid() != uid)
1922 croak("Can't do seteuid!\n");
1925 if (!cando(S_IXUSR,TRUE,&statbuf))
1926 croak("Permission denied\n"); /* they can't do this */
1929 else if (preprocess)
1930 croak("-P not allowed for setuid/setgid script\n");
1931 else if (fdscript >= 0)
1932 croak("fd script not allowed in suidperl\n");
1934 croak("Script is not setuid/setgid in suidperl\n");
1936 /* We absolutely must clear out any saved ids here, so we */
1937 /* exec the real perl, substituting fd script for scriptname. */
1938 /* (We pass script name as "subdir" of fd, which perl will grok.) */
1939 PerlIO_rewind(rsfp);
1940 lseek(PerlIO_fileno(rsfp),(Off_t)0,0); /* just in case rewind didn't */
1941 for (which = 1; origargv[which] && origargv[which] != scriptname; which++) ;
1942 if (!origargv[which])
1943 croak("Permission denied");
1944 (void)sprintf(buf, "/dev/fd/%d/%.127s", PerlIO_fileno(rsfp), origargv[which]);
1945 origargv[which] = buf;
1947 #if defined(HAS_FCNTL) && defined(F_SETFD)
1948 fcntl(PerlIO_fileno(rsfp),F_SETFD,0); /* ensure no close-on-exec */
1951 (void)sprintf(tokenbuf, "%s/perl%s", BIN, patchlevel);
1952 execv(tokenbuf, origargv); /* try again */
1953 croak("Can't do setuid\n");
1954 #endif /* IAMSUID */
1956 if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */
1957 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
1958 Fstat(PerlIO_fileno(rsfp),&statbuf); /* may be either wrapped or real suid */
1959 if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
1961 (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
1964 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
1965 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
1966 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
1967 /* not set-id, must be wrapped */
1975 register char *s, *s2;
1977 /* skip forward in input to the real script? */
1981 if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
1982 croak("No Perl script found in input\n");
1983 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
1984 PerlIO_ungetc(rsfp, '\n'); /* to keep line count right */
1986 while (*s && !(isSPACE (*s) || *s == '#')) s++;
1988 while (*s == ' ' || *s == '\t') s++;
1990 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
1991 if (strnEQ(s2-4,"perl",4))
1993 while (s = moreswitches(s)) ;
1995 if (cddir && chdir(cddir) < 0)
1996 croak("Can't chdir to %s",cddir);
2004 uid = (int)getuid();
2005 euid = (int)geteuid();
2006 gid = (int)getgid();
2007 egid = (int)getegid();
2012 tainting |= (uid && (euid != uid || egid != gid));
2020 croak("No %s allowed while running setuid", s);
2022 croak("No %s allowed while running setgid", s);
2028 curstash = debstash;
2029 dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2031 DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2032 DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2033 DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2034 DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2035 sv_setiv(DBsingle, 0);
2036 DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2037 sv_setiv(DBtrace, 0);
2038 DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2039 sv_setiv(DBsignal, 0);
2040 curstash = defstash;
2047 mainstack = curstack; /* remember in case we switch stacks */
2048 AvREAL_off(curstack); /* not a real array */
2049 av_extend(curstack,127);
2051 stack_base = AvARRAY(curstack);
2052 stack_sp = stack_base;
2053 stack_max = stack_base + 127;
2055 cxstack_max = 8192 / sizeof(CONTEXT) - 2; /* Use most of 8K. */
2056 New(50,cxstack,cxstack_max + 1,CONTEXT);
2059 New(50,tmps_stack,128,SV*);
2064 New(51,debname,128,char);
2065 New(52,debdelim,128,char);
2069 * The following stacks almost certainly should be per-interpreter,
2070 * but for now they're not. XXX
2074 markstack_ptr = markstack;
2076 New(54,markstack,64,I32);
2077 markstack_ptr = markstack;
2078 markstack_max = markstack + 64;
2084 New(54,scopestack,32,I32);
2086 scopestack_max = 32;
2092 New(54,savestack,128,ANY);
2094 savestack_max = 128;
2100 New(54,retstack,16,OP*);
2110 Safefree(tmps_stack);
2117 static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
2125 subname = newSVpv("main",4);
2129 init_predump_symbols()
2134 sv_setpvn(GvSV(gv_fetchpv("\"", TRUE, SVt_PV)), " ", 1);
2136 stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2137 GvMULTI_on(stdingv);
2138 IoIFP(GvIOp(stdingv)) = PerlIO_stdin();
2139 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2141 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv));
2143 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2145 IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
2147 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2149 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv));
2151 othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2152 GvMULTI_on(othergv);
2153 IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr();
2154 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2156 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
2158 statname = NEWSV(66,0); /* last filename we did stat on */
2161 osname = savepv(OSNAME);
2165 init_postdump_symbols(argc,argv,env)
2167 register char **argv;
2168 register char **env;
2174 argc--,argv++; /* skip name of script */
2176 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2179 if (argv[0][1] == '-') {
2183 if (s = strchr(argv[0], '=')) {
2185 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2188 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2191 toptarget = NEWSV(0,0);
2192 sv_upgrade(toptarget, SVt_PVFM);
2193 sv_setpvn(toptarget, "", 0);
2194 bodytarget = NEWSV(0,0);
2195 sv_upgrade(bodytarget, SVt_PVFM);
2196 sv_setpvn(bodytarget, "", 0);
2197 formtarget = bodytarget;
2200 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2201 sv_setpv(GvSV(tmpgv),origfilename);
2202 magicname("0", "0", 1);
2204 if (tmpgv = gv_fetchpv("\024",TRUE, SVt_PV))
2206 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2207 sv_setpv(GvSV(tmpgv),origargv[0]);
2208 if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2210 (void)gv_AVadd(argvgv);
2211 av_clear(GvAVn(argvgv));
2212 for (; argc > 0; argc--,argv++) {
2213 av_push(GvAVn(argvgv),newSVpv(argv[0],0));
2216 if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2221 #ifndef VMS /* VMS doesn't have environ array */
2222 /* Note that if the supplied env parameter is actually a copy
2223 of the global environ then it may now point to free'd memory
2224 if the environment has been modified since. To avoid this
2225 problem we treat env==NULL as meaning 'use the default'
2229 if (env != environ) {
2230 environ[0] = Nullch;
2231 hv_magic(hv, envgv, 'E');
2233 for (; *env; env++) {
2234 if (!(s = strchr(*env,'=')))
2237 sv = newSVpv(s--,0);
2238 sv_magic(sv, sv, 'e', *env, s - *env);
2239 (void)hv_store(hv, *env, s - *env, sv, 0);
2243 #ifdef DYNAMIC_ENV_FETCH
2244 HvNAME(hv) = savepv(ENV_HV_NAME);
2246 hv_magic(hv, envgv, 'E');
2249 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2250 sv_setiv(GvSV(tmpgv),(I32)getpid());
2259 s = getenv("PERL5LIB");
2263 incpush(getenv("PERLLIB"), FALSE);
2265 /* Treat PERL5?LIB as a possible search list logical name -- the
2266 * "natural" VMS idiom for a Unix path string. We allow each
2267 * element to be a set of |-separated directories for compatibility.
2271 if (my_trnlnm("PERL5LIB",buf,0))
2272 do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2274 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2278 /* Use the ~-expanded versions of APPLIB (undocumented),
2279 ARCHLIB PRIVLIB SITEARCH SITELIB and OLDARCHLIB
2282 incpush(APPLLIB_EXP, FALSE);
2286 incpush(ARCHLIB_EXP, FALSE);
2289 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2291 incpush(PRIVLIB_EXP, FALSE);
2294 incpush(SITEARCH_EXP, FALSE);
2297 incpush(SITELIB_EXP, FALSE);
2299 #ifdef OLDARCHLIB_EXP /* 5.00[01] compatibility */
2300 incpush(OLDARCHLIB_EXP, FALSE);
2304 incpush(".", FALSE);
2308 # define PERLLIB_SEP ';'
2311 # define PERLLIB_SEP '|'
2313 # define PERLLIB_SEP ':'
2316 #ifndef PERLLIB_MANGLE
2317 # define PERLLIB_MANGLE(s,n) (s)
2321 incpush(p, addsubdirs)
2325 SV *subdir = Nullsv;
2326 static char *archpat_auto;
2333 if (!archpat_auto) {
2334 STRLEN len = (sizeof(ARCHNAME) + strlen(patchlevel)
2335 + sizeof("//auto"));
2336 New(55, archpat_auto, len, char);
2337 sprintf(archpat_auto, "/%s/%s/auto", ARCHNAME, patchlevel);
2341 /* Break at all separators */
2343 SV *libdir = newSV(0);
2346 /* skip any consecutive separators */
2347 while ( *p == PERLLIB_SEP ) {
2348 /* Uncomment the next line for PATH semantics */
2349 /* av_push(GvAVn(incgv), newSVpv(".", 1)); */
2353 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2354 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2359 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2360 p = Nullch; /* break out */
2364 * BEFORE pushing libdir onto @INC we may first push version- and
2365 * archname-specific sub-directories.
2368 struct stat tmpstatbuf;
2370 /* .../archname/version if -d .../archname/auto */
2371 sv_setsv(subdir, libdir);
2372 sv_catpv(subdir, archpat_auto);
2373 if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2374 S_ISDIR(tmpstatbuf.st_mode))
2375 av_push(GvAVn(incgv),
2376 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2378 /* .../archname/version if -d .../archname/version/auto */
2379 sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
2380 strlen(patchlevel) + 1, "", 0);
2381 if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2382 S_ISDIR(tmpstatbuf.st_mode))
2383 av_push(GvAVn(incgv),
2384 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2387 /* finally push this lib directory on the end of @INC */
2388 av_push(GvAVn(incgv), libdir);
2391 SvREFCNT_dec(subdir);
2400 line_t oldline = curcop->cop_line;
2402 Copy(top_env, oldtop, 1, Sigjmp_buf);
2404 while (AvFILL(list) >= 0) {
2405 CV *cv = (CV*)av_shift(list);
2409 switch (Sigsetjmp(top_env,1)) {
2411 SV* atsv = GvSV(errgv);
2413 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
2414 (void)SvPV(atsv, len);
2416 Copy(oldtop, top_env, 1, Sigjmp_buf);
2417 curcop = &compiling;
2418 curcop->cop_line = oldline;
2419 if (list == beginav)
2420 sv_catpv(atsv, "BEGIN failed--compilation aborted");
2422 sv_catpv(atsv, "END failed--cleanup aborted");
2423 croak("%s", SvPVX(atsv));
2429 statusvalue = 255; /* XXX I don't think we use 1 anymore. */
2435 /* my_exit() was called */
2436 curstash = defstash;
2440 Copy(oldtop, top_env, 1, Sigjmp_buf);
2441 curcop = &compiling;
2442 curcop->cop_line = oldline;
2444 if (list == beginav)
2445 croak("BEGIN failed--compilation aborted");
2447 croak("END failed--cleanup aborted");
2449 my_exit(statusvalue);
2454 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
2458 Copy(oldtop, top_env, 1, Sigjmp_buf);
2459 curcop = &compiling;
2460 curcop->cop_line = oldline;
2461 Siglongjmp(top_env, 3);
2465 Copy(oldtop, top_env, 1, Sigjmp_buf);