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
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 static I32 read_e_script(pTHXo_ int idx, SV *buf_sv, int maxlen);
42 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
49 CPerlObj* perl_alloc(IPerlMem* ipM, IPerlEnv* ipE, IPerlStdIO* ipStd,
50 IPerlLIO* ipLIO, IPerlDir* ipD, IPerlSock* ipS, IPerlProc* ipP)
52 CPerlObj* pPerl = new(ipM) CPerlObj(ipM, ipE, ipStd, ipLIO, ipD, ipS, ipP);
62 PerlInterpreter *my_perl;
64 /* New() needs interpreter, so call malloc() instead */
65 my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
66 PERL_SET_INTERP(my_perl);
69 #endif /* PERL_OBJECT */
77 struct perl_thread *thr;
78 #endif /* FAKE_THREADS */
79 #endif /* USE_THREADS */
82 Zero(my_perl, 1, PerlInterpreter);
87 PL_perl_destruct_level = 1;
89 if (PL_perl_destruct_level > 0)
93 /* Init the real globals (and main thread)? */
98 #ifdef ALLOC_THREAD_KEY
101 if (pthread_key_create(&PL_thr_key, 0))
102 Perl_croak(aTHX_ "panic: pthread_key_create");
104 MUTEX_INIT(&PL_sv_mutex);
106 * Safe to use basic SV functions from now on (though
107 * not things like mortals or tainting yet).
109 MUTEX_INIT(&PL_eval_mutex);
110 COND_INIT(&PL_eval_cond);
111 MUTEX_INIT(&PL_threads_mutex);
112 COND_INIT(&PL_nthreads_cond);
113 #ifdef EMULATE_ATOMIC_REFCOUNTS
114 MUTEX_INIT(&PL_svref_mutex);
115 #endif /* EMULATE_ATOMIC_REFCOUNTS */
117 MUTEX_INIT(&PL_cred_mutex);
119 thr = init_main_thread();
120 #endif /* USE_THREADS */
122 PL_protect = MEMBER_TO_FPTR(Perl_default_protect); /* for exceptions */
124 PL_curcop = &PL_compiling; /* needed by ckWARN, right away */
126 PL_linestr = NEWSV(65,79);
127 sv_upgrade(PL_linestr,SVt_PVIV);
129 if (!SvREADONLY(&PL_sv_undef)) {
130 /* set read-only and try to insure than we wont see REFCNT==0
133 SvREADONLY_on(&PL_sv_undef);
134 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
136 sv_setpv(&PL_sv_no,PL_No);
138 SvREADONLY_on(&PL_sv_no);
139 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
141 sv_setpv(&PL_sv_yes,PL_Yes);
143 SvREADONLY_on(&PL_sv_yes);
144 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
149 /* PL_sighandlerp = sighandler; */
151 PL_sighandlerp = Perl_sighandler;
153 PL_pidstatus = newHV();
157 * There is no way we can refer to them from Perl so close them to save
158 * space. The other alternative would be to provide STDAUX and STDPRN
161 (void)fclose(stdaux);
162 (void)fclose(stdprn);
166 PL_nrs = newSVpvn("\n", 1);
167 PL_rs = SvREFCNT_inc(PL_nrs);
172 PL_lex_state = LEX_NOTPARSING;
178 SET_NUMERIC_STANDARD();
179 #if defined(PERL_SUBVERSION) && PERL_SUBVERSION > 0
180 sprintf(PL_patchlevel, "%7.5f", (double) PERL_REVISION
181 + ((double) PERL_VERSION / (double) 1000)
182 + ((double) PERL_SUBVERSION / (double) 100000));
184 sprintf(PL_patchlevel, "%5.3f", (double) PERL_REVISION +
185 ((double) PERL_VERSION / (double) 1000));
188 #if defined(LOCAL_PATCH_COUNT)
189 PL_localpatches = local_patches; /* For possible -v */
192 PerlIO_init(); /* Hook to IO system */
194 PL_fdpid = newAV(); /* for remembering popen pids by fd */
195 PL_modglobal = newHV(); /* pointers to per-interpreter module globals */
198 New(51,PL_debname,128,char);
199 New(52,PL_debdelim,128,char);
209 int destruct_level; /* 0=none, 1=full, 2=full with checks */
215 #endif /* USE_THREADS */
219 /* Pass 1 on any remaining threads: detach joinables, join zombies */
221 MUTEX_LOCK(&PL_threads_mutex);
222 DEBUG_S(PerlIO_printf(PerlIO_stderr(),
223 "perl_destruct: waiting for %d threads...\n",
225 for (t = thr->next; t != thr; t = t->next) {
226 MUTEX_LOCK(&t->mutex);
227 switch (ThrSTATE(t)) {
230 DEBUG_S(PerlIO_printf(PerlIO_stderr(),
231 "perl_destruct: joining zombie %p\n", t));
232 ThrSETSTATE(t, THRf_DEAD);
233 MUTEX_UNLOCK(&t->mutex);
236 * The SvREFCNT_dec below may take a long time (e.g. av
237 * may contain an object scalar whose destructor gets
238 * called) so we have to unlock threads_mutex and start
241 MUTEX_UNLOCK(&PL_threads_mutex);
243 SvREFCNT_dec((SV*)av);
244 DEBUG_S(PerlIO_printf(PerlIO_stderr(),
245 "perl_destruct: joined zombie %p OK\n", t));
247 case THRf_R_JOINABLE:
248 DEBUG_S(PerlIO_printf(PerlIO_stderr(),
249 "perl_destruct: detaching thread %p\n", t));
250 ThrSETSTATE(t, THRf_R_DETACHED);
252 * We unlock threads_mutex and t->mutex in the opposite order
253 * from which we locked them just so that DETACH won't
254 * deadlock if it panics. It's only a breach of good style
255 * not a bug since they are unlocks not locks.
257 MUTEX_UNLOCK(&PL_threads_mutex);
259 MUTEX_UNLOCK(&t->mutex);
262 DEBUG_S(PerlIO_printf(PerlIO_stderr(),
263 "perl_destruct: ignoring %p (state %u)\n",
265 MUTEX_UNLOCK(&t->mutex);
266 /* fall through and out */
269 /* We leave the above "Pass 1" loop with threads_mutex still locked */
271 /* Pass 2 on remaining threads: wait for the thread count to drop to one */
272 while (PL_nthreads > 1)
274 DEBUG_S(PerlIO_printf(PerlIO_stderr(),
275 "perl_destruct: final wait for %d threads\n",
277 COND_WAIT(&PL_nthreads_cond, &PL_threads_mutex);
279 /* At this point, we're the last thread */
280 MUTEX_UNLOCK(&PL_threads_mutex);
281 DEBUG_S(PerlIO_printf(PerlIO_stderr(), "perl_destruct: armageddon has arrived\n"));
282 MUTEX_DESTROY(&PL_threads_mutex);
283 COND_DESTROY(&PL_nthreads_cond);
284 #endif /* !defined(FAKE_THREADS) */
285 #endif /* USE_THREADS */
287 destruct_level = PL_perl_destruct_level;
291 if (s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL")) {
293 if (destruct_level < i)
302 /* We must account for everything. */
304 /* Destroy the main CV and syntax tree */
306 PL_curpad = AvARRAY(PL_comppad);
307 op_free(PL_main_root);
308 PL_main_root = Nullop;
310 PL_curcop = &PL_compiling;
311 PL_main_start = Nullop;
312 SvREFCNT_dec(PL_main_cv);
316 if (PL_sv_objcount) {
318 * Try to destruct global references. We do this first so that the
319 * destructors and destructees still exist. Some sv's might remain.
320 * Non-referenced objects are on their own.
325 /* unhook hooks which will soon be, or use, destroyed data */
326 SvREFCNT_dec(PL_warnhook);
327 PL_warnhook = Nullsv;
328 SvREFCNT_dec(PL_diehook);
330 SvREFCNT_dec(PL_parsehook);
331 PL_parsehook = Nullsv;
333 /* call exit list functions */
334 while (PL_exitlistlen-- > 0)
335 PL_exitlist[PL_exitlistlen].fn(aTHXo_ PL_exitlist[PL_exitlistlen].ptr);
337 Safefree(PL_exitlist);
339 if (destruct_level == 0){
341 DEBUG_P(debprofdump());
343 /* The exit() function will do everything that needs doing. */
347 /* loosen bonds of global variables */
350 (void)PerlIO_close(PL_rsfp);
354 /* Filters for program text */
355 SvREFCNT_dec(PL_rsfp_filters);
356 PL_rsfp_filters = Nullav;
359 PL_preprocess = FALSE;
365 PL_doswitches = FALSE;
366 PL_dowarn = G_WARN_OFF;
367 PL_doextract = FALSE;
368 PL_sawampersand = FALSE; /* must save all match strings */
369 PL_sawstudy = FALSE; /* do fbm_instr on all strings */
373 Safefree(PL_inplace);
377 SvREFCNT_dec(PL_e_script);
378 PL_e_script = Nullsv;
381 /* magical thingies */
383 Safefree(PL_ofs); /* $, */
386 Safefree(PL_ors); /* $\ */
389 SvREFCNT_dec(PL_rs); /* $/ */
392 SvREFCNT_dec(PL_nrs); /* $/ helper */
395 PL_multiline = 0; /* $* */
397 SvREFCNT_dec(PL_statname);
398 PL_statname = Nullsv;
401 /* defgv, aka *_ should be taken care of elsewhere */
403 /* clean up after study() */
404 SvREFCNT_dec(PL_lastscream);
405 PL_lastscream = Nullsv;
406 Safefree(PL_screamfirst);
408 Safefree(PL_screamnext);
411 /* startup and shutdown function lists */
412 SvREFCNT_dec(PL_beginav);
413 SvREFCNT_dec(PL_endav);
414 SvREFCNT_dec(PL_initav);
419 /* shortcuts just get cleared */
426 PL_argvoutgv = Nullgv;
428 PL_last_in_gv = Nullgv;
431 /* reset so print() ends up where we expect */
434 /* Prepare to destruct main symbol table. */
441 if (destruct_level >= 2 && ckWARN_d(WARN_INTERNAL)) {
442 if (PL_scopestack_ix != 0)
443 Perl_warner(aTHX_ WARN_INTERNAL,
444 "Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
445 (long)PL_scopestack_ix);
446 if (PL_savestack_ix != 0)
447 Perl_warner(aTHX_ WARN_INTERNAL,
448 "Unbalanced saves: %ld more saves than restores\n",
449 (long)PL_savestack_ix);
450 if (PL_tmps_floor != -1)
451 Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced tmps: %ld more allocs than frees\n",
452 (long)PL_tmps_floor + 1);
453 if (cxstack_ix != -1)
454 Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced context: %ld more PUSHes than POPs\n",
455 (long)cxstack_ix + 1);
458 /* Now absolutely destruct everything, somehow or other, loops or no. */
460 SvFLAGS(PL_strtab) |= SVTYPEMASK; /* don't clean out strtab now */
461 while (PL_sv_count != 0 && PL_sv_count != last_sv_count) {
462 last_sv_count = PL_sv_count;
465 SvFLAGS(PL_strtab) &= ~SVTYPEMASK;
466 SvFLAGS(PL_strtab) |= SVt_PVHV;
468 /* Destruct the global string table. */
470 /* Yell and reset the HeVAL() slots that are still holding refcounts,
471 * so that sv_free() won't fail on them.
479 max = HvMAX(PL_strtab);
480 array = HvARRAY(PL_strtab);
483 if (hent && ckWARN_d(WARN_INTERNAL)) {
484 Perl_warner(aTHX_ WARN_INTERNAL,
485 "Unbalanced string table refcount: (%d) for \"%s\"",
486 HeVAL(hent) - Nullsv, HeKEY(hent));
487 HeVAL(hent) = Nullsv;
497 SvREFCNT_dec(PL_strtab);
499 if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL))
500 Perl_warner(aTHX_ WARN_INTERNAL,"Scalars leaked: %ld\n", (long)PL_sv_count);
504 /* No SVs have survived, need to clean out */
506 PL_pidstatus = Nullhv;
507 Safefree(PL_origfilename);
508 Safefree(PL_archpat_auto);
509 Safefree(PL_reg_start_tmp);
511 Safefree(PL_reg_curpm);
512 Safefree(PL_reg_poscache);
513 Safefree(HeKEY_hek(&PL_hv_fetch_ent_mh));
514 Safefree(PL_op_mask);
516 PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */
518 DEBUG_P(debprofdump());
520 MUTEX_DESTROY(&PL_strtab_mutex);
521 MUTEX_DESTROY(&PL_sv_mutex);
522 MUTEX_DESTROY(&PL_eval_mutex);
523 MUTEX_DESTROY(&PL_cred_mutex);
524 COND_DESTROY(&PL_eval_cond);
525 #ifdef EMULATE_ATOMIC_REFCOUNTS
526 MUTEX_DESTROY(&PL_svref_mutex);
527 #endif /* EMULATE_ATOMIC_REFCOUNTS */
529 /* As the penultimate thing, free the non-arena SV for thrsv */
530 Safefree(SvPVX(PL_thrsv));
531 Safefree(SvANY(PL_thrsv));
534 #endif /* USE_THREADS */
536 /* As the absolutely last thing, free the non-arena SV for mess() */
539 /* it could have accumulated taint magic */
540 if (SvTYPE(PL_mess_sv) >= SVt_PVMG) {
543 for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) {
544 moremagic = mg->mg_moremagic;
545 if (mg->mg_ptr && mg->mg_type != 'g' && mg->mg_len >= 0)
546 Safefree(mg->mg_ptr);
550 /* we know that type >= SVt_PV */
551 SvOOK_off(PL_mess_sv);
552 Safefree(SvPVX(PL_mess_sv));
553 Safefree(SvANY(PL_mess_sv));
554 Safefree(PL_mess_sv);
562 #if defined(PERL_OBJECT)
570 Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
572 Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry);
573 PL_exitlist[PL_exitlistlen].fn = fn;
574 PL_exitlist[PL_exitlistlen].ptr = ptr;
579 perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
588 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
591 Perl_croak(aTHX_ "suidperl is no longer needed since the kernel can now execute\n\
592 setuid perl scripts securely.\n");
596 #if defined(__DYNAMIC__) && (defined(NeXT) || defined(__NeXT__))
597 _dyld_lookup_and_bind
598 ("__environ", (unsigned long *) &environ_pointer, NULL);
603 #ifndef VMS /* VMS doesn't have environ array */
604 PL_origenviron = environ;
609 /* Come here if running an undumped a.out. */
611 PL_origfilename = savepv(argv[0]);
612 PL_do_undump = FALSE;
613 cxstack_ix = -1; /* start label stack again */
615 init_postdump_symbols(argc,argv,env);
620 PL_curpad = AvARRAY(PL_comppad);
621 op_free(PL_main_root);
622 PL_main_root = Nullop;
624 PL_main_start = Nullop;
625 SvREFCNT_dec(PL_main_cv);
629 oldscope = PL_scopestack_ix;
630 PL_dowarn = G_WARN_OFF;
632 CALLPROTECT(aTHX_ &ret, MEMBER_TO_FPTR(S_parse_body), env, xsinit);
640 /* my_exit() was called */
641 while (PL_scopestack_ix > oldscope)
644 PL_curstash = PL_defstash;
646 call_list(oldscope, PL_endav);
647 return STATUS_NATIVE_EXPORT;
649 PerlIO_printf(PerlIO_stderr(), "panic: top_env\n");
656 S_parse_body(pTHX_ va_list args)
659 int argc = PL_origargc;
660 char **argv = PL_origargv;
661 char **env = va_arg(args, char**);
662 char *scriptname = NULL;
664 VOL bool dosearch = FALSE;
670 XSINIT_t xsinit = va_arg(args, XSINIT_t);
672 sv_setpvn(PL_linestr,"",0);
673 sv = newSVpvn("",0); /* first used for -I flags */
677 for (argc--,argv++; argc > 0; argc--,argv++) {
678 if (argv[0][0] != '-' || !argv[0][1])
682 validarg = " PHOOEY ";
689 #ifndef PERL_STRICT_CR
713 if (s = moreswitches(s))
723 if (PL_euid != PL_uid || PL_egid != PL_gid)
724 Perl_croak(aTHX_ "No -e allowed in setuid scripts");
726 PL_e_script = newSVpvn("",0);
727 filter_add(read_e_script, NULL);
730 sv_catpv(PL_e_script, s);
732 sv_catpv(PL_e_script, argv[1]);
736 Perl_croak(aTHX_ "No code specified for -e");
737 sv_catpv(PL_e_script, "\n");
740 case 'I': /* -I handled both here and in moreswitches() */
742 if (!*++s && (s=argv[1]) != Nullch) {
745 while (s && isSPACE(*s))
749 for (e = s; *e && !isSPACE(*e); e++) ;
756 } /* XXX else croak? */
760 PL_preprocess = TRUE;
770 PL_preambleav = newAV();
771 av_push(PL_preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
773 PL_Sv = newSVpv("print myconfig();",0);
775 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
777 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
779 #if defined(DEBUGGING) || defined(MULTIPLICITY)
780 sv_catpv(PL_Sv,"\" Compile-time options:");
782 sv_catpv(PL_Sv," DEBUGGING");
785 sv_catpv(PL_Sv," MULTIPLICITY");
787 sv_catpv(PL_Sv,"\\n\",");
789 #if defined(LOCAL_PATCH_COUNT)
790 if (LOCAL_PATCH_COUNT > 0) {
792 sv_catpv(PL_Sv,"\" Locally applied patches:\\n\",");
793 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
794 if (PL_localpatches[i])
795 Perl_sv_catpvf(aTHX_ PL_Sv,"q\" \t%s\n\",",PL_localpatches[i]);
799 Perl_sv_catpvf(aTHX_ PL_Sv,"\" Built under %s\\n\"",OSNAME);
802 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
804 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled on %s\\n\"",__DATE__);
809 @env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; \
810 print \" \\%ENV:\\n @env\\n\" if @env; \
811 print \" \\@INC:\\n @INC\\n\";");
814 PL_Sv = newSVpv("config_vars(qw(",0);
815 sv_catpv(PL_Sv, ++s);
816 sv_catpv(PL_Sv, "))");
819 av_push(PL_preambleav, PL_Sv);
820 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
826 PL_cddir = savepv(s);
831 if (!*++s || isSPACE(*s)) {
835 /* catch use of gnu style long options */
836 if (strEQ(s, "version")) {
840 if (strEQ(s, "help")) {
847 Perl_croak(aTHX_ "Unrecognized switch: -%s (-h will show valid options)",s);
853 #ifndef SECURE_INTERNAL_GETENV
856 (s = PerlEnv_getenv("PERL5OPT"))) {
859 if (*s == '-' && *(s+1) == 'T')
872 if (!strchr("DIMUdmw", *s))
873 Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
880 scriptname = argv[0];
883 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
885 else if (scriptname == Nullch) {
887 if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
895 open_script(scriptname,dosearch,sv,&fdscript);
897 validate_suid(validarg, scriptname,fdscript);
902 PL_main_cv = PL_compcv = (CV*)NEWSV(1104,0);
903 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
904 CvUNIQUE_on(PL_compcv);
906 PL_comppad = newAV();
907 av_push(PL_comppad, Nullsv);
908 PL_curpad = AvARRAY(PL_comppad);
909 PL_comppad_name = newAV();
910 PL_comppad_name_fill = 0;
911 PL_min_intro_pending = 0;
914 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
915 PL_curpad[0] = (SV*)newAV();
916 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
917 CvOWNER(PL_compcv) = 0;
918 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
919 MUTEX_INIT(CvMUTEXP(PL_compcv));
920 #endif /* USE_THREADS */
922 comppadlist = newAV();
923 AvREAL_off(comppadlist);
924 av_store(comppadlist, 0, (SV*)PL_comppad_name);
925 av_store(comppadlist, 1, (SV*)PL_comppad);
926 CvPADLIST(PL_compcv) = comppadlist;
928 boot_core_UNIVERSAL();
931 (*xsinit)(aTHXo); /* in case linked C routines want magical variables */
932 #if defined(VMS) || defined(WIN32) || defined(DJGPP)
940 init_predump_symbols();
941 /* init_postdump_symbols not currently designed to be called */
942 /* more than once (ENV isn't cleared first, for example) */
943 /* But running with -u leaves %ENV & @ARGV undefined! XXX */
945 init_postdump_symbols(argc,argv,env);
949 /* now parse the script */
951 SETERRNO(0,SS$_NORMAL);
953 if (yyparse() || PL_error_count) {
955 Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
957 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
961 PL_curcop->cop_line = 0;
962 PL_curstash = PL_defstash;
963 PL_preprocess = FALSE;
965 SvREFCNT_dec(PL_e_script);
966 PL_e_script = Nullsv;
969 /* now that script is parsed, we can modify record separator */
971 PL_rs = SvREFCNT_inc(PL_nrs);
972 sv_setsv(get_sv("/", TRUE), PL_rs);
977 gv_check(PL_defstash);
983 if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
984 dump_mstats("after compilation:");
1002 oldscope = PL_scopestack_ix;
1005 CALLPROTECT(aTHX_ &ret, MEMBER_TO_FPTR(S_run_body), oldscope);
1008 cxstack_ix = -1; /* start context stack again */
1010 case 0: /* normal completion */
1011 case 2: /* my_exit() */
1012 while (PL_scopestack_ix > oldscope)
1015 PL_curstash = PL_defstash;
1017 call_list(oldscope, PL_endav);
1019 if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
1020 dump_mstats("after execution: ");
1022 return STATUS_NATIVE_EXPORT;
1025 POPSTACK_TO(PL_mainstack);
1028 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
1038 S_run_body(pTHX_ va_list args)
1041 I32 oldscope = va_arg(args, I32);
1043 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
1044 PL_sawampersand ? "Enabling" : "Omitting"));
1046 if (!PL_restartop) {
1047 DEBUG_x(dump_all());
1048 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
1049 DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%lx\n",
1050 (unsigned long) thr));
1053 PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", PL_origfilename);
1056 if (PERLDB_SINGLE && PL_DBsingle)
1057 sv_setiv(PL_DBsingle, 1);
1059 call_list(oldscope, PL_initav);
1065 PL_op = PL_restartop;
1069 else if (PL_main_start) {
1070 CvDEPTH(PL_main_cv) = 1;
1071 PL_op = PL_main_start;
1081 Perl_get_sv(pTHX_ const char *name, I32 create)
1085 if (name[1] == '\0' && !isALPHA(name[0])) {
1086 PADOFFSET tmp = find_threadsv(name);
1087 if (tmp != NOT_IN_PAD) {
1089 return THREADSV(tmp);
1092 #endif /* USE_THREADS */
1093 gv = gv_fetchpv(name, create, SVt_PV);
1100 Perl_get_av(pTHX_ const char *name, I32 create)
1102 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1111 Perl_get_hv(pTHX_ const char *name, I32 create)
1113 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1122 Perl_get_cv(pTHX_ const char *name, I32 create)
1124 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
1125 /* XXX unsafe for threads if eval_owner isn't held */
1126 /* XXX this is probably not what they think they're getting.
1127 * It has the same effect as "sub name;", i.e. just a forward
1129 if (create && !GvCVu(gv))
1130 return newSUB(start_subparse(FALSE, 0),
1131 newSVOP(OP_CONST, 0, newSVpv(name,0)),
1139 /* Be sure to refetch the stack pointer after calling these routines. */
1142 Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv)
1144 /* See G_* flags in cop.h */
1145 /* null terminated arg list */
1152 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
1157 return call_pv(sub_name, flags);
1161 Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
1162 /* name of the subroutine */
1163 /* See G_* flags in cop.h */
1165 return call_sv((SV*)get_cv(sub_name, TRUE), flags);
1169 Perl_call_method(pTHX_ const char *methname, I32 flags)
1170 /* name of the subroutine */
1171 /* See G_* flags in cop.h */
1177 XPUSHs(sv_2mortal(newSVpv(methname,0)));
1182 return call_sv(*PL_stack_sp--, flags);
1185 /* May be called with any of a CV, a GV, or an SV containing the name. */
1187 Perl_call_sv(pTHX_ SV *sv, I32 flags)
1189 /* See G_* flags in cop.h */
1192 LOGOP myop; /* fake syntax tree node */
1196 bool oldcatch = CATCH_GET;
1200 if (flags & G_DISCARD) {
1205 Zero(&myop, 1, LOGOP);
1206 myop.op_next = Nullop;
1207 if (!(flags & G_NOARGS))
1208 myop.op_flags |= OPf_STACKED;
1209 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1210 (flags & G_ARRAY) ? OPf_WANT_LIST :
1215 EXTEND(PL_stack_sp, 1);
1216 *++PL_stack_sp = sv;
1218 oldscope = PL_scopestack_ix;
1220 if (PERLDB_SUB && PL_curstash != PL_debstash
1221 /* Handle first BEGIN of -d. */
1222 && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
1223 /* Try harder, since this may have been a sighandler, thus
1224 * curstash may be meaningless. */
1225 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != PL_debstash)
1226 && !(flags & G_NODEBUG))
1227 PL_op->op_private |= OPpENTERSUB_DB;
1229 if (!(flags & G_EVAL)) {
1230 /* G_NOCATCH is a hack for perl_vdie using this path to call
1231 a __DIE__ handler */
1232 if (!(flags & G_NOCATCH)) {
1235 call_xbody((OP*)&myop, FALSE);
1236 retval = PL_stack_sp - (PL_stack_base + oldmark);
1237 if (!(flags & G_NOCATCH)) {
1242 cLOGOP->op_other = PL_op;
1244 /* we're trying to emulate pp_entertry() here */
1246 register PERL_CONTEXT *cx;
1247 I32 gimme = GIMME_V;
1252 push_return(PL_op->op_next);
1253 PUSHBLOCK(cx, CXt_EVAL, PL_stack_sp);
1255 PL_eval_root = PL_op; /* Only needed so that goto works right. */
1257 PL_in_eval = EVAL_INEVAL;
1258 if (flags & G_KEEPERR)
1259 PL_in_eval |= EVAL_KEEPERR;
1266 CALLPROTECT(aTHX_ &ret, MEMBER_TO_FPTR(S_call_body), (OP*)&myop, FALSE);
1269 retval = PL_stack_sp - (PL_stack_base + oldmark);
1270 if (!(flags & G_KEEPERR))
1277 /* my_exit() was called */
1278 PL_curstash = PL_defstash;
1281 Perl_croak(aTHX_ "Callback called exit");
1286 PL_op = PL_restartop;
1290 PL_stack_sp = PL_stack_base + oldmark;
1291 if (flags & G_ARRAY)
1295 *++PL_stack_sp = &PL_sv_undef;
1300 if (PL_scopestack_ix > oldscope) {
1304 register PERL_CONTEXT *cx;
1315 if (flags & G_DISCARD) {
1316 PL_stack_sp = PL_stack_base + oldmark;
1326 S_call_body(pTHX_ va_list args)
1328 OP *myop = va_arg(args, OP*);
1329 int is_eval = va_arg(args, int);
1331 call_xbody(myop, is_eval);
1336 S_call_xbody(pTHX_ OP *myop, int is_eval)
1340 if (PL_op == myop) {
1342 PL_op = Perl_pp_entereval(aTHX);
1344 PL_op = Perl_pp_entersub(aTHX);
1350 /* Eval a string. The G_EVAL flag is always assumed. */
1353 Perl_eval_sv(pTHX_ SV *sv, I32 flags)
1355 /* See G_* flags in cop.h */
1358 UNOP myop; /* fake syntax tree node */
1359 I32 oldmark = SP - PL_stack_base;
1365 if (flags & G_DISCARD) {
1372 Zero(PL_op, 1, UNOP);
1373 EXTEND(PL_stack_sp, 1);
1374 *++PL_stack_sp = sv;
1375 oldscope = PL_scopestack_ix;
1377 if (!(flags & G_NOARGS))
1378 myop.op_flags = OPf_STACKED;
1379 myop.op_next = Nullop;
1380 myop.op_type = OP_ENTEREVAL;
1381 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1382 (flags & G_ARRAY) ? OPf_WANT_LIST :
1384 if (flags & G_KEEPERR)
1385 myop.op_flags |= OPf_SPECIAL;
1388 CALLPROTECT(aTHX_ &ret, MEMBER_TO_FPTR(S_call_body), (OP*)&myop, TRUE);
1391 retval = PL_stack_sp - (PL_stack_base + oldmark);
1392 if (!(flags & G_KEEPERR))
1399 /* my_exit() was called */
1400 PL_curstash = PL_defstash;
1403 Perl_croak(aTHX_ "Callback called exit");
1408 PL_op = PL_restartop;
1412 PL_stack_sp = PL_stack_base + oldmark;
1413 if (flags & G_ARRAY)
1417 *++PL_stack_sp = &PL_sv_undef;
1422 if (flags & G_DISCARD) {
1423 PL_stack_sp = PL_stack_base + oldmark;
1433 Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
1436 SV* sv = newSVpv(p, 0);
1439 eval_sv(sv, G_SCALAR);
1446 if (croak_on_error && SvTRUE(ERRSV)) {
1448 Perl_croak(aTHX_ SvPVx(ERRSV, n_a));
1454 /* Require a module. */
1457 Perl_require_pv(pTHX_ const char *pv)
1461 PUSHSTACKi(PERLSI_REQUIRE);
1463 sv = sv_newmortal();
1464 sv_setpv(sv, "require '");
1467 eval_sv(sv, G_DISCARD);
1473 Perl_magicname(pTHX_ char *sym, char *name, I32 namlen)
1477 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1478 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1482 S_usage(pTHX_ char *name) /* XXX move this out into a module ? */
1484 /* This message really ought to be max 23 lines.
1485 * Removed -h because the user already knows that opton. Others? */
1487 static char *usage_msg[] = {
1488 "-0[octal] specify record separator (\\0, if no argument)",
1489 "-a autosplit mode with -n or -p (splits $_ into @F)",
1490 "-c check syntax only (runs BEGIN and END blocks)",
1491 "-d[:debugger] run program under debugger",
1492 "-D[number/list] set debugging flags (argument is a bit mask or alphabets)",
1493 "-e 'command' one line of program (several -e's allowed, omit programfile)",
1494 "-F/pattern/ split() pattern for -a switch (//'s are optional)",
1495 "-i[extension] edit <> files in place (makes backup if extension supplied)",
1496 "-Idirectory specify @INC/#include directory (several -I's allowed)",
1497 "-l[octal] enable line ending processing, specifies line terminator",
1498 "-[mM][-]module execute `use/no module...' before executing program",
1499 "-n assume 'while (<>) { ... }' loop around program",
1500 "-p assume loop like -n but print line also, like sed",
1501 "-P run program through C preprocessor before compilation",
1502 "-s enable rudimentary parsing for switches after programfile",
1503 "-S look for programfile using PATH environment variable",
1504 "-T enable tainting checks",
1505 "-u dump core after parsing program",
1506 "-U allow unsafe operations",
1507 "-v print version, subversion (includes VERY IMPORTANT perl info)",
1508 "-V[:variable] print configuration summary (or a single Config.pm variable)",
1509 "-w enable many useful warnings (RECOMMENDED)",
1510 "-x[directory] strip off text before #!perl line and perhaps cd to directory",
1514 char **p = usage_msg;
1516 printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1518 printf("\n %s", *p++);
1521 /* This routine handles any switches that can be given during run */
1524 Perl_moreswitches(pTHX_ char *s)
1533 rschar = scan_oct(s, 4, &numlen);
1534 SvREFCNT_dec(PL_nrs);
1535 if (rschar & ~((U8)~0))
1536 PL_nrs = &PL_sv_undef;
1537 else if (!rschar && numlen >= 2)
1538 PL_nrs = newSVpvn("", 0);
1541 PL_nrs = newSVpvn(&ch, 1);
1547 PL_splitstr = savepv(s + 1);
1561 if (*s == ':' || *s == '=') {
1562 my_setenv("PERL5DB", Perl_form(aTHX_ "use Devel::%s;", ++s));
1566 PL_perldb = PERLDB_ALL;
1574 if (isALPHA(s[1])) {
1575 static char debopts[] = "psltocPmfrxuLHXDS";
1578 for (s++; *s && (d = strchr(debopts,*s)); s++)
1579 PL_debug |= 1 << (d - debopts);
1582 PL_debug = atoi(s+1);
1583 for (s++; isDIGIT(*s); s++) ;
1585 PL_debug |= 0x80000000;
1588 if (ckWARN_d(WARN_DEBUGGING))
1589 Perl_warner(aTHX_ WARN_DEBUGGING,
1590 "Recompile perl with -DDEBUGGING to use -D switch\n");
1591 for (s++; isALNUM(*s); s++) ;
1597 usage(PL_origargv[0]);
1601 Safefree(PL_inplace);
1602 PL_inplace = savepv(s+1);
1604 for (s = PL_inplace; *s && !isSPACE(*s); s++) ;
1607 if (*s == '-') /* Additional switches on #! line. */
1611 case 'I': /* -I handled both here and in parse_perl() */
1614 while (*s && isSPACE(*s))
1618 for (e = s; *e && !isSPACE(*e); e++) ;
1619 p = savepvn(s, e-s);
1625 Perl_croak(aTHX_ "No space allowed after -I");
1633 PL_ors = savepv("\n");
1635 *PL_ors = scan_oct(s, 3 + (*s == '0'), &numlen);
1640 if (RsPARA(PL_nrs)) {
1645 PL_ors = SvPV(PL_nrs, PL_orslen);
1646 PL_ors = savepvn(PL_ors, PL_orslen);
1650 forbid_setid("-M"); /* XXX ? */
1653 forbid_setid("-m"); /* XXX ? */
1658 /* -M-foo == 'no foo' */
1659 if (*s == '-') { use = "no "; ++s; }
1660 sv = newSVpv(use,0);
1662 /* We allow -M'Module qw(Foo Bar)' */
1663 while(isALNUM(*s) || *s==':') ++s;
1665 sv_catpv(sv, start);
1666 if (*(start-1) == 'm') {
1668 Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
1669 sv_catpv( sv, " ()");
1672 sv_catpvn(sv, start, s-start);
1673 sv_catpv(sv, " split(/,/,q{");
1678 if (PL_preambleav == NULL)
1679 PL_preambleav = newAV();
1680 av_push(PL_preambleav, sv);
1683 Perl_croak(aTHX_ "No space allowed after -%c", *(s-1));
1695 PL_doswitches = TRUE;
1700 Perl_croak(aTHX_ "Too late for \"-T\" option");
1704 PL_do_undump = TRUE;
1712 #if defined(PERL_SUBVERSION) && PERL_SUBVERSION > 0
1713 printf("\nThis is perl, version %d.%03d_%02d built for %s",
1714 PERL_REVISION, PERL_VERSION, PERL_SUBVERSION, ARCHNAME);
1716 printf("\nThis is perl, version %s built for %s",
1717 PL_patchlevel, ARCHNAME);
1719 #if defined(LOCAL_PATCH_COUNT)
1720 if (LOCAL_PATCH_COUNT > 0)
1721 printf("\n(with %d registered patch%s, see perl -V for more detail)",
1722 LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : "");
1725 printf("\n\nCopyright 1987-1999, Larry Wall\n");
1727 printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1730 printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
1731 printf("djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
1734 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1735 "Version 5 port Copyright (c) 1994-1999, Andreas Kaiser, Ilya Zakharevich\n");
1738 printf("atariST series port, ++jrb bammi@cadence.com\n");
1741 printf("BeOS port Copyright Tom Spindler, 1997-1999\n");
1744 printf("MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-1999\n");
1747 printf("MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
1750 printf("Stratus VOS port by Paul_Green@stratus.com, 1997-1999\n");
1753 printf("VM/ESA port by Neale Ferguson, 1998-1999\n");
1756 printf("BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
1759 printf("MiNT port by Guido Flohr, 1997-1999\n");
1761 #ifdef BINARY_BUILD_NOTICE
1762 BINARY_BUILD_NOTICE;
1765 Perl may be copied only under the terms of either the Artistic License or the\n\
1766 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n\
1767 Complete documentation for Perl, including FAQ lists, should be found on\n\
1768 this system using `man perl' or `perldoc perl'. If you have access to the\n\
1769 Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
1772 if (! (PL_dowarn & G_WARN_ALL_MASK))
1773 PL_dowarn |= G_WARN_ON;
1777 PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
1778 PL_compiling.cop_warnings = WARN_ALL ;
1782 PL_dowarn = G_WARN_ALL_OFF;
1783 PL_compiling.cop_warnings = WARN_NONE ;
1788 if (s[1] == '-') /* Additional switches on #! line. */
1793 #if defined(WIN32) || !defined(PERL_STRICT_CR)
1799 #ifdef ALTERNATE_SHEBANG
1800 case 'S': /* OS/2 needs -S on "extproc" line. */
1808 Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
1813 /* compliments of Tom Christiansen */
1815 /* unexec() can be found in the Gnu emacs distribution */
1816 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
1819 Perl_my_unexec(pTHX)
1827 prog = newSVpv(BIN_EXP, 0);
1828 sv_catpv(prog, "/perl");
1829 file = newSVpv(PL_origfilename, 0);
1830 sv_catpv(file, ".perldump");
1832 unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
1833 /* unexec prints msg to stderr in case of failure */
1834 PerlProc_exit(status);
1837 # include <lib$routines.h>
1838 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
1840 ABORT(); /* for use with undump */
1845 /* initialize curinterp */
1850 #ifdef PERL_OBJECT /* XXX kludge */
1853 PL_chopset = " \n-"; \
1854 PL_copline = NOLINE; \
1855 PL_curcop = &PL_compiling;\
1856 PL_curcopdb = NULL; \
1859 PL_dumpindent = 4; \
1860 PL_laststatval = -1; \
1861 PL_laststype = OP_STAT; \
1862 PL_maxscream = -1; \
1863 PL_maxsysfd = MAXSYSFD; \
1864 PL_statname = Nullsv; \
1865 PL_tmps_floor = -1; \
1867 PL_op_mask = NULL; \
1869 PL_laststatval = -1; \
1870 PL_laststype = OP_STAT; \
1871 PL_mess_sv = Nullsv; \
1872 PL_splitstr = " "; \
1873 PL_generation = 100; \
1874 PL_exitlist = NULL; \
1875 PL_exitlistlen = 0; \
1877 PL_in_clean_objs = FALSE; \
1878 PL_in_clean_all = FALSE; \
1879 PL_profiledata = NULL; \
1881 PL_rsfp_filters = Nullav; \
1886 # ifdef MULTIPLICITY
1887 # define PERLVAR(var,type)
1888 # define PERLVARA(var,n,type)
1889 # if defined(PERL_IMPLICIT_CONTEXT)
1890 # if defined(USE_THREADS)
1891 # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
1892 # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
1893 # else /* !USE_THREADS */
1894 # define PERLVARI(var,type,init) aTHX->var = init;
1895 # define PERLVARIC(var,type,init) aTHX->var = init;
1896 # endif /* USE_THREADS */
1898 # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
1899 # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
1901 # include "intrpvar.h"
1902 # ifndef USE_THREADS
1903 # include "thrdvar.h"
1910 # define PERLVAR(var,type)
1911 # define PERLVARA(var,n,type)
1912 # define PERLVARI(var,type,init) PL_##var = init;
1913 # define PERLVARIC(var,type,init) PL_##var = init;
1914 # include "intrpvar.h"
1915 # ifndef USE_THREADS
1916 # include "thrdvar.h"
1928 S_init_main_stash(pTHX)
1933 /* Note that strtab is a rather special HV. Assumptions are made
1934 about not iterating on it, and not adding tie magic to it.
1935 It is properly deallocated in perl_destruct() */
1936 PL_strtab = newHV();
1938 MUTEX_INIT(&PL_strtab_mutex);
1940 HvSHAREKEYS_off(PL_strtab); /* mandatory */
1941 hv_ksplit(PL_strtab, 512);
1943 PL_curstash = PL_defstash = newHV();
1944 PL_curstname = newSVpvn("main",4);
1945 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1946 SvREFCNT_dec(GvHV(gv));
1947 GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
1949 HvNAME(PL_defstash) = savepv("main");
1950 PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1951 GvMULTI_on(PL_incgv);
1952 PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
1953 GvMULTI_on(PL_hintgv);
1954 PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1955 PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1956 GvMULTI_on(PL_errgv);
1957 PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
1958 GvMULTI_on(PL_replgv);
1959 (void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */
1960 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
1961 sv_setpvn(ERRSV, "", 0);
1962 PL_curstash = PL_defstash;
1963 PL_compiling.cop_stash = PL_defstash;
1964 PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
1965 PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
1966 /* We must init $/ before switches are processed. */
1967 sv_setpvn(get_sv("/", TRUE), "\n", 1);
1971 S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
1979 PL_origfilename = savepv("-e");
1982 /* if find_script() returns, it returns a malloc()-ed value */
1983 PL_origfilename = scriptname = find_script(scriptname, dosearch, NULL, 1);
1985 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
1986 char *s = scriptname + 8;
1987 *fdscript = atoi(s);
1991 scriptname = savepv(s + 1);
1992 Safefree(PL_origfilename);
1993 PL_origfilename = scriptname;
1998 PL_curcop->cop_filegv = gv_fetchfile(PL_origfilename);
1999 if (strEQ(PL_origfilename,"-"))
2001 if (*fdscript >= 0) {
2002 PL_rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE);
2003 #if defined(HAS_FCNTL) && defined(F_SETFD)
2005 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); /* ensure close-on-exec */
2008 else if (PL_preprocess) {
2009 char *cpp_cfg = CPPSTDIN;
2010 SV *cpp = newSVpvn("",0);
2011 SV *cmd = NEWSV(0,0);
2013 if (strEQ(cpp_cfg, "cppstdin"))
2014 Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
2015 sv_catpv(cpp, cpp_cfg);
2018 sv_catpv(sv,PRIVLIB_EXP);
2021 Perl_sv_setpvf(aTHX_ cmd, "\
2022 sed %s -e \"/^[^#]/b\" \
2023 -e \"/^#[ ]*include[ ]/b\" \
2024 -e \"/^#[ ]*define[ ]/b\" \
2025 -e \"/^#[ ]*if[ ]/b\" \
2026 -e \"/^#[ ]*ifdef[ ]/b\" \
2027 -e \"/^#[ ]*ifndef[ ]/b\" \
2028 -e \"/^#[ ]*else/b\" \
2029 -e \"/^#[ ]*elif[ ]/b\" \
2030 -e \"/^#[ ]*undef[ ]/b\" \
2031 -e \"/^#[ ]*endif/b\" \
2034 (PL_doextract ? "-e \"1,/^#/d\n\"" : ""),
2037 Perl_sv_setpvf(aTHX_ cmd, "\
2038 %s %s -e '/^[^#]/b' \
2039 -e '/^#[ ]*include[ ]/b' \
2040 -e '/^#[ ]*define[ ]/b' \
2041 -e '/^#[ ]*if[ ]/b' \
2042 -e '/^#[ ]*ifdef[ ]/b' \
2043 -e '/^#[ ]*ifndef[ ]/b' \
2044 -e '/^#[ ]*else/b' \
2045 -e '/^#[ ]*elif[ ]/b' \
2046 -e '/^#[ ]*undef[ ]/b' \
2047 -e '/^#[ ]*endif/b' \
2051 Perl_sv_setpvf(aTHX_ cmd, "\
2052 %s %s -e '/^[^#]/b' \
2053 -e '/^#[ ]*include[ ]/b' \
2054 -e '/^#[ ]*define[ ]/b' \
2055 -e '/^#[ ]*if[ ]/b' \
2056 -e '/^#[ ]*ifdef[ ]/b' \
2057 -e '/^#[ ]*ifndef[ ]/b' \
2058 -e '/^#[ ]*else/b' \
2059 -e '/^#[ ]*elif[ ]/b' \
2060 -e '/^#[ ]*undef[ ]/b' \
2061 -e '/^#[ ]*endif/b' \
2070 (PL_doextract ? "-e '1,/^#/d\n'" : ""),
2072 scriptname, cpp, sv, CPPMINUS);
2073 PL_doextract = FALSE;
2074 #ifdef IAMSUID /* actually, this is caught earlier */
2075 if (PL_euid != PL_uid && !PL_euid) { /* if running suidperl */
2077 (void)seteuid(PL_uid); /* musn't stay setuid root */
2080 (void)setreuid((Uid_t)-1, PL_uid);
2082 #ifdef HAS_SETRESUID
2083 (void)setresuid((Uid_t)-1, PL_uid, (Uid_t)-1);
2085 PerlProc_setuid(PL_uid);
2089 if (PerlProc_geteuid() != PL_uid)
2090 Perl_croak(aTHX_ "Can't do seteuid!\n");
2092 #endif /* IAMSUID */
2093 PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
2097 else if (!*scriptname) {
2098 forbid_setid("program input from stdin");
2099 PL_rsfp = PerlIO_stdin();
2102 PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
2103 #if defined(HAS_FCNTL) && defined(F_SETFD)
2105 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); /* ensure close-on-exec */
2110 #ifndef IAMSUID /* in case script is not readable before setuid */
2112 PerlLIO_stat(SvPVX(GvSV(PL_curcop->cop_filegv)),&PL_statbuf) >= 0 &&
2113 PL_statbuf.st_mode & (S_ISUID|S_ISGID))
2116 PerlProc_execv(Perl_form(aTHX_ "%s/sperl%s", BIN_EXP, PL_patchlevel), PL_origargv);
2117 Perl_croak(aTHX_ "Can't do setuid\n");
2121 Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
2122 SvPVX(GvSV(PL_curcop->cop_filegv)), Strerror(errno));
2127 * I_SYSSTATVFS HAS_FSTATVFS
2129 * I_STATFS HAS_FSTATFS
2130 * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT
2131 * here so that metaconfig picks them up. */
2135 S_fd_on_nosuid_fs(pTHX_ int fd)
2140 * Preferred order: fstatvfs(), fstatfs(), getmntent().
2141 * fstatvfs() is UNIX98.
2143 * getmntent() is O(number-of-mounted-filesystems) and can hang.
2146 # ifdef HAS_FSTATVFS
2147 struct statvfs stfs;
2148 check_okay = fstatvfs(fd, &stfs) == 0;
2149 on_nosuid = check_okay && (stfs.f_flag & ST_NOSUID);
2151 # if defined(HAS_FSTATFS) && defined(HAS_STRUCT_STATFS_FLAGS)
2153 check_okay = fstatfs(fd, &stfs) == 0;
2154 # undef PERL_MOUNT_NOSUID
2155 # if !defined(PERL_MOUNT_NOSUID) && defined(MNT_NOSUID)
2156 # define PERL_MOUNT_NOSUID MNT_NOSUID
2158 # if !defined(PERL_MOUNT_NOSUID) && defined(MS_NOSUID)
2159 # define PERL_MOUNT_NOSUID MS_NOSUID
2161 # if !defined(PERL_MOUNT_NOSUID) && defined(M_NOSUID)
2162 # define PERL_MOUNT_NOSUID M_NOSUID
2164 # ifdef PERL_MOUNT_NOSUID
2165 on_nosuid = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
2168 # if defined(HAS_GETMNTENT) && defined(HAS_HASMNTOPT) && defined(MNTOPT_NOSUID)
2169 FILE *mtab = fopen("/etc/mtab", "r");
2170 struct mntent *entry;
2171 struct stat stb, fsb;
2173 if (mtab && (fstat(fd, &stb) == 0)) {
2174 while (entry = getmntent(mtab)) {
2175 if (stat(entry->mnt_dir, &fsb) == 0
2176 && fsb.st_dev == stb.st_dev)
2178 /* found the filesystem */
2180 if (hasmntopt(entry, MNTOPT_NOSUID))
2183 } /* A single fs may well fail its stat(). */
2188 # endif /* mntent */
2189 # endif /* statfs */
2190 # endif /* statvfs */
2192 Perl_croak(aTHX_ "Can't check filesystem of script \"%s\"", PL_origfilename);
2195 #endif /* IAMSUID */
2198 S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript)
2202 /* do we need to emulate setuid on scripts? */
2204 /* This code is for those BSD systems that have setuid #! scripts disabled
2205 * in the kernel because of a security problem. Merely defining DOSUID
2206 * in perl will not fix that problem, but if you have disabled setuid
2207 * scripts in the kernel, this will attempt to emulate setuid and setgid
2208 * on scripts that have those now-otherwise-useless bits set. The setuid
2209 * root version must be called suidperl or sperlN.NNN. If regular perl
2210 * discovers that it has opened a setuid script, it calls suidperl with
2211 * the same argv that it had. If suidperl finds that the script it has
2212 * just opened is NOT setuid root, it sets the effective uid back to the
2213 * uid. We don't just make perl setuid root because that loses the
2214 * effective uid we had before invoking perl, if it was different from the
2217 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
2218 * be defined in suidperl only. suidperl must be setuid root. The
2219 * Configure script will set this up for you if you want it.
2226 if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */
2227 Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
2228 if (fdscript < 0 && PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
2233 #ifndef HAS_SETREUID
2234 /* On this access check to make sure the directories are readable,
2235 * there is actually a small window that the user could use to make
2236 * filename point to an accessible directory. So there is a faint
2237 * chance that someone could execute a setuid script down in a
2238 * non-accessible directory. I don't know what to do about that.
2239 * But I don't think it's too important. The manual lies when
2240 * it says access() is useful in setuid programs.
2242 if (PerlLIO_access(SvPVX(GvSV(PL_curcop->cop_filegv)),1)) /*double check*/
2243 Perl_croak(aTHX_ "Permission denied");
2245 /* If we can swap euid and uid, then we can determine access rights
2246 * with a simple stat of the file, and then compare device and
2247 * inode to make sure we did stat() on the same file we opened.
2248 * Then we just have to make sure he or she can execute it.
2251 struct stat tmpstatbuf;
2255 setreuid(PL_euid,PL_uid) < 0
2258 setresuid(PL_euid,PL_uid,(Uid_t)-1) < 0
2261 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
2262 Perl_croak(aTHX_ "Can't swap uid and euid"); /* really paranoid */
2263 if (PerlLIO_stat(SvPVX(GvSV(PL_curcop->cop_filegv)),&tmpstatbuf) < 0)
2264 Perl_croak(aTHX_ "Permission denied"); /* testing full pathname here */
2265 #if defined(IAMSUID) && !defined(NO_NOSUID_CHECK)
2266 if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp)))
2267 Perl_croak(aTHX_ "Permission denied");
2269 if (tmpstatbuf.st_dev != PL_statbuf.st_dev ||
2270 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
2271 (void)PerlIO_close(PL_rsfp);
2272 if (PL_rsfp = PerlProc_popen("/bin/mail root","w")) { /* heh, heh */
2273 PerlIO_printf(PL_rsfp,
2274 "User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2275 (Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
2276 (long)PL_uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
2277 (long)PL_statbuf.st_dev, (long)PL_statbuf.st_ino,
2278 SvPVX(GvSV(PL_curcop->cop_filegv)),
2279 (long)PL_statbuf.st_uid, (long)PL_statbuf.st_gid);
2280 (void)PerlProc_pclose(PL_rsfp);
2282 Perl_croak(aTHX_ "Permission denied\n");
2286 setreuid(PL_uid,PL_euid) < 0
2288 # if defined(HAS_SETRESUID)
2289 setresuid(PL_uid,PL_euid,(Uid_t)-1) < 0
2292 || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
2293 Perl_croak(aTHX_ "Can't reswap uid and euid");
2294 if (!cando(S_IXUSR,FALSE,&PL_statbuf)) /* can real uid exec? */
2295 Perl_croak(aTHX_ "Permission denied\n");
2297 #endif /* HAS_SETREUID */
2298 #endif /* IAMSUID */
2300 if (!S_ISREG(PL_statbuf.st_mode))
2301 Perl_croak(aTHX_ "Permission denied");
2302 if (PL_statbuf.st_mode & S_IWOTH)
2303 Perl_croak(aTHX_ "Setuid/gid script is writable by world");
2304 PL_doswitches = FALSE; /* -s is insecure in suid */
2305 PL_curcop->cop_line++;
2306 if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
2307 strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */
2308 Perl_croak(aTHX_ "No #! line");
2309 s = SvPV(PL_linestr,n_a)+2;
2311 while (!isSPACE(*s)) s++;
2312 for (s2 = s; (s2 > SvPV(PL_linestr,n_a)+2 &&
2313 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
2314 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
2315 Perl_croak(aTHX_ "Not a perl script");
2316 while (*s == ' ' || *s == '\t') s++;
2318 * #! arg must be what we saw above. They can invoke it by
2319 * mentioning suidperl explicitly, but they may not add any strange
2320 * arguments beyond what #! says if they do invoke suidperl that way.
2322 len = strlen(validarg);
2323 if (strEQ(validarg," PHOOEY ") ||
2324 strnNE(s,validarg,len) || !isSPACE(s[len]))
2325 Perl_croak(aTHX_ "Args must match #! line");
2328 if (PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
2329 PL_euid == PL_statbuf.st_uid)
2331 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2332 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2333 #endif /* IAMSUID */
2335 if (PL_euid) { /* oops, we're not the setuid root perl */
2336 (void)PerlIO_close(PL_rsfp);
2339 PerlProc_execv(Perl_form(aTHX_ "%s/sperl%s", BIN_EXP, PL_patchlevel), PL_origargv);
2341 Perl_croak(aTHX_ "Can't do setuid\n");
2344 if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
2346 (void)setegid(PL_statbuf.st_gid);
2349 (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
2351 #ifdef HAS_SETRESGID
2352 (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
2354 PerlProc_setgid(PL_statbuf.st_gid);
2358 if (PerlProc_getegid() != PL_statbuf.st_gid)
2359 Perl_croak(aTHX_ "Can't do setegid!\n");
2361 if (PL_statbuf.st_mode & S_ISUID) {
2362 if (PL_statbuf.st_uid != PL_euid)
2364 (void)seteuid(PL_statbuf.st_uid); /* all that for this */
2367 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
2369 #ifdef HAS_SETRESUID
2370 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
2372 PerlProc_setuid(PL_statbuf.st_uid);
2376 if (PerlProc_geteuid() != PL_statbuf.st_uid)
2377 Perl_croak(aTHX_ "Can't do seteuid!\n");
2379 else if (PL_uid) { /* oops, mustn't run as root */
2381 (void)seteuid((Uid_t)PL_uid);
2384 (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
2386 #ifdef HAS_SETRESUID
2387 (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
2389 PerlProc_setuid((Uid_t)PL_uid);
2393 if (PerlProc_geteuid() != PL_uid)
2394 Perl_croak(aTHX_ "Can't do seteuid!\n");
2397 if (!cando(S_IXUSR,TRUE,&PL_statbuf))
2398 Perl_croak(aTHX_ "Permission denied\n"); /* they can't do this */
2401 else if (PL_preprocess)
2402 Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
2403 else if (fdscript >= 0)
2404 Perl_croak(aTHX_ "fd script not allowed in suidperl\n");
2406 Perl_croak(aTHX_ "Script is not setuid/setgid in suidperl\n");
2408 /* We absolutely must clear out any saved ids here, so we */
2409 /* exec the real perl, substituting fd script for scriptname. */
2410 /* (We pass script name as "subdir" of fd, which perl will grok.) */
2411 PerlIO_rewind(PL_rsfp);
2412 PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0); /* just in case rewind didn't */
2413 for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
2414 if (!PL_origargv[which])
2415 Perl_croak(aTHX_ "Permission denied");
2416 PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
2417 PerlIO_fileno(PL_rsfp), PL_origargv[which]));
2418 #if defined(HAS_FCNTL) && defined(F_SETFD)
2419 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */
2421 PerlProc_execv(Perl_form(aTHX_ "%s/perl%s", BIN_EXP, PL_patchlevel), PL_origargv);/* try again */
2422 Perl_croak(aTHX_ "Can't do setuid\n");
2423 #endif /* IAMSUID */
2425 if (PL_euid != PL_uid || PL_egid != PL_gid) { /* (suidperl doesn't exist, in fact) */
2426 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2428 PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf); /* may be either wrapped or real suid */
2429 if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
2431 (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
2434 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2435 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2436 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2437 /* not set-id, must be wrapped */
2443 S_find_beginning(pTHX)
2445 register char *s, *s2;
2447 /* skip forward in input to the real script? */
2450 while (PL_doextract) {
2451 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
2452 Perl_croak(aTHX_ "No Perl script found in input\n");
2453 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2454 PerlIO_ungetc(PL_rsfp, '\n'); /* to keep line count right */
2455 PL_doextract = FALSE;
2456 while (*s && !(isSPACE (*s) || *s == '#')) s++;
2458 while (*s == ' ' || *s == '\t') s++;
2460 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2461 if (strnEQ(s2-4,"perl",4))
2463 while (s = moreswitches(s)) ;
2465 if (PL_cddir && PerlDir_chdir(PL_cddir) < 0)
2466 Perl_croak(aTHX_ "Can't chdir to %s",PL_cddir);
2475 PL_uid = PerlProc_getuid();
2476 PL_euid = PerlProc_geteuid();
2477 PL_gid = PerlProc_getgid();
2478 PL_egid = PerlProc_getegid();
2480 PL_uid |= PL_gid << 16;
2481 PL_euid |= PL_egid << 16;
2483 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2487 S_forbid_setid(pTHX_ char *s)
2489 if (PL_euid != PL_uid)
2490 Perl_croak(aTHX_ "No %s allowed while running setuid", s);
2491 if (PL_egid != PL_gid)
2492 Perl_croak(aTHX_ "No %s allowed while running setgid", s);
2496 Perl_init_debugger(pTHX)
2499 HV *ostash = PL_curstash;
2501 PL_curstash = PL_debstash;
2502 PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2503 AvREAL_off(PL_dbargs);
2504 PL_DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2505 PL_DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2506 PL_DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2507 sv_upgrade(GvSV(PL_DBsub), SVt_IV); /* IVX accessed if PERLDB_SUB_NN */
2508 PL_DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2509 sv_setiv(PL_DBsingle, 0);
2510 PL_DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2511 sv_setiv(PL_DBtrace, 0);
2512 PL_DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2513 sv_setiv(PL_DBsignal, 0);
2514 PL_curstash = ostash;
2517 #ifndef STRESS_REALLOC
2518 #define REASONABLE(size) (size)
2520 #define REASONABLE(size) (1) /* unreasonable */
2524 Perl_init_stacks(pTHX)
2526 /* start with 128-item stack and 8K cxstack */
2527 PL_curstackinfo = new_stackinfo(REASONABLE(128),
2528 REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
2529 PL_curstackinfo->si_type = PERLSI_MAIN;
2530 PL_curstack = PL_curstackinfo->si_stack;
2531 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
2533 PL_stack_base = AvARRAY(PL_curstack);
2534 PL_stack_sp = PL_stack_base;
2535 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
2537 New(50,PL_tmps_stack,REASONABLE(128),SV*);
2540 PL_tmps_max = REASONABLE(128);
2542 New(54,PL_markstack,REASONABLE(32),I32);
2543 PL_markstack_ptr = PL_markstack;
2544 PL_markstack_max = PL_markstack + REASONABLE(32);
2548 New(54,PL_scopestack,REASONABLE(32),I32);
2549 PL_scopestack_ix = 0;
2550 PL_scopestack_max = REASONABLE(32);
2552 New(54,PL_savestack,REASONABLE(128),ANY);
2553 PL_savestack_ix = 0;
2554 PL_savestack_max = REASONABLE(128);
2556 New(54,PL_retstack,REASONABLE(16),OP*);
2558 PL_retstack_max = REASONABLE(16);
2567 while (PL_curstackinfo->si_next)
2568 PL_curstackinfo = PL_curstackinfo->si_next;
2569 while (PL_curstackinfo) {
2570 PERL_SI *p = PL_curstackinfo->si_prev;
2571 /* curstackinfo->si_stack got nuked by sv_free_arenas() */
2572 Safefree(PL_curstackinfo->si_cxstack);
2573 Safefree(PL_curstackinfo);
2574 PL_curstackinfo = p;
2576 Safefree(PL_tmps_stack);
2577 Safefree(PL_markstack);
2578 Safefree(PL_scopestack);
2579 Safefree(PL_savestack);
2580 Safefree(PL_retstack);
2582 Safefree(PL_debname);
2583 Safefree(PL_debdelim);
2588 static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
2599 lex_start(PL_linestr);
2601 PL_subname = newSVpvn("main",4);
2605 S_init_predump_symbols(pTHX)
2612 sv_setpvn(get_sv("\"", TRUE), " ", 1);
2613 PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2614 GvMULTI_on(PL_stdingv);
2615 io = GvIOp(PL_stdingv);
2616 IoIFP(io) = PerlIO_stdin();
2617 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2619 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
2621 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2624 IoOFP(io) = IoIFP(io) = PerlIO_stdout();
2626 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2628 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
2630 othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2631 GvMULTI_on(othergv);
2632 io = GvIOp(othergv);
2633 IoOFP(io) = IoIFP(io) = PerlIO_stderr();
2634 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2636 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
2638 PL_statname = NEWSV(66,0); /* last filename we did stat on */
2641 PL_osname = savepv(OSNAME);
2645 S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
2652 argc--,argv++; /* skip name of script */
2653 if (PL_doswitches) {
2654 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2657 if (argv[0][1] == '-') {
2661 if (s = strchr(argv[0], '=')) {
2663 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2666 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2669 PL_toptarget = NEWSV(0,0);
2670 sv_upgrade(PL_toptarget, SVt_PVFM);
2671 sv_setpvn(PL_toptarget, "", 0);
2672 PL_bodytarget = NEWSV(0,0);
2673 sv_upgrade(PL_bodytarget, SVt_PVFM);
2674 sv_setpvn(PL_bodytarget, "", 0);
2675 PL_formtarget = PL_bodytarget;
2678 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2679 sv_setpv(GvSV(tmpgv),PL_origfilename);
2680 magicname("0", "0", 1);
2682 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2683 sv_setpv(GvSV(tmpgv),PL_origargv[0]);
2684 if (PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2685 GvMULTI_on(PL_argvgv);
2686 (void)gv_AVadd(PL_argvgv);
2687 av_clear(GvAVn(PL_argvgv));
2688 for (; argc > 0; argc--,argv++) {
2689 av_push(GvAVn(PL_argvgv),newSVpv(argv[0],0));
2692 if (PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2694 GvMULTI_on(PL_envgv);
2695 hv = GvHVn(PL_envgv);
2696 hv_magic(hv, PL_envgv, 'E');
2697 #if !defined( VMS) && !defined(EPOC) /* VMS doesn't have environ array */
2698 /* Note that if the supplied env parameter is actually a copy
2699 of the global environ then it may now point to free'd memory
2700 if the environment has been modified since. To avoid this
2701 problem we treat env==NULL as meaning 'use the default'
2706 environ[0] = Nullch;
2707 for (; *env; env++) {
2708 if (!(s = strchr(*env,'=')))
2714 sv = newSVpv(s--,0);
2715 (void)hv_store(hv, *env, s - *env, sv, 0);
2717 #if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
2718 /* Sins of the RTL. See note in my_setenv(). */
2719 (void)PerlEnv_putenv(savepv(*env));
2723 #ifdef DYNAMIC_ENV_FETCH
2724 HvNAME(hv) = savepv(ENV_HV_NAME);
2728 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2729 sv_setiv(GvSV(tmpgv), (IV)getpid());
2733 S_init_perllib(pTHX)
2738 s = PerlEnv_getenv("PERL5LIB");
2742 incpush(PerlEnv_getenv("PERLLIB"), FALSE);
2744 /* Treat PERL5?LIB as a possible search list logical name -- the
2745 * "natural" VMS idiom for a Unix path string. We allow each
2746 * element to be a set of |-separated directories for compatibility.
2750 if (my_trnlnm("PERL5LIB",buf,0))
2751 do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2753 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2757 /* Use the ~-expanded versions of APPLLIB (undocumented),
2758 ARCHLIB PRIVLIB SITEARCH and SITELIB
2761 incpush(APPLLIB_EXP, TRUE);
2765 incpush(ARCHLIB_EXP, FALSE);
2768 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2771 incpush(PRIVLIB_EXP, TRUE);
2773 incpush(PRIVLIB_EXP, FALSE);
2777 incpush(SITEARCH_EXP, FALSE);
2781 incpush(SITELIB_EXP, TRUE);
2783 incpush(SITELIB_EXP, FALSE);
2786 #if defined(PERL_VENDORLIB_EXP)
2788 incpush(PERL_VENDORLIB_EXP, TRUE);
2790 incpush(PERL_VENDORLIB_EXP, FALSE);
2794 incpush(".", FALSE);
2798 # define PERLLIB_SEP ';'
2801 # define PERLLIB_SEP '|'
2803 # define PERLLIB_SEP ':'
2806 #ifndef PERLLIB_MANGLE
2807 # define PERLLIB_MANGLE(s,n) (s)
2811 S_incpush(pTHX_ char *p, int addsubdirs)
2813 SV *subdir = Nullsv;
2819 subdir = sv_newmortal();
2820 if (!PL_archpat_auto) {
2821 STRLEN len = (sizeof(ARCHNAME) + strlen(PL_patchlevel)
2822 + sizeof("//auto"));
2823 New(55, PL_archpat_auto, len, char);
2824 sprintf(PL_archpat_auto, "/%s/%s/auto", ARCHNAME, PL_patchlevel);
2826 for (len = sizeof(ARCHNAME) + 2;
2827 PL_archpat_auto[len] != '\0' && PL_archpat_auto[len] != '/'; len++)
2828 if (PL_archpat_auto[len] == '.') PL_archpat_auto[len] = '_';
2833 /* Break at all separators */
2835 SV *libdir = NEWSV(55,0);
2838 /* skip any consecutive separators */
2839 while ( *p == PERLLIB_SEP ) {
2840 /* Uncomment the next line for PATH semantics */
2841 /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */
2845 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2846 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2851 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2852 p = Nullch; /* break out */
2856 * BEFORE pushing libdir onto @INC we may first push version- and
2857 * archname-specific sub-directories.
2860 struct stat tmpstatbuf;
2865 if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) {
2867 while (unix[len-1] == '/') len--; /* Cosmetic */
2868 sv_usepvn(libdir,unix,len);
2871 PerlIO_printf(PerlIO_stderr(),
2872 "Failed to unixify @INC element \"%s\"\n",
2875 /* .../archname/version if -d .../archname/version/auto */
2876 sv_setsv(subdir, libdir);
2877 sv_catpv(subdir, PL_archpat_auto);
2878 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2879 S_ISDIR(tmpstatbuf.st_mode))
2880 av_push(GvAVn(PL_incgv),
2881 newSVpvn(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2883 /* .../archname if -d .../archname/auto */
2884 sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
2885 strlen(PL_patchlevel) + 1, "", 0);
2886 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2887 S_ISDIR(tmpstatbuf.st_mode))
2888 av_push(GvAVn(PL_incgv),
2889 newSVpvn(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2892 /* finally push this lib directory on the end of @INC */
2893 av_push(GvAVn(PL_incgv), libdir);
2898 STATIC struct perl_thread *
2899 S_init_main_thread(pTHX)
2901 #if !defined(PERL_IMPLICIT_CONTEXT)
2902 struct perl_thread *thr;
2906 Newz(53, thr, 1, struct perl_thread);
2907 PL_curcop = &PL_compiling;
2908 thr->interp = PERL_GET_INTERP;
2909 thr->cvcache = newHV();
2910 thr->threadsv = newAV();
2911 /* thr->threadsvp is set when find_threadsv is called */
2912 thr->specific = newAV();
2913 thr->errhv = newHV();
2914 thr->flags = THRf_R_JOINABLE;
2915 MUTEX_INIT(&thr->mutex);
2916 /* Handcraft thrsv similarly to mess_sv */
2917 New(53, PL_thrsv, 1, SV);
2918 Newz(53, xpv, 1, XPV);
2919 SvFLAGS(PL_thrsv) = SVt_PV;
2920 SvANY(PL_thrsv) = (void*)xpv;
2921 SvREFCNT(PL_thrsv) = 1 << 30; /* practically infinite */
2922 SvPVX(PL_thrsv) = (char*)thr;
2923 SvCUR_set(PL_thrsv, sizeof(thr));
2924 SvLEN_set(PL_thrsv, sizeof(thr));
2925 *SvEND(PL_thrsv) = '\0'; /* in the trailing_nul field */
2926 thr->oursv = PL_thrsv;
2927 PL_chopset = " \n-";
2930 MUTEX_LOCK(&PL_threads_mutex);
2935 MUTEX_UNLOCK(&PL_threads_mutex);
2937 #ifdef HAVE_THREAD_INTERN
2938 Perl_init_thread_intern(thr);
2941 #ifdef SET_THREAD_SELF
2942 SET_THREAD_SELF(thr);
2944 thr->self = pthread_self();
2945 #endif /* SET_THREAD_SELF */
2949 * These must come after the SET_THR because sv_setpvn does
2950 * SvTAINT and the taint fields require dTHR.
2952 PL_toptarget = NEWSV(0,0);
2953 sv_upgrade(PL_toptarget, SVt_PVFM);
2954 sv_setpvn(PL_toptarget, "", 0);
2955 PL_bodytarget = NEWSV(0,0);
2956 sv_upgrade(PL_bodytarget, SVt_PVFM);
2957 sv_setpvn(PL_bodytarget, "", 0);
2958 PL_formtarget = PL_bodytarget;
2959 thr->errsv = newSVpvn("", 0);
2960 (void) find_threadsv("@"); /* Ensure $@ is initialised early */
2963 PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
2964 PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
2965 PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
2966 PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
2967 PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
2969 PL_reginterp_cnt = 0;
2973 #endif /* USE_THREADS */
2976 Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
2980 line_t oldline = PL_curcop->cop_line;
2985 while (AvFILL(paramList) >= 0) {
2986 cv = (CV*)av_shift(paramList);
2988 CALLPROTECT(aTHX_ &ret, MEMBER_TO_FPTR(S_call_list_body), cv);
2991 (void)SvPV(atsv, len);
2993 PL_curcop = &PL_compiling;
2994 PL_curcop->cop_line = oldline;
2995 if (paramList == PL_beginav)
2996 sv_catpv(atsv, "BEGIN failed--compilation aborted");
2998 sv_catpv(atsv, "END failed--cleanup aborted");
2999 while (PL_scopestack_ix > oldscope)
3001 Perl_croak(aTHX_ "%s", SvPVX(atsv));
3008 /* my_exit() was called */
3009 while (PL_scopestack_ix > oldscope)
3012 PL_curstash = PL_defstash;
3014 call_list(oldscope, PL_endav);
3015 PL_curcop = &PL_compiling;
3016 PL_curcop->cop_line = oldline;
3017 if (PL_statusvalue) {
3018 if (paramList == PL_beginav)
3019 Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
3021 Perl_croak(aTHX_ "END failed--cleanup aborted");
3027 PL_curcop = &PL_compiling;
3028 PL_curcop->cop_line = oldline;
3031 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
3039 S_call_list_body(pTHX_ va_list args)
3042 CV *cv = va_arg(args, CV*);
3044 PUSHMARK(PL_stack_sp);
3045 call_sv((SV*)cv, G_EVAL|G_DISCARD);
3050 Perl_my_exit(pTHX_ U32 status)
3054 DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
3055 thr, (unsigned long) status));
3064 STATUS_NATIVE_SET(status);
3071 Perl_my_failure_exit(pTHX)
3074 if (vaxc$errno & 1) {
3075 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
3076 STATUS_NATIVE_SET(44);
3079 if (!vaxc$errno && errno) /* unlikely */
3080 STATUS_NATIVE_SET(44);
3082 STATUS_NATIVE_SET(vaxc$errno);
3087 STATUS_POSIX_SET(errno);
3089 exitstatus = STATUS_POSIX >> 8;
3090 if (exitstatus & 255)
3091 STATUS_POSIX_SET(exitstatus);
3093 STATUS_POSIX_SET(255);
3100 S_my_exit_jump(pTHX)
3103 register PERL_CONTEXT *cx;
3108 SvREFCNT_dec(PL_e_script);
3109 PL_e_script = Nullsv;
3112 POPSTACK_TO(PL_mainstack);
3113 if (cxstack_ix >= 0) {
3116 POPBLOCK(cx,PL_curpm);
3129 read_e_script(pTHXo_ int idx, SV *buf_sv, int maxlen)
3132 p = SvPVX(PL_e_script);
3133 nl = strchr(p, '\n');
3134 nl = (nl) ? nl+1 : SvEND(PL_e_script);
3136 filter_del(read_e_script);
3139 sv_catpvn(buf_sv, p, nl-p);
3140 sv_chop(PL_e_script, nl);