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
37 #ifdef USE_LOCALE_COLLATE
38 #define I_REINIT_LOCALE_C \
39 collation_standard = TRUE; \
42 #define I_REINIT_LOCALE_C
45 #ifdef USE_LOCALE_NUMERIC
46 #define I_REINIT_LOCALE_N \
47 numeric_standard = TRUE; \
50 #define I_REINIT_LOCALE_N
56 curcop = &compiling; \
63 laststype = OP_STAT; \
65 maxsysfd = MAXSYSFD; \
72 laststype = OP_STAT; \
76 static void find_beginning _((void));
77 static void forbid_setid _((char *));
78 static void incpush _((char *));
79 static void init_ids _((void));
80 static void init_debugger _((void));
81 static void init_lexer _((void));
82 static void init_main_stash _((void));
83 static void init_perllib _((void));
84 static void init_postdump_symbols _((int, char **, char **));
85 static void init_predump_symbols _((void));
86 static void init_stacks _((void));
87 static void nuke_stacks _((void));
88 static void open_script _((char *, bool, SV *));
89 static void usage _((char *));
90 static void validate_suid _((char *, char*));
92 static int fdscript = -1;
97 PerlInterpreter *sv_interp;
100 New(53, sv_interp, 1, PerlInterpreter);
105 perl_construct( sv_interp )
106 register PerlInterpreter *sv_interp;
108 if (!(curinterp = sv_interp))
112 Zero(sv_interp, 1, PerlInterpreter);
115 /* Init the real globals? */
117 linestr = NEWSV(65,80);
118 sv_upgrade(linestr,SVt_PVIV);
120 if (!SvREADONLY(&sv_undef)) {
121 SvREADONLY_on(&sv_undef);
125 SvREADONLY_on(&sv_no);
127 sv_setpv(&sv_yes,Yes);
129 SvREADONLY_on(&sv_yes);
132 nrs = newSVpv("\n", 1);
133 rs = SvREFCNT_inc(nrs);
137 * There is no way we can refer to them from Perl so close them to save
138 * space. The other alternative would be to provide STDAUX and STDPRN
141 (void)fclose(stdaux);
142 (void)fclose(stdprn);
148 perl_destruct_level = 1;
150 if(perl_destruct_level > 0) {
157 SET_NUMERIC_STANDARD();
158 #if defined(SUBVERSION) && SUBVERSION > 0
159 sprintf(patchlevel, "%7.5f", (double) 5
160 + ((double) PATCHLEVEL / (double) 1000)
161 + ((double) SUBVERSION / (double) 100000));
163 sprintf(patchlevel, "%5.3f", (double) 5 +
164 ((double) PATCHLEVEL / (double) 1000));
167 #if defined(LOCAL_PATCH_COUNT)
168 localpatches = local_patches; /* For possible -v */
171 PerlIO_init(); /* Hook to IO system */
173 fdpid = newAV(); /* for remembering popen pids by fd */
174 pidstatus = newHV();/* for remembering status of dead pids */
181 perl_destruct(sv_interp)
182 register PerlInterpreter *sv_interp;
184 int destruct_level; /* 0=none, 1=full, 2=full with checks */
188 if (!(curinterp = sv_interp))
191 destruct_level = perl_destruct_level;
195 if (s = getenv("PERL_DESTRUCT_LEVEL")) {
197 if (destruct_level < i)
203 /* unhook hooks which will soon be, or use, destroyed data */
204 SvREFCNT_dec(warnhook);
206 SvREFCNT_dec(diehook);
208 SvREFCNT_dec(parsehook);
214 /* We must account for everything. First the syntax tree. */
216 curpad = AvARRAY(comppad);
222 * Try to destruct global references. We do this first so that the
223 * destructors and destructees still exist. Some sv's might remain.
224 * Non-referenced objects are on their own.
231 if (destruct_level == 0){
233 DEBUG_P(debprofdump());
235 /* The exit() function will do everything that needs doing. */
239 /* loosen bonds of global variables */
243 /* script file pointer */
245 (void)PerlIO_close(rsfp);
249 /* Package::DATA, etc */
250 /* sv_clean_all() will remove these from the registry
252 sv_free((SV*)rsfp_filters);
253 rsfp_filters = Nullav;
257 /* pseudo environmental stuff */
258 /* sv_clean_all() takes care of %ENV, %SIG
275 sawampersand = FALSE; /* must save all match strings */
276 sawstudy = FALSE; /* do fbm_instr on all strings */
292 /* magical thingies */
301 multiline = 0; /* $* */
307 /* shortcuts to various I/O objects */
309 sv_free((SV*)stdingv);
313 sv_free((SV*)last_in_gv);
317 /* defgv, aka *_ should be taken care of elsewhere */
320 if(SvREFCNT(argvgv)) {
321 sv_free((SV*)argvgv);
324 /* reset so print() ends up where we expect */
325 sv_free((SV*)defoutgv);
328 /* be sure to get rid of -i inplace fds */
330 sv_free((SV*)argvoutgv);
334 #if 0 /* just about all regexp stuff, seems to be ok */
335 /* shortcuts to regexp stuff */
337 sv_free((SV*)leftgv);
341 sv_free((SV*)ampergv);
345 SAVEFREEOP(oldlastpm); /* for saving regexp context during debugger */
347 regprecomp = NULL; /* uncompiled string. */
348 regparse = NULL; /* Input-scan pointer. */
349 regxend = NULL; /* End of input for compile */
350 regnpar = 0; /* () count. */
351 regcode = NULL; /* Code-emit pointer; ®dummy = don't. */
352 regsize = 0; /* Code size. */
353 regnaughty = 0; /* How bad is this pattern? */
354 regsawback = 0; /* Did we see \1, ...? */
356 reginput = NULL; /* String-input pointer. */
357 regbol = NULL; /* Beginning of input, for ^ check. */
358 regeol = NULL; /* End of input, for $ check. */
359 regstartp = (char **)NULL; /* Pointer to startp array. */
360 regendp = (char **)NULL; /* Ditto for endp. */
361 reglastparen = 0; /* Similarly for lastparen. */
362 regtill = NULL; /* How far we are required to go. */
363 regflags = 0; /* are we folding, multilining? */
364 regprev = (char)NULL; /* char before regbol, \n if none */
367 /* clean up after study() */
373 Safefree(screamfirst);
377 Safefree(screamnext);
381 /* shortcuts to misc objects */
390 sv_free((SV*)beginav); /* names of BEGIN subroutines */
394 sv_free((SV*)endav); /* names of END subroutines */
398 /* subprocess state */
399 /* keep fd-to-pid mappings for my_popen */
400 /* don't, CORE::stat() will core dump
404 /* keep pid-to-status mappings for waitpid */
405 sv_free((SV*)pidstatus);
408 /* statics for shared library purposes */
410 /* temp stack during pp_sort() */
412 sv_free((SV*)sortstack);
416 /* Prepare to destruct main symbol table. */
423 if (destruct_level >= 2) {
424 if (scopestack_ix != 0)
425 warn("Unbalanced scopes: %d more ENTERs than LEAVEs\n", scopestack_ix);
426 if (savestack_ix != 0)
427 warn("Unbalanced saves: %d more saves than restores\n", savestack_ix);
428 if (tmps_floor != -1)
429 warn("Unbalanced tmps: %d more allocs than frees\n", tmps_floor + 1);
430 if (cxstack_ix != -1)
431 warn("Unbalanced context: %d more PUSHes than POPs\n", cxstack_ix + 1);
434 /* Now absolutely destruct everything, somehow or other, loops or no. */
436 SvFLAGS(strtab) |= SVTYPEMASK; /* don't clean out strtab now */
437 while (sv_count != 0 && sv_count != last_sv_count) {
438 last_sv_count = sv_count;
441 SvFLAGS(strtab) &= ~SVTYPEMASK;
442 SvFLAGS(strtab) |= SVt_PVHV;
444 /* Destruct the global string table. */
446 /* Yell and reset the HeVAL() slots that are still holding refcounts,
447 * so that sv_free() won't fail on them.
456 array = HvARRAY(strtab);
460 warn("Unbalanced string table refcount: (%d) for \"%s\"",
461 HeVAL(hent) - Nullsv, HeKEY(hent));
462 HeVAL(hent) = Nullsv;
472 SvREFCNT_dec(strtab);
475 warn("Scalars leaked: %d\n", sv_count);
479 linestr = NULL; /* No SVs have survived, need to clean out */
481 Safefree(origfilename);
483 hints = 0; /* Reset hints. Should hints be per-interpreter ? */
485 DEBUG_P(debprofdump());
490 PerlInterpreter *sv_interp;
492 if (!(curinterp = sv_interp))
496 #if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE)
497 char *getenv _((char *)); /* Usually in <stdlib.h> */
501 perl_parse(sv_interp, xsinit, argc, argv, env)
502 PerlInterpreter *sv_interp;
503 void (*xsinit)_((void));
510 char *scriptname = NULL;
511 VOL bool dosearch = FALSE;
515 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
518 croak("suidperl is no longer needed since the kernel can now execute\n\
519 setuid perl scripts securely.\n");
523 if (!(curinterp = sv_interp))
526 #if defined(NeXT) && defined(__DYNAMIC__)
527 _dyld_lookup_and_bind
528 ("__environ", (unsigned long *) &environ_pointer, NULL);
533 #ifndef VMS /* VMS doesn't have environ array */
534 origenviron = environ;
540 /* Come here if running an undumped a.out. */
542 origfilename = savepv(argv[0]);
544 cxstack_ix = -1; /* start label stack again */
546 init_postdump_symbols(argc,argv,env);
554 switch (Sigsetjmp(top_env,1)) {
565 return(statusvalue); /* my_exit() was called */
567 PerlIO_printf(PerlIO_stderr(), "panic: top_env\n");
571 sv_setpvn(linestr,"",0);
572 sv = newSVpv("",0); /* first used for -I flags */
575 for (argc--,argv++; argc > 0; argc--,argv++) {
576 if (argv[0][0] != '-' || !argv[0][1])
580 validarg = " PHOOEY ";
606 if (s = moreswitches(s))
611 if (euid != uid || egid != gid)
612 croak("No -e allowed in setuid scripts");
614 e_tmpname = savepv(TMPPATH);
615 (void)mktemp(e_tmpname);
617 croak("Can't mktemp()");
618 e_fp = PerlIO_open(e_tmpname,"w");
620 croak("Cannot open temporary file");
625 PerlIO_puts(e_fp,argv[1]);
629 croak("No code specified for -e");
630 (void)PerlIO_putc(e_fp,'\n');
638 av_push(GvAVn(incgv),newSVpv(s,0));
641 av_push(GvAVn(incgv),newSVpv(argv[1],0));
642 sv_catpv(sv,argv[1]);
659 preambleav = newAV();
660 av_push(preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
662 Sv = newSVpv("print myconfig();",0);
664 sv_catpv(Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
666 sv_catpv(Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
668 #if defined(DEBUGGING) || defined(NOEMBED) || defined(MULTIPLICITY)
669 strcpy(buf,"\" Compile-time options:");
671 strcat(buf," DEBUGGING");
674 strcat(buf," NOEMBED");
677 strcat(buf," MULTIPLICITY");
679 strcat(buf,"\\n\",");
682 #if defined(LOCAL_PATCH_COUNT)
683 if (LOCAL_PATCH_COUNT > 0)
685 sv_catpv(Sv,"print \" Locally applied patches:\\n\",");
686 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
687 if (localpatches[i]) {
688 sprintf(buf,"\" \\t%s\\n\",",localpatches[i]);
694 sprintf(buf,"\" Built under %s\\n\",",OSNAME);
698 sprintf(buf,"\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
700 sprintf(buf,"\" Compiled on %s\\n\"",__DATE__);
704 sv_catpv(Sv,"; $\"=\"\\n \"; print \" \\@INC:\\n @INC\\n\"");
707 Sv = newSVpv("config_vars(qw(",0);
712 av_push(preambleav, Sv);
713 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
727 croak("Unrecognized switch: -%s",s);
732 scriptname = argv[0];
734 if (PerlIO_flush(e_fp) || PerlIO_error(e_fp) || PerlIO_close(e_fp))
735 croak("Can't write to temp file for -e: %s", Strerror(errno));
738 scriptname = e_tmpname;
740 else if (scriptname == Nullch) {
742 if ( isatty(PerlIO_fileno(PerlIO_stdin())) )
750 open_script(scriptname,dosearch,sv);
752 validate_suid(validarg, scriptname);
757 compcv = (CV*)NEWSV(1104,0);
758 sv_upgrade((SV *)compcv, SVt_PVCV);
762 av_push(comppad, Nullsv);
763 curpad = AvARRAY(comppad);
764 comppad_name = newAV();
765 comppad_name_fill = 0;
766 min_intro_pending = 0;
769 comppadlist = newAV();
770 AvREAL_off(comppadlist);
771 av_store(comppadlist, 0, (SV*)comppad_name);
772 av_store(comppadlist, 1, (SV*)comppad);
773 CvPADLIST(compcv) = comppadlist;
775 boot_core_UNIVERSAL();
777 (*xsinit)(); /* in case linked C routines want magical variables */
782 init_predump_symbols();
784 init_postdump_symbols(argc,argv,env);
788 /* now parse the script */
791 if (yyparse() || error_count) {
793 croak("%s had compilation errors.\n", origfilename);
795 croak("Execution of %s aborted due to compilation errors.\n",
799 curcop->cop_line = 0;
803 (void)UNLINK(e_tmpname);
808 /* now that script is parsed, we can modify record separator */
810 rs = SvREFCNT_inc(nrs);
811 sv_setsv(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), rs);
822 #ifdef DEBUGGING_MSTATS
823 if ((s=getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
824 dump_mstats("after compilation:");
834 PerlInterpreter *sv_interp;
836 if (!(curinterp = sv_interp))
838 switch (Sigsetjmp(top_env,1)) {
840 cxstack_ix = -1; /* start context stack again */
847 #ifdef DEBUGGING_MSTATS
848 if (getenv("PERL_DEBUG_MSTATS"))
849 dump_mstats("after execution: ");
851 return(statusvalue); /* my_exit() was called */
854 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
858 if (curstack != mainstack) {
860 SWITCHSTACK(curstack, mainstack);
865 DEBUG_r(PerlIO_printf(PerlIO_stderr(), "%s $` $& $' support.\n",
866 sawampersand ? "Enabling" : "Omitting"));
870 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
873 PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", origfilename);
876 if (perldb && DBsingle)
877 sv_setiv(DBsingle, 1);
887 else if (main_start) {
900 register CONTEXT *cx;
904 statusvalue = FIXSTATUS(status);
905 if (cxstack_ix >= 0) {
911 Siglongjmp(top_env, 2);
915 perl_get_sv(name, create)
919 GV* gv = gv_fetchpv(name, create, SVt_PV);
926 perl_get_av(name, create)
930 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
939 perl_get_hv(name, create)
943 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
952 perl_get_cv(name, create)
956 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
957 if (create && !GvCV(gv))
958 return newSUB(start_subparse(),
959 newSVOP(OP_CONST, 0, newSVpv(name,0)),
967 /* Be sure to refetch the stack pointer after calling these routines. */
970 perl_call_argv(subname, flags, argv)
972 I32 flags; /* See G_* flags in cop.h */
973 register char **argv; /* null terminated arg list */
980 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
985 return perl_call_pv(subname, flags);
989 perl_call_pv(subname, flags)
990 char *subname; /* name of the subroutine */
991 I32 flags; /* See G_* flags in cop.h */
993 return perl_call_sv((SV*)perl_get_cv(subname, TRUE), flags);
997 perl_call_method(methname, flags)
998 char *methname; /* name of the subroutine */
999 I32 flags; /* See G_* flags in cop.h */
1005 XPUSHs(sv_2mortal(newSVpv(methname,0)));
1008 return perl_call_sv(*stack_sp--, flags);
1011 /* May be called with any of a CV, a GV, or an SV containing the name. */
1013 perl_call_sv(sv, flags)
1015 I32 flags; /* See G_* flags in cop.h */
1017 LOGOP myop; /* fake syntax tree node */
1019 I32 oldmark = TOPMARK;
1025 if (flags & G_DISCARD) {
1033 EXTEND(stack_sp, 1);
1035 oldscope = scopestack_ix;
1037 if (!(flags & G_NOARGS))
1038 myop.op_flags = OPf_STACKED;
1039 myop.op_next = Nullop;
1040 myop.op_flags |= OPf_KNOW;
1041 if (flags & G_ARRAY)
1042 myop.op_flags |= OPf_LIST;
1044 if (perldb && curstash != debstash
1045 /* Handle first BEGIN of -d. */
1046 && (DBcv || (DBcv = GvCV(DBsub)))
1047 /* Try harder, since this may have been a sighandler, thus
1048 * curstash may be meaningless. */
1049 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != debstash))
1050 op->op_private |= OPpENTERSUB_DB;
1052 if (flags & G_EVAL) {
1053 Copy(top_env, oldtop, 1, Sigjmp_buf);
1055 cLOGOP->op_other = op;
1057 /* we're trying to emulate pp_entertry() here */
1059 register CONTEXT *cx;
1065 push_return(op->op_next);
1066 PUSHBLOCK(cx, CXt_EVAL, stack_sp);
1068 eval_root = op; /* Only needed so that goto works right. */
1071 if (flags & G_KEEPERR)
1074 sv_setpv(GvSV(errgv),"");
1079 switch (Sigsetjmp(top_env,1)) {
1084 statusvalue = 255; /* XXX I don't think we use 1 anymore. */
1090 /* my_exit() was called */
1091 curstash = defstash;
1093 Copy(oldtop, top_env, 1, Sigjmp_buf);
1095 croak("Callback called exit");
1096 my_exit(statusvalue);
1104 stack_sp = stack_base + oldmark;
1105 if (flags & G_ARRAY)
1109 *++stack_sp = &sv_undef;
1115 if (op == (OP*)&myop)
1119 retval = stack_sp - (stack_base + oldmark);
1120 if ((flags & G_EVAL) && !(flags & G_KEEPERR))
1121 sv_setpv(GvSV(errgv),"");
1124 if (flags & G_EVAL) {
1125 if (scopestack_ix > oldscope) {
1129 register CONTEXT *cx;
1138 Copy(oldtop, top_env, 1, Sigjmp_buf);
1140 if (flags & G_DISCARD) {
1141 stack_sp = stack_base + oldmark;
1149 /* Eval a string. The G_EVAL flag is always assumed. */
1152 perl_eval_sv(sv, flags)
1154 I32 flags; /* See G_* flags in cop.h */
1156 UNOP myop; /* fake syntax tree node */
1158 I32 oldmark = sp - stack_base;
1163 if (flags & G_DISCARD) {
1171 EXTEND(stack_sp, 1);
1173 oldscope = scopestack_ix;
1175 if (!(flags & G_NOARGS))
1176 myop.op_flags = OPf_STACKED;
1177 myop.op_next = Nullop;
1178 myop.op_type = OP_ENTEREVAL;
1179 myop.op_flags |= OPf_KNOW;
1180 if (flags & G_KEEPERR)
1181 myop.op_flags |= OPf_SPECIAL;
1182 if (flags & G_ARRAY)
1183 myop.op_flags |= OPf_LIST;
1185 Copy(top_env, oldtop, 1, Sigjmp_buf);
1188 switch (Sigsetjmp(top_env,1)) {
1193 statusvalue = 255; /* XXX I don't think we use 1 anymore. */
1199 /* my_exit() was called */
1200 curstash = defstash;
1202 Copy(oldtop, top_env, 1, Sigjmp_buf);
1204 croak("Callback called exit");
1205 my_exit(statusvalue);
1213 stack_sp = stack_base + oldmark;
1214 if (flags & G_ARRAY)
1218 *++stack_sp = &sv_undef;
1223 if (op == (OP*)&myop)
1224 op = pp_entereval();
1227 retval = stack_sp - (stack_base + oldmark);
1228 if (!(flags & G_KEEPERR))
1229 sv_setpv(GvSV(errgv),"");
1232 Copy(oldtop, top_env, 1, Sigjmp_buf);
1233 if (flags & G_DISCARD) {
1234 stack_sp = stack_base + oldmark;
1242 /* Require a module. */
1248 SV* sv = sv_newmortal();
1249 sv_setpv(sv, "require '");
1252 perl_eval_sv(sv, G_DISCARD);
1256 magicname(sym,name,namlen)
1263 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1264 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1268 # define PERLLIB_SEP ';'
1271 # define PERLLIB_SEP '|'
1273 # define PERLLIB_SEP ':'
1276 #ifndef PERLLIB_MANGLE
1277 # define PERLLIB_MANGLE(s,n) (s)
1289 /* Break at all separators */
1291 /* First, skip any consecutive separators */
1292 while ( *p == PERLLIB_SEP ) {
1293 /* Uncomment the next line for PATH semantics */
1294 /* av_push(GvAVn(incgv), newSVpv(".", 1)); */
1297 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
1298 av_push(GvAVn(incgv), newSVpv(PERLLIB_MANGLE(p, (STRLEN)(s - p)),
1302 av_push(GvAVn(incgv), newSVpv(PERLLIB_MANGLE(p, 0), 0));
1309 usage(name) /* XXX move this out into a module ? */
1312 /* This message really ought to be max 23 lines.
1313 * Removed -h because the user already knows that opton. Others? */
1314 printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1315 printf("\n -0[octal] specify record separator (\\0, if no argument)");
1316 printf("\n -a autosplit mode with -n or -p (splits $_ into @F)");
1317 printf("\n -c check syntax only (runs BEGIN and END blocks)");
1318 printf("\n -d[:debugger] run scripts under debugger");
1319 printf("\n -D[number/list] set debugging flags (argument is a bit mask or flags)");
1320 printf("\n -e 'command' one line of script. Several -e's allowed. Omit [programfile].");
1321 printf("\n -F/pattern/ split() pattern for autosplit (-a). The //'s are optional.");
1322 printf("\n -i[extension] edit <> files in place (make backup if extension supplied)");
1323 printf("\n -Idirectory specify @INC/#include directory (may be used more then once)");
1324 printf("\n -l[octal] enable line ending processing, specifies line teminator");
1325 printf("\n -[mM][-]module.. executes `use/no module...' before executing your script.");
1326 printf("\n -n assume 'while (<>) { ... }' loop arround your script");
1327 printf("\n -p assume loop like -n but print line also like sed");
1328 printf("\n -P run script through C preprocessor before compilation");
1329 printf("\n -s enable some switch parsing for switches after script name");
1330 printf("\n -S look for the script using PATH environment variable");
1331 printf("\n -T turn on tainting checks");
1332 printf("\n -u dump core after parsing script");
1333 printf("\n -U allow unsafe operations");
1334 printf("\n -v print version number and patchlevel of perl");
1335 printf("\n -V[:variable] print perl configuration information");
1336 printf("\n -w TURN WARNINGS ON FOR COMPILATION OF YOUR SCRIPT.");
1337 printf("\n -x[directory] strip off text before #!perl line and perhaps cd to directory\n");
1340 /* This routine handles any switches that can be given during run */
1351 rschar = scan_oct(s, 4, &numlen);
1353 if (rschar & ~((U8)~0))
1355 else if (!rschar && numlen >= 2)
1356 nrs = newSVpv("", 0);
1359 nrs = newSVpv(&ch, 1);
1364 splitstr = savepv(s + 1);
1378 if (*s == ':' || *s == '=') {
1379 sprintf(buf, "use Devel::%s;", ++s);
1381 my_setenv("PERL5DB",buf);
1391 if (isALPHA(s[1])) {
1392 static char debopts[] = "psltocPmfrxuLHXD";
1395 for (s++; *s && (d = strchr(debopts,*s)); s++)
1396 debug |= 1 << (d - debopts);
1400 for (s++; isDIGIT(*s); s++) ;
1402 debug |= 0x80000000;
1404 warn("Recompile perl with -DDEBUGGING to use -D switch\n");
1405 for (s++; isALNUM(*s); s++) ;
1415 inplace = savepv(s+1);
1417 for (s = inplace; *s && !isSPACE(*s); s++) ;
1424 for (e = s; *e && !isSPACE(*e); e++) ;
1425 av_push(GvAVn(incgv),newSVpv(s,e-s));
1430 croak("No space allowed after -I");
1440 *ors = scan_oct(s, 3 + (*s == '0'), &numlen);
1449 ors = SvPV(nrs, orslen);
1450 ors = savepvn(ors, orslen);
1454 forbid_setid("-M"); /* XXX ? */
1457 forbid_setid("-m"); /* XXX ? */
1461 /* -M-foo == 'no foo' */
1462 if (*s == '-') { use = "no "; ++s; }
1463 Sv = newSVpv(use,0);
1465 /* We allow -M'Module qw(Foo Bar)' */
1466 while(isALNUM(*s) || *s==':') ++s;
1468 sv_catpv(Sv, start);
1469 if (*(start-1) == 'm') {
1471 croak("Can't use '%c' after -mname", *s);
1472 sv_catpv( Sv, " ()");
1475 sv_catpvn(Sv, start, s-start);
1476 sv_catpv(Sv, " split(/,/,q{");
1481 if (preambleav == NULL)
1482 preambleav = newAV();
1483 av_push(preambleav, Sv);
1486 croak("No space allowed after -%c", *(s-1));
1514 #if defined(SUBVERSION) && SUBVERSION > 0
1515 printf("\nThis is perl, version 5.%03d_%02d", PATCHLEVEL, SUBVERSION);
1517 printf("\nThis is perl, version %s",patchlevel);
1520 printf("\n\nCopyright 1987-1996, Larry Wall\n");
1521 printf("\n\t+ suidperl security patch");
1523 printf("\n\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1526 printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
1529 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1530 "Version 5 port Copyright (c) 1994-1996, Andreas Kaiser, Ilya Zakharevich\n");
1533 printf("atariST series port, ++jrb bammi@cadence.com\n");
1536 Perl may be copied only under the terms of either the Artistic License or the\n\
1537 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n");
1545 if (s[1] == '-') /* Additional switches on #! line. */
1558 croak("Can't emulate -%.1s on #! line",s);
1563 /* compliments of Tom Christiansen */
1565 /* unexec() can be found in the Gnu emacs distribution */
1574 sprintf (buf, "%s.perldump", origfilename);
1575 sprintf (tokenbuf, "%s/perl", BIN);
1577 status = unexec(buf, tokenbuf, &etext, sbrk(0), 0);
1579 PerlIO_printf(PerlIO_stderr(), "unexec of %s into %s failed!\n", tokenbuf, buf);
1583 # include <lib$routines.h>
1584 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
1586 ABORT(); /* for use with undump */
1596 /* Note that strtab is a rather special HV. Assumptions are made
1597 about not iterating on it, and not adding tie magic to it.
1598 It is properly deallocated in perl_destruct() */
1600 HvSHAREKEYS_off(strtab); /* mandatory */
1601 Newz(506,((XPVHV*)SvANY(strtab))->xhv_array,
1602 sizeof(HE*) * (((XPVHV*)SvANY(strtab))->xhv_max + 1), char);
1604 curstash = defstash = newHV();
1605 curstname = newSVpv("main",4);
1606 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1607 SvREFCNT_dec(GvHV(gv));
1608 GvHV(gv) = (HV*)SvREFCNT_inc(defstash);
1610 HvNAME(defstash) = savepv("main");
1611 incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1613 defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1614 errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1616 sv_setpvn(GvSV(errgv), "", 0);
1617 curstash = defstash;
1618 compiling.cop_stash = defstash;
1619 debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
1620 /* We must init $/ before switches are processed. */
1621 sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1);
1624 #ifdef CAN_PROTOTYPE
1626 open_script(char *scriptname, bool dosearch, SV *sv)
1629 open_script(scriptname,dosearch,sv)
1635 char *xfound = Nullch;
1636 char *xfailed = Nullch;
1640 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
1641 #define SEARCH_EXTS ".bat", ".cmd", NULL
1644 # define SEARCH_EXTS ".pl", ".com", NULL
1646 /* additional extensions to try in each dir if scriptname not found */
1648 char *ext[] = { SEARCH_EXTS };
1649 int extidx = (strchr(scriptname,'.')) ? -1 : 0; /* has ext already */
1654 int hasdir, idx = 0, deftypes = 1;
1656 hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
1657 /* The first time through, just add SEARCH_EXTS to whatever we
1658 * already have, so we can check for default file types. */
1659 while (deftypes || (!hasdir && my_trnlnm("DCL$PATH",tokenbuf,idx++)) ) {
1660 if (deftypes) { deftypes = 0; *tokenbuf = '\0'; }
1661 strcat(tokenbuf,scriptname);
1663 if (dosearch && !strchr(scriptname, '/') && (s = getenv("PATH"))) {
1665 bufend = s + strlen(s);
1668 s = cpytill(tokenbuf,s,bufend,':',&len);
1671 for (len = 0; *s && *s != ',' && *s != ';'; tokenbuf[len++] = *s++);
1672 tokenbuf[len] = '\0';
1674 for (len = 0; *s && *s != ';'; tokenbuf[len++] = *s++);
1675 tokenbuf[len] = '\0';
1681 if (len && tokenbuf[len-1] != '/')
1684 if (len && ((tokenbuf[len-1] != '\\') && (tokenbuf[len-1] != '/')))
1686 if (len && tokenbuf[len-1] != '\\')
1689 (void)strcat(tokenbuf+len,"/");
1690 (void)strcat(tokenbuf+len,scriptname);
1694 len = strlen(tokenbuf);
1695 if (extidx > 0) /* reset after previous loop */
1699 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tokenbuf));
1700 retval = Stat(tokenbuf,&statbuf);
1702 } while ( retval < 0 /* not there */
1703 && extidx>=0 && ext[extidx] /* try an extension? */
1704 && strcpy(tokenbuf+len, ext[extidx++])
1709 if (S_ISREG(statbuf.st_mode)
1710 && cando(S_IRUSR,TRUE,&statbuf) && cando(S_IXUSR,TRUE,&statbuf)) {
1711 xfound = tokenbuf; /* bingo! */
1715 xfailed = savepv(tokenbuf);
1718 croak("Can't execute %s", xfailed ? xfailed : scriptname );
1721 scriptname = xfound;
1724 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
1725 char *s = scriptname + 8;
1734 origfilename = savepv(e_tmpname ? "-e" : scriptname);
1735 curcop->cop_filegv = gv_fetchfile(origfilename);
1736 if (strEQ(origfilename,"-"))
1738 if (fdscript >= 0) {
1739 rsfp = PerlIO_fdopen(fdscript,"r");
1740 #if defined(HAS_FCNTL) && defined(F_SETFD)
1742 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
1745 else if (preprocess) {
1746 char *cpp = CPPSTDIN;
1748 if (strEQ(cpp,"cppstdin"))
1749 sprintf(tokenbuf, "%s/%s", SCRIPTDIR, cpp);
1751 sprintf(tokenbuf, "%s", cpp);
1753 sv_catpv(sv,PRIVLIB_EXP);
1755 (void)sprintf(buf, "\
1756 sed %s -e \"/^[^#]/b\" \
1757 -e \"/^#[ ]*include[ ]/b\" \
1758 -e \"/^#[ ]*define[ ]/b\" \
1759 -e \"/^#[ ]*if[ ]/b\" \
1760 -e \"/^#[ ]*ifdef[ ]/b\" \
1761 -e \"/^#[ ]*ifndef[ ]/b\" \
1762 -e \"/^#[ ]*else/b\" \
1763 -e \"/^#[ ]*elif[ ]/b\" \
1764 -e \"/^#[ ]*undef[ ]/b\" \
1765 -e \"/^#[ ]*endif/b\" \
1768 (doextract ? "-e \"1,/^#/d\n\"" : ""),
1770 (void)sprintf(buf, "\
1771 %s %s -e '/^[^#]/b' \
1772 -e '/^#[ ]*include[ ]/b' \
1773 -e '/^#[ ]*define[ ]/b' \
1774 -e '/^#[ ]*if[ ]/b' \
1775 -e '/^#[ ]*ifdef[ ]/b' \
1776 -e '/^#[ ]*ifndef[ ]/b' \
1777 -e '/^#[ ]*else/b' \
1778 -e '/^#[ ]*elif[ ]/b' \
1779 -e '/^#[ ]*undef[ ]/b' \
1780 -e '/^#[ ]*endif/b' \
1788 (doextract ? "-e '1,/^#/d\n'" : ""),
1790 scriptname, tokenbuf, SvPV(sv, na), CPPMINUS);
1792 #ifdef IAMSUID /* actually, this is caught earlier */
1793 if (euid != uid && !euid) { /* if running suidperl */
1795 (void)seteuid(uid); /* musn't stay setuid root */
1798 (void)setreuid((Uid_t)-1, uid);
1800 #ifdef HAS_SETRESUID
1801 (void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
1807 if (geteuid() != uid)
1808 croak("Can't do seteuid!\n");
1810 #endif /* IAMSUID */
1811 rsfp = my_popen(buf,"r");
1813 else if (!*scriptname) {
1814 forbid_setid("program input from stdin");
1815 rsfp = PerlIO_stdin();
1818 rsfp = PerlIO_open(scriptname,"r");
1819 #if defined(HAS_FCNTL) && defined(F_SETFD)
1821 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
1829 #ifndef IAMSUID /* in case script is not readable before setuid */
1830 if (euid && Stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
1831 statbuf.st_mode & (S_ISUID|S_ISGID)) {
1832 (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
1833 execv(buf, origargv); /* try again */
1834 croak("Can't do setuid\n");
1838 croak("Can't open perl script \"%s\": %s\n",
1839 SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno));
1844 validate_suid(validarg, scriptname)
1850 /* do we need to emulate setuid on scripts? */
1852 /* This code is for those BSD systems that have setuid #! scripts disabled
1853 * in the kernel because of a security problem. Merely defining DOSUID
1854 * in perl will not fix that problem, but if you have disabled setuid
1855 * scripts in the kernel, this will attempt to emulate setuid and setgid
1856 * on scripts that have those now-otherwise-useless bits set. The setuid
1857 * root version must be called suidperl or sperlN.NNN. If regular perl
1858 * discovers that it has opened a setuid script, it calls suidperl with
1859 * the same argv that it had. If suidperl finds that the script it has
1860 * just opened is NOT setuid root, it sets the effective uid back to the
1861 * uid. We don't just make perl setuid root because that loses the
1862 * effective uid we had before invoking perl, if it was different from the
1865 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
1866 * be defined in suidperl only. suidperl must be setuid root. The
1867 * Configure script will set this up for you if you want it.
1873 if (Fstat(PerlIO_fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
1874 croak("Can't stat script \"%s\"",origfilename);
1875 if (fdscript < 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) {
1879 #ifndef HAS_SETREUID
1880 /* On this access check to make sure the directories are readable,
1881 * there is actually a small window that the user could use to make
1882 * filename point to an accessible directory. So there is a faint
1883 * chance that someone could execute a setuid script down in a
1884 * non-accessible directory. I don't know what to do about that.
1885 * But I don't think it's too important. The manual lies when
1886 * it says access() is useful in setuid programs.
1888 if (access(SvPVX(GvSV(curcop->cop_filegv)),1)) /*double check*/
1889 croak("Permission denied");
1891 /* If we can swap euid and uid, then we can determine access rights
1892 * with a simple stat of the file, and then compare device and
1893 * inode to make sure we did stat() on the same file we opened.
1894 * Then we just have to make sure he or she can execute it.
1897 struct stat tmpstatbuf;
1901 setreuid(euid,uid) < 0
1904 setresuid(euid,uid,(Uid_t)-1) < 0
1907 || getuid() != euid || geteuid() != uid)
1908 croak("Can't swap uid and euid"); /* really paranoid */
1909 if (Stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
1910 croak("Permission denied"); /* testing full pathname here */
1911 if (tmpstatbuf.st_dev != statbuf.st_dev ||
1912 tmpstatbuf.st_ino != statbuf.st_ino) {
1913 (void)PerlIO_close(rsfp);
1914 if (rsfp = my_popen("/bin/mail root","w")) { /* heh, heh */
1916 "User %d tried to run dev %d ino %d in place of dev %d ino %d!\n\
1917 (Filename of set-id script was %s, uid %d gid %d.)\n\nSincerely,\nperl\n",
1918 uid,tmpstatbuf.st_dev, tmpstatbuf.st_ino,
1919 statbuf.st_dev, statbuf.st_ino,
1920 SvPVX(GvSV(curcop->cop_filegv)),
1921 statbuf.st_uid, statbuf.st_gid);
1922 (void)my_pclose(rsfp);
1924 croak("Permission denied\n");
1928 setreuid(uid,euid) < 0
1930 # if defined(HAS_SETRESUID)
1931 setresuid(uid,euid,(Uid_t)-1) < 0
1934 || getuid() != uid || geteuid() != euid)
1935 croak("Can't reswap uid and euid");
1936 if (!cando(S_IXUSR,FALSE,&statbuf)) /* can real uid exec? */
1937 croak("Permission denied\n");
1939 #endif /* HAS_SETREUID */
1940 #endif /* IAMSUID */
1942 if (!S_ISREG(statbuf.st_mode))
1943 croak("Permission denied");
1944 if (statbuf.st_mode & S_IWOTH)
1945 croak("Setuid/gid script is writable by world");
1946 doswitches = FALSE; /* -s is insecure in suid */
1948 if (sv_gets(linestr, rsfp, 0) == Nullch ||
1949 strnNE(SvPV(linestr,na),"#!",2) ) /* required even on Sys V */
1950 croak("No #! line");
1951 s = SvPV(linestr,na)+2;
1953 while (!isSPACE(*s)) s++;
1954 for (s2 = s; (s2 > SvPV(linestr,na)+2 &&
1955 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
1956 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
1957 croak("Not a perl script");
1958 while (*s == ' ' || *s == '\t') s++;
1960 * #! arg must be what we saw above. They can invoke it by
1961 * mentioning suidperl explicitly, but they may not add any strange
1962 * arguments beyond what #! says if they do invoke suidperl that way.
1964 len = strlen(validarg);
1965 if (strEQ(validarg," PHOOEY ") ||
1966 strnNE(s,validarg,len) || !isSPACE(s[len]))
1967 croak("Args must match #! line");
1970 if (euid != uid && (statbuf.st_mode & S_ISUID) &&
1971 euid == statbuf.st_uid)
1973 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
1974 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
1975 #endif /* IAMSUID */
1977 if (euid) { /* oops, we're not the setuid root perl */
1978 (void)PerlIO_close(rsfp);
1980 (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
1981 execv(buf, origargv); /* try again */
1983 croak("Can't do setuid\n");
1986 if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
1988 (void)setegid(statbuf.st_gid);
1991 (void)setregid((Gid_t)-1,statbuf.st_gid);
1993 #ifdef HAS_SETRESGID
1994 (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
1996 setgid(statbuf.st_gid);
2000 if (getegid() != statbuf.st_gid)
2001 croak("Can't do setegid!\n");
2003 if (statbuf.st_mode & S_ISUID) {
2004 if (statbuf.st_uid != euid)
2006 (void)seteuid(statbuf.st_uid); /* all that for this */
2009 (void)setreuid((Uid_t)-1,statbuf.st_uid);
2011 #ifdef HAS_SETRESUID
2012 (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
2014 setuid(statbuf.st_uid);
2018 if (geteuid() != statbuf.st_uid)
2019 croak("Can't do seteuid!\n");
2021 else if (uid) { /* oops, mustn't run as root */
2023 (void)seteuid((Uid_t)uid);
2026 (void)setreuid((Uid_t)-1,(Uid_t)uid);
2028 #ifdef HAS_SETRESUID
2029 (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
2035 if (geteuid() != uid)
2036 croak("Can't do seteuid!\n");
2039 if (!cando(S_IXUSR,TRUE,&statbuf))
2040 croak("Permission denied\n"); /* they can't do this */
2043 else if (preprocess)
2044 croak("-P not allowed for setuid/setgid script\n");
2045 else if (fdscript >= 0)
2046 croak("fd script not allowed in suidperl\n");
2048 croak("Script is not setuid/setgid in suidperl\n");
2050 /* We absolutely must clear out any saved ids here, so we */
2051 /* exec the real perl, substituting fd script for scriptname. */
2052 /* (We pass script name as "subdir" of fd, which perl will grok.) */
2053 PerlIO_rewind(rsfp);
2054 lseek(PerlIO_fileno(rsfp),(Off_t)0,0); /* just in case rewind didn't */
2055 for (which = 1; origargv[which] && origargv[which] != scriptname; which++) ;
2056 if (!origargv[which])
2057 croak("Permission denied");
2058 (void)sprintf(buf, "/dev/fd/%d/%.127s", PerlIO_fileno(rsfp), origargv[which]);
2059 origargv[which] = buf;
2061 #if defined(HAS_FCNTL) && defined(F_SETFD)
2062 fcntl(PerlIO_fileno(rsfp),F_SETFD,0); /* ensure no close-on-exec */
2065 (void)sprintf(tokenbuf, "%s/perl%s", BIN, patchlevel);
2066 execv(tokenbuf, origargv); /* try again */
2067 croak("Can't do setuid\n");
2068 #endif /* IAMSUID */
2070 if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */
2071 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2072 Fstat(PerlIO_fileno(rsfp),&statbuf); /* may be either wrapped or real suid */
2073 if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
2075 (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
2078 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2079 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2080 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2081 /* not set-id, must be wrapped */
2089 register char *s, *s2;
2091 /* skip forward in input to the real script? */
2095 if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
2096 croak("No Perl script found in input\n");
2097 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2098 PerlIO_ungetc(rsfp, '\n'); /* to keep line count right */
2100 while (*s && !(isSPACE (*s) || *s == '#')) s++;
2102 while (*s == ' ' || *s == '\t') s++;
2104 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2105 if (strnEQ(s2-4,"perl",4))
2107 while (s = moreswitches(s)) ;
2109 if (cddir && chdir(cddir) < 0)
2110 croak("Can't chdir to %s",cddir);
2118 uid = (int)getuid();
2119 euid = (int)geteuid();
2120 gid = (int)getgid();
2121 egid = (int)getegid();
2126 tainting |= (uid && (euid != uid || egid != gid));
2134 croak("No %s allowed while running setuid", s);
2136 croak("No %s allowed while running setgid", s);
2142 curstash = debstash;
2143 dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2145 DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2146 DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2147 DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2148 DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2149 sv_setiv(DBsingle, 0);
2150 DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2151 sv_setiv(DBtrace, 0);
2152 DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2153 sv_setiv(DBsignal, 0);
2154 curstash = defstash;
2161 mainstack = curstack; /* remember in case we switch stacks */
2162 AvREAL_off(curstack); /* not a real array */
2163 av_extend(curstack,127);
2165 stack_base = AvARRAY(curstack);
2166 stack_sp = stack_base;
2167 stack_max = stack_base + 127;
2169 cxstack_max = 8192 / sizeof(CONTEXT) - 2; /* Use most of 8K. */
2170 New(50,cxstack,cxstack_max + 1,CONTEXT);
2173 New(50,tmps_stack,128,SV*);
2178 New(51,debname,128,char);
2179 New(52,debdelim,128,char);
2183 * The following stacks almost certainly should be per-interpreter,
2184 * but for now they're not. XXX
2188 markstack_ptr = markstack;
2190 New(54,markstack,64,I32);
2191 markstack_ptr = markstack;
2192 markstack_max = markstack + 64;
2198 New(54,scopestack,32,I32);
2200 scopestack_max = 32;
2206 New(54,savestack,128,ANY);
2208 savestack_max = 128;
2214 New(54,retstack,16,OP*);
2224 Safefree(tmps_stack);
2231 static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
2239 subname = newSVpv("main",4);
2243 init_predump_symbols()
2248 sv_setpvn(GvSV(gv_fetchpv("\"", TRUE, SVt_PV)), " ", 1);
2250 stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2251 GvMULTI_on(stdingv);
2252 IoIFP(GvIOp(stdingv)) = PerlIO_stdin();
2253 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2255 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv));
2257 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2259 IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
2261 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2263 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv));
2265 othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2266 GvMULTI_on(othergv);
2267 IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr();
2268 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2270 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
2272 statname = NEWSV(66,0); /* last filename we did stat on */
2275 osname = savepv(OSNAME);
2279 init_postdump_symbols(argc,argv,env)
2281 register char **argv;
2282 register char **env;
2288 argc--,argv++; /* skip name of script */
2290 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2293 if (argv[0][1] == '-') {
2297 if (s = strchr(argv[0], '=')) {
2299 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2302 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2305 toptarget = NEWSV(0,0);
2306 sv_upgrade(toptarget, SVt_PVFM);
2307 sv_setpvn(toptarget, "", 0);
2308 bodytarget = NEWSV(0,0);
2309 sv_upgrade(bodytarget, SVt_PVFM);
2310 sv_setpvn(bodytarget, "", 0);
2311 formtarget = bodytarget;
2314 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2315 sv_setpv(GvSV(tmpgv),origfilename);
2316 magicname("0", "0", 1);
2318 if (tmpgv = gv_fetchpv("\024",TRUE, SVt_PV))
2320 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2321 sv_setpv(GvSV(tmpgv),origargv[0]);
2322 if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2324 (void)gv_AVadd(argvgv);
2325 av_clear(GvAVn(argvgv));
2326 for (; argc > 0; argc--,argv++) {
2327 av_push(GvAVn(argvgv),newSVpv(argv[0],0));
2330 if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2335 #ifndef VMS /* VMS doesn't have environ array */
2336 /* Note that if the supplied env parameter is actually a copy
2337 of the global environ then it may now point to free'd memory
2338 if the environment has been modified since. To avoid this
2339 problem we treat env==NULL as meaning 'use the default'
2343 if (env != environ) {
2344 environ[0] = Nullch;
2345 hv_magic(hv, envgv, 'E');
2347 for (; *env; env++) {
2348 if (!(s = strchr(*env,'=')))
2351 sv = newSVpv(s--,0);
2352 sv_magic(sv, sv, 'e', *env, s - *env);
2353 (void)hv_store(hv, *env, s - *env, sv, 0);
2357 #ifdef DYNAMIC_ENV_FETCH
2358 HvNAME(hv) = savepv(ENV_HV_NAME);
2360 hv_magic(hv, envgv, 'E');
2363 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2364 sv_setiv(GvSV(tmpgv),(I32)getpid());
2373 s = getenv("PERL5LIB");
2377 incpush(getenv("PERLLIB"));
2379 /* Treat PERL5?LIB as a possible search list logical name -- the
2380 * "natural" VMS idiom for a Unix path string. We allow each
2381 * element to be a set of |-separated directories for compatibility.
2385 if (my_trnlnm("PERL5LIB",buf,0))
2386 do { incpush(buf); } while (my_trnlnm("PERL5LIB",buf,++idx));
2388 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf);
2392 /* Use the ~-expanded versions of APPLIB (undocumented),
2393 ARCHLIB PRIVLIB SITEARCH SITELIB and OLDARCHLIB
2396 incpush(APPLLIB_EXP);
2400 incpush(ARCHLIB_EXP);
2403 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2405 incpush(PRIVLIB_EXP);
2408 incpush(SITEARCH_EXP);
2411 incpush(SITELIB_EXP);
2413 #ifdef OLDARCHLIB_EXP /* 5.00[01] compatibility */
2414 incpush(OLDARCHLIB_EXP);
2427 line_t oldline = curcop->cop_line;
2429 Copy(top_env, oldtop, 1, Sigjmp_buf);
2431 while (AvFILL(list) >= 0) {
2432 CV *cv = (CV*)av_shift(list);
2436 switch (Sigsetjmp(top_env,1)) {
2438 SV* atsv = GvSV(errgv);
2440 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
2441 (void)SvPV(atsv, len);
2443 Copy(oldtop, top_env, 1, Sigjmp_buf);
2444 curcop = &compiling;
2445 curcop->cop_line = oldline;
2446 if (list == beginav)
2447 sv_catpv(atsv, "BEGIN failed--compilation aborted");
2449 sv_catpv(atsv, "END failed--cleanup aborted");
2450 croak("%s", SvPVX(atsv));
2456 statusvalue = 255; /* XXX I don't think we use 1 anymore. */
2462 /* my_exit() was called */
2463 curstash = defstash;
2467 Copy(oldtop, top_env, 1, Sigjmp_buf);
2468 curcop = &compiling;
2469 curcop->cop_line = oldline;
2471 if (list == beginav)
2472 croak("BEGIN failed--compilation aborted");
2474 croak("END failed--cleanup aborted");
2476 my_exit(statusvalue);
2481 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
2485 Copy(oldtop, top_env, 1, Sigjmp_buf);
2486 curcop = &compiling;
2487 curcop->cop_line = oldline;
2488 Siglongjmp(top_env, 3);
2492 Copy(oldtop, top_env, 1, Sigjmp_buf);