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 av_push(comppad, Nullsv);
836 curpad = AvARRAY(comppad);
837 comppad_name = newAV();
838 comppad_name_fill = 0;
839 min_intro_pending = 0;
842 av_store(comppad_name, 0, newSVpv("@_", 2));
843 curpad[0] = (SV*)newAV();
844 SvPADMY_on(curpad[0]); /* XXX Needed? */
846 New(666, CvMUTEXP(compcv), 1, pthread_mutex_t);
847 MUTEX_INIT(CvMUTEXP(compcv));
848 New(666, CvCONDP(compcv), 1, pthread_cond_t);
849 COND_INIT(CvCONDP(compcv));
850 #endif /* USE_THREADS */
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)
1338 SV* sv = newSVpv(p, 0);
1341 perl_eval_sv(sv, G_SCALAR);
1348 if (croak_on_error && SvTRUE(GvSV(errgv)))
1349 croak(SvPVx(GvSV(errgv), na));
1354 /* Require a module. */
1360 SV* sv = sv_newmortal();
1361 sv_setpv(sv, "require '");
1364 perl_eval_sv(sv, G_DISCARD);
1368 magicname(sym,name,namlen)
1375 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1376 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1380 usage(name) /* XXX move this out into a module ? */
1383 /* This message really ought to be max 23 lines.
1384 * Removed -h because the user already knows that opton. Others? */
1385 printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1386 printf("\n -0[octal] specify record separator (\\0, if no argument)");
1387 printf("\n -a autosplit mode with -n or -p (splits $_ into @F)");
1388 printf("\n -c check syntax only (runs BEGIN and END blocks)");
1389 printf("\n -d[:debugger] run scripts under debugger");
1390 printf("\n -D[number/list] set debugging flags (argument is a bit mask or flags)");
1391 printf("\n -e 'command' one line of script. Several -e's allowed. Omit [programfile].");
1392 printf("\n -F/pattern/ split() pattern for autosplit (-a). The //'s are optional.");
1393 printf("\n -i[extension] edit <> files in place (make backup if extension supplied)");
1394 printf("\n -Idirectory specify @INC/#include directory (may be used more then once)");
1395 printf("\n -l[octal] enable line ending processing, specifies line teminator");
1396 printf("\n -[mM][-]module.. executes `use/no module...' before executing your script.");
1397 printf("\n -n assume 'while (<>) { ... }' loop arround your script");
1398 printf("\n -p assume loop like -n but print line also like sed");
1399 printf("\n -P run script through C preprocessor before compilation");
1400 printf("\n -s enable some switch parsing for switches after script name");
1401 printf("\n -S look for the script using PATH environment variable");
1402 printf("\n -T turn on tainting checks");
1403 printf("\n -u dump core after parsing script");
1404 printf("\n -U allow unsafe operations");
1405 printf("\n -v print version number and patchlevel of perl");
1406 printf("\n -V[:variable] print perl configuration information");
1407 printf("\n -w TURN WARNINGS ON FOR COMPILATION OF YOUR SCRIPT.");
1408 printf("\n -x[directory] strip off text before #!perl line and perhaps cd to directory\n");
1411 /* This routine handles any switches that can be given during run */
1422 rschar = scan_oct(s, 4, &numlen);
1424 if (rschar & ~((U8)~0))
1426 else if (!rschar && numlen >= 2)
1427 nrs = newSVpv("", 0);
1430 nrs = newSVpv(&ch, 1);
1435 splitstr = savepv(s + 1);
1449 if (*s == ':' || *s == '=') {
1450 my_setenv("PERL5DB", form("use Devel::%s;", ++s));
1461 if (isALPHA(s[1])) {
1462 static char debopts[] = "psltocPmfrxuLHXD";
1465 for (s++; *s && (d = strchr(debopts,*s)); s++)
1466 debug |= 1 << (d - debopts);
1470 for (s++; isDIGIT(*s); s++) ;
1472 debug |= 0x80000000;
1474 warn("Recompile perl with -DDEBUGGING to use -D switch\n");
1475 for (s++; isALNUM(*s); s++) ;
1485 inplace = savepv(s+1);
1487 for (s = inplace; *s && !isSPACE(*s); s++) ;
1494 for (e = s; *e && !isSPACE(*e); e++) ;
1495 p = savepvn(s, e-s);
1502 croak("No space allowed after -I");
1512 *ors = scan_oct(s, 3 + (*s == '0'), &numlen);
1521 ors = SvPV(nrs, orslen);
1522 ors = savepvn(ors, orslen);
1526 forbid_setid("-M"); /* XXX ? */
1529 forbid_setid("-m"); /* XXX ? */
1534 /* -M-foo == 'no foo' */
1535 if (*s == '-') { use = "no "; ++s; }
1536 sv = newSVpv(use,0);
1538 /* We allow -M'Module qw(Foo Bar)' */
1539 while(isALNUM(*s) || *s==':') ++s;
1541 sv_catpv(sv, start);
1542 if (*(start-1) == 'm') {
1544 croak("Can't use '%c' after -mname", *s);
1545 sv_catpv( sv, " ()");
1548 sv_catpvn(sv, start, s-start);
1549 sv_catpv(sv, " split(/,/,q{");
1554 if (preambleav == NULL)
1555 preambleav = newAV();
1556 av_push(preambleav, sv);
1559 croak("No space allowed after -%c", *(s-1));
1576 croak("Too late for \"-T\" option");
1588 #if defined(SUBVERSION) && SUBVERSION > 0
1589 printf("\nThis is perl, version 5.%03d_%02d", PATCHLEVEL, SUBVERSION);
1591 printf("\nThis is perl, version %s",patchlevel);
1594 printf("\n\nCopyright 1987-1997, Larry Wall\n");
1596 printf("\n\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1599 printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
1602 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1603 "Version 5 port Copyright (c) 1994-1997, Andreas Kaiser, Ilya Zakharevich\n");
1606 printf("atariST series port, ++jrb bammi@cadence.com\n");
1609 Perl may be copied only under the terms of either the Artistic License or the\n\
1610 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n");
1618 if (s[1] == '-') /* Additional switches on #! line. */
1626 #ifdef ALTERNATE_SHEBANG
1627 case 'S': /* OS/2 needs -S on "extproc" line. */
1635 croak("Can't emulate -%.1s on #! line",s);
1640 /* compliments of Tom Christiansen */
1642 /* unexec() can be found in the Gnu emacs distribution */
1653 prog = newSVpv(BIN_EXP);
1654 sv_catpv(prog, "/perl");
1655 file = newSVpv(origfilename);
1656 sv_catpv(file, ".perldump");
1658 status = unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
1660 PerlIO_printf(PerlIO_stderr(), "unexec of %s into %s failed!\n",
1661 SvPVX(prog), SvPVX(file));
1665 # include <lib$routines.h>
1666 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
1668 ABORT(); /* for use with undump */
1679 /* Note that strtab is a rather special HV. Assumptions are made
1680 about not iterating on it, and not adding tie magic to it.
1681 It is properly deallocated in perl_destruct() */
1683 HvSHAREKEYS_off(strtab); /* mandatory */
1684 Newz(506,((XPVHV*)SvANY(strtab))->xhv_array,
1685 sizeof(HE*) * (((XPVHV*)SvANY(strtab))->xhv_max + 1), char);
1687 curstash = defstash = newHV();
1688 curstname = newSVpv("main",4);
1689 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1690 SvREFCNT_dec(GvHV(gv));
1691 GvHV(gv) = (HV*)SvREFCNT_inc(defstash);
1693 HvNAME(defstash) = savepv("main");
1694 incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1696 defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1697 errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1699 sv_setpvn(GvSV(errgv), "", 0);
1700 curstash = defstash;
1701 compiling.cop_stash = defstash;
1702 debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
1703 /* We must init $/ before switches are processed. */
1704 sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1);
1707 #ifdef CAN_PROTOTYPE
1709 open_script(char *scriptname, bool dosearch, SV *sv)
1712 open_script(scriptname,dosearch,sv)
1718 char *xfound = Nullch;
1719 char *xfailed = Nullch;
1723 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
1724 # define SEARCH_EXTS ".bat", ".cmd", NULL
1725 # define MAX_EXT_LEN 4
1728 # define SEARCH_EXTS ".pl", ".com", NULL
1729 # define MAX_EXT_LEN 4
1731 /* additional extensions to try in each dir if scriptname not found */
1733 char *ext[] = { SEARCH_EXTS };
1734 int extidx = (strchr(scriptname,'.')) ? -1 : 0; /* has ext already */
1736 # define MAX_EXT_LEN 0
1741 int hasdir, idx = 0, deftypes = 1;
1743 hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
1744 /* The first time through, just add SEARCH_EXTS to whatever we
1745 * already have, so we can check for default file types. */
1747 (!hasdir && my_trnlnm("DCL$PATH",tokenbuf,idx++)) )
1753 if ((strlen(tokenbuf) + strlen(scriptname)
1754 + MAX_EXT_LEN) >= sizeof tokenbuf)
1755 continue; /* don't search dir with too-long name */
1756 strcat(tokenbuf, scriptname);
1758 if (dosearch && !strchr(scriptname, '/') && (s = getenv("PATH"))) {
1759 bufend = s + strlen(s);
1760 while (s < bufend) {
1762 s = delimcpy(tokenbuf, tokenbuf + sizeof tokenbuf, s, bufend,
1770 for (len = 0; *s && *s != ',' && *s != ';'; len++, s++) {
1771 if (len < sizeof tokenbuf)
1774 if (len < sizeof tokenbuf)
1775 tokenbuf[len] = '\0';
1776 #endif /* atarist */
1779 if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tokenbuf)
1780 continue; /* don't search dir with too-long name */
1782 #if defined(atarist) && !defined(DOSISH)
1783 && tokenbuf[len - 1] != '/'
1785 #if defined(atarist) || defined(DOSISH)
1786 && tokenbuf[len - 1] != '\\'
1789 tokenbuf[len++] = '/';
1790 (void)strcpy(tokenbuf + len, scriptname);
1794 len = strlen(tokenbuf);
1795 if (extidx > 0) /* reset after previous loop */
1799 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tokenbuf));
1800 retval = Stat(tokenbuf,&statbuf);
1802 } while ( retval < 0 /* not there */
1803 && extidx>=0 && ext[extidx] /* try an extension? */
1804 && strcpy(tokenbuf+len, ext[extidx++])
1809 if (S_ISREG(statbuf.st_mode)
1810 && cando(S_IRUSR,TRUE,&statbuf)
1812 && cando(S_IXUSR,TRUE,&statbuf)
1816 xfound = tokenbuf; /* bingo! */
1820 xfailed = savepv(tokenbuf);
1823 croak("Can't execute %s", xfailed ? xfailed : scriptname );
1826 scriptname = xfound;
1829 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
1830 char *s = scriptname + 8;
1839 origfilename = savepv(e_tmpname ? "-e" : scriptname);
1840 curcop->cop_filegv = gv_fetchfile(origfilename);
1841 if (strEQ(origfilename,"-"))
1843 if (fdscript >= 0) {
1844 rsfp = PerlIO_fdopen(fdscript,"r");
1845 #if defined(HAS_FCNTL) && defined(F_SETFD)
1847 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
1850 else if (preprocess) {
1851 char *cpp_cfg = CPPSTDIN;
1852 SV *cpp = NEWSV(0,0);
1853 SV *cmd = NEWSV(0,0);
1855 if (strEQ(cpp_cfg, "cppstdin"))
1856 sv_catpvf(cpp, "%s/", BIN_EXP);
1857 sv_catpv(cpp, cpp_cfg);
1860 sv_catpv(sv,PRIVLIB_EXP);
1864 sed %s -e \"/^[^#]/b\" \
1865 -e \"/^#[ ]*include[ ]/b\" \
1866 -e \"/^#[ ]*define[ ]/b\" \
1867 -e \"/^#[ ]*if[ ]/b\" \
1868 -e \"/^#[ ]*ifdef[ ]/b\" \
1869 -e \"/^#[ ]*ifndef[ ]/b\" \
1870 -e \"/^#[ ]*else/b\" \
1871 -e \"/^#[ ]*elif[ ]/b\" \
1872 -e \"/^#[ ]*undef[ ]/b\" \
1873 -e \"/^#[ ]*endif/b\" \
1876 (doextract ? "-e \"1,/^#/d\n\"" : ""),
1879 %s %s -e '/^[^#]/b' \
1880 -e '/^#[ ]*include[ ]/b' \
1881 -e '/^#[ ]*define[ ]/b' \
1882 -e '/^#[ ]*if[ ]/b' \
1883 -e '/^#[ ]*ifdef[ ]/b' \
1884 -e '/^#[ ]*ifndef[ ]/b' \
1885 -e '/^#[ ]*else/b' \
1886 -e '/^#[ ]*elif[ ]/b' \
1887 -e '/^#[ ]*undef[ ]/b' \
1888 -e '/^#[ ]*endif/b' \
1896 (doextract ? "-e '1,/^#/d\n'" : ""),
1898 scriptname, cpp, sv, CPPMINUS);
1900 #ifdef IAMSUID /* actually, this is caught earlier */
1901 if (euid != uid && !euid) { /* if running suidperl */
1903 (void)seteuid(uid); /* musn't stay setuid root */
1906 (void)setreuid((Uid_t)-1, uid);
1908 #ifdef HAS_SETRESUID
1909 (void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
1915 if (geteuid() != uid)
1916 croak("Can't do seteuid!\n");
1918 #endif /* IAMSUID */
1919 rsfp = my_popen(SvPVX(cmd), "r");
1923 else if (!*scriptname) {
1924 forbid_setid("program input from stdin");
1925 rsfp = PerlIO_stdin();
1928 rsfp = PerlIO_open(scriptname,"r");
1929 #if defined(HAS_FCNTL) && defined(F_SETFD)
1931 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
1939 #ifndef IAMSUID /* in case script is not readable before setuid */
1940 if (euid && Stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
1941 statbuf.st_mode & (S_ISUID|S_ISGID)) {
1943 execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
1944 croak("Can't do setuid\n");
1948 croak("Can't open perl script \"%s\": %s\n",
1949 SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno));
1954 validate_suid(validarg, scriptname)
1960 /* do we need to emulate setuid on scripts? */
1962 /* This code is for those BSD systems that have setuid #! scripts disabled
1963 * in the kernel because of a security problem. Merely defining DOSUID
1964 * in perl will not fix that problem, but if you have disabled setuid
1965 * scripts in the kernel, this will attempt to emulate setuid and setgid
1966 * on scripts that have those now-otherwise-useless bits set. The setuid
1967 * root version must be called suidperl or sperlN.NNN. If regular perl
1968 * discovers that it has opened a setuid script, it calls suidperl with
1969 * the same argv that it had. If suidperl finds that the script it has
1970 * just opened is NOT setuid root, it sets the effective uid back to the
1971 * uid. We don't just make perl setuid root because that loses the
1972 * effective uid we had before invoking perl, if it was different from the
1975 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
1976 * be defined in suidperl only. suidperl must be setuid root. The
1977 * Configure script will set this up for you if you want it.
1983 if (Fstat(PerlIO_fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
1984 croak("Can't stat script \"%s\"",origfilename);
1985 if (fdscript < 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) {
1989 #ifndef HAS_SETREUID
1990 /* On this access check to make sure the directories are readable,
1991 * there is actually a small window that the user could use to make
1992 * filename point to an accessible directory. So there is a faint
1993 * chance that someone could execute a setuid script down in a
1994 * non-accessible directory. I don't know what to do about that.
1995 * But I don't think it's too important. The manual lies when
1996 * it says access() is useful in setuid programs.
1998 if (access(SvPVX(GvSV(curcop->cop_filegv)),1)) /*double check*/
1999 croak("Permission denied");
2001 /* If we can swap euid and uid, then we can determine access rights
2002 * with a simple stat of the file, and then compare device and
2003 * inode to make sure we did stat() on the same file we opened.
2004 * Then we just have to make sure he or she can execute it.
2007 struct stat tmpstatbuf;
2011 setreuid(euid,uid) < 0
2014 setresuid(euid,uid,(Uid_t)-1) < 0
2017 || getuid() != euid || geteuid() != uid)
2018 croak("Can't swap uid and euid"); /* really paranoid */
2019 if (Stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
2020 croak("Permission denied"); /* testing full pathname here */
2021 if (tmpstatbuf.st_dev != statbuf.st_dev ||
2022 tmpstatbuf.st_ino != statbuf.st_ino) {
2023 (void)PerlIO_close(rsfp);
2024 if (rsfp = my_popen("/bin/mail root","w")) { /* heh, heh */
2026 "User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2027 (Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
2028 (long)uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
2029 (long)statbuf.st_dev, (long)statbuf.st_ino,
2030 SvPVX(GvSV(curcop->cop_filegv)),
2031 (long)statbuf.st_uid, (long)statbuf.st_gid);
2032 (void)my_pclose(rsfp);
2034 croak("Permission denied\n");
2038 setreuid(uid,euid) < 0
2040 # if defined(HAS_SETRESUID)
2041 setresuid(uid,euid,(Uid_t)-1) < 0
2044 || getuid() != uid || geteuid() != euid)
2045 croak("Can't reswap uid and euid");
2046 if (!cando(S_IXUSR,FALSE,&statbuf)) /* can real uid exec? */
2047 croak("Permission denied\n");
2049 #endif /* HAS_SETREUID */
2050 #endif /* IAMSUID */
2052 if (!S_ISREG(statbuf.st_mode))
2053 croak("Permission denied");
2054 if (statbuf.st_mode & S_IWOTH)
2055 croak("Setuid/gid script is writable by world");
2056 doswitches = FALSE; /* -s is insecure in suid */
2058 if (sv_gets(linestr, rsfp, 0) == Nullch ||
2059 strnNE(SvPV(linestr,na),"#!",2) ) /* required even on Sys V */
2060 croak("No #! line");
2061 s = SvPV(linestr,na)+2;
2063 while (!isSPACE(*s)) s++;
2064 for (s2 = s; (s2 > SvPV(linestr,na)+2 &&
2065 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
2066 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
2067 croak("Not a perl script");
2068 while (*s == ' ' || *s == '\t') s++;
2070 * #! arg must be what we saw above. They can invoke it by
2071 * mentioning suidperl explicitly, but they may not add any strange
2072 * arguments beyond what #! says if they do invoke suidperl that way.
2074 len = strlen(validarg);
2075 if (strEQ(validarg," PHOOEY ") ||
2076 strnNE(s,validarg,len) || !isSPACE(s[len]))
2077 croak("Args must match #! line");
2080 if (euid != uid && (statbuf.st_mode & S_ISUID) &&
2081 euid == statbuf.st_uid)
2083 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2084 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2085 #endif /* IAMSUID */
2087 if (euid) { /* oops, we're not the setuid root perl */
2088 (void)PerlIO_close(rsfp);
2091 execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
2093 croak("Can't do setuid\n");
2096 if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
2098 (void)setegid(statbuf.st_gid);
2101 (void)setregid((Gid_t)-1,statbuf.st_gid);
2103 #ifdef HAS_SETRESGID
2104 (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
2106 setgid(statbuf.st_gid);
2110 if (getegid() != statbuf.st_gid)
2111 croak("Can't do setegid!\n");
2113 if (statbuf.st_mode & S_ISUID) {
2114 if (statbuf.st_uid != euid)
2116 (void)seteuid(statbuf.st_uid); /* all that for this */
2119 (void)setreuid((Uid_t)-1,statbuf.st_uid);
2121 #ifdef HAS_SETRESUID
2122 (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
2124 setuid(statbuf.st_uid);
2128 if (geteuid() != statbuf.st_uid)
2129 croak("Can't do seteuid!\n");
2131 else if (uid) { /* oops, mustn't run as root */
2133 (void)seteuid((Uid_t)uid);
2136 (void)setreuid((Uid_t)-1,(Uid_t)uid);
2138 #ifdef HAS_SETRESUID
2139 (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
2145 if (geteuid() != uid)
2146 croak("Can't do seteuid!\n");
2149 if (!cando(S_IXUSR,TRUE,&statbuf))
2150 croak("Permission denied\n"); /* they can't do this */
2153 else if (preprocess)
2154 croak("-P not allowed for setuid/setgid script\n");
2155 else if (fdscript >= 0)
2156 croak("fd script not allowed in suidperl\n");
2158 croak("Script is not setuid/setgid in suidperl\n");
2160 /* We absolutely must clear out any saved ids here, so we */
2161 /* exec the real perl, substituting fd script for scriptname. */
2162 /* (We pass script name as "subdir" of fd, which perl will grok.) */
2163 PerlIO_rewind(rsfp);
2164 lseek(PerlIO_fileno(rsfp),(Off_t)0,0); /* just in case rewind didn't */
2165 for (which = 1; origargv[which] && origargv[which] != scriptname; which++) ;
2166 if (!origargv[which])
2167 croak("Permission denied");
2168 origargv[which] = savepv(form("/dev/fd/%d/%s",
2169 PerlIO_fileno(rsfp), origargv[which]));
2170 #if defined(HAS_FCNTL) && defined(F_SETFD)
2171 fcntl(PerlIO_fileno(rsfp),F_SETFD,0); /* ensure no close-on-exec */
2173 execv(form("%s/perl%s", BIN_EXP, patchlevel), origargv); /* try again */
2174 croak("Can't do setuid\n");
2175 #endif /* IAMSUID */
2177 if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */
2178 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2179 Fstat(PerlIO_fileno(rsfp),&statbuf); /* may be either wrapped or real suid */
2180 if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
2182 (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
2185 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2186 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2187 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2188 /* not set-id, must be wrapped */
2196 register char *s, *s2;
2198 /* skip forward in input to the real script? */
2202 if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
2203 croak("No Perl script found in input\n");
2204 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2205 PerlIO_ungetc(rsfp, '\n'); /* to keep line count right */
2207 while (*s && !(isSPACE (*s) || *s == '#')) s++;
2209 while (*s == ' ' || *s == '\t') s++;
2211 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2212 if (strnEQ(s2-4,"perl",4))
2214 while (s = moreswitches(s)) ;
2216 if (cddir && chdir(cddir) < 0)
2217 croak("Can't chdir to %s",cddir);
2225 uid = (int)getuid();
2226 euid = (int)geteuid();
2227 gid = (int)getgid();
2228 egid = (int)getegid();
2233 tainting |= (uid && (euid != uid || egid != gid));
2241 croak("No %s allowed while running setuid", s);
2243 croak("No %s allowed while running setgid", s);
2250 curstash = debstash;
2251 dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2253 DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2254 DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2255 DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2256 DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2257 sv_setiv(DBsingle, 0);
2258 DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2259 sv_setiv(DBtrace, 0);
2260 DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2261 sv_setiv(DBsignal, 0);
2262 curstash = defstash;
2270 mainstack = curstack; /* remember in case we switch stacks */
2271 AvREAL_off(curstack); /* not a real array */
2272 av_extend(curstack,127);
2274 stack_base = AvARRAY(curstack);
2275 stack_sp = stack_base;
2276 stack_max = stack_base + 127;
2278 cxstack_max = 8192 / sizeof(CONTEXT) - 2; /* Use most of 8K. */
2279 New(50,cxstack,cxstack_max + 1,CONTEXT);
2282 New(50,tmps_stack,128,SV*);
2288 * The following stacks almost certainly should be per-interpreter,
2289 * but for now they're not. XXX
2293 markstack_ptr = markstack;
2295 New(54,markstack,64,I32);
2296 markstack_ptr = markstack;
2297 markstack_max = markstack + 64;
2303 New(54,scopestack,32,I32);
2305 scopestack_max = 32;
2311 New(54,savestack,128,ANY);
2313 savestack_max = 128;
2319 New(54,retstack,16,OP*);
2330 Safefree(tmps_stack);
2337 static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
2345 subname = newSVpv("main",4);
2349 init_predump_symbols()
2355 sv_setpvn(GvSV(gv_fetchpv("\"", TRUE, SVt_PV)), " ", 1);
2357 stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2358 GvMULTI_on(stdingv);
2359 IoIFP(GvIOp(stdingv)) = PerlIO_stdin();
2360 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2362 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv));
2364 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2366 IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
2368 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2370 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv));
2372 othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2373 GvMULTI_on(othergv);
2374 IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr();
2375 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2377 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
2379 statname = NEWSV(66,0); /* last filename we did stat on */
2382 osname = savepv(OSNAME);
2386 init_postdump_symbols(argc,argv,env)
2388 register char **argv;
2389 register char **env;
2395 argc--,argv++; /* skip name of script */
2397 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2400 if (argv[0][1] == '-') {
2404 if (s = strchr(argv[0], '=')) {
2406 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2409 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2412 toptarget = NEWSV(0,0);
2413 sv_upgrade(toptarget, SVt_PVFM);
2414 sv_setpvn(toptarget, "", 0);
2415 bodytarget = NEWSV(0,0);
2416 sv_upgrade(bodytarget, SVt_PVFM);
2417 sv_setpvn(bodytarget, "", 0);
2418 formtarget = bodytarget;
2421 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2422 sv_setpv(GvSV(tmpgv),origfilename);
2423 magicname("0", "0", 1);
2425 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2426 sv_setpv(GvSV(tmpgv),origargv[0]);
2427 if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2429 (void)gv_AVadd(argvgv);
2430 av_clear(GvAVn(argvgv));
2431 for (; argc > 0; argc--,argv++) {
2432 av_push(GvAVn(argvgv),newSVpv(argv[0],0));
2435 if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2439 hv_magic(hv, envgv, 'E');
2440 #ifndef VMS /* VMS doesn't have environ array */
2441 /* Note that if the supplied env parameter is actually a copy
2442 of the global environ then it may now point to free'd memory
2443 if the environment has been modified since. To avoid this
2444 problem we treat env==NULL as meaning 'use the default'
2449 environ[0] = Nullch;
2450 for (; *env; env++) {
2451 if (!(s = strchr(*env,'=')))
2457 sv = newSVpv(s--,0);
2458 (void)hv_store(hv, *env, s - *env, sv, 0);
2462 #ifdef DYNAMIC_ENV_FETCH
2463 HvNAME(hv) = savepv(ENV_HV_NAME);
2467 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2468 sv_setiv(GvSV(tmpgv), (IV)getpid());
2477 s = getenv("PERL5LIB");
2481 incpush(getenv("PERLLIB"), FALSE);
2483 /* Treat PERL5?LIB as a possible search list logical name -- the
2484 * "natural" VMS idiom for a Unix path string. We allow each
2485 * element to be a set of |-separated directories for compatibility.
2489 if (my_trnlnm("PERL5LIB",buf,0))
2490 do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2492 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2496 /* Use the ~-expanded versions of APPLLIB (undocumented),
2497 ARCHLIB PRIVLIB SITEARCH SITELIB and OLDARCHLIB
2500 incpush(APPLLIB_EXP, FALSE);
2504 incpush(ARCHLIB_EXP, FALSE);
2507 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2509 incpush(PRIVLIB_EXP, FALSE);
2512 incpush(SITEARCH_EXP, FALSE);
2515 incpush(SITELIB_EXP, FALSE);
2517 #ifdef OLDARCHLIB_EXP /* 5.00[01] compatibility */
2518 incpush(OLDARCHLIB_EXP, FALSE);
2522 incpush(".", FALSE);
2526 # define PERLLIB_SEP ';'
2529 # define PERLLIB_SEP '|'
2531 # define PERLLIB_SEP ':'
2534 #ifndef PERLLIB_MANGLE
2535 # define PERLLIB_MANGLE(s,n) (s)
2539 incpush(p, addsubdirs)
2543 SV *subdir = Nullsv;
2544 static char *archpat_auto;
2551 if (!archpat_auto) {
2552 STRLEN len = (sizeof(ARCHNAME) + strlen(patchlevel)
2553 + sizeof("//auto"));
2554 New(55, archpat_auto, len, char);
2555 sprintf(archpat_auto, "/%s/%s/auto", ARCHNAME, patchlevel);
2557 for (len = sizeof(ARCHNAME) + 2;
2558 archpat_auto[len] != '\0' && archpat_auto[len] != '/'; len++)
2559 if (archpat_auto[len] == '.') archpat_auto[len] = '_';
2564 /* Break at all separators */
2566 SV *libdir = newSV(0);
2569 /* skip any consecutive separators */
2570 while ( *p == PERLLIB_SEP ) {
2571 /* Uncomment the next line for PATH semantics */
2572 /* av_push(GvAVn(incgv), newSVpv(".", 1)); */
2576 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2577 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2582 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2583 p = Nullch; /* break out */
2587 * BEFORE pushing libdir onto @INC we may first push version- and
2588 * archname-specific sub-directories.
2591 struct stat tmpstatbuf;
2596 if ((unix = tounixspec_ts(SvPV(libdir,na),Nullch)) != Nullch) {
2598 while (unix[len-1] == '/') len--; /* Cosmetic */
2599 sv_usepvn(libdir,unix,len);
2602 PerlIO_printf(PerlIO_stderr(),
2603 "Failed to unixify @INC element \"%s\"\n",
2606 /* .../archname/version if -d .../archname/version/auto */
2607 sv_setsv(subdir, libdir);
2608 sv_catpv(subdir, archpat_auto);
2609 if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2610 S_ISDIR(tmpstatbuf.st_mode))
2611 av_push(GvAVn(incgv),
2612 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2614 /* .../archname if -d .../archname/auto */
2615 sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
2616 strlen(patchlevel) + 1, "", 0);
2617 if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2618 S_ISDIR(tmpstatbuf.st_mode))
2619 av_push(GvAVn(incgv),
2620 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2623 /* finally push this lib directory on the end of @INC */
2624 av_push(GvAVn(incgv), libdir);
2627 SvREFCNT_dec(subdir);
2631 call_list(oldscope, list)
2636 line_t oldline = curcop->cop_line;
2641 while (AvFILL(list) >= 0) {
2642 CV *cv = (CV*)av_shift(list);
2649 SV* atsv = GvSV(errgv);
2651 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
2652 (void)SvPV(atsv, len);
2655 curcop = &compiling;
2656 curcop->cop_line = oldline;
2657 if (list == beginav)
2658 sv_catpv(atsv, "BEGIN failed--compilation aborted");
2660 sv_catpv(atsv, "END failed--cleanup aborted");
2661 while (scopestack_ix > oldscope)
2663 croak("%s", SvPVX(atsv));
2671 /* my_exit() was called */
2672 while (scopestack_ix > oldscope)
2674 curstash = defstash;
2676 call_list(oldscope, endav);
2679 curcop = &compiling;
2680 curcop->cop_line = oldline;
2682 if (list == beginav)
2683 croak("BEGIN failed--compilation aborted");
2685 croak("END failed--cleanup aborted");
2691 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
2696 curcop = &compiling;
2697 curcop->cop_line = oldline;
2711 DEBUG_L(PerlIO_printf(Perl_debug_log, "my_exit: thread 0x%lx, status %lu\n",
2712 (unsigned long) thr, (unsigned long) status));
2713 #endif /* USE_THREADS */
2722 STATUS_NATIVE_SET(status);
2732 if (vaxc$errno & 1) {
2733 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
2734 STATUS_NATIVE_SET(44);
2737 if (!vaxc$errno && errno) /* unlikely */
2738 STATUS_NATIVE_SET(44);
2740 STATUS_NATIVE_SET(vaxc$errno);
2744 STATUS_POSIX_SET(errno);
2745 else if (STATUS_POSIX == 0)
2746 STATUS_POSIX_SET(255);
2755 register CONTEXT *cx;
2764 (void)UNLINK(e_tmpname);
2765 Safefree(e_tmpname);
2769 if (cxstack_ix >= 0) {