3 * Copyright (c) 1987-1999 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
15 #define PERL_IN_PERL_C
17 #include "patchlevel.h" /* for local_patches */
19 /* XXX If this causes problems, set i_unistd=undef in the hint file. */
24 #if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE)
25 char *getenv (char *); /* Usually in <stdlib.h> */
28 static I32 read_e_script(pTHXo_ int idx, SV *buf_sv, int maxlen);
43 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
50 CPerlObj* perl_alloc(IPerlMem* ipM, IPerlEnv* ipE, IPerlStdIO* ipStd,
51 IPerlLIO* ipLIO, IPerlDir* ipD, IPerlSock* ipS, IPerlProc* ipP)
53 CPerlObj* pPerl = new(ipM) CPerlObj(ipM, ipE, ipStd, ipLIO, ipD, ipS, ipP);
63 PerlInterpreter *my_perl;
65 /* New() needs interpreter, so call malloc() instead */
66 my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
67 PERL_SET_INTERP(my_perl);
70 #endif /* PERL_OBJECT */
78 struct perl_thread *thr;
79 #endif /* FAKE_THREADS */
80 #endif /* USE_THREADS */
83 Zero(my_perl, 1, PerlInterpreter);
88 PL_perl_destruct_level = 1;
90 if (PL_perl_destruct_level > 0)
94 /* Init the real globals (and main thread)? */
99 #ifdef ALLOC_THREAD_KEY
102 if (pthread_key_create(&PL_thr_key, 0))
103 Perl_croak(aTHX_ "panic: pthread_key_create");
105 MUTEX_INIT(&PL_sv_mutex);
107 * Safe to use basic SV functions from now on (though
108 * not things like mortals or tainting yet).
110 MUTEX_INIT(&PL_eval_mutex);
111 COND_INIT(&PL_eval_cond);
112 MUTEX_INIT(&PL_threads_mutex);
113 COND_INIT(&PL_nthreads_cond);
114 #ifdef EMULATE_ATOMIC_REFCOUNTS
115 MUTEX_INIT(&PL_svref_mutex);
116 #endif /* EMULATE_ATOMIC_REFCOUNTS */
118 MUTEX_INIT(&PL_cred_mutex);
120 thr = init_main_thread();
121 #endif /* USE_THREADS */
123 PL_protect = MEMBER_TO_FPTR(Perl_default_protect); /* for exceptions */
125 PL_curcop = &PL_compiling; /* needed by ckWARN, right away */
127 PL_linestr = NEWSV(65,79);
128 sv_upgrade(PL_linestr,SVt_PVIV);
130 if (!SvREADONLY(&PL_sv_undef)) {
131 /* set read-only and try to insure than we wont see REFCNT==0
134 SvREADONLY_on(&PL_sv_undef);
135 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
137 sv_setpv(&PL_sv_no,PL_No);
139 SvREADONLY_on(&PL_sv_no);
140 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
142 sv_setpv(&PL_sv_yes,PL_Yes);
144 SvREADONLY_on(&PL_sv_yes);
145 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
150 /* PL_sighandlerp = sighandler; */
152 PL_sighandlerp = Perl_sighandler;
154 PL_pidstatus = newHV();
158 * There is no way we can refer to them from Perl so close them to save
159 * space. The other alternative would be to provide STDAUX and STDPRN
162 (void)fclose(stdaux);
163 (void)fclose(stdprn);
167 PL_nrs = newSVpvn("\n", 1);
168 PL_rs = SvREFCNT_inc(PL_nrs);
173 PL_lex_state = LEX_NOTPARSING;
179 SET_NUMERIC_STANDARD();
180 #if defined(PERL_SUBVERSION) && PERL_SUBVERSION > 0
181 sprintf(PL_patchlevel, "%7.5f", (double) PERL_REVISION
182 + ((double) PERL_VERSION / (double) 1000)
183 + ((double) PERL_SUBVERSION / (double) 100000));
185 sprintf(PL_patchlevel, "%5.3f", (double) PERL_REVISION +
186 ((double) PERL_VERSION / (double) 1000));
189 #if defined(LOCAL_PATCH_COUNT)
190 PL_localpatches = local_patches; /* For possible -v */
193 PerlIO_init(); /* Hook to IO system */
195 PL_fdpid = newAV(); /* for remembering popen pids by fd */
196 PL_modglobal = newHV(); /* pointers to per-interpreter module globals */
199 New(51,PL_debname,128,char);
200 New(52,PL_debdelim,128,char);
210 int destruct_level; /* 0=none, 1=full, 2=full with checks */
216 #endif /* USE_THREADS */
220 /* Pass 1 on any remaining threads: detach joinables, join zombies */
222 MUTEX_LOCK(&PL_threads_mutex);
223 DEBUG_S(PerlIO_printf(PerlIO_stderr(),
224 "perl_destruct: waiting for %d threads...\n",
226 for (t = thr->next; t != thr; t = t->next) {
227 MUTEX_LOCK(&t->mutex);
228 switch (ThrSTATE(t)) {
231 DEBUG_S(PerlIO_printf(PerlIO_stderr(),
232 "perl_destruct: joining zombie %p\n", t));
233 ThrSETSTATE(t, THRf_DEAD);
234 MUTEX_UNLOCK(&t->mutex);
237 * The SvREFCNT_dec below may take a long time (e.g. av
238 * may contain an object scalar whose destructor gets
239 * called) so we have to unlock threads_mutex and start
242 MUTEX_UNLOCK(&PL_threads_mutex);
244 SvREFCNT_dec((SV*)av);
245 DEBUG_S(PerlIO_printf(PerlIO_stderr(),
246 "perl_destruct: joined zombie %p OK\n", t));
248 case THRf_R_JOINABLE:
249 DEBUG_S(PerlIO_printf(PerlIO_stderr(),
250 "perl_destruct: detaching thread %p\n", t));
251 ThrSETSTATE(t, THRf_R_DETACHED);
253 * We unlock threads_mutex and t->mutex in the opposite order
254 * from which we locked them just so that DETACH won't
255 * deadlock if it panics. It's only a breach of good style
256 * not a bug since they are unlocks not locks.
258 MUTEX_UNLOCK(&PL_threads_mutex);
260 MUTEX_UNLOCK(&t->mutex);
263 DEBUG_S(PerlIO_printf(PerlIO_stderr(),
264 "perl_destruct: ignoring %p (state %u)\n",
266 MUTEX_UNLOCK(&t->mutex);
267 /* fall through and out */
270 /* We leave the above "Pass 1" loop with threads_mutex still locked */
272 /* Pass 2 on remaining threads: wait for the thread count to drop to one */
273 while (PL_nthreads > 1)
275 DEBUG_S(PerlIO_printf(PerlIO_stderr(),
276 "perl_destruct: final wait for %d threads\n",
278 COND_WAIT(&PL_nthreads_cond, &PL_threads_mutex);
280 /* At this point, we're the last thread */
281 MUTEX_UNLOCK(&PL_threads_mutex);
282 DEBUG_S(PerlIO_printf(PerlIO_stderr(), "perl_destruct: armageddon has arrived\n"));
283 MUTEX_DESTROY(&PL_threads_mutex);
284 COND_DESTROY(&PL_nthreads_cond);
285 #endif /* !defined(FAKE_THREADS) */
286 #endif /* USE_THREADS */
288 destruct_level = PL_perl_destruct_level;
292 if (s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL")) {
294 if (destruct_level < i)
303 /* We must account for everything. */
305 /* Destroy the main CV and syntax tree */
307 PL_curpad = AvARRAY(PL_comppad);
308 op_free(PL_main_root);
309 PL_main_root = Nullop;
311 PL_curcop = &PL_compiling;
312 PL_main_start = Nullop;
313 SvREFCNT_dec(PL_main_cv);
317 if (PL_sv_objcount) {
319 * Try to destruct global references. We do this first so that the
320 * destructors and destructees still exist. Some sv's might remain.
321 * Non-referenced objects are on their own.
326 /* unhook hooks which will soon be, or use, destroyed data */
327 SvREFCNT_dec(PL_warnhook);
328 PL_warnhook = Nullsv;
329 SvREFCNT_dec(PL_diehook);
331 SvREFCNT_dec(PL_parsehook);
332 PL_parsehook = Nullsv;
334 /* call exit list functions */
335 while (PL_exitlistlen-- > 0)
336 PL_exitlist[PL_exitlistlen].fn(aTHXo_ PL_exitlist[PL_exitlistlen].ptr);
338 Safefree(PL_exitlist);
340 if (destruct_level == 0){
342 DEBUG_P(debprofdump());
344 /* The exit() function will do everything that needs doing. */
348 /* loosen bonds of global variables */
351 (void)PerlIO_close(PL_rsfp);
355 /* Filters for program text */
356 SvREFCNT_dec(PL_rsfp_filters);
357 PL_rsfp_filters = Nullav;
360 PL_preprocess = FALSE;
366 PL_doswitches = FALSE;
367 PL_dowarn = G_WARN_OFF;
368 PL_doextract = FALSE;
369 PL_sawampersand = FALSE; /* must save all match strings */
370 PL_sawstudy = FALSE; /* do fbm_instr on all strings */
374 Safefree(PL_inplace);
378 SvREFCNT_dec(PL_e_script);
379 PL_e_script = Nullsv;
382 /* magical thingies */
384 Safefree(PL_ofs); /* $, */
387 Safefree(PL_ors); /* $\ */
390 SvREFCNT_dec(PL_rs); /* $/ */
393 SvREFCNT_dec(PL_nrs); /* $/ helper */
396 PL_multiline = 0; /* $* */
398 SvREFCNT_dec(PL_statname);
399 PL_statname = Nullsv;
402 /* defgv, aka *_ should be taken care of elsewhere */
404 /* clean up after study() */
405 SvREFCNT_dec(PL_lastscream);
406 PL_lastscream = Nullsv;
407 Safefree(PL_screamfirst);
409 Safefree(PL_screamnext);
413 Safefree(PL_efloatbuf);
414 PL_efloatbuf = Nullch;
417 /* startup and shutdown function lists */
418 SvREFCNT_dec(PL_beginav);
419 SvREFCNT_dec(PL_endav);
420 SvREFCNT_dec(PL_initav);
425 /* shortcuts just get cleared */
432 PL_argvoutgv = Nullgv;
434 PL_last_in_gv = Nullgv;
437 /* reset so print() ends up where we expect */
440 /* Prepare to destruct main symbol table. */
447 if (destruct_level >= 2 && ckWARN_d(WARN_INTERNAL)) {
448 if (PL_scopestack_ix != 0)
449 Perl_warner(aTHX_ WARN_INTERNAL,
450 "Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
451 (long)PL_scopestack_ix);
452 if (PL_savestack_ix != 0)
453 Perl_warner(aTHX_ WARN_INTERNAL,
454 "Unbalanced saves: %ld more saves than restores\n",
455 (long)PL_savestack_ix);
456 if (PL_tmps_floor != -1)
457 Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced tmps: %ld more allocs than frees\n",
458 (long)PL_tmps_floor + 1);
459 if (cxstack_ix != -1)
460 Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced context: %ld more PUSHes than POPs\n",
461 (long)cxstack_ix + 1);
464 /* Now absolutely destruct everything, somehow or other, loops or no. */
466 SvFLAGS(PL_strtab) |= SVTYPEMASK; /* don't clean out strtab now */
467 while (PL_sv_count != 0 && PL_sv_count != last_sv_count) {
468 last_sv_count = PL_sv_count;
471 SvFLAGS(PL_strtab) &= ~SVTYPEMASK;
472 SvFLAGS(PL_strtab) |= SVt_PVHV;
474 /* Destruct the global string table. */
476 /* Yell and reset the HeVAL() slots that are still holding refcounts,
477 * so that sv_free() won't fail on them.
485 max = HvMAX(PL_strtab);
486 array = HvARRAY(PL_strtab);
489 if (hent && ckWARN_d(WARN_INTERNAL)) {
490 Perl_warner(aTHX_ WARN_INTERNAL,
491 "Unbalanced string table refcount: (%d) for \"%s\"",
492 HeVAL(hent) - Nullsv, HeKEY(hent));
493 HeVAL(hent) = Nullsv;
503 SvREFCNT_dec(PL_strtab);
505 if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL))
506 Perl_warner(aTHX_ WARN_INTERNAL,"Scalars leaked: %ld\n", (long)PL_sv_count);
510 /* No SVs have survived, need to clean out */
512 PL_pidstatus = Nullhv;
513 Safefree(PL_origfilename);
514 Safefree(PL_archpat_auto);
515 Safefree(PL_reg_start_tmp);
517 Safefree(PL_reg_curpm);
518 Safefree(PL_reg_poscache);
519 Safefree(HeKEY_hek(&PL_hv_fetch_ent_mh));
520 Safefree(PL_op_mask);
522 PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */
524 DEBUG_P(debprofdump());
526 MUTEX_DESTROY(&PL_strtab_mutex);
527 MUTEX_DESTROY(&PL_sv_mutex);
528 MUTEX_DESTROY(&PL_eval_mutex);
529 MUTEX_DESTROY(&PL_cred_mutex);
530 COND_DESTROY(&PL_eval_cond);
531 #ifdef EMULATE_ATOMIC_REFCOUNTS
532 MUTEX_DESTROY(&PL_svref_mutex);
533 #endif /* EMULATE_ATOMIC_REFCOUNTS */
535 /* As the penultimate thing, free the non-arena SV for thrsv */
536 Safefree(SvPVX(PL_thrsv));
537 Safefree(SvANY(PL_thrsv));
540 #endif /* USE_THREADS */
542 /* As the absolutely last thing, free the non-arena SV for mess() */
545 /* it could have accumulated taint magic */
546 if (SvTYPE(PL_mess_sv) >= SVt_PVMG) {
549 for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) {
550 moremagic = mg->mg_moremagic;
551 if (mg->mg_ptr && mg->mg_type != 'g' && mg->mg_len >= 0)
552 Safefree(mg->mg_ptr);
556 /* we know that type >= SVt_PV */
557 SvOOK_off(PL_mess_sv);
558 Safefree(SvPVX(PL_mess_sv));
559 Safefree(SvANY(PL_mess_sv));
560 Safefree(PL_mess_sv);
568 #if defined(PERL_OBJECT)
576 Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
578 Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry);
579 PL_exitlist[PL_exitlistlen].fn = fn;
580 PL_exitlist[PL_exitlistlen].ptr = ptr;
585 perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
594 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
597 Perl_croak(aTHX_ "suidperl is no longer needed since the kernel can now execute\n\
598 setuid perl scripts securely.\n");
602 #if defined(__DYNAMIC__) && (defined(NeXT) || defined(__NeXT__))
603 _dyld_lookup_and_bind
604 ("__environ", (unsigned long *) &environ_pointer, NULL);
609 #ifndef VMS /* VMS doesn't have environ array */
610 PL_origenviron = environ;
615 /* Come here if running an undumped a.out. */
617 PL_origfilename = savepv(argv[0]);
618 PL_do_undump = FALSE;
619 cxstack_ix = -1; /* start label stack again */
621 init_postdump_symbols(argc,argv,env);
626 PL_curpad = AvARRAY(PL_comppad);
627 op_free(PL_main_root);
628 PL_main_root = Nullop;
630 PL_main_start = Nullop;
631 SvREFCNT_dec(PL_main_cv);
635 oldscope = PL_scopestack_ix;
636 PL_dowarn = G_WARN_OFF;
638 CALLPROTECT(aTHX_ &ret, MEMBER_TO_FPTR(S_parse_body), env, xsinit);
646 /* my_exit() was called */
647 while (PL_scopestack_ix > oldscope)
650 PL_curstash = PL_defstash;
652 call_list(oldscope, PL_endav);
653 return STATUS_NATIVE_EXPORT;
655 PerlIO_printf(PerlIO_stderr(), "panic: top_env\n");
662 S_parse_body(pTHX_ va_list args)
665 int argc = PL_origargc;
666 char **argv = PL_origargv;
667 char **env = va_arg(args, char**);
668 char *scriptname = NULL;
670 VOL bool dosearch = FALSE;
676 XSINIT_t xsinit = va_arg(args, XSINIT_t);
678 sv_setpvn(PL_linestr,"",0);
679 sv = newSVpvn("",0); /* first used for -I flags */
683 for (argc--,argv++; argc > 0; argc--,argv++) {
684 if (argv[0][0] != '-' || !argv[0][1])
688 validarg = " PHOOEY ";
695 #ifndef PERL_STRICT_CR
719 if (s = moreswitches(s))
729 if (PL_euid != PL_uid || PL_egid != PL_gid)
730 Perl_croak(aTHX_ "No -e allowed in setuid scripts");
732 PL_e_script = newSVpvn("",0);
733 filter_add(read_e_script, NULL);
736 sv_catpv(PL_e_script, s);
738 sv_catpv(PL_e_script, argv[1]);
742 Perl_croak(aTHX_ "No code specified for -e");
743 sv_catpv(PL_e_script, "\n");
746 case 'I': /* -I handled both here and in moreswitches() */
748 if (!*++s && (s=argv[1]) != Nullch) {
751 while (s && isSPACE(*s))
755 for (e = s; *e && !isSPACE(*e); e++) ;
762 } /* XXX else croak? */
766 PL_preprocess = TRUE;
776 PL_preambleav = newAV();
777 av_push(PL_preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
779 PL_Sv = newSVpv("print myconfig();",0);
781 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
783 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
785 #if defined(DEBUGGING) || defined(MULTIPLICITY)
786 sv_catpv(PL_Sv,"\" Compile-time options:");
788 sv_catpv(PL_Sv," DEBUGGING");
791 sv_catpv(PL_Sv," MULTIPLICITY");
793 sv_catpv(PL_Sv,"\\n\",");
795 #if defined(LOCAL_PATCH_COUNT)
796 if (LOCAL_PATCH_COUNT > 0) {
798 sv_catpv(PL_Sv,"\" Locally applied patches:\\n\",");
799 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
800 if (PL_localpatches[i])
801 Perl_sv_catpvf(aTHX_ PL_Sv,"q\" \t%s\n\",",PL_localpatches[i]);
805 Perl_sv_catpvf(aTHX_ PL_Sv,"\" Built under %s\\n\"",OSNAME);
808 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
810 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled on %s\\n\"",__DATE__);
815 @env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; \
816 print \" \\%ENV:\\n @env\\n\" if @env; \
817 print \" \\@INC:\\n @INC\\n\";");
820 PL_Sv = newSVpv("config_vars(qw(",0);
821 sv_catpv(PL_Sv, ++s);
822 sv_catpv(PL_Sv, "))");
825 av_push(PL_preambleav, PL_Sv);
826 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
832 PL_cddir = savepv(s);
837 if (!*++s || isSPACE(*s)) {
841 /* catch use of gnu style long options */
842 if (strEQ(s, "version")) {
846 if (strEQ(s, "help")) {
853 Perl_croak(aTHX_ "Unrecognized switch: -%s (-h will show valid options)",s);
859 #ifndef SECURE_INTERNAL_GETENV
862 (s = PerlEnv_getenv("PERL5OPT"))) {
865 if (*s == '-' && *(s+1) == 'T')
878 if (!strchr("DIMUdmw", *s))
879 Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
886 scriptname = argv[0];
889 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
891 else if (scriptname == Nullch) {
893 if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
901 open_script(scriptname,dosearch,sv,&fdscript);
903 validate_suid(validarg, scriptname,fdscript);
908 PL_main_cv = PL_compcv = (CV*)NEWSV(1104,0);
909 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
910 CvUNIQUE_on(PL_compcv);
912 PL_comppad = newAV();
913 av_push(PL_comppad, Nullsv);
914 PL_curpad = AvARRAY(PL_comppad);
915 PL_comppad_name = newAV();
916 PL_comppad_name_fill = 0;
917 PL_min_intro_pending = 0;
920 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
921 PL_curpad[0] = (SV*)newAV();
922 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
923 CvOWNER(PL_compcv) = 0;
924 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
925 MUTEX_INIT(CvMUTEXP(PL_compcv));
926 #endif /* USE_THREADS */
928 comppadlist = newAV();
929 AvREAL_off(comppadlist);
930 av_store(comppadlist, 0, (SV*)PL_comppad_name);
931 av_store(comppadlist, 1, (SV*)PL_comppad);
932 CvPADLIST(PL_compcv) = comppadlist;
934 boot_core_UNIVERSAL();
938 (*xsinit)(aTHXo); /* in case linked C routines want magical variables */
939 #if defined(VMS) || defined(WIN32) || defined(DJGPP)
947 init_predump_symbols();
948 /* init_postdump_symbols not currently designed to be called */
949 /* more than once (ENV isn't cleared first, for example) */
950 /* But running with -u leaves %ENV & @ARGV undefined! XXX */
952 init_postdump_symbols(argc,argv,env);
956 /* now parse the script */
958 SETERRNO(0,SS$_NORMAL);
960 if (yyparse() || PL_error_count) {
962 Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
964 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
968 PL_curcop->cop_line = 0;
969 PL_curstash = PL_defstash;
970 PL_preprocess = FALSE;
972 SvREFCNT_dec(PL_e_script);
973 PL_e_script = Nullsv;
976 /* now that script is parsed, we can modify record separator */
978 PL_rs = SvREFCNT_inc(PL_nrs);
979 sv_setsv(get_sv("/", TRUE), PL_rs);
984 gv_check(PL_defstash);
990 if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
991 dump_mstats("after compilation:");
1009 oldscope = PL_scopestack_ix;
1012 CALLPROTECT(aTHX_ &ret, MEMBER_TO_FPTR(S_run_body), oldscope);
1015 cxstack_ix = -1; /* start context stack again */
1017 case 0: /* normal completion */
1018 case 2: /* my_exit() */
1019 while (PL_scopestack_ix > oldscope)
1022 PL_curstash = PL_defstash;
1024 call_list(oldscope, PL_endav);
1026 if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
1027 dump_mstats("after execution: ");
1029 return STATUS_NATIVE_EXPORT;
1032 POPSTACK_TO(PL_mainstack);
1035 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
1045 S_run_body(pTHX_ va_list args)
1048 I32 oldscope = va_arg(args, I32);
1050 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
1051 PL_sawampersand ? "Enabling" : "Omitting"));
1053 if (!PL_restartop) {
1054 DEBUG_x(dump_all());
1055 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
1056 DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%lx\n",
1057 (unsigned long) thr));
1060 PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", PL_origfilename);
1063 if (PERLDB_SINGLE && PL_DBsingle)
1064 sv_setiv(PL_DBsingle, 1);
1066 call_list(oldscope, PL_initav);
1072 PL_op = PL_restartop;
1076 else if (PL_main_start) {
1077 CvDEPTH(PL_main_cv) = 1;
1078 PL_op = PL_main_start;
1088 Perl_get_sv(pTHX_ const char *name, I32 create)
1092 if (name[1] == '\0' && !isALPHA(name[0])) {
1093 PADOFFSET tmp = find_threadsv(name);
1094 if (tmp != NOT_IN_PAD) {
1096 return THREADSV(tmp);
1099 #endif /* USE_THREADS */
1100 gv = gv_fetchpv(name, create, SVt_PV);
1107 Perl_get_av(pTHX_ const char *name, I32 create)
1109 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1118 Perl_get_hv(pTHX_ const char *name, I32 create)
1120 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1129 Perl_get_cv(pTHX_ const char *name, I32 create)
1131 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
1132 /* XXX unsafe for threads if eval_owner isn't held */
1133 /* XXX this is probably not what they think they're getting.
1134 * It has the same effect as "sub name;", i.e. just a forward
1136 if (create && !GvCVu(gv))
1137 return newSUB(start_subparse(FALSE, 0),
1138 newSVOP(OP_CONST, 0, newSVpv(name,0)),
1146 /* Be sure to refetch the stack pointer after calling these routines. */
1149 Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv)
1151 /* See G_* flags in cop.h */
1152 /* null terminated arg list */
1159 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
1164 return call_pv(sub_name, flags);
1168 Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
1169 /* name of the subroutine */
1170 /* See G_* flags in cop.h */
1172 return call_sv((SV*)get_cv(sub_name, TRUE), flags);
1176 Perl_call_method(pTHX_ const char *methname, I32 flags)
1177 /* name of the subroutine */
1178 /* See G_* flags in cop.h */
1184 XPUSHs(sv_2mortal(newSVpv(methname,0)));
1189 return call_sv(*PL_stack_sp--, flags);
1192 /* May be called with any of a CV, a GV, or an SV containing the name. */
1194 Perl_call_sv(pTHX_ SV *sv, I32 flags)
1196 /* See G_* flags in cop.h */
1199 LOGOP myop; /* fake syntax tree node */
1203 bool oldcatch = CATCH_GET;
1207 if (flags & G_DISCARD) {
1212 Zero(&myop, 1, LOGOP);
1213 myop.op_next = Nullop;
1214 if (!(flags & G_NOARGS))
1215 myop.op_flags |= OPf_STACKED;
1216 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1217 (flags & G_ARRAY) ? OPf_WANT_LIST :
1222 EXTEND(PL_stack_sp, 1);
1223 *++PL_stack_sp = sv;
1225 oldscope = PL_scopestack_ix;
1227 if (PERLDB_SUB && PL_curstash != PL_debstash
1228 /* Handle first BEGIN of -d. */
1229 && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
1230 /* Try harder, since this may have been a sighandler, thus
1231 * curstash may be meaningless. */
1232 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != PL_debstash)
1233 && !(flags & G_NODEBUG))
1234 PL_op->op_private |= OPpENTERSUB_DB;
1236 if (!(flags & G_EVAL)) {
1237 /* G_NOCATCH is a hack for perl_vdie using this path to call
1238 a __DIE__ handler */
1239 if (!(flags & G_NOCATCH)) {
1242 call_xbody((OP*)&myop, FALSE);
1243 retval = PL_stack_sp - (PL_stack_base + oldmark);
1244 if (!(flags & G_NOCATCH)) {
1249 cLOGOP->op_other = PL_op;
1251 /* we're trying to emulate pp_entertry() here */
1253 register PERL_CONTEXT *cx;
1254 I32 gimme = GIMME_V;
1259 push_return(PL_op->op_next);
1260 PUSHBLOCK(cx, CXt_EVAL, PL_stack_sp);
1262 PL_eval_root = PL_op; /* Only needed so that goto works right. */
1264 PL_in_eval = EVAL_INEVAL;
1265 if (flags & G_KEEPERR)
1266 PL_in_eval |= EVAL_KEEPERR;
1273 CALLPROTECT(aTHX_ &ret, MEMBER_TO_FPTR(S_call_body), (OP*)&myop, FALSE);
1276 retval = PL_stack_sp - (PL_stack_base + oldmark);
1277 if (!(flags & G_KEEPERR))
1284 /* my_exit() was called */
1285 PL_curstash = PL_defstash;
1288 Perl_croak(aTHX_ "Callback called exit");
1293 PL_op = PL_restartop;
1297 PL_stack_sp = PL_stack_base + oldmark;
1298 if (flags & G_ARRAY)
1302 *++PL_stack_sp = &PL_sv_undef;
1307 if (PL_scopestack_ix > oldscope) {
1311 register PERL_CONTEXT *cx;
1322 if (flags & G_DISCARD) {
1323 PL_stack_sp = PL_stack_base + oldmark;
1333 S_call_body(pTHX_ va_list args)
1335 OP *myop = va_arg(args, OP*);
1336 int is_eval = va_arg(args, int);
1338 call_xbody(myop, is_eval);
1343 S_call_xbody(pTHX_ OP *myop, int is_eval)
1347 if (PL_op == myop) {
1349 PL_op = Perl_pp_entereval(aTHX);
1351 PL_op = Perl_pp_entersub(aTHX);
1357 /* Eval a string. The G_EVAL flag is always assumed. */
1360 Perl_eval_sv(pTHX_ SV *sv, I32 flags)
1362 /* See G_* flags in cop.h */
1365 UNOP myop; /* fake syntax tree node */
1366 I32 oldmark = SP - PL_stack_base;
1372 if (flags & G_DISCARD) {
1379 Zero(PL_op, 1, UNOP);
1380 EXTEND(PL_stack_sp, 1);
1381 *++PL_stack_sp = sv;
1382 oldscope = PL_scopestack_ix;
1384 if (!(flags & G_NOARGS))
1385 myop.op_flags = OPf_STACKED;
1386 myop.op_next = Nullop;
1387 myop.op_type = OP_ENTEREVAL;
1388 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1389 (flags & G_ARRAY) ? OPf_WANT_LIST :
1391 if (flags & G_KEEPERR)
1392 myop.op_flags |= OPf_SPECIAL;
1395 CALLPROTECT(aTHX_ &ret, MEMBER_TO_FPTR(S_call_body), (OP*)&myop, TRUE);
1398 retval = PL_stack_sp - (PL_stack_base + oldmark);
1399 if (!(flags & G_KEEPERR))
1406 /* my_exit() was called */
1407 PL_curstash = PL_defstash;
1410 Perl_croak(aTHX_ "Callback called exit");
1415 PL_op = PL_restartop;
1419 PL_stack_sp = PL_stack_base + oldmark;
1420 if (flags & G_ARRAY)
1424 *++PL_stack_sp = &PL_sv_undef;
1429 if (flags & G_DISCARD) {
1430 PL_stack_sp = PL_stack_base + oldmark;
1440 Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
1443 SV* sv = newSVpv(p, 0);
1446 eval_sv(sv, G_SCALAR);
1453 if (croak_on_error && SvTRUE(ERRSV)) {
1455 Perl_croak(aTHX_ SvPVx(ERRSV, n_a));
1461 /* Require a module. */
1464 Perl_require_pv(pTHX_ const char *pv)
1468 PUSHSTACKi(PERLSI_REQUIRE);
1470 sv = sv_newmortal();
1471 sv_setpv(sv, "require '");
1474 eval_sv(sv, G_DISCARD);
1480 Perl_magicname(pTHX_ char *sym, char *name, I32 namlen)
1484 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1485 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1489 S_usage(pTHX_ char *name) /* XXX move this out into a module ? */
1491 /* This message really ought to be max 23 lines.
1492 * Removed -h because the user already knows that opton. Others? */
1494 static char *usage_msg[] = {
1495 "-0[octal] specify record separator (\\0, if no argument)",
1496 "-a autosplit mode with -n or -p (splits $_ into @F)",
1497 "-c check syntax only (runs BEGIN and END blocks)",
1498 "-d[:debugger] run program under debugger",
1499 "-D[number/list] set debugging flags (argument is a bit mask or alphabets)",
1500 "-e 'command' one line of program (several -e's allowed, omit programfile)",
1501 "-F/pattern/ split() pattern for -a switch (//'s are optional)",
1502 "-i[extension] edit <> files in place (makes backup if extension supplied)",
1503 "-Idirectory specify @INC/#include directory (several -I's allowed)",
1504 "-l[octal] enable line ending processing, specifies line terminator",
1505 "-[mM][-]module execute `use/no module...' before executing program",
1506 "-n assume 'while (<>) { ... }' loop around program",
1507 "-p assume loop like -n but print line also, like sed",
1508 "-P run program through C preprocessor before compilation",
1509 "-s enable rudimentary parsing for switches after programfile",
1510 "-S look for programfile using PATH environment variable",
1511 "-T enable tainting checks",
1512 "-u dump core after parsing program",
1513 "-U allow unsafe operations",
1514 "-v print version, subversion (includes VERY IMPORTANT perl info)",
1515 "-V[:variable] print configuration summary (or a single Config.pm variable)",
1516 "-w enable many useful warnings (RECOMMENDED)",
1517 "-x[directory] strip off text before #!perl line and perhaps cd to directory",
1521 char **p = usage_msg;
1523 printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1525 printf("\n %s", *p++);
1528 /* This routine handles any switches that can be given during run */
1531 Perl_moreswitches(pTHX_ char *s)
1540 rschar = scan_oct(s, 4, &numlen);
1541 SvREFCNT_dec(PL_nrs);
1542 if (rschar & ~((U8)~0))
1543 PL_nrs = &PL_sv_undef;
1544 else if (!rschar && numlen >= 2)
1545 PL_nrs = newSVpvn("", 0);
1548 PL_nrs = newSVpvn(&ch, 1);
1554 PL_splitstr = savepv(s + 1);
1568 if (*s == ':' || *s == '=') {
1569 my_setenv("PERL5DB", Perl_form(aTHX_ "use Devel::%s;", ++s));
1573 PL_perldb = PERLDB_ALL;
1581 if (isALPHA(s[1])) {
1582 static char debopts[] = "psltocPmfrxuLHXDS";
1585 for (s++; *s && (d = strchr(debopts,*s)); s++)
1586 PL_debug |= 1 << (d - debopts);
1589 PL_debug = atoi(s+1);
1590 for (s++; isDIGIT(*s); s++) ;
1592 PL_debug |= 0x80000000;
1595 if (ckWARN_d(WARN_DEBUGGING))
1596 Perl_warner(aTHX_ WARN_DEBUGGING,
1597 "Recompile perl with -DDEBUGGING to use -D switch\n");
1598 for (s++; isALNUM(*s); s++) ;
1604 usage(PL_origargv[0]);
1608 Safefree(PL_inplace);
1609 PL_inplace = savepv(s+1);
1611 for (s = PL_inplace; *s && !isSPACE(*s); s++) ;
1614 if (*s == '-') /* Additional switches on #! line. */
1618 case 'I': /* -I handled both here and in parse_perl() */
1621 while (*s && isSPACE(*s))
1625 for (e = s; *e && !isSPACE(*e); e++) ;
1626 p = savepvn(s, e-s);
1632 Perl_croak(aTHX_ "No space allowed after -I");
1640 PL_ors = savepv("\n");
1642 *PL_ors = scan_oct(s, 3 + (*s == '0'), &numlen);
1647 if (RsPARA(PL_nrs)) {
1652 PL_ors = SvPV(PL_nrs, PL_orslen);
1653 PL_ors = savepvn(PL_ors, PL_orslen);
1657 forbid_setid("-M"); /* XXX ? */
1660 forbid_setid("-m"); /* XXX ? */
1665 /* -M-foo == 'no foo' */
1666 if (*s == '-') { use = "no "; ++s; }
1667 sv = newSVpv(use,0);
1669 /* We allow -M'Module qw(Foo Bar)' */
1670 while(isALNUM(*s) || *s==':') ++s;
1672 sv_catpv(sv, start);
1673 if (*(start-1) == 'm') {
1675 Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
1676 sv_catpv( sv, " ()");
1679 sv_catpvn(sv, start, s-start);
1680 sv_catpv(sv, " split(/,/,q{");
1685 if (PL_preambleav == NULL)
1686 PL_preambleav = newAV();
1687 av_push(PL_preambleav, sv);
1690 Perl_croak(aTHX_ "No space allowed after -%c", *(s-1));
1702 PL_doswitches = TRUE;
1707 Perl_croak(aTHX_ "Too late for \"-T\" option");
1711 PL_do_undump = TRUE;
1719 #if defined(PERL_SUBVERSION) && PERL_SUBVERSION > 0
1720 printf("\nThis is perl, version %d.%03d_%02d built for %s",
1721 PERL_REVISION, PERL_VERSION, PERL_SUBVERSION, ARCHNAME);
1723 printf("\nThis is perl, version %s built for %s",
1724 PL_patchlevel, ARCHNAME);
1726 #if defined(LOCAL_PATCH_COUNT)
1727 if (LOCAL_PATCH_COUNT > 0)
1728 printf("\n(with %d registered patch%s, see perl -V for more detail)",
1729 LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : "");
1732 printf("\n\nCopyright 1987-1999, Larry Wall\n");
1734 printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1737 printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
1738 printf("djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
1741 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1742 "Version 5 port Copyright (c) 1994-1999, Andreas Kaiser, Ilya Zakharevich\n");
1745 printf("atariST series port, ++jrb bammi@cadence.com\n");
1748 printf("BeOS port Copyright Tom Spindler, 1997-1999\n");
1751 printf("MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-1999\n");
1754 printf("MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
1757 printf("Stratus VOS port by Paul_Green@stratus.com, 1997-1999\n");
1760 printf("VM/ESA port by Neale Ferguson, 1998-1999\n");
1763 printf("BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
1766 printf("MiNT port by Guido Flohr, 1997-1999\n");
1768 #ifdef BINARY_BUILD_NOTICE
1769 BINARY_BUILD_NOTICE;
1772 Perl may be copied only under the terms of either the Artistic License or the\n\
1773 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n\
1774 Complete documentation for Perl, including FAQ lists, should be found on\n\
1775 this system using `man perl' or `perldoc perl'. If you have access to the\n\
1776 Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
1779 if (! (PL_dowarn & G_WARN_ALL_MASK))
1780 PL_dowarn |= G_WARN_ON;
1784 PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
1785 PL_compiling.cop_warnings = WARN_ALL ;
1789 PL_dowarn = G_WARN_ALL_OFF;
1790 PL_compiling.cop_warnings = WARN_NONE ;
1795 if (s[1] == '-') /* Additional switches on #! line. */
1800 #if defined(WIN32) || !defined(PERL_STRICT_CR)
1806 #ifdef ALTERNATE_SHEBANG
1807 case 'S': /* OS/2 needs -S on "extproc" line. */
1815 Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
1820 /* compliments of Tom Christiansen */
1822 /* unexec() can be found in the Gnu emacs distribution */
1823 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
1826 Perl_my_unexec(pTHX)
1834 prog = newSVpv(BIN_EXP, 0);
1835 sv_catpv(prog, "/perl");
1836 file = newSVpv(PL_origfilename, 0);
1837 sv_catpv(file, ".perldump");
1839 unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
1840 /* unexec prints msg to stderr in case of failure */
1841 PerlProc_exit(status);
1844 # include <lib$routines.h>
1845 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
1847 ABORT(); /* for use with undump */
1852 /* initialize curinterp */
1857 #ifdef PERL_OBJECT /* XXX kludge */
1860 PL_chopset = " \n-"; \
1861 PL_copline = NOLINE; \
1862 PL_curcop = &PL_compiling;\
1863 PL_curcopdb = NULL; \
1866 PL_dumpindent = 4; \
1867 PL_laststatval = -1; \
1868 PL_laststype = OP_STAT; \
1869 PL_maxscream = -1; \
1870 PL_maxsysfd = MAXSYSFD; \
1871 PL_statname = Nullsv; \
1872 PL_tmps_floor = -1; \
1874 PL_op_mask = NULL; \
1876 PL_laststatval = -1; \
1877 PL_laststype = OP_STAT; \
1878 PL_mess_sv = Nullsv; \
1879 PL_splitstr = " "; \
1880 PL_generation = 100; \
1881 PL_exitlist = NULL; \
1882 PL_exitlistlen = 0; \
1884 PL_in_clean_objs = FALSE; \
1885 PL_in_clean_all = FALSE; \
1886 PL_profiledata = NULL; \
1888 PL_rsfp_filters = Nullav; \
1893 # ifdef MULTIPLICITY
1894 # define PERLVAR(var,type)
1895 # define PERLVARA(var,n,type)
1896 # if defined(PERL_IMPLICIT_CONTEXT)
1897 # if defined(USE_THREADS)
1898 # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
1899 # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
1900 # else /* !USE_THREADS */
1901 # define PERLVARI(var,type,init) aTHX->var = init;
1902 # define PERLVARIC(var,type,init) aTHX->var = init;
1903 # endif /* USE_THREADS */
1905 # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
1906 # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
1908 # include "intrpvar.h"
1909 # ifndef USE_THREADS
1910 # include "thrdvar.h"
1917 # define PERLVAR(var,type)
1918 # define PERLVARA(var,n,type)
1919 # define PERLVARI(var,type,init) PL_##var = init;
1920 # define PERLVARIC(var,type,init) PL_##var = init;
1921 # include "intrpvar.h"
1922 # ifndef USE_THREADS
1923 # include "thrdvar.h"
1935 S_init_main_stash(pTHX)
1940 /* Note that strtab is a rather special HV. Assumptions are made
1941 about not iterating on it, and not adding tie magic to it.
1942 It is properly deallocated in perl_destruct() */
1943 PL_strtab = newHV();
1945 MUTEX_INIT(&PL_strtab_mutex);
1947 HvSHAREKEYS_off(PL_strtab); /* mandatory */
1948 hv_ksplit(PL_strtab, 512);
1950 PL_curstash = PL_defstash = newHV();
1951 PL_curstname = newSVpvn("main",4);
1952 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1953 SvREFCNT_dec(GvHV(gv));
1954 GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
1956 HvNAME(PL_defstash) = savepv("main");
1957 PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1958 GvMULTI_on(PL_incgv);
1959 PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
1960 GvMULTI_on(PL_hintgv);
1961 PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1962 PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1963 GvMULTI_on(PL_errgv);
1964 PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
1965 GvMULTI_on(PL_replgv);
1966 (void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */
1967 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
1968 sv_setpvn(ERRSV, "", 0);
1969 PL_curstash = PL_defstash;
1970 PL_compiling.cop_stash = PL_defstash;
1971 PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
1972 PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
1973 /* We must init $/ before switches are processed. */
1974 sv_setpvn(get_sv("/", TRUE), "\n", 1);
1978 S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
1986 PL_origfilename = savepv("-e");
1989 /* if find_script() returns, it returns a malloc()-ed value */
1990 PL_origfilename = scriptname = find_script(scriptname, dosearch, NULL, 1);
1992 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
1993 char *s = scriptname + 8;
1994 *fdscript = atoi(s);
1998 scriptname = savepv(s + 1);
1999 Safefree(PL_origfilename);
2000 PL_origfilename = scriptname;
2005 PL_curcop->cop_filegv = gv_fetchfile(PL_origfilename);
2006 if (strEQ(PL_origfilename,"-"))
2008 if (*fdscript >= 0) {
2009 PL_rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE);
2010 #if defined(HAS_FCNTL) && defined(F_SETFD)
2012 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); /* ensure close-on-exec */
2015 else if (PL_preprocess) {
2016 char *cpp_cfg = CPPSTDIN;
2017 SV *cpp = newSVpvn("",0);
2018 SV *cmd = NEWSV(0,0);
2020 if (strEQ(cpp_cfg, "cppstdin"))
2021 Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
2022 sv_catpv(cpp, cpp_cfg);
2025 sv_catpv(sv,PRIVLIB_EXP);
2028 Perl_sv_setpvf(aTHX_ cmd, "\
2029 sed %s -e \"/^[^#]/b\" \
2030 -e \"/^#[ ]*include[ ]/b\" \
2031 -e \"/^#[ ]*define[ ]/b\" \
2032 -e \"/^#[ ]*if[ ]/b\" \
2033 -e \"/^#[ ]*ifdef[ ]/b\" \
2034 -e \"/^#[ ]*ifndef[ ]/b\" \
2035 -e \"/^#[ ]*else/b\" \
2036 -e \"/^#[ ]*elif[ ]/b\" \
2037 -e \"/^#[ ]*undef[ ]/b\" \
2038 -e \"/^#[ ]*endif/b\" \
2041 (PL_doextract ? "-e \"1,/^#/d\n\"" : ""),
2044 Perl_sv_setpvf(aTHX_ cmd, "\
2045 %s %s -e '/^[^#]/b' \
2046 -e '/^#[ ]*include[ ]/b' \
2047 -e '/^#[ ]*define[ ]/b' \
2048 -e '/^#[ ]*if[ ]/b' \
2049 -e '/^#[ ]*ifdef[ ]/b' \
2050 -e '/^#[ ]*ifndef[ ]/b' \
2051 -e '/^#[ ]*else/b' \
2052 -e '/^#[ ]*elif[ ]/b' \
2053 -e '/^#[ ]*undef[ ]/b' \
2054 -e '/^#[ ]*endif/b' \
2058 Perl_sv_setpvf(aTHX_ cmd, "\
2059 %s %s -e '/^[^#]/b' \
2060 -e '/^#[ ]*include[ ]/b' \
2061 -e '/^#[ ]*define[ ]/b' \
2062 -e '/^#[ ]*if[ ]/b' \
2063 -e '/^#[ ]*ifdef[ ]/b' \
2064 -e '/^#[ ]*ifndef[ ]/b' \
2065 -e '/^#[ ]*else/b' \
2066 -e '/^#[ ]*elif[ ]/b' \
2067 -e '/^#[ ]*undef[ ]/b' \
2068 -e '/^#[ ]*endif/b' \
2077 (PL_doextract ? "-e '1,/^#/d\n'" : ""),
2079 scriptname, cpp, sv, CPPMINUS);
2080 PL_doextract = FALSE;
2081 #ifdef IAMSUID /* actually, this is caught earlier */
2082 if (PL_euid != PL_uid && !PL_euid) { /* if running suidperl */
2084 (void)seteuid(PL_uid); /* musn't stay setuid root */
2087 (void)setreuid((Uid_t)-1, PL_uid);
2089 #ifdef HAS_SETRESUID
2090 (void)setresuid((Uid_t)-1, PL_uid, (Uid_t)-1);
2092 PerlProc_setuid(PL_uid);
2096 if (PerlProc_geteuid() != PL_uid)
2097 Perl_croak(aTHX_ "Can't do seteuid!\n");
2099 #endif /* IAMSUID */
2100 PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
2104 else if (!*scriptname) {
2105 forbid_setid("program input from stdin");
2106 PL_rsfp = PerlIO_stdin();
2109 PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
2110 #if defined(HAS_FCNTL) && defined(F_SETFD)
2112 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); /* ensure close-on-exec */
2117 #ifndef IAMSUID /* in case script is not readable before setuid */
2119 PerlLIO_stat(SvPVX(GvSV(PL_curcop->cop_filegv)),&PL_statbuf) >= 0 &&
2120 PL_statbuf.st_mode & (S_ISUID|S_ISGID))
2123 PerlProc_execv(Perl_form(aTHX_ "%s/sperl%s", BIN_EXP, PL_patchlevel), PL_origargv);
2124 Perl_croak(aTHX_ "Can't do setuid\n");
2128 Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
2129 SvPVX(GvSV(PL_curcop->cop_filegv)), Strerror(errno));
2134 * I_SYSSTATVFS HAS_FSTATVFS
2136 * I_STATFS HAS_FSTATFS
2137 * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT
2138 * here so that metaconfig picks them up. */
2142 S_fd_on_nosuid_fs(pTHX_ int fd)
2147 * Preferred order: fstatvfs(), fstatfs(), getmntent().
2148 * fstatvfs() is UNIX98.
2150 * getmntent() is O(number-of-mounted-filesystems) and can hang.
2153 # ifdef HAS_FSTATVFS
2154 struct statvfs stfs;
2155 check_okay = fstatvfs(fd, &stfs) == 0;
2156 on_nosuid = check_okay && (stfs.f_flag & ST_NOSUID);
2158 # if defined(HAS_FSTATFS) && defined(HAS_STRUCT_STATFS_FLAGS)
2160 check_okay = fstatfs(fd, &stfs) == 0;
2161 # undef PERL_MOUNT_NOSUID
2162 # if !defined(PERL_MOUNT_NOSUID) && defined(MNT_NOSUID)
2163 # define PERL_MOUNT_NOSUID MNT_NOSUID
2165 # if !defined(PERL_MOUNT_NOSUID) && defined(MS_NOSUID)
2166 # define PERL_MOUNT_NOSUID MS_NOSUID
2168 # if !defined(PERL_MOUNT_NOSUID) && defined(M_NOSUID)
2169 # define PERL_MOUNT_NOSUID M_NOSUID
2171 # ifdef PERL_MOUNT_NOSUID
2172 on_nosuid = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
2175 # if defined(HAS_GETMNTENT) && defined(HAS_HASMNTOPT) && defined(MNTOPT_NOSUID)
2176 FILE *mtab = fopen("/etc/mtab", "r");
2177 struct mntent *entry;
2178 struct stat stb, fsb;
2180 if (mtab && (fstat(fd, &stb) == 0)) {
2181 while (entry = getmntent(mtab)) {
2182 if (stat(entry->mnt_dir, &fsb) == 0
2183 && fsb.st_dev == stb.st_dev)
2185 /* found the filesystem */
2187 if (hasmntopt(entry, MNTOPT_NOSUID))
2190 } /* A single fs may well fail its stat(). */
2195 # endif /* mntent */
2196 # endif /* statfs */
2197 # endif /* statvfs */
2199 Perl_croak(aTHX_ "Can't check filesystem of script \"%s\"", PL_origfilename);
2202 #endif /* IAMSUID */
2205 S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript)
2209 /* do we need to emulate setuid on scripts? */
2211 /* This code is for those BSD systems that have setuid #! scripts disabled
2212 * in the kernel because of a security problem. Merely defining DOSUID
2213 * in perl will not fix that problem, but if you have disabled setuid
2214 * scripts in the kernel, this will attempt to emulate setuid and setgid
2215 * on scripts that have those now-otherwise-useless bits set. The setuid
2216 * root version must be called suidperl or sperlN.NNN. If regular perl
2217 * discovers that it has opened a setuid script, it calls suidperl with
2218 * the same argv that it had. If suidperl finds that the script it has
2219 * just opened is NOT setuid root, it sets the effective uid back to the
2220 * uid. We don't just make perl setuid root because that loses the
2221 * effective uid we had before invoking perl, if it was different from the
2224 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
2225 * be defined in suidperl only. suidperl must be setuid root. The
2226 * Configure script will set this up for you if you want it.
2233 if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */
2234 Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
2235 if (fdscript < 0 && PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
2240 #ifndef HAS_SETREUID
2241 /* On this access check to make sure the directories are readable,
2242 * there is actually a small window that the user could use to make
2243 * filename point to an accessible directory. So there is a faint
2244 * chance that someone could execute a setuid script down in a
2245 * non-accessible directory. I don't know what to do about that.
2246 * But I don't think it's too important. The manual lies when
2247 * it says access() is useful in setuid programs.
2249 if (PerlLIO_access(SvPVX(GvSV(PL_curcop->cop_filegv)),1)) /*double check*/
2250 Perl_croak(aTHX_ "Permission denied");
2252 /* If we can swap euid and uid, then we can determine access rights
2253 * with a simple stat of the file, and then compare device and
2254 * inode to make sure we did stat() on the same file we opened.
2255 * Then we just have to make sure he or she can execute it.
2258 struct stat tmpstatbuf;
2262 setreuid(PL_euid,PL_uid) < 0
2265 setresuid(PL_euid,PL_uid,(Uid_t)-1) < 0
2268 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
2269 Perl_croak(aTHX_ "Can't swap uid and euid"); /* really paranoid */
2270 if (PerlLIO_stat(SvPVX(GvSV(PL_curcop->cop_filegv)),&tmpstatbuf) < 0)
2271 Perl_croak(aTHX_ "Permission denied"); /* testing full pathname here */
2272 #if defined(IAMSUID) && !defined(NO_NOSUID_CHECK)
2273 if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp)))
2274 Perl_croak(aTHX_ "Permission denied");
2276 if (tmpstatbuf.st_dev != PL_statbuf.st_dev ||
2277 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
2278 (void)PerlIO_close(PL_rsfp);
2279 if (PL_rsfp = PerlProc_popen("/bin/mail root","w")) { /* heh, heh */
2280 PerlIO_printf(PL_rsfp,
2281 "User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2282 (Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
2283 (long)PL_uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
2284 (long)PL_statbuf.st_dev, (long)PL_statbuf.st_ino,
2285 SvPVX(GvSV(PL_curcop->cop_filegv)),
2286 (long)PL_statbuf.st_uid, (long)PL_statbuf.st_gid);
2287 (void)PerlProc_pclose(PL_rsfp);
2289 Perl_croak(aTHX_ "Permission denied\n");
2293 setreuid(PL_uid,PL_euid) < 0
2295 # if defined(HAS_SETRESUID)
2296 setresuid(PL_uid,PL_euid,(Uid_t)-1) < 0
2299 || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
2300 Perl_croak(aTHX_ "Can't reswap uid and euid");
2301 if (!cando(S_IXUSR,FALSE,&PL_statbuf)) /* can real uid exec? */
2302 Perl_croak(aTHX_ "Permission denied\n");
2304 #endif /* HAS_SETREUID */
2305 #endif /* IAMSUID */
2307 if (!S_ISREG(PL_statbuf.st_mode))
2308 Perl_croak(aTHX_ "Permission denied");
2309 if (PL_statbuf.st_mode & S_IWOTH)
2310 Perl_croak(aTHX_ "Setuid/gid script is writable by world");
2311 PL_doswitches = FALSE; /* -s is insecure in suid */
2312 PL_curcop->cop_line++;
2313 if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
2314 strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */
2315 Perl_croak(aTHX_ "No #! line");
2316 s = SvPV(PL_linestr,n_a)+2;
2318 while (!isSPACE(*s)) s++;
2319 for (s2 = s; (s2 > SvPV(PL_linestr,n_a)+2 &&
2320 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
2321 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
2322 Perl_croak(aTHX_ "Not a perl script");
2323 while (*s == ' ' || *s == '\t') s++;
2325 * #! arg must be what we saw above. They can invoke it by
2326 * mentioning suidperl explicitly, but they may not add any strange
2327 * arguments beyond what #! says if they do invoke suidperl that way.
2329 len = strlen(validarg);
2330 if (strEQ(validarg," PHOOEY ") ||
2331 strnNE(s,validarg,len) || !isSPACE(s[len]))
2332 Perl_croak(aTHX_ "Args must match #! line");
2335 if (PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
2336 PL_euid == PL_statbuf.st_uid)
2338 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2339 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2340 #endif /* IAMSUID */
2342 if (PL_euid) { /* oops, we're not the setuid root perl */
2343 (void)PerlIO_close(PL_rsfp);
2346 PerlProc_execv(Perl_form(aTHX_ "%s/sperl%s", BIN_EXP, PL_patchlevel), PL_origargv);
2348 Perl_croak(aTHX_ "Can't do setuid\n");
2351 if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
2353 (void)setegid(PL_statbuf.st_gid);
2356 (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
2358 #ifdef HAS_SETRESGID
2359 (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
2361 PerlProc_setgid(PL_statbuf.st_gid);
2365 if (PerlProc_getegid() != PL_statbuf.st_gid)
2366 Perl_croak(aTHX_ "Can't do setegid!\n");
2368 if (PL_statbuf.st_mode & S_ISUID) {
2369 if (PL_statbuf.st_uid != PL_euid)
2371 (void)seteuid(PL_statbuf.st_uid); /* all that for this */
2374 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
2376 #ifdef HAS_SETRESUID
2377 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
2379 PerlProc_setuid(PL_statbuf.st_uid);
2383 if (PerlProc_geteuid() != PL_statbuf.st_uid)
2384 Perl_croak(aTHX_ "Can't do seteuid!\n");
2386 else if (PL_uid) { /* oops, mustn't run as root */
2388 (void)seteuid((Uid_t)PL_uid);
2391 (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
2393 #ifdef HAS_SETRESUID
2394 (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
2396 PerlProc_setuid((Uid_t)PL_uid);
2400 if (PerlProc_geteuid() != PL_uid)
2401 Perl_croak(aTHX_ "Can't do seteuid!\n");
2404 if (!cando(S_IXUSR,TRUE,&PL_statbuf))
2405 Perl_croak(aTHX_ "Permission denied\n"); /* they can't do this */
2408 else if (PL_preprocess)
2409 Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
2410 else if (fdscript >= 0)
2411 Perl_croak(aTHX_ "fd script not allowed in suidperl\n");
2413 Perl_croak(aTHX_ "Script is not setuid/setgid in suidperl\n");
2415 /* We absolutely must clear out any saved ids here, so we */
2416 /* exec the real perl, substituting fd script for scriptname. */
2417 /* (We pass script name as "subdir" of fd, which perl will grok.) */
2418 PerlIO_rewind(PL_rsfp);
2419 PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0); /* just in case rewind didn't */
2420 for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
2421 if (!PL_origargv[which])
2422 Perl_croak(aTHX_ "Permission denied");
2423 PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
2424 PerlIO_fileno(PL_rsfp), PL_origargv[which]));
2425 #if defined(HAS_FCNTL) && defined(F_SETFD)
2426 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */
2428 PerlProc_execv(Perl_form(aTHX_ "%s/perl%s", BIN_EXP, PL_patchlevel), PL_origargv);/* try again */
2429 Perl_croak(aTHX_ "Can't do setuid\n");
2430 #endif /* IAMSUID */
2432 if (PL_euid != PL_uid || PL_egid != PL_gid) { /* (suidperl doesn't exist, in fact) */
2433 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2435 PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf); /* may be either wrapped or real suid */
2436 if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
2438 (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
2441 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2442 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2443 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2444 /* not set-id, must be wrapped */
2450 S_find_beginning(pTHX)
2452 register char *s, *s2;
2454 /* skip forward in input to the real script? */
2457 while (PL_doextract) {
2458 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
2459 Perl_croak(aTHX_ "No Perl script found in input\n");
2460 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2461 PerlIO_ungetc(PL_rsfp, '\n'); /* to keep line count right */
2462 PL_doextract = FALSE;
2463 while (*s && !(isSPACE (*s) || *s == '#')) s++;
2465 while (*s == ' ' || *s == '\t') s++;
2467 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2468 if (strnEQ(s2-4,"perl",4))
2470 while (s = moreswitches(s)) ;
2472 if (PL_cddir && PerlDir_chdir(PL_cddir) < 0)
2473 Perl_croak(aTHX_ "Can't chdir to %s",PL_cddir);
2482 PL_uid = PerlProc_getuid();
2483 PL_euid = PerlProc_geteuid();
2484 PL_gid = PerlProc_getgid();
2485 PL_egid = PerlProc_getegid();
2487 PL_uid |= PL_gid << 16;
2488 PL_euid |= PL_egid << 16;
2490 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2494 S_forbid_setid(pTHX_ char *s)
2496 if (PL_euid != PL_uid)
2497 Perl_croak(aTHX_ "No %s allowed while running setuid", s);
2498 if (PL_egid != PL_gid)
2499 Perl_croak(aTHX_ "No %s allowed while running setgid", s);
2503 Perl_init_debugger(pTHX)
2506 HV *ostash = PL_curstash;
2508 PL_curstash = PL_debstash;
2509 PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2510 AvREAL_off(PL_dbargs);
2511 PL_DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2512 PL_DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2513 PL_DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2514 sv_upgrade(GvSV(PL_DBsub), SVt_IV); /* IVX accessed if PERLDB_SUB_NN */
2515 PL_DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2516 sv_setiv(PL_DBsingle, 0);
2517 PL_DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2518 sv_setiv(PL_DBtrace, 0);
2519 PL_DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2520 sv_setiv(PL_DBsignal, 0);
2521 PL_curstash = ostash;
2524 #ifndef STRESS_REALLOC
2525 #define REASONABLE(size) (size)
2527 #define REASONABLE(size) (1) /* unreasonable */
2531 Perl_init_stacks(pTHX)
2533 /* start with 128-item stack and 8K cxstack */
2534 PL_curstackinfo = new_stackinfo(REASONABLE(128),
2535 REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
2536 PL_curstackinfo->si_type = PERLSI_MAIN;
2537 PL_curstack = PL_curstackinfo->si_stack;
2538 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
2540 PL_stack_base = AvARRAY(PL_curstack);
2541 PL_stack_sp = PL_stack_base;
2542 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
2544 New(50,PL_tmps_stack,REASONABLE(128),SV*);
2547 PL_tmps_max = REASONABLE(128);
2549 New(54,PL_markstack,REASONABLE(32),I32);
2550 PL_markstack_ptr = PL_markstack;
2551 PL_markstack_max = PL_markstack + REASONABLE(32);
2555 New(54,PL_scopestack,REASONABLE(32),I32);
2556 PL_scopestack_ix = 0;
2557 PL_scopestack_max = REASONABLE(32);
2559 New(54,PL_savestack,REASONABLE(128),ANY);
2560 PL_savestack_ix = 0;
2561 PL_savestack_max = REASONABLE(128);
2563 New(54,PL_retstack,REASONABLE(16),OP*);
2565 PL_retstack_max = REASONABLE(16);
2574 while (PL_curstackinfo->si_next)
2575 PL_curstackinfo = PL_curstackinfo->si_next;
2576 while (PL_curstackinfo) {
2577 PERL_SI *p = PL_curstackinfo->si_prev;
2578 /* curstackinfo->si_stack got nuked by sv_free_arenas() */
2579 Safefree(PL_curstackinfo->si_cxstack);
2580 Safefree(PL_curstackinfo);
2581 PL_curstackinfo = p;
2583 Safefree(PL_tmps_stack);
2584 Safefree(PL_markstack);
2585 Safefree(PL_scopestack);
2586 Safefree(PL_savestack);
2587 Safefree(PL_retstack);
2589 Safefree(PL_debname);
2590 Safefree(PL_debdelim);
2595 static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
2606 lex_start(PL_linestr);
2608 PL_subname = newSVpvn("main",4);
2612 S_init_predump_symbols(pTHX)
2619 sv_setpvn(get_sv("\"", TRUE), " ", 1);
2620 PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2621 GvMULTI_on(PL_stdingv);
2622 io = GvIOp(PL_stdingv);
2623 IoIFP(io) = PerlIO_stdin();
2624 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2626 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
2628 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2631 IoOFP(io) = IoIFP(io) = PerlIO_stdout();
2633 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2635 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
2637 othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2638 GvMULTI_on(othergv);
2639 io = GvIOp(othergv);
2640 IoOFP(io) = IoIFP(io) = PerlIO_stderr();
2641 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2643 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
2645 PL_statname = NEWSV(66,0); /* last filename we did stat on */
2648 PL_osname = savepv(OSNAME);
2652 S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
2659 argc--,argv++; /* skip name of script */
2660 if (PL_doswitches) {
2661 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2664 if (argv[0][1] == '-') {
2668 if (s = strchr(argv[0], '=')) {
2670 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2673 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2676 PL_toptarget = NEWSV(0,0);
2677 sv_upgrade(PL_toptarget, SVt_PVFM);
2678 sv_setpvn(PL_toptarget, "", 0);
2679 PL_bodytarget = NEWSV(0,0);
2680 sv_upgrade(PL_bodytarget, SVt_PVFM);
2681 sv_setpvn(PL_bodytarget, "", 0);
2682 PL_formtarget = PL_bodytarget;
2685 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2686 sv_setpv(GvSV(tmpgv),PL_origfilename);
2687 magicname("0", "0", 1);
2689 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2690 sv_setpv(GvSV(tmpgv),PL_origargv[0]);
2691 if (PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2692 GvMULTI_on(PL_argvgv);
2693 (void)gv_AVadd(PL_argvgv);
2694 av_clear(GvAVn(PL_argvgv));
2695 for (; argc > 0; argc--,argv++) {
2696 av_push(GvAVn(PL_argvgv),newSVpv(argv[0],0));
2699 if (PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2701 GvMULTI_on(PL_envgv);
2702 hv = GvHVn(PL_envgv);
2703 hv_magic(hv, PL_envgv, 'E');
2704 #if !defined( VMS) && !defined(EPOC) /* VMS doesn't have environ array */
2705 /* Note that if the supplied env parameter is actually a copy
2706 of the global environ then it may now point to free'd memory
2707 if the environment has been modified since. To avoid this
2708 problem we treat env==NULL as meaning 'use the default'
2713 environ[0] = Nullch;
2714 for (; *env; env++) {
2715 if (!(s = strchr(*env,'=')))
2721 sv = newSVpv(s--,0);
2722 (void)hv_store(hv, *env, s - *env, sv, 0);
2724 #if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
2725 /* Sins of the RTL. See note in my_setenv(). */
2726 (void)PerlEnv_putenv(savepv(*env));
2730 #ifdef DYNAMIC_ENV_FETCH
2731 HvNAME(hv) = savepv(ENV_HV_NAME);
2735 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2736 sv_setiv(GvSV(tmpgv), (IV)getpid());
2740 S_init_perllib(pTHX)
2745 s = PerlEnv_getenv("PERL5LIB");
2749 incpush(PerlEnv_getenv("PERLLIB"), FALSE);
2751 /* Treat PERL5?LIB as a possible search list logical name -- the
2752 * "natural" VMS idiom for a Unix path string. We allow each
2753 * element to be a set of |-separated directories for compatibility.
2757 if (my_trnlnm("PERL5LIB",buf,0))
2758 do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2760 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2764 /* Use the ~-expanded versions of APPLLIB (undocumented),
2765 ARCHLIB PRIVLIB SITEARCH and SITELIB
2768 incpush(APPLLIB_EXP, TRUE);
2772 incpush(ARCHLIB_EXP, FALSE);
2775 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2778 incpush(PRIVLIB_EXP, TRUE);
2780 incpush(PRIVLIB_EXP, FALSE);
2784 incpush(SITEARCH_EXP, FALSE);
2788 incpush(SITELIB_EXP, TRUE);
2790 incpush(SITELIB_EXP, FALSE);
2793 #if defined(PERL_VENDORLIB_EXP)
2795 incpush(PERL_VENDORLIB_EXP, TRUE);
2797 incpush(PERL_VENDORLIB_EXP, FALSE);
2801 incpush(".", FALSE);
2805 # define PERLLIB_SEP ';'
2808 # define PERLLIB_SEP '|'
2810 # define PERLLIB_SEP ':'
2813 #ifndef PERLLIB_MANGLE
2814 # define PERLLIB_MANGLE(s,n) (s)
2818 S_incpush(pTHX_ char *p, int addsubdirs)
2820 SV *subdir = Nullsv;
2826 subdir = sv_newmortal();
2827 if (!PL_archpat_auto) {
2828 STRLEN len = (sizeof(ARCHNAME) + strlen(PL_patchlevel)
2829 + sizeof("//auto"));
2830 New(55, PL_archpat_auto, len, char);
2831 sprintf(PL_archpat_auto, "/%s/%s/auto", ARCHNAME, PL_patchlevel);
2833 for (len = sizeof(ARCHNAME) + 2;
2834 PL_archpat_auto[len] != '\0' && PL_archpat_auto[len] != '/'; len++)
2835 if (PL_archpat_auto[len] == '.') PL_archpat_auto[len] = '_';
2840 /* Break at all separators */
2842 SV *libdir = NEWSV(55,0);
2845 /* skip any consecutive separators */
2846 while ( *p == PERLLIB_SEP ) {
2847 /* Uncomment the next line for PATH semantics */
2848 /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */
2852 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2853 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2858 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2859 p = Nullch; /* break out */
2863 * BEFORE pushing libdir onto @INC we may first push version- and
2864 * archname-specific sub-directories.
2867 struct stat tmpstatbuf;
2872 if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) {
2874 while (unix[len-1] == '/') len--; /* Cosmetic */
2875 sv_usepvn(libdir,unix,len);
2878 PerlIO_printf(PerlIO_stderr(),
2879 "Failed to unixify @INC element \"%s\"\n",
2882 /* .../archname/version if -d .../archname/version/auto */
2883 sv_setsv(subdir, libdir);
2884 sv_catpv(subdir, PL_archpat_auto);
2885 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2886 S_ISDIR(tmpstatbuf.st_mode))
2887 av_push(GvAVn(PL_incgv),
2888 newSVpvn(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2890 /* .../archname if -d .../archname/auto */
2891 sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
2892 strlen(PL_patchlevel) + 1, "", 0);
2893 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2894 S_ISDIR(tmpstatbuf.st_mode))
2895 av_push(GvAVn(PL_incgv),
2896 newSVpvn(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2899 /* finally push this lib directory on the end of @INC */
2900 av_push(GvAVn(PL_incgv), libdir);
2905 STATIC struct perl_thread *
2906 S_init_main_thread(pTHX)
2908 #if !defined(PERL_IMPLICIT_CONTEXT)
2909 struct perl_thread *thr;
2913 Newz(53, thr, 1, struct perl_thread);
2914 PL_curcop = &PL_compiling;
2915 thr->interp = PERL_GET_INTERP;
2916 thr->cvcache = newHV();
2917 thr->threadsv = newAV();
2918 /* thr->threadsvp is set when find_threadsv is called */
2919 thr->specific = newAV();
2920 thr->errhv = newHV();
2921 thr->flags = THRf_R_JOINABLE;
2922 MUTEX_INIT(&thr->mutex);
2923 /* Handcraft thrsv similarly to mess_sv */
2924 New(53, PL_thrsv, 1, SV);
2925 Newz(53, xpv, 1, XPV);
2926 SvFLAGS(PL_thrsv) = SVt_PV;
2927 SvANY(PL_thrsv) = (void*)xpv;
2928 SvREFCNT(PL_thrsv) = 1 << 30; /* practically infinite */
2929 SvPVX(PL_thrsv) = (char*)thr;
2930 SvCUR_set(PL_thrsv, sizeof(thr));
2931 SvLEN_set(PL_thrsv, sizeof(thr));
2932 *SvEND(PL_thrsv) = '\0'; /* in the trailing_nul field */
2933 thr->oursv = PL_thrsv;
2934 PL_chopset = " \n-";
2937 MUTEX_LOCK(&PL_threads_mutex);
2942 MUTEX_UNLOCK(&PL_threads_mutex);
2944 #ifdef HAVE_THREAD_INTERN
2945 Perl_init_thread_intern(thr);
2948 #ifdef SET_THREAD_SELF
2949 SET_THREAD_SELF(thr);
2951 thr->self = pthread_self();
2952 #endif /* SET_THREAD_SELF */
2956 * These must come after the SET_THR because sv_setpvn does
2957 * SvTAINT and the taint fields require dTHR.
2959 PL_toptarget = NEWSV(0,0);
2960 sv_upgrade(PL_toptarget, SVt_PVFM);
2961 sv_setpvn(PL_toptarget, "", 0);
2962 PL_bodytarget = NEWSV(0,0);
2963 sv_upgrade(PL_bodytarget, SVt_PVFM);
2964 sv_setpvn(PL_bodytarget, "", 0);
2965 PL_formtarget = PL_bodytarget;
2966 thr->errsv = newSVpvn("", 0);
2967 (void) find_threadsv("@"); /* Ensure $@ is initialised early */
2970 PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
2971 PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
2972 PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
2973 PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
2974 PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
2976 PL_reginterp_cnt = 0;
2980 #endif /* USE_THREADS */
2983 Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
2987 line_t oldline = PL_curcop->cop_line;
2992 while (AvFILL(paramList) >= 0) {
2993 cv = (CV*)av_shift(paramList);
2995 CALLPROTECT(aTHX_ &ret, MEMBER_TO_FPTR(S_call_list_body), cv);
2998 (void)SvPV(atsv, len);
3000 PL_curcop = &PL_compiling;
3001 PL_curcop->cop_line = oldline;
3002 if (paramList == PL_beginav)
3003 sv_catpv(atsv, "BEGIN failed--compilation aborted");
3005 sv_catpv(atsv, "END failed--cleanup aborted");
3006 while (PL_scopestack_ix > oldscope)
3008 Perl_croak(aTHX_ "%s", SvPVX(atsv));
3015 /* my_exit() was called */
3016 while (PL_scopestack_ix > oldscope)
3019 PL_curstash = PL_defstash;
3021 call_list(oldscope, PL_endav);
3022 PL_curcop = &PL_compiling;
3023 PL_curcop->cop_line = oldline;
3024 if (PL_statusvalue) {
3025 if (paramList == PL_beginav)
3026 Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
3028 Perl_croak(aTHX_ "END failed--cleanup aborted");
3034 PL_curcop = &PL_compiling;
3035 PL_curcop->cop_line = oldline;
3038 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
3046 S_call_list_body(pTHX_ va_list args)
3049 CV *cv = va_arg(args, CV*);
3051 PUSHMARK(PL_stack_sp);
3052 call_sv((SV*)cv, G_EVAL|G_DISCARD);
3057 Perl_my_exit(pTHX_ U32 status)
3061 DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
3062 thr, (unsigned long) status));
3071 STATUS_NATIVE_SET(status);
3078 Perl_my_failure_exit(pTHX)
3081 if (vaxc$errno & 1) {
3082 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
3083 STATUS_NATIVE_SET(44);
3086 if (!vaxc$errno && errno) /* unlikely */
3087 STATUS_NATIVE_SET(44);
3089 STATUS_NATIVE_SET(vaxc$errno);
3094 STATUS_POSIX_SET(errno);
3096 exitstatus = STATUS_POSIX >> 8;
3097 if (exitstatus & 255)
3098 STATUS_POSIX_SET(exitstatus);
3100 STATUS_POSIX_SET(255);
3107 S_my_exit_jump(pTHX)
3110 register PERL_CONTEXT *cx;
3115 SvREFCNT_dec(PL_e_script);
3116 PL_e_script = Nullsv;
3119 POPSTACK_TO(PL_mainstack);
3120 if (cxstack_ix >= 0) {
3123 POPBLOCK(cx,PL_curpm);
3136 read_e_script(pTHXo_ int idx, SV *buf_sv, int maxlen)
3139 p = SvPVX(PL_e_script);
3140 nl = strchr(p, '\n');
3141 nl = (nl) ? nl+1 : SvEND(PL_e_script);
3143 filter_del(read_e_script);
3146 sv_catpvn(buf_sv, p, nl-p);
3147 sv_chop(PL_e_script, nl);