3 * Copyright (c) 1987-1997 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 #if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE)
24 char *getenv _((char *)); /* Usually in <stdlib.h> */
27 dEXTCONST char rcsid[] = "perl.c\nPatch level: ###\n";
35 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
45 curcop = &compiling; \
52 laststype = OP_STAT; \
54 maxsysfd = MAXSYSFD; \
61 laststype = OP_STAT; \
65 static void find_beginning _((void));
66 static void forbid_setid _((char *));
67 static void incpush _((char *, int));
68 static void init_ids _((void));
69 static void init_debugger _((void));
70 static void init_lexer _((void));
71 static void init_main_stash _((void));
72 static void init_perllib _((void));
73 static void init_postdump_symbols _((int, char **, char **));
74 static void init_predump_symbols _((void));
75 static void my_exit_jump _((void)) __attribute__((noreturn));
76 static void nuke_stacks _((void));
77 static void open_script _((char *, bool, SV *));
79 static void thread_destruct _((void *));
80 #endif /* USE_THREADS */
81 static void usage _((char *));
82 static void validate_suid _((char *, char*));
84 static int fdscript = -1;
89 PerlInterpreter *sv_interp;
92 New(53, sv_interp, 1, PerlInterpreter);
97 perl_construct( sv_interp )
98 register PerlInterpreter *sv_interp;
102 #endif /* USE_THREADS */
104 if (!(curinterp = sv_interp))
108 Zero(sv_interp, 1, PerlInterpreter);
112 #ifdef NEED_PTHREAD_INIT
114 #endif /* NEED_PTHREAD_INIT */
115 New(53, thr, 1, struct thread);
116 self = pthread_self();
117 if (pthread_key_create(&thr_key, thread_destruct))
118 croak("panic: pthread_key_create");
119 if (pthread_setspecific(thr_key, (void *) thr))
120 croak("panic: pthread_setspecific");
124 #endif /* USE_THREADS */
126 /* Init the real globals? */
128 linestr = NEWSV(65,80);
129 sv_upgrade(linestr,SVt_PVIV);
131 if (!SvREADONLY(&sv_undef)) {
132 SvREADONLY_on(&sv_undef);
136 SvREADONLY_on(&sv_no);
138 sv_setpv(&sv_yes,Yes);
140 SvREADONLY_on(&sv_yes);
143 nrs = newSVpv("\n", 1);
144 rs = SvREFCNT_inc(nrs);
146 MUTEX_INIT(&malloc_mutex);
147 MUTEX_INIT(&sv_mutex);
148 MUTEX_INIT(&eval_mutex);
149 MUTEX_INIT(&nthreads_mutex);
150 COND_INIT(&nthreads_cond);
156 * There is no way we can refer to them from Perl so close them to save
157 * space. The other alternative would be to provide STDAUX and STDPRN
160 (void)fclose(stdaux);
161 (void)fclose(stdprn);
167 perl_destruct_level = 1;
169 if(perl_destruct_level > 0)
175 start_env.je_prev = NULL;
176 start_env.je_ret = -1;
177 start_env.je_mustcatch = TRUE;
178 top_env = &start_env;
181 SET_NUMERIC_STANDARD();
182 #if defined(SUBVERSION) && SUBVERSION > 0
183 sprintf(patchlevel, "%7.5f", (double) 5
184 + ((double) PATCHLEVEL / (double) 1000)
185 + ((double) SUBVERSION / (double) 100000));
187 sprintf(patchlevel, "%5.3f", (double) 5 +
188 ((double) PATCHLEVEL / (double) 1000));
191 #if defined(LOCAL_PATCH_COUNT)
192 localpatches = local_patches; /* For possible -v */
195 PerlIO_init(); /* Hook to IO system */
197 fdpid = newAV(); /* for remembering popen pids by fd */
201 New(51,debname,128,char);
202 New(52,debdelim,128,char);
213 struct thread *thr = (struct thread *) arg;
215 * Decrement the global thread count and signal anyone listening.
216 * The only official thread listening is the original thread while
217 * in perl_destruct. It waits until it's the only thread and then
218 * performs END blocks and other process clean-ups.
220 DEBUG_L(fprintf(stderr, "thread_destruct: 0x%lx\n", (unsigned long) thr));
223 MUTEX_LOCK(&nthreads_mutex);
225 COND_BROADCAST(&nthreads_cond);
226 MUTEX_UNLOCK(&nthreads_mutex);
228 #endif /* USE_THREADS */
231 perl_destruct(sv_interp)
232 register PerlInterpreter *sv_interp;
235 int destruct_level; /* 0=none, 1=full, 2=full with checks */
239 if (!(curinterp = sv_interp))
243 /* Wait until all user-created threads go away */
244 MUTEX_LOCK(&nthreads_mutex);
247 DEBUG_L(fprintf(stderr, "perl_destruct: waiting for %d threads\n",
249 COND_WAIT(&nthreads_cond, &nthreads_mutex);
251 /* At this point, we're the last thread */
252 MUTEX_UNLOCK(&nthreads_mutex);
253 DEBUG_L(fprintf(stderr, "perl_destruct: armageddon has arrived\n"));
254 MUTEX_DESTROY(&nthreads_mutex);
255 COND_DESTROY(&nthreads_cond);
256 #endif /* USE_THREADS */
258 destruct_level = perl_destruct_level;
262 if (s = getenv("PERL_DESTRUCT_LEVEL")) {
264 if (destruct_level < i)
273 /* We must account for everything. */
275 /* Destroy the main CV and syntax tree */
277 curpad = AvARRAY(comppad);
282 SvREFCNT_dec(main_cv);
287 * Try to destruct global references. We do this first so that the
288 * destructors and destructees still exist. Some sv's might remain.
289 * Non-referenced objects are on their own.
296 /* unhook hooks which will soon be, or use, destroyed data */
297 SvREFCNT_dec(warnhook);
299 SvREFCNT_dec(diehook);
301 SvREFCNT_dec(parsehook);
304 if (destruct_level == 0){
306 DEBUG_P(debprofdump());
308 /* The exit() function will do everything that needs doing. */
312 /* loosen bonds of global variables */
315 (void)PerlIO_close(rsfp);
319 /* Filters for program text */
320 SvREFCNT_dec(rsfp_filters);
321 rsfp_filters = Nullav;
333 sawampersand = FALSE; /* must save all match strings */
334 sawstudy = FALSE; /* do fbm_instr on all strings */
349 /* magical thingies */
351 Safefree(ofs); /* $, */
354 Safefree(ors); /* $\ */
357 SvREFCNT_dec(nrs); /* $\ helper */
360 multiline = 0; /* $* */
362 SvREFCNT_dec(statname);
366 /* defgv, aka *_ should be taken care of elsewhere */
368 #if 0 /* just about all regexp stuff, seems to be ok */
370 /* shortcuts to regexp stuff */
375 SAVEFREEOP(oldlastpm); /* for saving regexp context during debugger */
377 regprecomp = NULL; /* uncompiled string. */
378 regparse = NULL; /* Input-scan pointer. */
379 regxend = NULL; /* End of input for compile */
380 regnpar = 0; /* () count. */
381 regcode = NULL; /* Code-emit pointer; ®dummy = don't. */
382 regsize = 0; /* Code size. */
383 regnaughty = 0; /* How bad is this pattern? */
384 regsawback = 0; /* Did we see \1, ...? */
386 reginput = NULL; /* String-input pointer. */
387 regbol = NULL; /* Beginning of input, for ^ check. */
388 regeol = NULL; /* End of input, for $ check. */
389 regstartp = (char **)NULL; /* Pointer to startp array. */
390 regendp = (char **)NULL; /* Ditto for endp. */
391 reglastparen = 0; /* Similarly for lastparen. */
392 regtill = NULL; /* How far we are required to go. */
393 regflags = 0; /* are we folding, multilining? */
394 regprev = (char)NULL; /* char before regbol, \n if none */
398 /* clean up after study() */
399 SvREFCNT_dec(lastscream);
401 Safefree(screamfirst);
403 Safefree(screamnext);
406 /* startup and shutdown function lists */
407 SvREFCNT_dec(beginav);
412 /* temp stack during pp_sort() */
413 SvREFCNT_dec(sortstack);
416 /* shortcuts just get cleared */
426 /* reset so print() ends up where we expect */
429 /* Prepare to destruct main symbol table. */
436 if (destruct_level >= 2) {
437 if (scopestack_ix != 0)
438 warn("Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
439 (long)scopestack_ix);
440 if (savestack_ix != 0)
441 warn("Unbalanced saves: %ld more saves than restores\n",
443 if (tmps_floor != -1)
444 warn("Unbalanced tmps: %ld more allocs than frees\n",
445 (long)tmps_floor + 1);
446 if (cxstack_ix != -1)
447 warn("Unbalanced context: %ld more PUSHes than POPs\n",
448 (long)cxstack_ix + 1);
451 /* Now absolutely destruct everything, somehow or other, loops or no. */
453 SvFLAGS(strtab) |= SVTYPEMASK; /* don't clean out strtab now */
454 while (sv_count != 0 && sv_count != last_sv_count) {
455 last_sv_count = sv_count;
458 SvFLAGS(strtab) &= ~SVTYPEMASK;
459 SvFLAGS(strtab) |= SVt_PVHV;
461 /* Destruct the global string table. */
463 /* Yell and reset the HeVAL() slots that are still holding refcounts,
464 * so that sv_free() won't fail on them.
473 array = HvARRAY(strtab);
477 warn("Unbalanced string table refcount: (%d) for \"%s\"",
478 HeVAL(hent) - Nullsv, HeKEY(hent));
479 HeVAL(hent) = Nullsv;
489 SvREFCNT_dec(strtab);
492 warn("Scalars leaked: %ld\n", (long)sv_count);
496 /* No SVs have survived, need to clean out */
500 Safefree(origfilename);
502 hints = 0; /* Reset hints. Should hints be per-interpreter ? */
504 DEBUG_P(debprofdump());
506 MUTEX_DESTROY(&sv_mutex);
507 MUTEX_DESTROY(&malloc_mutex);
508 MUTEX_DESTROY(&eval_mutex);
509 #endif /* USE_THREADS */
511 /* As the absolutely last thing, free the non-arena SV for mess() */
514 /* we know that type >= SVt_PV */
516 Safefree(SvPVX(mess_sv));
517 Safefree(SvANY(mess_sv));
525 PerlInterpreter *sv_interp;
527 if (!(curinterp = sv_interp))
533 perl_parse(sv_interp, xsinit, argc, argv, env)
534 PerlInterpreter *sv_interp;
535 void (*xsinit)_((void));
543 char *scriptname = NULL;
544 VOL bool dosearch = FALSE;
551 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
554 croak("suidperl is no longer needed since the kernel can now execute\n\
555 setuid perl scripts securely.\n");
559 if (!(curinterp = sv_interp))
562 #if defined(NeXT) && defined(__DYNAMIC__)
563 _dyld_lookup_and_bind
564 ("__environ", (unsigned long *) &environ_pointer, NULL);
569 #ifndef VMS /* VMS doesn't have environ array */
570 origenviron = environ;
576 /* Come here if running an undumped a.out. */
578 origfilename = savepv(argv[0]);
580 cxstack_ix = -1; /* start label stack again */
582 init_postdump_symbols(argc,argv,env);
587 curpad = AvARRAY(comppad);
592 SvREFCNT_dec(main_cv);
596 oldscope = scopestack_ix;
604 /* my_exit() was called */
605 while (scopestack_ix > oldscope)
609 call_list(oldscope, endav);
611 return STATUS_NATIVE_EXPORT;
614 PerlIO_printf(PerlIO_stderr(), "panic: top_env\n");
618 sv_setpvn(linestr,"",0);
619 sv = newSVpv("",0); /* first used for -I flags */
623 for (argc--,argv++; argc > 0; argc--,argv++) {
624 if (argv[0][0] != '-' || !argv[0][1])
628 validarg = " PHOOEY ";
653 if (s = moreswitches(s))
663 if (euid != uid || egid != gid)
664 croak("No -e allowed in setuid scripts");
666 e_tmpname = savepv(TMPPATH);
667 (void)mktemp(e_tmpname);
669 croak("Can't mktemp()");
670 e_fp = PerlIO_open(e_tmpname,"w");
672 croak("Cannot open temporary file");
677 PerlIO_puts(e_fp,argv[1]);
681 croak("No code specified for -e");
682 (void)PerlIO_putc(e_fp,'\n');
693 incpush(argv[1], TRUE);
694 sv_catpv(sv,argv[1]);
711 preambleav = newAV();
712 av_push(preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
714 Sv = newSVpv("print myconfig();",0);
716 sv_catpv(Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
718 sv_catpv(Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
720 #if defined(DEBUGGING) || defined(NO_EMBED) || defined(MULTIPLICITY)
721 sv_catpv(Sv,"\" Compile-time options:");
723 sv_catpv(Sv," DEBUGGING");
726 sv_catpv(Sv," NO_EMBED");
729 sv_catpv(Sv," MULTIPLICITY");
731 sv_catpv(Sv,"\\n\",");
733 #if defined(LOCAL_PATCH_COUNT)
734 if (LOCAL_PATCH_COUNT > 0) {
736 sv_catpv(Sv,"\" Locally applied patches:\\n\",");
737 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
739 sv_catpvf(Sv,"\" \\t%s\\n\",",localpatches[i]);
743 sv_catpvf(Sv,"\" Built under %s\\n\"",OSNAME);
746 sv_catpvf(Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
748 sv_catpvf(Sv,",\" Compiled on %s\\n\"",__DATE__);
753 @env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; \
754 print \" \\%ENV:\\n @env\\n\" if @env; \
755 print \" \\@INC:\\n @INC\\n\";");
758 Sv = newSVpv("config_vars(qw(",0);
763 av_push(preambleav, Sv);
764 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
778 croak("Unrecognized switch: -%s",s);
783 if (!tainting && (s = getenv("PERL5OPT"))) {
794 if (!strchr("DIMUdmw", *s))
795 croak("Illegal switch in PERL5OPT: -%c", *s);
801 scriptname = argv[0];
803 if (PerlIO_flush(e_fp) || PerlIO_error(e_fp) || PerlIO_close(e_fp)) {
805 warn("Did you forget to compile with -DMULTIPLICITY?");
807 croak("Can't write to temp file for -e: %s", Strerror(errno));
811 scriptname = e_tmpname;
813 else if (scriptname == Nullch) {
815 if ( isatty(PerlIO_fileno(PerlIO_stdin())) )
823 open_script(scriptname,dosearch,sv);
825 validate_suid(validarg, scriptname);
830 main_cv = compcv = (CV*)NEWSV(1104,0);
831 sv_upgrade((SV *)compcv, SVt_PVCV);
835 New(666, CvMUTEXP(compcv), 1, pthread_mutex_t);
836 MUTEX_INIT(CvMUTEXP(compcv));
837 New(666, CvCONDP(compcv), 1, pthread_cond_t);
838 COND_INIT(CvCONDP(compcv));
839 #endif /* USE_THREADS */
842 av_push(comppad, Nullsv);
843 curpad = AvARRAY(comppad);
844 comppad_name = newAV();
845 comppad_name_fill = 0;
847 av_store(comppad_name, 0, newSVpv("@_", 2));
848 #endif /* USE_THREADS */
849 min_intro_pending = 0;
852 comppadlist = newAV();
853 AvREAL_off(comppadlist);
854 av_store(comppadlist, 0, (SV*)comppad_name);
855 av_store(comppadlist, 1, (SV*)comppad);
856 CvPADLIST(compcv) = comppadlist;
858 boot_core_UNIVERSAL();
860 (*xsinit)(); /* in case linked C routines want magical variables */
865 init_predump_symbols();
867 init_postdump_symbols(argc,argv,env);
871 /* now parse the script */
874 if (yyparse() || error_count) {
876 croak("%s had compilation errors.\n", origfilename);
878 croak("Execution of %s aborted due to compilation errors.\n",
882 curcop->cop_line = 0;
886 (void)UNLINK(e_tmpname);
891 /* now that script is parsed, we can modify record separator */
893 rs = SvREFCNT_inc(nrs);
894 sv_setsv(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), rs);
905 #ifdef DEBUGGING_MSTATS
906 if ((s=getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
907 dump_mstats("after compilation:");
918 PerlInterpreter *sv_interp;
925 if (!(curinterp = sv_interp))
928 oldscope = scopestack_ix;
933 cxstack_ix = -1; /* start context stack again */
936 /* my_exit() was called */
937 while (scopestack_ix > oldscope)
941 call_list(oldscope, endav);
943 #ifdef DEBUGGING_MSTATS
944 if (getenv("PERL_DEBUG_MSTATS"))
945 dump_mstats("after execution: ");
948 return STATUS_NATIVE_EXPORT;
951 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
956 if (curstack != mainstack) {
958 SWITCHSTACK(curstack, mainstack);
963 DEBUG_r(PerlIO_printf(PerlIO_stderr(), "%s $` $& $' support.\n",
964 sawampersand ? "Enabling" : "Omitting"));
968 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
970 DEBUG_L(PerlIO_printf(Perl_debug_log, "main thread is 0x%lx\n",
971 (unsigned long) thr));
972 #endif /* USE_THREADS */
975 PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", origfilename);
978 if (perldb && DBsingle)
979 sv_setiv(DBsingle, 1);
981 call_list(oldscope, restartav);
991 else if (main_start) {
992 CvDEPTH(main_cv) = 1;
1003 perl_get_sv(name, create)
1007 GV* gv = gv_fetchpv(name, create, SVt_PV);
1014 perl_get_av(name, create)
1018 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1027 perl_get_hv(name, create)
1031 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1040 perl_get_cv(name, create)
1044 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
1045 if (create && !GvCVu(gv))
1046 return newSUB(start_subparse(FALSE, 0),
1047 newSVOP(OP_CONST, 0, newSVpv(name,0)),
1055 /* Be sure to refetch the stack pointer after calling these routines. */
1058 perl_call_argv(subname, flags, argv)
1060 I32 flags; /* See G_* flags in cop.h */
1061 register char **argv; /* null terminated arg list */
1069 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
1074 return perl_call_pv(subname, flags);
1078 perl_call_pv(subname, flags)
1079 char *subname; /* name of the subroutine */
1080 I32 flags; /* See G_* flags in cop.h */
1082 return perl_call_sv((SV*)perl_get_cv(subname, TRUE), flags);
1086 perl_call_method(methname, flags)
1087 char *methname; /* name of the subroutine */
1088 I32 flags; /* See G_* flags in cop.h */
1095 XPUSHs(sv_2mortal(newSVpv(methname,0)));
1098 return perl_call_sv(*stack_sp--, flags);
1101 /* May be called with any of a CV, a GV, or an SV containing the name. */
1103 perl_call_sv(sv, flags)
1105 I32 flags; /* See G_* flags in cop.h */
1108 LOGOP myop; /* fake syntax tree node */
1114 bool oldcatch = CATCH_GET;
1118 if (flags & G_DISCARD) {
1123 Zero(&myop, 1, LOGOP);
1124 myop.op_next = Nullop;
1125 if (!(flags & G_NOARGS))
1126 myop.op_flags |= OPf_STACKED;
1127 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1128 (flags & G_ARRAY) ? OPf_WANT_LIST :
1133 EXTEND(stack_sp, 1);
1136 oldscope = scopestack_ix;
1138 if (perldb && curstash != debstash
1139 /* Handle first BEGIN of -d. */
1140 && (DBcv || (DBcv = GvCV(DBsub)))
1141 /* Try harder, since this may have been a sighandler, thus
1142 * curstash may be meaningless. */
1143 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != debstash))
1144 op->op_private |= OPpENTERSUB_DB;
1146 if (flags & G_EVAL) {
1147 cLOGOP->op_other = op;
1149 /* we're trying to emulate pp_entertry() here */
1151 register CONTEXT *cx;
1152 I32 gimme = GIMME_V;
1157 push_return(op->op_next);
1158 PUSHBLOCK(cx, CXt_EVAL, stack_sp);
1160 eval_root = op; /* Only needed so that goto works right. */
1163 if (flags & G_KEEPERR)
1166 sv_setpv(GvSV(errgv),"");
1178 /* my_exit() was called */
1179 curstash = defstash;
1183 croak("Callback called exit");
1192 stack_sp = stack_base + oldmark;
1193 if (flags & G_ARRAY)
1197 *++stack_sp = &sv_undef;
1205 if (op == (OP*)&myop)
1206 op = pp_entersub(ARGS);
1209 retval = stack_sp - (stack_base + oldmark);
1210 if ((flags & G_EVAL) && !(flags & G_KEEPERR))
1211 sv_setpv(GvSV(errgv),"");
1214 if (flags & G_EVAL) {
1215 if (scopestack_ix > oldscope) {
1219 register CONTEXT *cx;
1231 CATCH_SET(oldcatch);
1233 if (flags & G_DISCARD) {
1234 stack_sp = stack_base + oldmark;
1242 /* Eval a string. The G_EVAL flag is always assumed. */
1245 perl_eval_sv(sv, flags)
1247 I32 flags; /* See G_* flags in cop.h */
1250 UNOP myop; /* fake syntax tree node */
1252 I32 oldmark = sp - stack_base;
1258 if (flags & G_DISCARD) {
1266 EXTEND(stack_sp, 1);
1268 oldscope = scopestack_ix;
1270 if (!(flags & G_NOARGS))
1271 myop.op_flags = OPf_STACKED;
1272 myop.op_next = Nullop;
1273 myop.op_type = OP_ENTEREVAL;
1274 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1275 (flags & G_ARRAY) ? OPf_WANT_LIST :
1277 if (flags & G_KEEPERR)
1278 myop.op_flags |= OPf_SPECIAL;
1288 /* my_exit() was called */
1289 curstash = defstash;
1293 croak("Callback called exit");
1302 stack_sp = stack_base + oldmark;
1303 if (flags & G_ARRAY)
1307 *++stack_sp = &sv_undef;
1312 if (op == (OP*)&myop)
1313 op = pp_entereval(ARGS);
1316 retval = stack_sp - (stack_base + oldmark);
1317 if (!(flags & G_KEEPERR))
1318 sv_setpv(GvSV(errgv),"");
1322 if (flags & G_DISCARD) {
1323 stack_sp = stack_base + oldmark;
1332 perl_eval_pv(p, croak_on_error)
1337 SV* sv = newSVpv(p, 0);
1340 perl_eval_sv(sv, G_SCALAR);
1347 if (croak_on_error && SvTRUE(GvSV(errgv)))
1348 croak(SvPVx(GvSV(errgv), na));
1353 /* Require a module. */
1359 SV* sv = sv_newmortal();
1360 sv_setpv(sv, "require '");
1363 perl_eval_sv(sv, G_DISCARD);
1367 magicname(sym,name,namlen)
1374 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1375 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1379 usage(name) /* XXX move this out into a module ? */
1382 /* This message really ought to be max 23 lines.
1383 * Removed -h because the user already knows that opton. Others? */
1384 printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1385 printf("\n -0[octal] specify record separator (\\0, if no argument)");
1386 printf("\n -a autosplit mode with -n or -p (splits $_ into @F)");
1387 printf("\n -c check syntax only (runs BEGIN and END blocks)");
1388 printf("\n -d[:debugger] run scripts under debugger");
1389 printf("\n -D[number/list] set debugging flags (argument is a bit mask or flags)");
1390 printf("\n -e 'command' one line of script. Several -e's allowed. Omit [programfile].");
1391 printf("\n -F/pattern/ split() pattern for autosplit (-a). The //'s are optional.");
1392 printf("\n -i[extension] edit <> files in place (make backup if extension supplied)");
1393 printf("\n -Idirectory specify @INC/#include directory (may be used more then once)");
1394 printf("\n -l[octal] enable line ending processing, specifies line teminator");
1395 printf("\n -[mM][-]module.. executes `use/no module...' before executing your script.");
1396 printf("\n -n assume 'while (<>) { ... }' loop arround your script");
1397 printf("\n -p assume loop like -n but print line also like sed");
1398 printf("\n -P run script through C preprocessor before compilation");
1399 printf("\n -s enable some switch parsing for switches after script name");
1400 printf("\n -S look for the script using PATH environment variable");
1401 printf("\n -T turn on tainting checks");
1402 printf("\n -u dump core after parsing script");
1403 printf("\n -U allow unsafe operations");
1404 printf("\n -v print version number and patchlevel of perl");
1405 printf("\n -V[:variable] print perl configuration information");
1406 printf("\n -w TURN WARNINGS ON FOR COMPILATION OF YOUR SCRIPT.");
1407 printf("\n -x[directory] strip off text before #!perl line and perhaps cd to directory\n");
1410 /* This routine handles any switches that can be given during run */
1421 rschar = scan_oct(s, 4, &numlen);
1423 if (rschar & ~((U8)~0))
1425 else if (!rschar && numlen >= 2)
1426 nrs = newSVpv("", 0);
1429 nrs = newSVpv(&ch, 1);
1434 splitstr = savepv(s + 1);
1448 if (*s == ':' || *s == '=') {
1449 my_setenv("PERL5DB", form("use Devel::%s;", ++s));
1460 if (isALPHA(s[1])) {
1461 static char debopts[] = "psltocPmfrxuLHXD";
1464 for (s++; *s && (d = strchr(debopts,*s)); s++)
1465 debug |= 1 << (d - debopts);
1469 for (s++; isDIGIT(*s); s++) ;
1471 debug |= 0x80000000;
1473 warn("Recompile perl with -DDEBUGGING to use -D switch\n");
1474 for (s++; isALNUM(*s); s++) ;
1484 inplace = savepv(s+1);
1486 for (s = inplace; *s && !isSPACE(*s); s++) ;
1493 for (e = s; *e && !isSPACE(*e); e++) ;
1494 p = savepvn(s, e-s);
1501 croak("No space allowed after -I");
1511 *ors = scan_oct(s, 3 + (*s == '0'), &numlen);
1520 ors = SvPV(nrs, orslen);
1521 ors = savepvn(ors, orslen);
1525 forbid_setid("-M"); /* XXX ? */
1528 forbid_setid("-m"); /* XXX ? */
1533 /* -M-foo == 'no foo' */
1534 if (*s == '-') { use = "no "; ++s; }
1535 sv = newSVpv(use,0);
1537 /* We allow -M'Module qw(Foo Bar)' */
1538 while(isALNUM(*s) || *s==':') ++s;
1540 sv_catpv(sv, start);
1541 if (*(start-1) == 'm') {
1543 croak("Can't use '%c' after -mname", *s);
1544 sv_catpv( sv, " ()");
1547 sv_catpvn(sv, start, s-start);
1548 sv_catpv(sv, " split(/,/,q{");
1553 if (preambleav == NULL)
1554 preambleav = newAV();
1555 av_push(preambleav, sv);
1558 croak("No space allowed after -%c", *(s-1));
1575 croak("Too late for \"-T\" option");
1587 #if defined(SUBVERSION) && SUBVERSION > 0
1588 printf("\nThis is perl, version 5.%03d_%02d", PATCHLEVEL, SUBVERSION);
1590 printf("\nThis is perl, version %s",patchlevel);
1593 printf("\n\nCopyright 1987-1997, Larry Wall\n");
1595 printf("\n\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1598 printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
1601 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1602 "Version 5 port Copyright (c) 1994-1997, Andreas Kaiser, Ilya Zakharevich\n");
1605 printf("atariST series port, ++jrb bammi@cadence.com\n");
1608 Perl may be copied only under the terms of either the Artistic License or the\n\
1609 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n");
1617 if (s[1] == '-') /* Additional switches on #! line. */
1625 #ifdef ALTERNATE_SHEBANG
1626 case 'S': /* OS/2 needs -S on "extproc" line. */
1634 croak("Can't emulate -%.1s on #! line",s);
1639 /* compliments of Tom Christiansen */
1641 /* unexec() can be found in the Gnu emacs distribution */
1652 prog = newSVpv(BIN_EXP);
1653 sv_catpv(prog, "/perl");
1654 file = newSVpv(origfilename);
1655 sv_catpv(file, ".perldump");
1657 status = unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
1659 PerlIO_printf(PerlIO_stderr(), "unexec of %s into %s failed!\n",
1660 SvPVX(prog), SvPVX(file));
1664 # include <lib$routines.h>
1665 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
1667 ABORT(); /* for use with undump */
1678 /* Note that strtab is a rather special HV. Assumptions are made
1679 about not iterating on it, and not adding tie magic to it.
1680 It is properly deallocated in perl_destruct() */
1682 HvSHAREKEYS_off(strtab); /* mandatory */
1683 Newz(506,((XPVHV*)SvANY(strtab))->xhv_array,
1684 sizeof(HE*) * (((XPVHV*)SvANY(strtab))->xhv_max + 1), char);
1686 curstash = defstash = newHV();
1687 curstname = newSVpv("main",4);
1688 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1689 SvREFCNT_dec(GvHV(gv));
1690 GvHV(gv) = (HV*)SvREFCNT_inc(defstash);
1692 HvNAME(defstash) = savepv("main");
1693 incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1695 defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1696 errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1698 sv_setpvn(GvSV(errgv), "", 0);
1699 curstash = defstash;
1700 compiling.cop_stash = defstash;
1701 debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
1702 /* We must init $/ before switches are processed. */
1703 sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1);
1706 #ifdef CAN_PROTOTYPE
1708 open_script(char *scriptname, bool dosearch, SV *sv)
1711 open_script(scriptname,dosearch,sv)
1717 char *xfound = Nullch;
1718 char *xfailed = Nullch;
1722 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
1723 # define SEARCH_EXTS ".bat", ".cmd", NULL
1724 # define MAX_EXT_LEN 4
1727 # define SEARCH_EXTS ".pl", ".com", NULL
1728 # define MAX_EXT_LEN 4
1730 /* additional extensions to try in each dir if scriptname not found */
1732 char *ext[] = { SEARCH_EXTS };
1733 int extidx = (strchr(scriptname,'.')) ? -1 : 0; /* has ext already */
1735 # define MAX_EXT_LEN 0
1740 int hasdir, idx = 0, deftypes = 1;
1742 hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
1743 /* The first time through, just add SEARCH_EXTS to whatever we
1744 * already have, so we can check for default file types. */
1746 (!hasdir && my_trnlnm("DCL$PATH",tokenbuf,idx++)) )
1752 if ((strlen(tokenbuf) + strlen(scriptname)
1753 + MAX_EXT_LEN) >= sizeof tokenbuf)
1754 continue; /* don't search dir with too-long name */
1755 strcat(tokenbuf, scriptname);
1757 if (dosearch && !strchr(scriptname, '/') && (s = getenv("PATH"))) {
1758 bufend = s + strlen(s);
1759 while (s < bufend) {
1761 s = delimcpy(tokenbuf, tokenbuf + sizeof tokenbuf, s, bufend,
1769 for (len = 0; *s && *s != ',' && *s != ';'; len++, s++) {
1770 if (len < sizeof tokenbuf)
1773 if (len < sizeof tokenbuf)
1774 tokenbuf[len] = '\0';
1775 #endif /* atarist */
1778 if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tokenbuf)
1779 continue; /* don't search dir with too-long name */
1781 #if defined(atarist) && !defined(DOSISH)
1782 && tokenbuf[len - 1] != '/'
1784 #if defined(atarist) || defined(DOSISH)
1785 && tokenbuf[len - 1] != '\\'
1788 tokenbuf[len++] = '/';
1789 (void)strcpy(tokenbuf + len, scriptname);
1793 len = strlen(tokenbuf);
1794 if (extidx > 0) /* reset after previous loop */
1798 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tokenbuf));
1799 retval = Stat(tokenbuf,&statbuf);
1801 } while ( retval < 0 /* not there */
1802 && extidx>=0 && ext[extidx] /* try an extension? */
1803 && strcpy(tokenbuf+len, ext[extidx++])
1808 if (S_ISREG(statbuf.st_mode)
1809 && cando(S_IRUSR,TRUE,&statbuf)
1811 && cando(S_IXUSR,TRUE,&statbuf)
1815 xfound = tokenbuf; /* bingo! */
1819 xfailed = savepv(tokenbuf);
1822 croak("Can't execute %s", xfailed ? xfailed : scriptname );
1825 scriptname = xfound;
1828 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
1829 char *s = scriptname + 8;
1838 origfilename = savepv(e_tmpname ? "-e" : scriptname);
1839 curcop->cop_filegv = gv_fetchfile(origfilename);
1840 if (strEQ(origfilename,"-"))
1842 if (fdscript >= 0) {
1843 rsfp = PerlIO_fdopen(fdscript,"r");
1844 #if defined(HAS_FCNTL) && defined(F_SETFD)
1846 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
1849 else if (preprocess) {
1850 char *cpp_cfg = CPPSTDIN;
1851 SV *cpp = NEWSV(0,0);
1852 SV *cmd = NEWSV(0,0);
1854 if (strEQ(cpp_cfg, "cppstdin"))
1855 sv_catpvf(cpp, "%s/", BIN_EXP);
1856 sv_catpv(cpp, cpp_cfg);
1859 sv_catpv(sv,PRIVLIB_EXP);
1863 sed %s -e \"/^[^#]/b\" \
1864 -e \"/^#[ ]*include[ ]/b\" \
1865 -e \"/^#[ ]*define[ ]/b\" \
1866 -e \"/^#[ ]*if[ ]/b\" \
1867 -e \"/^#[ ]*ifdef[ ]/b\" \
1868 -e \"/^#[ ]*ifndef[ ]/b\" \
1869 -e \"/^#[ ]*else/b\" \
1870 -e \"/^#[ ]*elif[ ]/b\" \
1871 -e \"/^#[ ]*undef[ ]/b\" \
1872 -e \"/^#[ ]*endif/b\" \
1875 (doextract ? "-e \"1,/^#/d\n\"" : ""),
1878 %s %s -e '/^[^#]/b' \
1879 -e '/^#[ ]*include[ ]/b' \
1880 -e '/^#[ ]*define[ ]/b' \
1881 -e '/^#[ ]*if[ ]/b' \
1882 -e '/^#[ ]*ifdef[ ]/b' \
1883 -e '/^#[ ]*ifndef[ ]/b' \
1884 -e '/^#[ ]*else/b' \
1885 -e '/^#[ ]*elif[ ]/b' \
1886 -e '/^#[ ]*undef[ ]/b' \
1887 -e '/^#[ ]*endif/b' \
1895 (doextract ? "-e '1,/^#/d\n'" : ""),
1897 scriptname, cpp, sv, CPPMINUS);
1899 #ifdef IAMSUID /* actually, this is caught earlier */
1900 if (euid != uid && !euid) { /* if running suidperl */
1902 (void)seteuid(uid); /* musn't stay setuid root */
1905 (void)setreuid((Uid_t)-1, uid);
1907 #ifdef HAS_SETRESUID
1908 (void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
1914 if (geteuid() != uid)
1915 croak("Can't do seteuid!\n");
1917 #endif /* IAMSUID */
1918 rsfp = my_popen(SvPVX(cmd), "r");
1922 else if (!*scriptname) {
1923 forbid_setid("program input from stdin");
1924 rsfp = PerlIO_stdin();
1927 rsfp = PerlIO_open(scriptname,"r");
1928 #if defined(HAS_FCNTL) && defined(F_SETFD)
1930 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
1938 #ifndef IAMSUID /* in case script is not readable before setuid */
1939 if (euid && Stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
1940 statbuf.st_mode & (S_ISUID|S_ISGID)) {
1942 execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
1943 croak("Can't do setuid\n");
1947 croak("Can't open perl script \"%s\": %s\n",
1948 SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno));
1953 validate_suid(validarg, scriptname)
1959 /* do we need to emulate setuid on scripts? */
1961 /* This code is for those BSD systems that have setuid #! scripts disabled
1962 * in the kernel because of a security problem. Merely defining DOSUID
1963 * in perl will not fix that problem, but if you have disabled setuid
1964 * scripts in the kernel, this will attempt to emulate setuid and setgid
1965 * on scripts that have those now-otherwise-useless bits set. The setuid
1966 * root version must be called suidperl or sperlN.NNN. If regular perl
1967 * discovers that it has opened a setuid script, it calls suidperl with
1968 * the same argv that it had. If suidperl finds that the script it has
1969 * just opened is NOT setuid root, it sets the effective uid back to the
1970 * uid. We don't just make perl setuid root because that loses the
1971 * effective uid we had before invoking perl, if it was different from the
1974 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
1975 * be defined in suidperl only. suidperl must be setuid root. The
1976 * Configure script will set this up for you if you want it.
1982 if (Fstat(PerlIO_fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
1983 croak("Can't stat script \"%s\"",origfilename);
1984 if (fdscript < 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) {
1988 #ifndef HAS_SETREUID
1989 /* On this access check to make sure the directories are readable,
1990 * there is actually a small window that the user could use to make
1991 * filename point to an accessible directory. So there is a faint
1992 * chance that someone could execute a setuid script down in a
1993 * non-accessible directory. I don't know what to do about that.
1994 * But I don't think it's too important. The manual lies when
1995 * it says access() is useful in setuid programs.
1997 if (access(SvPVX(GvSV(curcop->cop_filegv)),1)) /*double check*/
1998 croak("Permission denied");
2000 /* If we can swap euid and uid, then we can determine access rights
2001 * with a simple stat of the file, and then compare device and
2002 * inode to make sure we did stat() on the same file we opened.
2003 * Then we just have to make sure he or she can execute it.
2006 struct stat tmpstatbuf;
2010 setreuid(euid,uid) < 0
2013 setresuid(euid,uid,(Uid_t)-1) < 0
2016 || getuid() != euid || geteuid() != uid)
2017 croak("Can't swap uid and euid"); /* really paranoid */
2018 if (Stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
2019 croak("Permission denied"); /* testing full pathname here */
2020 if (tmpstatbuf.st_dev != statbuf.st_dev ||
2021 tmpstatbuf.st_ino != statbuf.st_ino) {
2022 (void)PerlIO_close(rsfp);
2023 if (rsfp = my_popen("/bin/mail root","w")) { /* heh, heh */
2025 "User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2026 (Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
2027 (long)uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
2028 (long)statbuf.st_dev, (long)statbuf.st_ino,
2029 SvPVX(GvSV(curcop->cop_filegv)),
2030 (long)statbuf.st_uid, (long)statbuf.st_gid);
2031 (void)my_pclose(rsfp);
2033 croak("Permission denied\n");
2037 setreuid(uid,euid) < 0
2039 # if defined(HAS_SETRESUID)
2040 setresuid(uid,euid,(Uid_t)-1) < 0
2043 || getuid() != uid || geteuid() != euid)
2044 croak("Can't reswap uid and euid");
2045 if (!cando(S_IXUSR,FALSE,&statbuf)) /* can real uid exec? */
2046 croak("Permission denied\n");
2048 #endif /* HAS_SETREUID */
2049 #endif /* IAMSUID */
2051 if (!S_ISREG(statbuf.st_mode))
2052 croak("Permission denied");
2053 if (statbuf.st_mode & S_IWOTH)
2054 croak("Setuid/gid script is writable by world");
2055 doswitches = FALSE; /* -s is insecure in suid */
2057 if (sv_gets(linestr, rsfp, 0) == Nullch ||
2058 strnNE(SvPV(linestr,na),"#!",2) ) /* required even on Sys V */
2059 croak("No #! line");
2060 s = SvPV(linestr,na)+2;
2062 while (!isSPACE(*s)) s++;
2063 for (s2 = s; (s2 > SvPV(linestr,na)+2 &&
2064 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
2065 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
2066 croak("Not a perl script");
2067 while (*s == ' ' || *s == '\t') s++;
2069 * #! arg must be what we saw above. They can invoke it by
2070 * mentioning suidperl explicitly, but they may not add any strange
2071 * arguments beyond what #! says if they do invoke suidperl that way.
2073 len = strlen(validarg);
2074 if (strEQ(validarg," PHOOEY ") ||
2075 strnNE(s,validarg,len) || !isSPACE(s[len]))
2076 croak("Args must match #! line");
2079 if (euid != uid && (statbuf.st_mode & S_ISUID) &&
2080 euid == statbuf.st_uid)
2082 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2083 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2084 #endif /* IAMSUID */
2086 if (euid) { /* oops, we're not the setuid root perl */
2087 (void)PerlIO_close(rsfp);
2090 execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
2092 croak("Can't do setuid\n");
2095 if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
2097 (void)setegid(statbuf.st_gid);
2100 (void)setregid((Gid_t)-1,statbuf.st_gid);
2102 #ifdef HAS_SETRESGID
2103 (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
2105 setgid(statbuf.st_gid);
2109 if (getegid() != statbuf.st_gid)
2110 croak("Can't do setegid!\n");
2112 if (statbuf.st_mode & S_ISUID) {
2113 if (statbuf.st_uid != euid)
2115 (void)seteuid(statbuf.st_uid); /* all that for this */
2118 (void)setreuid((Uid_t)-1,statbuf.st_uid);
2120 #ifdef HAS_SETRESUID
2121 (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
2123 setuid(statbuf.st_uid);
2127 if (geteuid() != statbuf.st_uid)
2128 croak("Can't do seteuid!\n");
2130 else if (uid) { /* oops, mustn't run as root */
2132 (void)seteuid((Uid_t)uid);
2135 (void)setreuid((Uid_t)-1,(Uid_t)uid);
2137 #ifdef HAS_SETRESUID
2138 (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
2144 if (geteuid() != uid)
2145 croak("Can't do seteuid!\n");
2148 if (!cando(S_IXUSR,TRUE,&statbuf))
2149 croak("Permission denied\n"); /* they can't do this */
2152 else if (preprocess)
2153 croak("-P not allowed for setuid/setgid script\n");
2154 else if (fdscript >= 0)
2155 croak("fd script not allowed in suidperl\n");
2157 croak("Script is not setuid/setgid in suidperl\n");
2159 /* We absolutely must clear out any saved ids here, so we */
2160 /* exec the real perl, substituting fd script for scriptname. */
2161 /* (We pass script name as "subdir" of fd, which perl will grok.) */
2162 PerlIO_rewind(rsfp);
2163 lseek(PerlIO_fileno(rsfp),(Off_t)0,0); /* just in case rewind didn't */
2164 for (which = 1; origargv[which] && origargv[which] != scriptname; which++) ;
2165 if (!origargv[which])
2166 croak("Permission denied");
2167 origargv[which] = savepv(form("/dev/fd/%d/%s",
2168 PerlIO_fileno(rsfp), origargv[which]));
2169 #if defined(HAS_FCNTL) && defined(F_SETFD)
2170 fcntl(PerlIO_fileno(rsfp),F_SETFD,0); /* ensure no close-on-exec */
2172 execv(form("%s/perl%s", BIN_EXP, patchlevel), origargv); /* try again */
2173 croak("Can't do setuid\n");
2174 #endif /* IAMSUID */
2176 if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */
2177 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2178 Fstat(PerlIO_fileno(rsfp),&statbuf); /* may be either wrapped or real suid */
2179 if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
2181 (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
2184 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2185 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2186 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2187 /* not set-id, must be wrapped */
2195 register char *s, *s2;
2197 /* skip forward in input to the real script? */
2201 if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
2202 croak("No Perl script found in input\n");
2203 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2204 PerlIO_ungetc(rsfp, '\n'); /* to keep line count right */
2206 while (*s && !(isSPACE (*s) || *s == '#')) s++;
2208 while (*s == ' ' || *s == '\t') s++;
2210 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2211 if (strnEQ(s2-4,"perl",4))
2213 while (s = moreswitches(s)) ;
2215 if (cddir && chdir(cddir) < 0)
2216 croak("Can't chdir to %s",cddir);
2224 uid = (int)getuid();
2225 euid = (int)geteuid();
2226 gid = (int)getgid();
2227 egid = (int)getegid();
2232 tainting |= (uid && (euid != uid || egid != gid));
2240 croak("No %s allowed while running setuid", s);
2242 croak("No %s allowed while running setgid", s);
2249 curstash = debstash;
2250 dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2252 DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2253 DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2254 DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2255 DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2256 sv_setiv(DBsingle, 0);
2257 DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2258 sv_setiv(DBtrace, 0);
2259 DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2260 sv_setiv(DBsignal, 0);
2261 curstash = defstash;
2269 mainstack = curstack; /* remember in case we switch stacks */
2270 AvREAL_off(curstack); /* not a real array */
2271 av_extend(curstack,127);
2273 stack_base = AvARRAY(curstack);
2274 stack_sp = stack_base;
2275 stack_max = stack_base + 127;
2277 cxstack_max = 8192 / sizeof(CONTEXT) - 2; /* Use most of 8K. */
2278 New(50,cxstack,cxstack_max + 1,CONTEXT);
2281 New(50,tmps_stack,128,SV*);
2286 * The following stacks almost certainly should be per-interpreter,
2287 * but for now they're not. XXX
2291 markstack_ptr = markstack;
2293 New(54,markstack,64,I32);
2294 markstack_ptr = markstack;
2295 markstack_max = markstack + 64;
2301 New(54,scopestack,32,I32);
2303 scopestack_max = 32;
2309 New(54,savestack,128,ANY);
2311 savestack_max = 128;
2317 New(54,retstack,16,OP*);
2327 Safefree(tmps_stack);
2335 static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
2343 subname = newSVpv("main",4);
2347 init_predump_symbols()
2353 sv_setpvn(GvSV(gv_fetchpv("\"", TRUE, SVt_PV)), " ", 1);
2355 stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2356 GvMULTI_on(stdingv);
2357 IoIFP(GvIOp(stdingv)) = PerlIO_stdin();
2358 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2360 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv));
2362 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2364 IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
2366 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2368 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv));
2370 othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2371 GvMULTI_on(othergv);
2372 IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr();
2373 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2375 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
2377 statname = NEWSV(66,0); /* last filename we did stat on */
2380 osname = savepv(OSNAME);
2384 init_postdump_symbols(argc,argv,env)
2386 register char **argv;
2387 register char **env;
2393 argc--,argv++; /* skip name of script */
2395 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2398 if (argv[0][1] == '-') {
2402 if (s = strchr(argv[0], '=')) {
2404 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2407 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2410 toptarget = NEWSV(0,0);
2411 sv_upgrade(toptarget, SVt_PVFM);
2412 sv_setpvn(toptarget, "", 0);
2413 bodytarget = NEWSV(0,0);
2414 sv_upgrade(bodytarget, SVt_PVFM);
2415 sv_setpvn(bodytarget, "", 0);
2416 formtarget = bodytarget;
2419 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2420 sv_setpv(GvSV(tmpgv),origfilename);
2421 magicname("0", "0", 1);
2423 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2424 sv_setpv(GvSV(tmpgv),origargv[0]);
2425 if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2427 (void)gv_AVadd(argvgv);
2428 av_clear(GvAVn(argvgv));
2429 for (; argc > 0; argc--,argv++) {
2430 av_push(GvAVn(argvgv),newSVpv(argv[0],0));
2433 if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2437 hv_magic(hv, envgv, 'E');
2438 #ifndef VMS /* VMS doesn't have environ array */
2439 /* Note that if the supplied env parameter is actually a copy
2440 of the global environ then it may now point to free'd memory
2441 if the environment has been modified since. To avoid this
2442 problem we treat env==NULL as meaning 'use the default'
2447 environ[0] = Nullch;
2448 for (; *env; env++) {
2449 if (!(s = strchr(*env,'=')))
2455 sv = newSVpv(s--,0);
2456 (void)hv_store(hv, *env, s - *env, sv, 0);
2460 #ifdef DYNAMIC_ENV_FETCH
2461 HvNAME(hv) = savepv(ENV_HV_NAME);
2465 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2466 sv_setiv(GvSV(tmpgv), (IV)getpid());
2475 s = getenv("PERL5LIB");
2479 incpush(getenv("PERLLIB"), FALSE);
2481 /* Treat PERL5?LIB as a possible search list logical name -- the
2482 * "natural" VMS idiom for a Unix path string. We allow each
2483 * element to be a set of |-separated directories for compatibility.
2487 if (my_trnlnm("PERL5LIB",buf,0))
2488 do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2490 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2494 /* Use the ~-expanded versions of APPLLIB (undocumented),
2495 ARCHLIB PRIVLIB SITEARCH SITELIB and OLDARCHLIB
2498 incpush(APPLLIB_EXP, FALSE);
2502 incpush(ARCHLIB_EXP, FALSE);
2505 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2507 incpush(PRIVLIB_EXP, FALSE);
2510 incpush(SITEARCH_EXP, FALSE);
2513 incpush(SITELIB_EXP, FALSE);
2515 #ifdef OLDARCHLIB_EXP /* 5.00[01] compatibility */
2516 incpush(OLDARCHLIB_EXP, FALSE);
2520 incpush(".", FALSE);
2524 # define PERLLIB_SEP ';'
2527 # define PERLLIB_SEP '|'
2529 # define PERLLIB_SEP ':'
2532 #ifndef PERLLIB_MANGLE
2533 # define PERLLIB_MANGLE(s,n) (s)
2537 incpush(p, addsubdirs)
2541 SV *subdir = Nullsv;
2542 static char *archpat_auto;
2549 if (!archpat_auto) {
2550 STRLEN len = (sizeof(ARCHNAME) + strlen(patchlevel)
2551 + sizeof("//auto"));
2552 New(55, archpat_auto, len, char);
2553 sprintf(archpat_auto, "/%s/%s/auto", ARCHNAME, patchlevel);
2555 for (len = sizeof(ARCHNAME) + 2;
2556 archpat_auto[len] != '\0' && archpat_auto[len] != '/'; len++)
2557 if (archpat_auto[len] == '.') archpat_auto[len] = '_';
2562 /* Break at all separators */
2564 SV *libdir = newSV(0);
2567 /* skip any consecutive separators */
2568 while ( *p == PERLLIB_SEP ) {
2569 /* Uncomment the next line for PATH semantics */
2570 /* av_push(GvAVn(incgv), newSVpv(".", 1)); */
2574 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2575 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2580 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2581 p = Nullch; /* break out */
2585 * BEFORE pushing libdir onto @INC we may first push version- and
2586 * archname-specific sub-directories.
2589 struct stat tmpstatbuf;
2594 if ((unix = tounixspec_ts(SvPV(libdir,na),Nullch)) != Nullch) {
2596 while (unix[len-1] == '/') len--; /* Cosmetic */
2597 sv_usepvn(libdir,unix,len);
2600 PerlIO_printf(PerlIO_stderr(),
2601 "Failed to unixify @INC element \"%s\"\n",
2604 /* .../archname/version if -d .../archname/version/auto */
2605 sv_setsv(subdir, libdir);
2606 sv_catpv(subdir, archpat_auto);
2607 if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2608 S_ISDIR(tmpstatbuf.st_mode))
2609 av_push(GvAVn(incgv),
2610 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2612 /* .../archname if -d .../archname/auto */
2613 sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
2614 strlen(patchlevel) + 1, "", 0);
2615 if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2616 S_ISDIR(tmpstatbuf.st_mode))
2617 av_push(GvAVn(incgv),
2618 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2621 /* finally push this lib directory on the end of @INC */
2622 av_push(GvAVn(incgv), libdir);
2625 SvREFCNT_dec(subdir);
2629 call_list(oldscope, list)
2634 line_t oldline = curcop->cop_line;
2639 while (AvFILL(list) >= 0) {
2640 CV *cv = (CV*)av_shift(list);
2647 SV* atsv = GvSV(errgv);
2649 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
2650 (void)SvPV(atsv, len);
2653 curcop = &compiling;
2654 curcop->cop_line = oldline;
2655 if (list == beginav)
2656 sv_catpv(atsv, "BEGIN failed--compilation aborted");
2658 sv_catpv(atsv, "END failed--cleanup aborted");
2659 while (scopestack_ix > oldscope)
2661 croak("%s", SvPVX(atsv));
2669 /* my_exit() was called */
2670 while (scopestack_ix > oldscope)
2672 curstash = defstash;
2674 call_list(oldscope, endav);
2677 curcop = &compiling;
2678 curcop->cop_line = oldline;
2680 if (list == beginav)
2681 croak("BEGIN failed--compilation aborted");
2683 croak("END failed--cleanup aborted");
2689 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
2694 curcop = &compiling;
2695 curcop->cop_line = oldline;
2709 DEBUG_L(PerlIO_printf(Perl_debug_log, "my_exit: thread 0x%lx, status %lu\n",
2710 (unsigned long) thr, (unsigned long) status));
2711 #endif /* USE_THREADS */
2720 STATUS_NATIVE_SET(status);
2730 if (vaxc$errno & 1) {
2731 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
2732 STATUS_NATIVE_SET(44);
2735 if (!vaxc$errno && errno) /* unlikely */
2736 STATUS_NATIVE_SET(44);
2738 STATUS_NATIVE_SET(vaxc$errno);
2742 STATUS_POSIX_SET(errno);
2743 else if (STATUS_POSIX == 0)
2744 STATUS_POSIX_SET(255);
2752 register CONTEXT *cx;
2761 (void)UNLINK(e_tmpname);
2762 Safefree(e_tmpname);
2766 if (cxstack_ix >= 0) {