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;
100 #if defined(USE_THREADS) && !defined(FAKE_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);
118 thr->next = thr->prev = thr->next_run = thr->prev_run = thr;
122 self = pthread_self();
123 if (pthread_key_create(&thr_key, thread_destruct))
124 croak("panic: pthread_key_create");
125 if (pthread_setspecific(thr_key, (void *) thr))
126 croak("panic: pthread_setspecific");
127 #endif /* !FAKE_THREADS */
132 #endif /* USE_THREADS */
134 /* Init the real globals? */
136 linestr = NEWSV(65,80);
137 sv_upgrade(linestr,SVt_PVIV);
139 if (!SvREADONLY(&sv_undef)) {
140 SvREADONLY_on(&sv_undef);
144 SvREADONLY_on(&sv_no);
146 sv_setpv(&sv_yes,Yes);
148 SvREADONLY_on(&sv_yes);
151 nrs = newSVpv("\n", 1);
152 rs = SvREFCNT_inc(nrs);
154 MUTEX_INIT(&malloc_mutex);
155 MUTEX_INIT(&sv_mutex);
156 MUTEX_INIT(&eval_mutex);
157 MUTEX_INIT(&nthreads_mutex);
158 COND_INIT(&nthreads_cond);
164 * There is no way we can refer to them from Perl so close them to save
165 * space. The other alternative would be to provide STDAUX and STDPRN
168 (void)fclose(stdaux);
169 (void)fclose(stdprn);
175 perl_destruct_level = 1;
177 if(perl_destruct_level > 0)
183 start_env.je_prev = NULL;
184 start_env.je_ret = -1;
185 start_env.je_mustcatch = TRUE;
186 top_env = &start_env;
189 SET_NUMERIC_STANDARD();
190 #if defined(SUBVERSION) && SUBVERSION > 0
191 sprintf(patchlevel, "%7.5f", (double) 5
192 + ((double) PATCHLEVEL / (double) 1000)
193 + ((double) SUBVERSION / (double) 100000));
195 sprintf(patchlevel, "%5.3f", (double) 5 +
196 ((double) PATCHLEVEL / (double) 1000));
199 #if defined(LOCAL_PATCH_COUNT)
200 localpatches = local_patches; /* For possible -v */
203 PerlIO_init(); /* Hook to IO system */
205 fdpid = newAV(); /* for remembering popen pids by fd */
209 New(51,debname,128,char);
210 New(52,debdelim,128,char);
221 struct thread *thr = (struct thread *) arg;
223 * Decrement the global thread count and signal anyone listening.
224 * The only official thread listening is the original thread while
225 * in perl_destruct. It waits until it's the only thread and then
226 * performs END blocks and other process clean-ups.
228 DEBUG_L(fprintf(stderr, "thread_destruct: 0x%lx\n", (unsigned long) thr));
231 MUTEX_LOCK(&nthreads_mutex);
233 COND_BROADCAST(&nthreads_cond);
234 MUTEX_UNLOCK(&nthreads_mutex);
236 #endif /* USE_THREADS */
239 perl_destruct(sv_interp)
240 register PerlInterpreter *sv_interp;
243 int destruct_level; /* 0=none, 1=full, 2=full with checks */
247 if (!(curinterp = sv_interp))
252 /* Wait until all user-created threads go away */
253 MUTEX_LOCK(&nthreads_mutex);
256 DEBUG_L(fprintf(stderr, "perl_destruct: waiting for %d threads\n",
258 COND_WAIT(&nthreads_cond, &nthreads_mutex);
260 /* At this point, we're the last thread */
261 MUTEX_UNLOCK(&nthreads_mutex);
262 DEBUG_L(fprintf(stderr, "perl_destruct: armageddon has arrived\n"));
263 MUTEX_DESTROY(&nthreads_mutex);
264 COND_DESTROY(&nthreads_cond);
265 #endif /* !defined(FAKE_THREADS) */
266 #endif /* USE_THREADS */
268 destruct_level = perl_destruct_level;
272 if (s = getenv("PERL_DESTRUCT_LEVEL")) {
274 if (destruct_level < i)
283 /* We must account for everything. */
285 /* Destroy the main CV and syntax tree */
287 curpad = AvARRAY(comppad);
292 SvREFCNT_dec(main_cv);
297 * Try to destruct global references. We do this first so that the
298 * destructors and destructees still exist. Some sv's might remain.
299 * Non-referenced objects are on their own.
306 /* unhook hooks which will soon be, or use, destroyed data */
307 SvREFCNT_dec(warnhook);
309 SvREFCNT_dec(diehook);
311 SvREFCNT_dec(parsehook);
314 if (destruct_level == 0){
316 DEBUG_P(debprofdump());
318 /* The exit() function will do everything that needs doing. */
322 /* loosen bonds of global variables */
325 (void)PerlIO_close(rsfp);
329 /* Filters for program text */
330 SvREFCNT_dec(rsfp_filters);
331 rsfp_filters = Nullav;
343 sawampersand = FALSE; /* must save all match strings */
344 sawstudy = FALSE; /* do fbm_instr on all strings */
359 /* magical thingies */
361 Safefree(ofs); /* $, */
364 Safefree(ors); /* $\ */
367 SvREFCNT_dec(nrs); /* $\ helper */
370 multiline = 0; /* $* */
372 SvREFCNT_dec(statname);
376 /* defgv, aka *_ should be taken care of elsewhere */
378 #if 0 /* just about all regexp stuff, seems to be ok */
380 /* shortcuts to regexp stuff */
385 SAVEFREEOP(oldlastpm); /* for saving regexp context during debugger */
387 regprecomp = NULL; /* uncompiled string. */
388 regparse = NULL; /* Input-scan pointer. */
389 regxend = NULL; /* End of input for compile */
390 regnpar = 0; /* () count. */
391 regcode = NULL; /* Code-emit pointer; ®dummy = don't. */
392 regsize = 0; /* Code size. */
393 regnaughty = 0; /* How bad is this pattern? */
394 regsawback = 0; /* Did we see \1, ...? */
396 reginput = NULL; /* String-input pointer. */
397 regbol = NULL; /* Beginning of input, for ^ check. */
398 regeol = NULL; /* End of input, for $ check. */
399 regstartp = (char **)NULL; /* Pointer to startp array. */
400 regendp = (char **)NULL; /* Ditto for endp. */
401 reglastparen = 0; /* Similarly for lastparen. */
402 regtill = NULL; /* How far we are required to go. */
403 regflags = 0; /* are we folding, multilining? */
404 regprev = (char)NULL; /* char before regbol, \n if none */
408 /* clean up after study() */
409 SvREFCNT_dec(lastscream);
411 Safefree(screamfirst);
413 Safefree(screamnext);
416 /* startup and shutdown function lists */
417 SvREFCNT_dec(beginav);
422 /* temp stack during pp_sort() */
423 SvREFCNT_dec(sortstack);
426 /* shortcuts just get cleared */
436 /* reset so print() ends up where we expect */
439 /* Prepare to destruct main symbol table. */
446 if (destruct_level >= 2) {
447 if (scopestack_ix != 0)
448 warn("Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
449 (long)scopestack_ix);
450 if (savestack_ix != 0)
451 warn("Unbalanced saves: %ld more saves than restores\n",
453 if (tmps_floor != -1)
454 warn("Unbalanced tmps: %ld more allocs than frees\n",
455 (long)tmps_floor + 1);
456 if (cxstack_ix != -1)
457 warn("Unbalanced context: %ld more PUSHes than POPs\n",
458 (long)cxstack_ix + 1);
461 /* Now absolutely destruct everything, somehow or other, loops or no. */
463 SvFLAGS(strtab) |= SVTYPEMASK; /* don't clean out strtab now */
464 while (sv_count != 0 && sv_count != last_sv_count) {
465 last_sv_count = sv_count;
468 SvFLAGS(strtab) &= ~SVTYPEMASK;
469 SvFLAGS(strtab) |= SVt_PVHV;
471 /* Destruct the global string table. */
473 /* Yell and reset the HeVAL() slots that are still holding refcounts,
474 * so that sv_free() won't fail on them.
483 array = HvARRAY(strtab);
487 warn("Unbalanced string table refcount: (%d) for \"%s\"",
488 HeVAL(hent) - Nullsv, HeKEY(hent));
489 HeVAL(hent) = Nullsv;
499 SvREFCNT_dec(strtab);
502 warn("Scalars leaked: %ld\n", (long)sv_count);
506 /* No SVs have survived, need to clean out */
510 Safefree(origfilename);
512 hints = 0; /* Reset hints. Should hints be per-interpreter ? */
514 DEBUG_P(debprofdump());
516 MUTEX_DESTROY(&sv_mutex);
517 MUTEX_DESTROY(&malloc_mutex);
518 MUTEX_DESTROY(&eval_mutex);
519 #endif /* USE_THREADS */
521 /* As the absolutely last thing, free the non-arena SV for mess() */
524 /* we know that type >= SVt_PV */
526 Safefree(SvPVX(mess_sv));
527 Safefree(SvANY(mess_sv));
535 PerlInterpreter *sv_interp;
537 if (!(curinterp = sv_interp))
543 perl_parse(sv_interp, xsinit, argc, argv, env)
544 PerlInterpreter *sv_interp;
545 void (*xsinit)_((void));
553 char *scriptname = NULL;
554 VOL bool dosearch = FALSE;
561 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
564 croak("suidperl is no longer needed since the kernel can now execute\n\
565 setuid perl scripts securely.\n");
569 if (!(curinterp = sv_interp))
572 #if defined(NeXT) && defined(__DYNAMIC__)
573 _dyld_lookup_and_bind
574 ("__environ", (unsigned long *) &environ_pointer, NULL);
579 #ifndef VMS /* VMS doesn't have environ array */
580 origenviron = environ;
586 /* Come here if running an undumped a.out. */
588 origfilename = savepv(argv[0]);
590 cxstack_ix = -1; /* start label stack again */
592 init_postdump_symbols(argc,argv,env);
597 curpad = AvARRAY(comppad);
602 SvREFCNT_dec(main_cv);
606 oldscope = scopestack_ix;
614 /* my_exit() was called */
615 while (scopestack_ix > oldscope)
619 call_list(oldscope, endav);
621 return STATUS_NATIVE_EXPORT;
624 PerlIO_printf(PerlIO_stderr(), "panic: top_env\n");
628 sv_setpvn(linestr,"",0);
629 sv = newSVpv("",0); /* first used for -I flags */
633 for (argc--,argv++; argc > 0; argc--,argv++) {
634 if (argv[0][0] != '-' || !argv[0][1])
638 validarg = " PHOOEY ";
663 if (s = moreswitches(s))
673 if (euid != uid || egid != gid)
674 croak("No -e allowed in setuid scripts");
676 e_tmpname = savepv(TMPPATH);
677 (void)mktemp(e_tmpname);
679 croak("Can't mktemp()");
680 e_fp = PerlIO_open(e_tmpname,"w");
682 croak("Cannot open temporary file");
687 PerlIO_puts(e_fp,argv[1]);
691 croak("No code specified for -e");
692 (void)PerlIO_putc(e_fp,'\n');
703 incpush(argv[1], TRUE);
704 sv_catpv(sv,argv[1]);
721 preambleav = newAV();
722 av_push(preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
724 Sv = newSVpv("print myconfig();",0);
726 sv_catpv(Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
728 sv_catpv(Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
730 #if defined(DEBUGGING) || defined(NO_EMBED) || defined(MULTIPLICITY)
731 sv_catpv(Sv,"\" Compile-time options:");
733 sv_catpv(Sv," DEBUGGING");
736 sv_catpv(Sv," NO_EMBED");
739 sv_catpv(Sv," MULTIPLICITY");
741 sv_catpv(Sv,"\\n\",");
743 #if defined(LOCAL_PATCH_COUNT)
744 if (LOCAL_PATCH_COUNT > 0) {
746 sv_catpv(Sv,"\" Locally applied patches:\\n\",");
747 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
749 sv_catpvf(Sv,"\" \\t%s\\n\",",localpatches[i]);
753 sv_catpvf(Sv,"\" Built under %s\\n\"",OSNAME);
756 sv_catpvf(Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
758 sv_catpvf(Sv,",\" Compiled on %s\\n\"",__DATE__);
763 @env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; \
764 print \" \\%ENV:\\n @env\\n\" if @env; \
765 print \" \\@INC:\\n @INC\\n\";");
768 Sv = newSVpv("config_vars(qw(",0);
773 av_push(preambleav, Sv);
774 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
788 croak("Unrecognized switch: -%s",s);
793 if (!tainting && (s = getenv("PERL5OPT"))) {
804 if (!strchr("DIMUdmw", *s))
805 croak("Illegal switch in PERL5OPT: -%c", *s);
811 scriptname = argv[0];
813 if (PerlIO_flush(e_fp) || PerlIO_error(e_fp) || PerlIO_close(e_fp)) {
815 warn("Did you forget to compile with -DMULTIPLICITY?");
817 croak("Can't write to temp file for -e: %s", Strerror(errno));
821 scriptname = e_tmpname;
823 else if (scriptname == Nullch) {
825 if ( isatty(PerlIO_fileno(PerlIO_stdin())) )
833 open_script(scriptname,dosearch,sv);
835 validate_suid(validarg, scriptname);
840 main_cv = compcv = (CV*)NEWSV(1104,0);
841 sv_upgrade((SV *)compcv, SVt_PVCV);
845 av_push(comppad, Nullsv);
846 curpad = AvARRAY(comppad);
847 comppad_name = newAV();
848 comppad_name_fill = 0;
849 min_intro_pending = 0;
852 av_store(comppad_name, 0, newSVpv("@_", 2));
853 curpad[0] = (SV*)newAV();
854 SvPADMY_on(curpad[0]); /* XXX Needed? */
856 New(666, CvMUTEXP(compcv), 1, perl_mutex);
857 MUTEX_INIT(CvMUTEXP(compcv));
858 New(666, CvCONDP(compcv), 1, perl_cond);
859 COND_INIT(CvCONDP(compcv));
860 #endif /* USE_THREADS */
862 comppadlist = newAV();
863 AvREAL_off(comppadlist);
864 av_store(comppadlist, 0, (SV*)comppad_name);
865 av_store(comppadlist, 1, (SV*)comppad);
866 CvPADLIST(compcv) = comppadlist;
868 boot_core_UNIVERSAL();
870 (*xsinit)(); /* in case linked C routines want magical variables */
875 init_predump_symbols();
877 init_postdump_symbols(argc,argv,env);
881 /* now parse the script */
884 if (yyparse() || error_count) {
886 croak("%s had compilation errors.\n", origfilename);
888 croak("Execution of %s aborted due to compilation errors.\n",
892 curcop->cop_line = 0;
896 (void)UNLINK(e_tmpname);
901 /* now that script is parsed, we can modify record separator */
903 rs = SvREFCNT_inc(nrs);
904 sv_setsv(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), rs);
915 #ifdef DEBUGGING_MSTATS
916 if ((s=getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
917 dump_mstats("after compilation:");
928 PerlInterpreter *sv_interp;
935 if (!(curinterp = sv_interp))
938 oldscope = scopestack_ix;
943 cxstack_ix = -1; /* start context stack again */
946 /* my_exit() was called */
947 while (scopestack_ix > oldscope)
951 call_list(oldscope, endav);
953 #ifdef DEBUGGING_MSTATS
954 if (getenv("PERL_DEBUG_MSTATS"))
955 dump_mstats("after execution: ");
958 return STATUS_NATIVE_EXPORT;
961 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
966 if (curstack != mainstack) {
968 SWITCHSTACK(curstack, mainstack);
973 DEBUG_r(PerlIO_printf(PerlIO_stderr(), "%s $` $& $' support.\n",
974 sawampersand ? "Enabling" : "Omitting"));
978 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
980 DEBUG_L(PerlIO_printf(Perl_debug_log, "main thread is 0x%lx\n",
981 (unsigned long) thr));
982 #endif /* USE_THREADS */
985 PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", origfilename);
988 if (perldb && DBsingle)
989 sv_setiv(DBsingle, 1);
991 call_list(oldscope, restartav);
1001 else if (main_start) {
1002 CvDEPTH(main_cv) = 1;
1013 perl_get_sv(name, create)
1017 GV* gv = gv_fetchpv(name, create, SVt_PV);
1024 perl_get_av(name, create)
1028 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1037 perl_get_hv(name, create)
1041 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1050 perl_get_cv(name, create)
1054 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
1055 if (create && !GvCVu(gv))
1056 return newSUB(start_subparse(FALSE, 0),
1057 newSVOP(OP_CONST, 0, newSVpv(name,0)),
1065 /* Be sure to refetch the stack pointer after calling these routines. */
1068 perl_call_argv(subname, flags, argv)
1070 I32 flags; /* See G_* flags in cop.h */
1071 register char **argv; /* null terminated arg list */
1079 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
1084 return perl_call_pv(subname, flags);
1088 perl_call_pv(subname, flags)
1089 char *subname; /* name of the subroutine */
1090 I32 flags; /* See G_* flags in cop.h */
1092 return perl_call_sv((SV*)perl_get_cv(subname, TRUE), flags);
1096 perl_call_method(methname, flags)
1097 char *methname; /* name of the subroutine */
1098 I32 flags; /* See G_* flags in cop.h */
1105 XPUSHs(sv_2mortal(newSVpv(methname,0)));
1108 return perl_call_sv(*stack_sp--, flags);
1111 /* May be called with any of a CV, a GV, or an SV containing the name. */
1113 perl_call_sv(sv, flags)
1115 I32 flags; /* See G_* flags in cop.h */
1118 LOGOP myop; /* fake syntax tree node */
1124 bool oldcatch = CATCH_GET;
1128 if (flags & G_DISCARD) {
1133 Zero(&myop, 1, LOGOP);
1134 myop.op_next = Nullop;
1135 if (!(flags & G_NOARGS))
1136 myop.op_flags |= OPf_STACKED;
1137 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1138 (flags & G_ARRAY) ? OPf_WANT_LIST :
1143 EXTEND(stack_sp, 1);
1146 oldscope = scopestack_ix;
1148 if (perldb && curstash != debstash
1149 /* Handle first BEGIN of -d. */
1150 && (DBcv || (DBcv = GvCV(DBsub)))
1151 /* Try harder, since this may have been a sighandler, thus
1152 * curstash may be meaningless. */
1153 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != debstash))
1154 op->op_private |= OPpENTERSUB_DB;
1156 if (flags & G_EVAL) {
1157 cLOGOP->op_other = op;
1159 /* we're trying to emulate pp_entertry() here */
1161 register CONTEXT *cx;
1162 I32 gimme = GIMME_V;
1167 push_return(op->op_next);
1168 PUSHBLOCK(cx, CXt_EVAL, stack_sp);
1170 eval_root = op; /* Only needed so that goto works right. */
1173 if (flags & G_KEEPERR)
1176 sv_setpv(GvSV(errgv),"");
1188 /* my_exit() was called */
1189 curstash = defstash;
1193 croak("Callback called exit");
1202 stack_sp = stack_base + oldmark;
1203 if (flags & G_ARRAY)
1207 *++stack_sp = &sv_undef;
1215 if (op == (OP*)&myop)
1216 op = pp_entersub(ARGS);
1219 retval = stack_sp - (stack_base + oldmark);
1220 if ((flags & G_EVAL) && !(flags & G_KEEPERR))
1221 sv_setpv(GvSV(errgv),"");
1224 if (flags & G_EVAL) {
1225 if (scopestack_ix > oldscope) {
1229 register CONTEXT *cx;
1241 CATCH_SET(oldcatch);
1243 if (flags & G_DISCARD) {
1244 stack_sp = stack_base + oldmark;
1252 /* Eval a string. The G_EVAL flag is always assumed. */
1255 perl_eval_sv(sv, flags)
1257 I32 flags; /* See G_* flags in cop.h */
1260 UNOP myop; /* fake syntax tree node */
1262 I32 oldmark = sp - stack_base;
1268 if (flags & G_DISCARD) {
1276 EXTEND(stack_sp, 1);
1278 oldscope = scopestack_ix;
1280 if (!(flags & G_NOARGS))
1281 myop.op_flags = OPf_STACKED;
1282 myop.op_next = Nullop;
1283 myop.op_type = OP_ENTEREVAL;
1284 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1285 (flags & G_ARRAY) ? OPf_WANT_LIST :
1287 if (flags & G_KEEPERR)
1288 myop.op_flags |= OPf_SPECIAL;
1298 /* my_exit() was called */
1299 curstash = defstash;
1303 croak("Callback called exit");
1312 stack_sp = stack_base + oldmark;
1313 if (flags & G_ARRAY)
1317 *++stack_sp = &sv_undef;
1322 if (op == (OP*)&myop)
1323 op = pp_entereval(ARGS);
1326 retval = stack_sp - (stack_base + oldmark);
1327 if (!(flags & G_KEEPERR))
1328 sv_setpv(GvSV(errgv),"");
1332 if (flags & G_DISCARD) {
1333 stack_sp = stack_base + oldmark;
1342 perl_eval_pv(p, croak_on_error)
1348 SV* sv = newSVpv(p, 0);
1351 perl_eval_sv(sv, G_SCALAR);
1358 if (croak_on_error && SvTRUE(GvSV(errgv)))
1359 croak(SvPVx(GvSV(errgv), na));
1364 /* Require a module. */
1370 SV* sv = sv_newmortal();
1371 sv_setpv(sv, "require '");
1374 perl_eval_sv(sv, G_DISCARD);
1378 magicname(sym,name,namlen)
1385 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1386 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1390 usage(name) /* XXX move this out into a module ? */
1393 /* This message really ought to be max 23 lines.
1394 * Removed -h because the user already knows that opton. Others? */
1395 printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1396 printf("\n -0[octal] specify record separator (\\0, if no argument)");
1397 printf("\n -a autosplit mode with -n or -p (splits $_ into @F)");
1398 printf("\n -c check syntax only (runs BEGIN and END blocks)");
1399 printf("\n -d[:debugger] run scripts under debugger");
1400 printf("\n -D[number/list] set debugging flags (argument is a bit mask or flags)");
1401 printf("\n -e 'command' one line of script. Several -e's allowed. Omit [programfile].");
1402 printf("\n -F/pattern/ split() pattern for autosplit (-a). The //'s are optional.");
1403 printf("\n -i[extension] edit <> files in place (make backup if extension supplied)");
1404 printf("\n -Idirectory specify @INC/#include directory (may be used more then once)");
1405 printf("\n -l[octal] enable line ending processing, specifies line teminator");
1406 printf("\n -[mM][-]module.. executes `use/no module...' before executing your script.");
1407 printf("\n -n assume 'while (<>) { ... }' loop arround your script");
1408 printf("\n -p assume loop like -n but print line also like sed");
1409 printf("\n -P run script through C preprocessor before compilation");
1410 printf("\n -s enable some switch parsing for switches after script name");
1411 printf("\n -S look for the script using PATH environment variable");
1412 printf("\n -T turn on tainting checks");
1413 printf("\n -u dump core after parsing script");
1414 printf("\n -U allow unsafe operations");
1415 printf("\n -v print version number and patchlevel of perl");
1416 printf("\n -V[:variable] print perl configuration information");
1417 printf("\n -w TURN WARNINGS ON FOR COMPILATION OF YOUR SCRIPT.");
1418 printf("\n -x[directory] strip off text before #!perl line and perhaps cd to directory\n");
1421 /* This routine handles any switches that can be given during run */
1432 rschar = scan_oct(s, 4, &numlen);
1434 if (rschar & ~((U8)~0))
1436 else if (!rschar && numlen >= 2)
1437 nrs = newSVpv("", 0);
1440 nrs = newSVpv(&ch, 1);
1445 splitstr = savepv(s + 1);
1459 if (*s == ':' || *s == '=') {
1460 my_setenv("PERL5DB", form("use Devel::%s;", ++s));
1471 if (isALPHA(s[1])) {
1472 static char debopts[] = "psltocPmfrxuLHXD";
1475 for (s++; *s && (d = strchr(debopts,*s)); s++)
1476 debug |= 1 << (d - debopts);
1480 for (s++; isDIGIT(*s); s++) ;
1482 debug |= 0x80000000;
1484 warn("Recompile perl with -DDEBUGGING to use -D switch\n");
1485 for (s++; isALNUM(*s); s++) ;
1495 inplace = savepv(s+1);
1497 for (s = inplace; *s && !isSPACE(*s); s++) ;
1504 for (e = s; *e && !isSPACE(*e); e++) ;
1505 p = savepvn(s, e-s);
1512 croak("No space allowed after -I");
1522 *ors = scan_oct(s, 3 + (*s == '0'), &numlen);
1531 ors = SvPV(nrs, orslen);
1532 ors = savepvn(ors, orslen);
1536 forbid_setid("-M"); /* XXX ? */
1539 forbid_setid("-m"); /* XXX ? */
1544 /* -M-foo == 'no foo' */
1545 if (*s == '-') { use = "no "; ++s; }
1546 sv = newSVpv(use,0);
1548 /* We allow -M'Module qw(Foo Bar)' */
1549 while(isALNUM(*s) || *s==':') ++s;
1551 sv_catpv(sv, start);
1552 if (*(start-1) == 'm') {
1554 croak("Can't use '%c' after -mname", *s);
1555 sv_catpv( sv, " ()");
1558 sv_catpvn(sv, start, s-start);
1559 sv_catpv(sv, " split(/,/,q{");
1564 if (preambleav == NULL)
1565 preambleav = newAV();
1566 av_push(preambleav, sv);
1569 croak("No space allowed after -%c", *(s-1));
1586 croak("Too late for \"-T\" option");
1598 #if defined(SUBVERSION) && SUBVERSION > 0
1599 printf("\nThis is perl, version 5.%03d_%02d", PATCHLEVEL, SUBVERSION);
1601 printf("\nThis is perl, version %s",patchlevel);
1604 printf("\n\nCopyright 1987-1997, Larry Wall\n");
1606 printf("\n\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1609 printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
1612 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1613 "Version 5 port Copyright (c) 1994-1997, Andreas Kaiser, Ilya Zakharevich\n");
1616 printf("atariST series port, ++jrb bammi@cadence.com\n");
1619 Perl may be copied only under the terms of either the Artistic License or the\n\
1620 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n");
1628 if (s[1] == '-') /* Additional switches on #! line. */
1636 #ifdef ALTERNATE_SHEBANG
1637 case 'S': /* OS/2 needs -S on "extproc" line. */
1645 croak("Can't emulate -%.1s on #! line",s);
1650 /* compliments of Tom Christiansen */
1652 /* unexec() can be found in the Gnu emacs distribution */
1663 prog = newSVpv(BIN_EXP);
1664 sv_catpv(prog, "/perl");
1665 file = newSVpv(origfilename);
1666 sv_catpv(file, ".perldump");
1668 status = unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
1670 PerlIO_printf(PerlIO_stderr(), "unexec of %s into %s failed!\n",
1671 SvPVX(prog), SvPVX(file));
1675 # include <lib$routines.h>
1676 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
1678 ABORT(); /* for use with undump */
1689 /* Note that strtab is a rather special HV. Assumptions are made
1690 about not iterating on it, and not adding tie magic to it.
1691 It is properly deallocated in perl_destruct() */
1693 HvSHAREKEYS_off(strtab); /* mandatory */
1694 Newz(506,((XPVHV*)SvANY(strtab))->xhv_array,
1695 sizeof(HE*) * (((XPVHV*)SvANY(strtab))->xhv_max + 1), char);
1697 curstash = defstash = newHV();
1698 curstname = newSVpv("main",4);
1699 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1700 SvREFCNT_dec(GvHV(gv));
1701 GvHV(gv) = (HV*)SvREFCNT_inc(defstash);
1703 HvNAME(defstash) = savepv("main");
1704 incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1706 defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1707 errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1709 sv_setpvn(GvSV(errgv), "", 0);
1710 curstash = defstash;
1711 compiling.cop_stash = defstash;
1712 debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
1713 /* We must init $/ before switches are processed. */
1714 sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1);
1717 #ifdef CAN_PROTOTYPE
1719 open_script(char *scriptname, bool dosearch, SV *sv)
1722 open_script(scriptname,dosearch,sv)
1729 char *xfound = Nullch;
1730 char *xfailed = Nullch;
1734 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
1735 # define SEARCH_EXTS ".bat", ".cmd", NULL
1736 # define MAX_EXT_LEN 4
1739 # define SEARCH_EXTS ".pl", ".com", NULL
1740 # define MAX_EXT_LEN 4
1742 /* additional extensions to try in each dir if scriptname not found */
1744 char *ext[] = { SEARCH_EXTS };
1745 int extidx = (strchr(scriptname,'.')) ? -1 : 0; /* has ext already */
1747 # define MAX_EXT_LEN 0
1752 int hasdir, idx = 0, deftypes = 1;
1754 hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
1755 /* The first time through, just add SEARCH_EXTS to whatever we
1756 * already have, so we can check for default file types. */
1758 (!hasdir && my_trnlnm("DCL$PATH",tokenbuf,idx++)) )
1764 if ((strlen(tokenbuf) + strlen(scriptname)
1765 + MAX_EXT_LEN) >= sizeof tokenbuf)
1766 continue; /* don't search dir with too-long name */
1767 strcat(tokenbuf, scriptname);
1769 if (dosearch && !strchr(scriptname, '/') && (s = getenv("PATH"))) {
1770 bufend = s + strlen(s);
1771 while (s < bufend) {
1773 s = delimcpy(tokenbuf, tokenbuf + sizeof tokenbuf, s, bufend,
1781 for (len = 0; *s && *s != ',' && *s != ';'; len++, s++) {
1782 if (len < sizeof tokenbuf)
1785 if (len < sizeof tokenbuf)
1786 tokenbuf[len] = '\0';
1787 #endif /* atarist */
1790 if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tokenbuf)
1791 continue; /* don't search dir with too-long name */
1793 #if defined(atarist) && !defined(DOSISH)
1794 && tokenbuf[len - 1] != '/'
1796 #if defined(atarist) || defined(DOSISH)
1797 && tokenbuf[len - 1] != '\\'
1800 tokenbuf[len++] = '/';
1801 (void)strcpy(tokenbuf + len, scriptname);
1805 len = strlen(tokenbuf);
1806 if (extidx > 0) /* reset after previous loop */
1810 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tokenbuf));
1811 retval = Stat(tokenbuf,&statbuf);
1813 } while ( retval < 0 /* not there */
1814 && extidx>=0 && ext[extidx] /* try an extension? */
1815 && strcpy(tokenbuf+len, ext[extidx++])
1820 if (S_ISREG(statbuf.st_mode)
1821 && cando(S_IRUSR,TRUE,&statbuf)
1823 && cando(S_IXUSR,TRUE,&statbuf)
1827 xfound = tokenbuf; /* bingo! */
1831 xfailed = savepv(tokenbuf);
1834 croak("Can't execute %s", xfailed ? xfailed : scriptname );
1837 scriptname = xfound;
1840 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
1841 char *s = scriptname + 8;
1850 origfilename = savepv(e_tmpname ? "-e" : scriptname);
1851 curcop->cop_filegv = gv_fetchfile(origfilename);
1852 if (strEQ(origfilename,"-"))
1854 if (fdscript >= 0) {
1855 rsfp = PerlIO_fdopen(fdscript,"r");
1856 #if defined(HAS_FCNTL) && defined(F_SETFD)
1858 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
1861 else if (preprocess) {
1862 char *cpp_cfg = CPPSTDIN;
1863 SV *cpp = NEWSV(0,0);
1864 SV *cmd = NEWSV(0,0);
1866 if (strEQ(cpp_cfg, "cppstdin"))
1867 sv_catpvf(cpp, "%s/", BIN_EXP);
1868 sv_catpv(cpp, cpp_cfg);
1871 sv_catpv(sv,PRIVLIB_EXP);
1875 sed %s -e \"/^[^#]/b\" \
1876 -e \"/^#[ ]*include[ ]/b\" \
1877 -e \"/^#[ ]*define[ ]/b\" \
1878 -e \"/^#[ ]*if[ ]/b\" \
1879 -e \"/^#[ ]*ifdef[ ]/b\" \
1880 -e \"/^#[ ]*ifndef[ ]/b\" \
1881 -e \"/^#[ ]*else/b\" \
1882 -e \"/^#[ ]*elif[ ]/b\" \
1883 -e \"/^#[ ]*undef[ ]/b\" \
1884 -e \"/^#[ ]*endif/b\" \
1887 (doextract ? "-e \"1,/^#/d\n\"" : ""),
1890 %s %s -e '/^[^#]/b' \
1891 -e '/^#[ ]*include[ ]/b' \
1892 -e '/^#[ ]*define[ ]/b' \
1893 -e '/^#[ ]*if[ ]/b' \
1894 -e '/^#[ ]*ifdef[ ]/b' \
1895 -e '/^#[ ]*ifndef[ ]/b' \
1896 -e '/^#[ ]*else/b' \
1897 -e '/^#[ ]*elif[ ]/b' \
1898 -e '/^#[ ]*undef[ ]/b' \
1899 -e '/^#[ ]*endif/b' \
1907 (doextract ? "-e '1,/^#/d\n'" : ""),
1909 scriptname, cpp, sv, CPPMINUS);
1911 #ifdef IAMSUID /* actually, this is caught earlier */
1912 if (euid != uid && !euid) { /* if running suidperl */
1914 (void)seteuid(uid); /* musn't stay setuid root */
1917 (void)setreuid((Uid_t)-1, uid);
1919 #ifdef HAS_SETRESUID
1920 (void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
1926 if (geteuid() != uid)
1927 croak("Can't do seteuid!\n");
1929 #endif /* IAMSUID */
1930 rsfp = my_popen(SvPVX(cmd), "r");
1934 else if (!*scriptname) {
1935 forbid_setid("program input from stdin");
1936 rsfp = PerlIO_stdin();
1939 rsfp = PerlIO_open(scriptname,"r");
1940 #if defined(HAS_FCNTL) && defined(F_SETFD)
1942 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
1950 #ifndef IAMSUID /* in case script is not readable before setuid */
1951 if (euid && Stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
1952 statbuf.st_mode & (S_ISUID|S_ISGID)) {
1954 execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
1955 croak("Can't do setuid\n");
1959 croak("Can't open perl script \"%s\": %s\n",
1960 SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno));
1965 validate_suid(validarg, scriptname)
1971 /* do we need to emulate setuid on scripts? */
1973 /* This code is for those BSD systems that have setuid #! scripts disabled
1974 * in the kernel because of a security problem. Merely defining DOSUID
1975 * in perl will not fix that problem, but if you have disabled setuid
1976 * scripts in the kernel, this will attempt to emulate setuid and setgid
1977 * on scripts that have those now-otherwise-useless bits set. The setuid
1978 * root version must be called suidperl or sperlN.NNN. If regular perl
1979 * discovers that it has opened a setuid script, it calls suidperl with
1980 * the same argv that it had. If suidperl finds that the script it has
1981 * just opened is NOT setuid root, it sets the effective uid back to the
1982 * uid. We don't just make perl setuid root because that loses the
1983 * effective uid we had before invoking perl, if it was different from the
1986 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
1987 * be defined in suidperl only. suidperl must be setuid root. The
1988 * Configure script will set this up for you if you want it.
1994 if (Fstat(PerlIO_fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
1995 croak("Can't stat script \"%s\"",origfilename);
1996 if (fdscript < 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) {
2000 #ifndef HAS_SETREUID
2001 /* On this access check to make sure the directories are readable,
2002 * there is actually a small window that the user could use to make
2003 * filename point to an accessible directory. So there is a faint
2004 * chance that someone could execute a setuid script down in a
2005 * non-accessible directory. I don't know what to do about that.
2006 * But I don't think it's too important. The manual lies when
2007 * it says access() is useful in setuid programs.
2009 if (access(SvPVX(GvSV(curcop->cop_filegv)),1)) /*double check*/
2010 croak("Permission denied");
2012 /* If we can swap euid and uid, then we can determine access rights
2013 * with a simple stat of the file, and then compare device and
2014 * inode to make sure we did stat() on the same file we opened.
2015 * Then we just have to make sure he or she can execute it.
2018 struct stat tmpstatbuf;
2022 setreuid(euid,uid) < 0
2025 setresuid(euid,uid,(Uid_t)-1) < 0
2028 || getuid() != euid || geteuid() != uid)
2029 croak("Can't swap uid and euid"); /* really paranoid */
2030 if (Stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
2031 croak("Permission denied"); /* testing full pathname here */
2032 if (tmpstatbuf.st_dev != statbuf.st_dev ||
2033 tmpstatbuf.st_ino != statbuf.st_ino) {
2034 (void)PerlIO_close(rsfp);
2035 if (rsfp = my_popen("/bin/mail root","w")) { /* heh, heh */
2037 "User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2038 (Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
2039 (long)uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
2040 (long)statbuf.st_dev, (long)statbuf.st_ino,
2041 SvPVX(GvSV(curcop->cop_filegv)),
2042 (long)statbuf.st_uid, (long)statbuf.st_gid);
2043 (void)my_pclose(rsfp);
2045 croak("Permission denied\n");
2049 setreuid(uid,euid) < 0
2051 # if defined(HAS_SETRESUID)
2052 setresuid(uid,euid,(Uid_t)-1) < 0
2055 || getuid() != uid || geteuid() != euid)
2056 croak("Can't reswap uid and euid");
2057 if (!cando(S_IXUSR,FALSE,&statbuf)) /* can real uid exec? */
2058 croak("Permission denied\n");
2060 #endif /* HAS_SETREUID */
2061 #endif /* IAMSUID */
2063 if (!S_ISREG(statbuf.st_mode))
2064 croak("Permission denied");
2065 if (statbuf.st_mode & S_IWOTH)
2066 croak("Setuid/gid script is writable by world");
2067 doswitches = FALSE; /* -s is insecure in suid */
2069 if (sv_gets(linestr, rsfp, 0) == Nullch ||
2070 strnNE(SvPV(linestr,na),"#!",2) ) /* required even on Sys V */
2071 croak("No #! line");
2072 s = SvPV(linestr,na)+2;
2074 while (!isSPACE(*s)) s++;
2075 for (s2 = s; (s2 > SvPV(linestr,na)+2 &&
2076 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
2077 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
2078 croak("Not a perl script");
2079 while (*s == ' ' || *s == '\t') s++;
2081 * #! arg must be what we saw above. They can invoke it by
2082 * mentioning suidperl explicitly, but they may not add any strange
2083 * arguments beyond what #! says if they do invoke suidperl that way.
2085 len = strlen(validarg);
2086 if (strEQ(validarg," PHOOEY ") ||
2087 strnNE(s,validarg,len) || !isSPACE(s[len]))
2088 croak("Args must match #! line");
2091 if (euid != uid && (statbuf.st_mode & S_ISUID) &&
2092 euid == statbuf.st_uid)
2094 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2095 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2096 #endif /* IAMSUID */
2098 if (euid) { /* oops, we're not the setuid root perl */
2099 (void)PerlIO_close(rsfp);
2102 execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
2104 croak("Can't do setuid\n");
2107 if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
2109 (void)setegid(statbuf.st_gid);
2112 (void)setregid((Gid_t)-1,statbuf.st_gid);
2114 #ifdef HAS_SETRESGID
2115 (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
2117 setgid(statbuf.st_gid);
2121 if (getegid() != statbuf.st_gid)
2122 croak("Can't do setegid!\n");
2124 if (statbuf.st_mode & S_ISUID) {
2125 if (statbuf.st_uid != euid)
2127 (void)seteuid(statbuf.st_uid); /* all that for this */
2130 (void)setreuid((Uid_t)-1,statbuf.st_uid);
2132 #ifdef HAS_SETRESUID
2133 (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
2135 setuid(statbuf.st_uid);
2139 if (geteuid() != statbuf.st_uid)
2140 croak("Can't do seteuid!\n");
2142 else if (uid) { /* oops, mustn't run as root */
2144 (void)seteuid((Uid_t)uid);
2147 (void)setreuid((Uid_t)-1,(Uid_t)uid);
2149 #ifdef HAS_SETRESUID
2150 (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
2156 if (geteuid() != uid)
2157 croak("Can't do seteuid!\n");
2160 if (!cando(S_IXUSR,TRUE,&statbuf))
2161 croak("Permission denied\n"); /* they can't do this */
2164 else if (preprocess)
2165 croak("-P not allowed for setuid/setgid script\n");
2166 else if (fdscript >= 0)
2167 croak("fd script not allowed in suidperl\n");
2169 croak("Script is not setuid/setgid in suidperl\n");
2171 /* We absolutely must clear out any saved ids here, so we */
2172 /* exec the real perl, substituting fd script for scriptname. */
2173 /* (We pass script name as "subdir" of fd, which perl will grok.) */
2174 PerlIO_rewind(rsfp);
2175 lseek(PerlIO_fileno(rsfp),(Off_t)0,0); /* just in case rewind didn't */
2176 for (which = 1; origargv[which] && origargv[which] != scriptname; which++) ;
2177 if (!origargv[which])
2178 croak("Permission denied");
2179 origargv[which] = savepv(form("/dev/fd/%d/%s",
2180 PerlIO_fileno(rsfp), origargv[which]));
2181 #if defined(HAS_FCNTL) && defined(F_SETFD)
2182 fcntl(PerlIO_fileno(rsfp),F_SETFD,0); /* ensure no close-on-exec */
2184 execv(form("%s/perl%s", BIN_EXP, patchlevel), origargv); /* try again */
2185 croak("Can't do setuid\n");
2186 #endif /* IAMSUID */
2188 if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */
2189 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2190 Fstat(PerlIO_fileno(rsfp),&statbuf); /* may be either wrapped or real suid */
2191 if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
2193 (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
2196 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2197 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2198 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2199 /* not set-id, must be wrapped */
2207 register char *s, *s2;
2209 /* skip forward in input to the real script? */
2213 if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
2214 croak("No Perl script found in input\n");
2215 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2216 PerlIO_ungetc(rsfp, '\n'); /* to keep line count right */
2218 while (*s && !(isSPACE (*s) || *s == '#')) s++;
2220 while (*s == ' ' || *s == '\t') s++;
2222 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2223 if (strnEQ(s2-4,"perl",4))
2225 while (s = moreswitches(s)) ;
2227 if (cddir && chdir(cddir) < 0)
2228 croak("Can't chdir to %s",cddir);
2236 uid = (int)getuid();
2237 euid = (int)geteuid();
2238 gid = (int)getgid();
2239 egid = (int)getegid();
2244 tainting |= (uid && (euid != uid || egid != gid));
2252 croak("No %s allowed while running setuid", s);
2254 croak("No %s allowed while running setgid", s);
2261 curstash = debstash;
2262 dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2264 DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2265 DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2266 DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2267 DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2268 sv_setiv(DBsingle, 0);
2269 DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2270 sv_setiv(DBtrace, 0);
2271 DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2272 sv_setiv(DBsignal, 0);
2273 curstash = defstash;
2281 mainstack = curstack; /* remember in case we switch stacks */
2282 AvREAL_off(curstack); /* not a real array */
2283 av_extend(curstack,127);
2285 stack_base = AvARRAY(curstack);
2286 stack_sp = stack_base;
2287 stack_max = stack_base + 127;
2289 cxstack_max = 8192 / sizeof(CONTEXT) - 2; /* Use most of 8K. */
2290 New(50,cxstack,cxstack_max + 1,CONTEXT);
2293 New(50,tmps_stack,128,SV*);
2299 * The following stacks almost certainly should be per-interpreter,
2300 * but for now they're not. XXX
2304 markstack_ptr = markstack;
2306 New(54,markstack,64,I32);
2307 markstack_ptr = markstack;
2308 markstack_max = markstack + 64;
2314 New(54,scopestack,32,I32);
2316 scopestack_max = 32;
2322 New(54,savestack,128,ANY);
2324 savestack_max = 128;
2330 New(54,retstack,16,OP*);
2341 Safefree(tmps_stack);
2348 static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
2356 subname = newSVpv("main",4);
2360 init_predump_symbols()
2366 sv_setpvn(GvSV(gv_fetchpv("\"", TRUE, SVt_PV)), " ", 1);
2368 stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2369 GvMULTI_on(stdingv);
2370 IoIFP(GvIOp(stdingv)) = PerlIO_stdin();
2371 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2373 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv));
2375 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2377 IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
2379 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2381 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv));
2383 othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2384 GvMULTI_on(othergv);
2385 IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr();
2386 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2388 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
2390 statname = NEWSV(66,0); /* last filename we did stat on */
2393 osname = savepv(OSNAME);
2397 init_postdump_symbols(argc,argv,env)
2399 register char **argv;
2400 register char **env;
2406 argc--,argv++; /* skip name of script */
2408 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2411 if (argv[0][1] == '-') {
2415 if (s = strchr(argv[0], '=')) {
2417 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2420 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2423 toptarget = NEWSV(0,0);
2424 sv_upgrade(toptarget, SVt_PVFM);
2425 sv_setpvn(toptarget, "", 0);
2426 bodytarget = NEWSV(0,0);
2427 sv_upgrade(bodytarget, SVt_PVFM);
2428 sv_setpvn(bodytarget, "", 0);
2429 formtarget = bodytarget;
2432 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2433 sv_setpv(GvSV(tmpgv),origfilename);
2434 magicname("0", "0", 1);
2436 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2437 sv_setpv(GvSV(tmpgv),origargv[0]);
2438 if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2440 (void)gv_AVadd(argvgv);
2441 av_clear(GvAVn(argvgv));
2442 for (; argc > 0; argc--,argv++) {
2443 av_push(GvAVn(argvgv),newSVpv(argv[0],0));
2446 if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2450 hv_magic(hv, envgv, 'E');
2451 #ifndef VMS /* VMS doesn't have environ array */
2452 /* Note that if the supplied env parameter is actually a copy
2453 of the global environ then it may now point to free'd memory
2454 if the environment has been modified since. To avoid this
2455 problem we treat env==NULL as meaning 'use the default'
2460 environ[0] = Nullch;
2461 for (; *env; env++) {
2462 if (!(s = strchr(*env,'=')))
2468 sv = newSVpv(s--,0);
2469 (void)hv_store(hv, *env, s - *env, sv, 0);
2473 #ifdef DYNAMIC_ENV_FETCH
2474 HvNAME(hv) = savepv(ENV_HV_NAME);
2478 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2479 sv_setiv(GvSV(tmpgv), (IV)getpid());
2488 s = getenv("PERL5LIB");
2492 incpush(getenv("PERLLIB"), FALSE);
2494 /* Treat PERL5?LIB as a possible search list logical name -- the
2495 * "natural" VMS idiom for a Unix path string. We allow each
2496 * element to be a set of |-separated directories for compatibility.
2500 if (my_trnlnm("PERL5LIB",buf,0))
2501 do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2503 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2507 /* Use the ~-expanded versions of APPLLIB (undocumented),
2508 ARCHLIB PRIVLIB SITEARCH SITELIB and OLDARCHLIB
2511 incpush(APPLLIB_EXP, FALSE);
2515 incpush(ARCHLIB_EXP, FALSE);
2518 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2520 incpush(PRIVLIB_EXP, FALSE);
2523 incpush(SITEARCH_EXP, FALSE);
2526 incpush(SITELIB_EXP, FALSE);
2528 #ifdef OLDARCHLIB_EXP /* 5.00[01] compatibility */
2529 incpush(OLDARCHLIB_EXP, FALSE);
2533 incpush(".", FALSE);
2537 # define PERLLIB_SEP ';'
2540 # define PERLLIB_SEP '|'
2542 # define PERLLIB_SEP ':'
2545 #ifndef PERLLIB_MANGLE
2546 # define PERLLIB_MANGLE(s,n) (s)
2550 incpush(p, addsubdirs)
2554 SV *subdir = Nullsv;
2555 static char *archpat_auto;
2562 if (!archpat_auto) {
2563 STRLEN len = (sizeof(ARCHNAME) + strlen(patchlevel)
2564 + sizeof("//auto"));
2565 New(55, archpat_auto, len, char);
2566 sprintf(archpat_auto, "/%s/%s/auto", ARCHNAME, patchlevel);
2568 for (len = sizeof(ARCHNAME) + 2;
2569 archpat_auto[len] != '\0' && archpat_auto[len] != '/'; len++)
2570 if (archpat_auto[len] == '.') archpat_auto[len] = '_';
2575 /* Break at all separators */
2577 SV *libdir = newSV(0);
2580 /* skip any consecutive separators */
2581 while ( *p == PERLLIB_SEP ) {
2582 /* Uncomment the next line for PATH semantics */
2583 /* av_push(GvAVn(incgv), newSVpv(".", 1)); */
2587 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2588 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2593 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2594 p = Nullch; /* break out */
2598 * BEFORE pushing libdir onto @INC we may first push version- and
2599 * archname-specific sub-directories.
2602 struct stat tmpstatbuf;
2607 if ((unix = tounixspec_ts(SvPV(libdir,na),Nullch)) != Nullch) {
2609 while (unix[len-1] == '/') len--; /* Cosmetic */
2610 sv_usepvn(libdir,unix,len);
2613 PerlIO_printf(PerlIO_stderr(),
2614 "Failed to unixify @INC element \"%s\"\n",
2617 /* .../archname/version if -d .../archname/version/auto */
2618 sv_setsv(subdir, libdir);
2619 sv_catpv(subdir, archpat_auto);
2620 if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2621 S_ISDIR(tmpstatbuf.st_mode))
2622 av_push(GvAVn(incgv),
2623 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2625 /* .../archname if -d .../archname/auto */
2626 sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
2627 strlen(patchlevel) + 1, "", 0);
2628 if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2629 S_ISDIR(tmpstatbuf.st_mode))
2630 av_push(GvAVn(incgv),
2631 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2634 /* finally push this lib directory on the end of @INC */
2635 av_push(GvAVn(incgv), libdir);
2638 SvREFCNT_dec(subdir);
2642 call_list(oldscope, list)
2647 line_t oldline = curcop->cop_line;
2652 while (AvFILL(list) >= 0) {
2653 CV *cv = (CV*)av_shift(list);
2660 SV* atsv = GvSV(errgv);
2662 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
2663 (void)SvPV(atsv, len);
2666 curcop = &compiling;
2667 curcop->cop_line = oldline;
2668 if (list == beginav)
2669 sv_catpv(atsv, "BEGIN failed--compilation aborted");
2671 sv_catpv(atsv, "END failed--cleanup aborted");
2672 while (scopestack_ix > oldscope)
2674 croak("%s", SvPVX(atsv));
2682 /* my_exit() was called */
2683 while (scopestack_ix > oldscope)
2685 curstash = defstash;
2687 call_list(oldscope, endav);
2690 curcop = &compiling;
2691 curcop->cop_line = oldline;
2693 if (list == beginav)
2694 croak("BEGIN failed--compilation aborted");
2696 croak("END failed--cleanup aborted");
2702 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
2707 curcop = &compiling;
2708 curcop->cop_line = oldline;
2722 DEBUG_L(PerlIO_printf(Perl_debug_log, "my_exit: thread 0x%lx, status %lu\n",
2723 (unsigned long) thr, (unsigned long) status));
2724 #endif /* USE_THREADS */
2733 STATUS_NATIVE_SET(status);
2743 if (vaxc$errno & 1) {
2744 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
2745 STATUS_NATIVE_SET(44);
2748 if (!vaxc$errno && errno) /* unlikely */
2749 STATUS_NATIVE_SET(44);
2751 STATUS_NATIVE_SET(vaxc$errno);
2755 STATUS_POSIX_SET(errno);
2756 else if (STATUS_POSIX == 0)
2757 STATUS_POSIX_SET(255);
2766 register CONTEXT *cx;
2775 (void)UNLINK(e_tmpname);
2776 Safefree(e_tmpname);
2780 if (cxstack_ix >= 0) {