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();
932 (*xsinit)(aTHXo); /* in case linked C routines want magical variables */
933 #if defined(VMS) || defined(WIN32) || defined(DJGPP)
941 init_predump_symbols();
942 /* init_postdump_symbols not currently designed to be called */
943 /* more than once (ENV isn't cleared first, for example) */
944 /* But running with -u leaves %ENV & @ARGV undefined! XXX */
946 init_postdump_symbols(argc,argv,env);
950 /* now parse the script */
952 SETERRNO(0,SS$_NORMAL);
954 if (yyparse() || PL_error_count) {
956 Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
958 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
962 PL_curcop->cop_line = 0;
963 PL_curstash = PL_defstash;
964 PL_preprocess = FALSE;
966 SvREFCNT_dec(PL_e_script);
967 PL_e_script = Nullsv;
970 /* now that script is parsed, we can modify record separator */
972 PL_rs = SvREFCNT_inc(PL_nrs);
973 sv_setsv(get_sv("/", TRUE), PL_rs);
978 gv_check(PL_defstash);
984 if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
985 dump_mstats("after compilation:");
1003 oldscope = PL_scopestack_ix;
1006 CALLPROTECT(aTHX_ &ret, MEMBER_TO_FPTR(S_run_body), oldscope);
1009 cxstack_ix = -1; /* start context stack again */
1011 case 0: /* normal completion */
1012 case 2: /* my_exit() */
1013 while (PL_scopestack_ix > oldscope)
1016 PL_curstash = PL_defstash;
1018 call_list(oldscope, PL_endav);
1020 if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
1021 dump_mstats("after execution: ");
1023 return STATUS_NATIVE_EXPORT;
1026 POPSTACK_TO(PL_mainstack);
1029 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
1039 S_run_body(pTHX_ va_list args)
1042 I32 oldscope = va_arg(args, I32);
1044 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
1045 PL_sawampersand ? "Enabling" : "Omitting"));
1047 if (!PL_restartop) {
1048 DEBUG_x(dump_all());
1049 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
1050 DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%lx\n",
1051 (unsigned long) thr));
1054 PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", PL_origfilename);
1057 if (PERLDB_SINGLE && PL_DBsingle)
1058 sv_setiv(PL_DBsingle, 1);
1060 call_list(oldscope, PL_initav);
1066 PL_op = PL_restartop;
1070 else if (PL_main_start) {
1071 CvDEPTH(PL_main_cv) = 1;
1072 PL_op = PL_main_start;
1082 Perl_get_sv(pTHX_ const char *name, I32 create)
1086 if (name[1] == '\0' && !isALPHA(name[0])) {
1087 PADOFFSET tmp = find_threadsv(name);
1088 if (tmp != NOT_IN_PAD) {
1090 return THREADSV(tmp);
1093 #endif /* USE_THREADS */
1094 gv = gv_fetchpv(name, create, SVt_PV);
1101 Perl_get_av(pTHX_ const char *name, I32 create)
1103 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1112 Perl_get_hv(pTHX_ const char *name, I32 create)
1114 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1123 Perl_get_cv(pTHX_ const char *name, I32 create)
1125 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
1126 /* XXX unsafe for threads if eval_owner isn't held */
1127 /* XXX this is probably not what they think they're getting.
1128 * It has the same effect as "sub name;", i.e. just a forward
1130 if (create && !GvCVu(gv))
1131 return newSUB(start_subparse(FALSE, 0),
1132 newSVOP(OP_CONST, 0, newSVpv(name,0)),
1140 /* Be sure to refetch the stack pointer after calling these routines. */
1143 Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv)
1145 /* See G_* flags in cop.h */
1146 /* null terminated arg list */
1153 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
1158 return call_pv(sub_name, flags);
1162 Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
1163 /* name of the subroutine */
1164 /* See G_* flags in cop.h */
1166 return call_sv((SV*)get_cv(sub_name, TRUE), flags);
1170 Perl_call_method(pTHX_ const char *methname, I32 flags)
1171 /* name of the subroutine */
1172 /* See G_* flags in cop.h */
1178 XPUSHs(sv_2mortal(newSVpv(methname,0)));
1183 return call_sv(*PL_stack_sp--, flags);
1186 /* May be called with any of a CV, a GV, or an SV containing the name. */
1188 Perl_call_sv(pTHX_ SV *sv, I32 flags)
1190 /* See G_* flags in cop.h */
1193 LOGOP myop; /* fake syntax tree node */
1197 bool oldcatch = CATCH_GET;
1201 if (flags & G_DISCARD) {
1206 Zero(&myop, 1, LOGOP);
1207 myop.op_next = Nullop;
1208 if (!(flags & G_NOARGS))
1209 myop.op_flags |= OPf_STACKED;
1210 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1211 (flags & G_ARRAY) ? OPf_WANT_LIST :
1216 EXTEND(PL_stack_sp, 1);
1217 *++PL_stack_sp = sv;
1219 oldscope = PL_scopestack_ix;
1221 if (PERLDB_SUB && PL_curstash != PL_debstash
1222 /* Handle first BEGIN of -d. */
1223 && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
1224 /* Try harder, since this may have been a sighandler, thus
1225 * curstash may be meaningless. */
1226 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != PL_debstash)
1227 && !(flags & G_NODEBUG))
1228 PL_op->op_private |= OPpENTERSUB_DB;
1230 if (!(flags & G_EVAL)) {
1231 /* G_NOCATCH is a hack for perl_vdie using this path to call
1232 a __DIE__ handler */
1233 if (!(flags & G_NOCATCH)) {
1236 call_xbody((OP*)&myop, FALSE);
1237 retval = PL_stack_sp - (PL_stack_base + oldmark);
1238 if (!(flags & G_NOCATCH)) {
1243 cLOGOP->op_other = PL_op;
1245 /* we're trying to emulate pp_entertry() here */
1247 register PERL_CONTEXT *cx;
1248 I32 gimme = GIMME_V;
1253 push_return(PL_op->op_next);
1254 PUSHBLOCK(cx, CXt_EVAL, PL_stack_sp);
1256 PL_eval_root = PL_op; /* Only needed so that goto works right. */
1258 PL_in_eval = EVAL_INEVAL;
1259 if (flags & G_KEEPERR)
1260 PL_in_eval |= EVAL_KEEPERR;
1267 CALLPROTECT(aTHX_ &ret, MEMBER_TO_FPTR(S_call_body), (OP*)&myop, FALSE);
1270 retval = PL_stack_sp - (PL_stack_base + oldmark);
1271 if (!(flags & G_KEEPERR))
1278 /* my_exit() was called */
1279 PL_curstash = PL_defstash;
1282 Perl_croak(aTHX_ "Callback called exit");
1287 PL_op = PL_restartop;
1291 PL_stack_sp = PL_stack_base + oldmark;
1292 if (flags & G_ARRAY)
1296 *++PL_stack_sp = &PL_sv_undef;
1301 if (PL_scopestack_ix > oldscope) {
1305 register PERL_CONTEXT *cx;
1316 if (flags & G_DISCARD) {
1317 PL_stack_sp = PL_stack_base + oldmark;
1327 S_call_body(pTHX_ va_list args)
1329 OP *myop = va_arg(args, OP*);
1330 int is_eval = va_arg(args, int);
1332 call_xbody(myop, is_eval);
1337 S_call_xbody(pTHX_ OP *myop, int is_eval)
1341 if (PL_op == myop) {
1343 PL_op = Perl_pp_entereval(aTHX);
1345 PL_op = Perl_pp_entersub(aTHX);
1351 /* Eval a string. The G_EVAL flag is always assumed. */
1354 Perl_eval_sv(pTHX_ SV *sv, I32 flags)
1356 /* See G_* flags in cop.h */
1359 UNOP myop; /* fake syntax tree node */
1360 I32 oldmark = SP - PL_stack_base;
1366 if (flags & G_DISCARD) {
1373 Zero(PL_op, 1, UNOP);
1374 EXTEND(PL_stack_sp, 1);
1375 *++PL_stack_sp = sv;
1376 oldscope = PL_scopestack_ix;
1378 if (!(flags & G_NOARGS))
1379 myop.op_flags = OPf_STACKED;
1380 myop.op_next = Nullop;
1381 myop.op_type = OP_ENTEREVAL;
1382 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1383 (flags & G_ARRAY) ? OPf_WANT_LIST :
1385 if (flags & G_KEEPERR)
1386 myop.op_flags |= OPf_SPECIAL;
1389 CALLPROTECT(aTHX_ &ret, MEMBER_TO_FPTR(S_call_body), (OP*)&myop, TRUE);
1392 retval = PL_stack_sp - (PL_stack_base + oldmark);
1393 if (!(flags & G_KEEPERR))
1400 /* my_exit() was called */
1401 PL_curstash = PL_defstash;
1404 Perl_croak(aTHX_ "Callback called exit");
1409 PL_op = PL_restartop;
1413 PL_stack_sp = PL_stack_base + oldmark;
1414 if (flags & G_ARRAY)
1418 *++PL_stack_sp = &PL_sv_undef;
1423 if (flags & G_DISCARD) {
1424 PL_stack_sp = PL_stack_base + oldmark;
1434 Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
1437 SV* sv = newSVpv(p, 0);
1440 eval_sv(sv, G_SCALAR);
1447 if (croak_on_error && SvTRUE(ERRSV)) {
1449 Perl_croak(aTHX_ SvPVx(ERRSV, n_a));
1455 /* Require a module. */
1458 Perl_require_pv(pTHX_ const char *pv)
1462 PUSHSTACKi(PERLSI_REQUIRE);
1464 sv = sv_newmortal();
1465 sv_setpv(sv, "require '");
1468 eval_sv(sv, G_DISCARD);
1474 Perl_magicname(pTHX_ char *sym, char *name, I32 namlen)
1478 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1479 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1483 S_usage(pTHX_ char *name) /* XXX move this out into a module ? */
1485 /* This message really ought to be max 23 lines.
1486 * Removed -h because the user already knows that opton. Others? */
1488 static char *usage_msg[] = {
1489 "-0[octal] specify record separator (\\0, if no argument)",
1490 "-a autosplit mode with -n or -p (splits $_ into @F)",
1491 "-c check syntax only (runs BEGIN and END blocks)",
1492 "-d[:debugger] run program under debugger",
1493 "-D[number/list] set debugging flags (argument is a bit mask or alphabets)",
1494 "-e 'command' one line of program (several -e's allowed, omit programfile)",
1495 "-F/pattern/ split() pattern for -a switch (//'s are optional)",
1496 "-i[extension] edit <> files in place (makes backup if extension supplied)",
1497 "-Idirectory specify @INC/#include directory (several -I's allowed)",
1498 "-l[octal] enable line ending processing, specifies line terminator",
1499 "-[mM][-]module execute `use/no module...' before executing program",
1500 "-n assume 'while (<>) { ... }' loop around program",
1501 "-p assume loop like -n but print line also, like sed",
1502 "-P run program through C preprocessor before compilation",
1503 "-s enable rudimentary parsing for switches after programfile",
1504 "-S look for programfile using PATH environment variable",
1505 "-T enable tainting checks",
1506 "-u dump core after parsing program",
1507 "-U allow unsafe operations",
1508 "-v print version, subversion (includes VERY IMPORTANT perl info)",
1509 "-V[:variable] print configuration summary (or a single Config.pm variable)",
1510 "-w enable many useful warnings (RECOMMENDED)",
1511 "-x[directory] strip off text before #!perl line and perhaps cd to directory",
1515 char **p = usage_msg;
1517 printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1519 printf("\n %s", *p++);
1522 /* This routine handles any switches that can be given during run */
1525 Perl_moreswitches(pTHX_ char *s)
1534 rschar = scan_oct(s, 4, &numlen);
1535 SvREFCNT_dec(PL_nrs);
1536 if (rschar & ~((U8)~0))
1537 PL_nrs = &PL_sv_undef;
1538 else if (!rschar && numlen >= 2)
1539 PL_nrs = newSVpvn("", 0);
1542 PL_nrs = newSVpvn(&ch, 1);
1548 PL_splitstr = savepv(s + 1);
1562 if (*s == ':' || *s == '=') {
1563 my_setenv("PERL5DB", Perl_form(aTHX_ "use Devel::%s;", ++s));
1567 PL_perldb = PERLDB_ALL;
1575 if (isALPHA(s[1])) {
1576 static char debopts[] = "psltocPmfrxuLHXDS";
1579 for (s++; *s && (d = strchr(debopts,*s)); s++)
1580 PL_debug |= 1 << (d - debopts);
1583 PL_debug = atoi(s+1);
1584 for (s++; isDIGIT(*s); s++) ;
1586 PL_debug |= 0x80000000;
1589 if (ckWARN_d(WARN_DEBUGGING))
1590 Perl_warner(aTHX_ WARN_DEBUGGING,
1591 "Recompile perl with -DDEBUGGING to use -D switch\n");
1592 for (s++; isALNUM(*s); s++) ;
1598 usage(PL_origargv[0]);
1602 Safefree(PL_inplace);
1603 PL_inplace = savepv(s+1);
1605 for (s = PL_inplace; *s && !isSPACE(*s); s++) ;
1608 if (*s == '-') /* Additional switches on #! line. */
1612 case 'I': /* -I handled both here and in parse_perl() */
1615 while (*s && isSPACE(*s))
1619 for (e = s; *e && !isSPACE(*e); e++) ;
1620 p = savepvn(s, e-s);
1626 Perl_croak(aTHX_ "No space allowed after -I");
1634 PL_ors = savepv("\n");
1636 *PL_ors = scan_oct(s, 3 + (*s == '0'), &numlen);
1641 if (RsPARA(PL_nrs)) {
1646 PL_ors = SvPV(PL_nrs, PL_orslen);
1647 PL_ors = savepvn(PL_ors, PL_orslen);
1651 forbid_setid("-M"); /* XXX ? */
1654 forbid_setid("-m"); /* XXX ? */
1659 /* -M-foo == 'no foo' */
1660 if (*s == '-') { use = "no "; ++s; }
1661 sv = newSVpv(use,0);
1663 /* We allow -M'Module qw(Foo Bar)' */
1664 while(isALNUM(*s) || *s==':') ++s;
1666 sv_catpv(sv, start);
1667 if (*(start-1) == 'm') {
1669 Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
1670 sv_catpv( sv, " ()");
1673 sv_catpvn(sv, start, s-start);
1674 sv_catpv(sv, " split(/,/,q{");
1679 if (PL_preambleav == NULL)
1680 PL_preambleav = newAV();
1681 av_push(PL_preambleav, sv);
1684 Perl_croak(aTHX_ "No space allowed after -%c", *(s-1));
1696 PL_doswitches = TRUE;
1701 Perl_croak(aTHX_ "Too late for \"-T\" option");
1705 PL_do_undump = TRUE;
1713 #if defined(PERL_SUBVERSION) && PERL_SUBVERSION > 0
1714 printf("\nThis is perl, version %d.%03d_%02d built for %s",
1715 PERL_REVISION, PERL_VERSION, PERL_SUBVERSION, ARCHNAME);
1717 printf("\nThis is perl, version %s built for %s",
1718 PL_patchlevel, ARCHNAME);
1720 #if defined(LOCAL_PATCH_COUNT)
1721 if (LOCAL_PATCH_COUNT > 0)
1722 printf("\n(with %d registered patch%s, see perl -V for more detail)",
1723 LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : "");
1726 printf("\n\nCopyright 1987-1999, Larry Wall\n");
1728 printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1731 printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
1732 printf("djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
1735 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1736 "Version 5 port Copyright (c) 1994-1999, Andreas Kaiser, Ilya Zakharevich\n");
1739 printf("atariST series port, ++jrb bammi@cadence.com\n");
1742 printf("BeOS port Copyright Tom Spindler, 1997-1999\n");
1745 printf("MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-1999\n");
1748 printf("MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
1751 printf("Stratus VOS port by Paul_Green@stratus.com, 1997-1999\n");
1754 printf("VM/ESA port by Neale Ferguson, 1998-1999\n");
1757 printf("BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
1760 printf("MiNT port by Guido Flohr, 1997-1999\n");
1762 #ifdef BINARY_BUILD_NOTICE
1763 BINARY_BUILD_NOTICE;
1766 Perl may be copied only under the terms of either the Artistic License or the\n\
1767 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n\
1768 Complete documentation for Perl, including FAQ lists, should be found on\n\
1769 this system using `man perl' or `perldoc perl'. If you have access to the\n\
1770 Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
1773 if (! (PL_dowarn & G_WARN_ALL_MASK))
1774 PL_dowarn |= G_WARN_ON;
1778 PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
1779 PL_compiling.cop_warnings = WARN_ALL ;
1783 PL_dowarn = G_WARN_ALL_OFF;
1784 PL_compiling.cop_warnings = WARN_NONE ;
1789 if (s[1] == '-') /* Additional switches on #! line. */
1794 #if defined(WIN32) || !defined(PERL_STRICT_CR)
1800 #ifdef ALTERNATE_SHEBANG
1801 case 'S': /* OS/2 needs -S on "extproc" line. */
1809 Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
1814 /* compliments of Tom Christiansen */
1816 /* unexec() can be found in the Gnu emacs distribution */
1817 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
1820 Perl_my_unexec(pTHX)
1828 prog = newSVpv(BIN_EXP, 0);
1829 sv_catpv(prog, "/perl");
1830 file = newSVpv(PL_origfilename, 0);
1831 sv_catpv(file, ".perldump");
1833 unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
1834 /* unexec prints msg to stderr in case of failure */
1835 PerlProc_exit(status);
1838 # include <lib$routines.h>
1839 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
1841 ABORT(); /* for use with undump */
1846 /* initialize curinterp */
1851 #ifdef PERL_OBJECT /* XXX kludge */
1854 PL_chopset = " \n-"; \
1855 PL_copline = NOLINE; \
1856 PL_curcop = &PL_compiling;\
1857 PL_curcopdb = NULL; \
1860 PL_dumpindent = 4; \
1861 PL_laststatval = -1; \
1862 PL_laststype = OP_STAT; \
1863 PL_maxscream = -1; \
1864 PL_maxsysfd = MAXSYSFD; \
1865 PL_statname = Nullsv; \
1866 PL_tmps_floor = -1; \
1868 PL_op_mask = NULL; \
1870 PL_laststatval = -1; \
1871 PL_laststype = OP_STAT; \
1872 PL_mess_sv = Nullsv; \
1873 PL_splitstr = " "; \
1874 PL_generation = 100; \
1875 PL_exitlist = NULL; \
1876 PL_exitlistlen = 0; \
1878 PL_in_clean_objs = FALSE; \
1879 PL_in_clean_all = FALSE; \
1880 PL_profiledata = NULL; \
1882 PL_rsfp_filters = Nullav; \
1887 # ifdef MULTIPLICITY
1888 # define PERLVAR(var,type)
1889 # define PERLVARA(var,n,type)
1890 # if defined(PERL_IMPLICIT_CONTEXT)
1891 # if defined(USE_THREADS)
1892 # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
1893 # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
1894 # else /* !USE_THREADS */
1895 # define PERLVARI(var,type,init) aTHX->var = init;
1896 # define PERLVARIC(var,type,init) aTHX->var = init;
1897 # endif /* USE_THREADS */
1899 # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
1900 # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
1902 # include "intrpvar.h"
1903 # ifndef USE_THREADS
1904 # include "thrdvar.h"
1911 # define PERLVAR(var,type)
1912 # define PERLVARA(var,n,type)
1913 # define PERLVARI(var,type,init) PL_##var = init;
1914 # define PERLVARIC(var,type,init) PL_##var = init;
1915 # include "intrpvar.h"
1916 # ifndef USE_THREADS
1917 # include "thrdvar.h"
1929 S_init_main_stash(pTHX)
1934 /* Note that strtab is a rather special HV. Assumptions are made
1935 about not iterating on it, and not adding tie magic to it.
1936 It is properly deallocated in perl_destruct() */
1937 PL_strtab = newHV();
1939 MUTEX_INIT(&PL_strtab_mutex);
1941 HvSHAREKEYS_off(PL_strtab); /* mandatory */
1942 hv_ksplit(PL_strtab, 512);
1944 PL_curstash = PL_defstash = newHV();
1945 PL_curstname = newSVpvn("main",4);
1946 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1947 SvREFCNT_dec(GvHV(gv));
1948 GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
1950 HvNAME(PL_defstash) = savepv("main");
1951 PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1952 GvMULTI_on(PL_incgv);
1953 PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
1954 GvMULTI_on(PL_hintgv);
1955 PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1956 PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1957 GvMULTI_on(PL_errgv);
1958 PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
1959 GvMULTI_on(PL_replgv);
1960 (void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */
1961 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
1962 sv_setpvn(ERRSV, "", 0);
1963 PL_curstash = PL_defstash;
1964 PL_compiling.cop_stash = PL_defstash;
1965 PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
1966 PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
1967 /* We must init $/ before switches are processed. */
1968 sv_setpvn(get_sv("/", TRUE), "\n", 1);
1972 S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
1980 PL_origfilename = savepv("-e");
1983 /* if find_script() returns, it returns a malloc()-ed value */
1984 PL_origfilename = scriptname = find_script(scriptname, dosearch, NULL, 1);
1986 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
1987 char *s = scriptname + 8;
1988 *fdscript = atoi(s);
1992 scriptname = savepv(s + 1);
1993 Safefree(PL_origfilename);
1994 PL_origfilename = scriptname;
1999 PL_curcop->cop_filegv = gv_fetchfile(PL_origfilename);
2000 if (strEQ(PL_origfilename,"-"))
2002 if (*fdscript >= 0) {
2003 PL_rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE);
2004 #if defined(HAS_FCNTL) && defined(F_SETFD)
2006 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); /* ensure close-on-exec */
2009 else if (PL_preprocess) {
2010 char *cpp_cfg = CPPSTDIN;
2011 SV *cpp = newSVpvn("",0);
2012 SV *cmd = NEWSV(0,0);
2014 if (strEQ(cpp_cfg, "cppstdin"))
2015 Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
2016 sv_catpv(cpp, cpp_cfg);
2019 sv_catpv(sv,PRIVLIB_EXP);
2022 Perl_sv_setpvf(aTHX_ cmd, "\
2023 sed %s -e \"/^[^#]/b\" \
2024 -e \"/^#[ ]*include[ ]/b\" \
2025 -e \"/^#[ ]*define[ ]/b\" \
2026 -e \"/^#[ ]*if[ ]/b\" \
2027 -e \"/^#[ ]*ifdef[ ]/b\" \
2028 -e \"/^#[ ]*ifndef[ ]/b\" \
2029 -e \"/^#[ ]*else/b\" \
2030 -e \"/^#[ ]*elif[ ]/b\" \
2031 -e \"/^#[ ]*undef[ ]/b\" \
2032 -e \"/^#[ ]*endif/b\" \
2035 (PL_doextract ? "-e \"1,/^#/d\n\"" : ""),
2038 Perl_sv_setpvf(aTHX_ cmd, "\
2039 %s %s -e '/^[^#]/b' \
2040 -e '/^#[ ]*include[ ]/b' \
2041 -e '/^#[ ]*define[ ]/b' \
2042 -e '/^#[ ]*if[ ]/b' \
2043 -e '/^#[ ]*ifdef[ ]/b' \
2044 -e '/^#[ ]*ifndef[ ]/b' \
2045 -e '/^#[ ]*else/b' \
2046 -e '/^#[ ]*elif[ ]/b' \
2047 -e '/^#[ ]*undef[ ]/b' \
2048 -e '/^#[ ]*endif/b' \
2052 Perl_sv_setpvf(aTHX_ cmd, "\
2053 %s %s -e '/^[^#]/b' \
2054 -e '/^#[ ]*include[ ]/b' \
2055 -e '/^#[ ]*define[ ]/b' \
2056 -e '/^#[ ]*if[ ]/b' \
2057 -e '/^#[ ]*ifdef[ ]/b' \
2058 -e '/^#[ ]*ifndef[ ]/b' \
2059 -e '/^#[ ]*else/b' \
2060 -e '/^#[ ]*elif[ ]/b' \
2061 -e '/^#[ ]*undef[ ]/b' \
2062 -e '/^#[ ]*endif/b' \
2071 (PL_doextract ? "-e '1,/^#/d\n'" : ""),
2073 scriptname, cpp, sv, CPPMINUS);
2074 PL_doextract = FALSE;
2075 #ifdef IAMSUID /* actually, this is caught earlier */
2076 if (PL_euid != PL_uid && !PL_euid) { /* if running suidperl */
2078 (void)seteuid(PL_uid); /* musn't stay setuid root */
2081 (void)setreuid((Uid_t)-1, PL_uid);
2083 #ifdef HAS_SETRESUID
2084 (void)setresuid((Uid_t)-1, PL_uid, (Uid_t)-1);
2086 PerlProc_setuid(PL_uid);
2090 if (PerlProc_geteuid() != PL_uid)
2091 Perl_croak(aTHX_ "Can't do seteuid!\n");
2093 #endif /* IAMSUID */
2094 PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
2098 else if (!*scriptname) {
2099 forbid_setid("program input from stdin");
2100 PL_rsfp = PerlIO_stdin();
2103 PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
2104 #if defined(HAS_FCNTL) && defined(F_SETFD)
2106 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); /* ensure close-on-exec */
2111 #ifndef IAMSUID /* in case script is not readable before setuid */
2113 PerlLIO_stat(SvPVX(GvSV(PL_curcop->cop_filegv)),&PL_statbuf) >= 0 &&
2114 PL_statbuf.st_mode & (S_ISUID|S_ISGID))
2117 PerlProc_execv(Perl_form(aTHX_ "%s/sperl%s", BIN_EXP, PL_patchlevel), PL_origargv);
2118 Perl_croak(aTHX_ "Can't do setuid\n");
2122 Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
2123 SvPVX(GvSV(PL_curcop->cop_filegv)), Strerror(errno));
2128 * I_SYSSTATVFS HAS_FSTATVFS
2130 * I_STATFS HAS_FSTATFS
2131 * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT
2132 * here so that metaconfig picks them up. */
2136 S_fd_on_nosuid_fs(pTHX_ int fd)
2141 * Preferred order: fstatvfs(), fstatfs(), getmntent().
2142 * fstatvfs() is UNIX98.
2144 * getmntent() is O(number-of-mounted-filesystems) and can hang.
2147 # ifdef HAS_FSTATVFS
2148 struct statvfs stfs;
2149 check_okay = fstatvfs(fd, &stfs) == 0;
2150 on_nosuid = check_okay && (stfs.f_flag & ST_NOSUID);
2152 # if defined(HAS_FSTATFS) && defined(HAS_STRUCT_STATFS_FLAGS)
2154 check_okay = fstatfs(fd, &stfs) == 0;
2155 # undef PERL_MOUNT_NOSUID
2156 # if !defined(PERL_MOUNT_NOSUID) && defined(MNT_NOSUID)
2157 # define PERL_MOUNT_NOSUID MNT_NOSUID
2159 # if !defined(PERL_MOUNT_NOSUID) && defined(MS_NOSUID)
2160 # define PERL_MOUNT_NOSUID MS_NOSUID
2162 # if !defined(PERL_MOUNT_NOSUID) && defined(M_NOSUID)
2163 # define PERL_MOUNT_NOSUID M_NOSUID
2165 # ifdef PERL_MOUNT_NOSUID
2166 on_nosuid = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
2169 # if defined(HAS_GETMNTENT) && defined(HAS_HASMNTOPT) && defined(MNTOPT_NOSUID)
2170 FILE *mtab = fopen("/etc/mtab", "r");
2171 struct mntent *entry;
2172 struct stat stb, fsb;
2174 if (mtab && (fstat(fd, &stb) == 0)) {
2175 while (entry = getmntent(mtab)) {
2176 if (stat(entry->mnt_dir, &fsb) == 0
2177 && fsb.st_dev == stb.st_dev)
2179 /* found the filesystem */
2181 if (hasmntopt(entry, MNTOPT_NOSUID))
2184 } /* A single fs may well fail its stat(). */
2189 # endif /* mntent */
2190 # endif /* statfs */
2191 # endif /* statvfs */
2193 Perl_croak(aTHX_ "Can't check filesystem of script \"%s\"", PL_origfilename);
2196 #endif /* IAMSUID */
2199 S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript)
2203 /* do we need to emulate setuid on scripts? */
2205 /* This code is for those BSD systems that have setuid #! scripts disabled
2206 * in the kernel because of a security problem. Merely defining DOSUID
2207 * in perl will not fix that problem, but if you have disabled setuid
2208 * scripts in the kernel, this will attempt to emulate setuid and setgid
2209 * on scripts that have those now-otherwise-useless bits set. The setuid
2210 * root version must be called suidperl or sperlN.NNN. If regular perl
2211 * discovers that it has opened a setuid script, it calls suidperl with
2212 * the same argv that it had. If suidperl finds that the script it has
2213 * just opened is NOT setuid root, it sets the effective uid back to the
2214 * uid. We don't just make perl setuid root because that loses the
2215 * effective uid we had before invoking perl, if it was different from the
2218 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
2219 * be defined in suidperl only. suidperl must be setuid root. The
2220 * Configure script will set this up for you if you want it.
2227 if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */
2228 Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
2229 if (fdscript < 0 && PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
2234 #ifndef HAS_SETREUID
2235 /* On this access check to make sure the directories are readable,
2236 * there is actually a small window that the user could use to make
2237 * filename point to an accessible directory. So there is a faint
2238 * chance that someone could execute a setuid script down in a
2239 * non-accessible directory. I don't know what to do about that.
2240 * But I don't think it's too important. The manual lies when
2241 * it says access() is useful in setuid programs.
2243 if (PerlLIO_access(SvPVX(GvSV(PL_curcop->cop_filegv)),1)) /*double check*/
2244 Perl_croak(aTHX_ "Permission denied");
2246 /* If we can swap euid and uid, then we can determine access rights
2247 * with a simple stat of the file, and then compare device and
2248 * inode to make sure we did stat() on the same file we opened.
2249 * Then we just have to make sure he or she can execute it.
2252 struct stat tmpstatbuf;
2256 setreuid(PL_euid,PL_uid) < 0
2259 setresuid(PL_euid,PL_uid,(Uid_t)-1) < 0
2262 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
2263 Perl_croak(aTHX_ "Can't swap uid and euid"); /* really paranoid */
2264 if (PerlLIO_stat(SvPVX(GvSV(PL_curcop->cop_filegv)),&tmpstatbuf) < 0)
2265 Perl_croak(aTHX_ "Permission denied"); /* testing full pathname here */
2266 #if defined(IAMSUID) && !defined(NO_NOSUID_CHECK)
2267 if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp)))
2268 Perl_croak(aTHX_ "Permission denied");
2270 if (tmpstatbuf.st_dev != PL_statbuf.st_dev ||
2271 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
2272 (void)PerlIO_close(PL_rsfp);
2273 if (PL_rsfp = PerlProc_popen("/bin/mail root","w")) { /* heh, heh */
2274 PerlIO_printf(PL_rsfp,
2275 "User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2276 (Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
2277 (long)PL_uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
2278 (long)PL_statbuf.st_dev, (long)PL_statbuf.st_ino,
2279 SvPVX(GvSV(PL_curcop->cop_filegv)),
2280 (long)PL_statbuf.st_uid, (long)PL_statbuf.st_gid);
2281 (void)PerlProc_pclose(PL_rsfp);
2283 Perl_croak(aTHX_ "Permission denied\n");
2287 setreuid(PL_uid,PL_euid) < 0
2289 # if defined(HAS_SETRESUID)
2290 setresuid(PL_uid,PL_euid,(Uid_t)-1) < 0
2293 || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
2294 Perl_croak(aTHX_ "Can't reswap uid and euid");
2295 if (!cando(S_IXUSR,FALSE,&PL_statbuf)) /* can real uid exec? */
2296 Perl_croak(aTHX_ "Permission denied\n");
2298 #endif /* HAS_SETREUID */
2299 #endif /* IAMSUID */
2301 if (!S_ISREG(PL_statbuf.st_mode))
2302 Perl_croak(aTHX_ "Permission denied");
2303 if (PL_statbuf.st_mode & S_IWOTH)
2304 Perl_croak(aTHX_ "Setuid/gid script is writable by world");
2305 PL_doswitches = FALSE; /* -s is insecure in suid */
2306 PL_curcop->cop_line++;
2307 if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
2308 strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */
2309 Perl_croak(aTHX_ "No #! line");
2310 s = SvPV(PL_linestr,n_a)+2;
2312 while (!isSPACE(*s)) s++;
2313 for (s2 = s; (s2 > SvPV(PL_linestr,n_a)+2 &&
2314 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
2315 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
2316 Perl_croak(aTHX_ "Not a perl script");
2317 while (*s == ' ' || *s == '\t') s++;
2319 * #! arg must be what we saw above. They can invoke it by
2320 * mentioning suidperl explicitly, but they may not add any strange
2321 * arguments beyond what #! says if they do invoke suidperl that way.
2323 len = strlen(validarg);
2324 if (strEQ(validarg," PHOOEY ") ||
2325 strnNE(s,validarg,len) || !isSPACE(s[len]))
2326 Perl_croak(aTHX_ "Args must match #! line");
2329 if (PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
2330 PL_euid == PL_statbuf.st_uid)
2332 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2333 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2334 #endif /* IAMSUID */
2336 if (PL_euid) { /* oops, we're not the setuid root perl */
2337 (void)PerlIO_close(PL_rsfp);
2340 PerlProc_execv(Perl_form(aTHX_ "%s/sperl%s", BIN_EXP, PL_patchlevel), PL_origargv);
2342 Perl_croak(aTHX_ "Can't do setuid\n");
2345 if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
2347 (void)setegid(PL_statbuf.st_gid);
2350 (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
2352 #ifdef HAS_SETRESGID
2353 (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
2355 PerlProc_setgid(PL_statbuf.st_gid);
2359 if (PerlProc_getegid() != PL_statbuf.st_gid)
2360 Perl_croak(aTHX_ "Can't do setegid!\n");
2362 if (PL_statbuf.st_mode & S_ISUID) {
2363 if (PL_statbuf.st_uid != PL_euid)
2365 (void)seteuid(PL_statbuf.st_uid); /* all that for this */
2368 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
2370 #ifdef HAS_SETRESUID
2371 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
2373 PerlProc_setuid(PL_statbuf.st_uid);
2377 if (PerlProc_geteuid() != PL_statbuf.st_uid)
2378 Perl_croak(aTHX_ "Can't do seteuid!\n");
2380 else if (PL_uid) { /* oops, mustn't run as root */
2382 (void)seteuid((Uid_t)PL_uid);
2385 (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
2387 #ifdef HAS_SETRESUID
2388 (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
2390 PerlProc_setuid((Uid_t)PL_uid);
2394 if (PerlProc_geteuid() != PL_uid)
2395 Perl_croak(aTHX_ "Can't do seteuid!\n");
2398 if (!cando(S_IXUSR,TRUE,&PL_statbuf))
2399 Perl_croak(aTHX_ "Permission denied\n"); /* they can't do this */
2402 else if (PL_preprocess)
2403 Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
2404 else if (fdscript >= 0)
2405 Perl_croak(aTHX_ "fd script not allowed in suidperl\n");
2407 Perl_croak(aTHX_ "Script is not setuid/setgid in suidperl\n");
2409 /* We absolutely must clear out any saved ids here, so we */
2410 /* exec the real perl, substituting fd script for scriptname. */
2411 /* (We pass script name as "subdir" of fd, which perl will grok.) */
2412 PerlIO_rewind(PL_rsfp);
2413 PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0); /* just in case rewind didn't */
2414 for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
2415 if (!PL_origargv[which])
2416 Perl_croak(aTHX_ "Permission denied");
2417 PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
2418 PerlIO_fileno(PL_rsfp), PL_origargv[which]));
2419 #if defined(HAS_FCNTL) && defined(F_SETFD)
2420 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */
2422 PerlProc_execv(Perl_form(aTHX_ "%s/perl%s", BIN_EXP, PL_patchlevel), PL_origargv);/* try again */
2423 Perl_croak(aTHX_ "Can't do setuid\n");
2424 #endif /* IAMSUID */
2426 if (PL_euid != PL_uid || PL_egid != PL_gid) { /* (suidperl doesn't exist, in fact) */
2427 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2429 PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf); /* may be either wrapped or real suid */
2430 if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
2432 (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
2435 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2436 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2437 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2438 /* not set-id, must be wrapped */
2444 S_find_beginning(pTHX)
2446 register char *s, *s2;
2448 /* skip forward in input to the real script? */
2451 while (PL_doextract) {
2452 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
2453 Perl_croak(aTHX_ "No Perl script found in input\n");
2454 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2455 PerlIO_ungetc(PL_rsfp, '\n'); /* to keep line count right */
2456 PL_doextract = FALSE;
2457 while (*s && !(isSPACE (*s) || *s == '#')) s++;
2459 while (*s == ' ' || *s == '\t') s++;
2461 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2462 if (strnEQ(s2-4,"perl",4))
2464 while (s = moreswitches(s)) ;
2466 if (PL_cddir && PerlDir_chdir(PL_cddir) < 0)
2467 Perl_croak(aTHX_ "Can't chdir to %s",PL_cddir);
2476 PL_uid = PerlProc_getuid();
2477 PL_euid = PerlProc_geteuid();
2478 PL_gid = PerlProc_getgid();
2479 PL_egid = PerlProc_getegid();
2481 PL_uid |= PL_gid << 16;
2482 PL_euid |= PL_egid << 16;
2484 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2488 S_forbid_setid(pTHX_ char *s)
2490 if (PL_euid != PL_uid)
2491 Perl_croak(aTHX_ "No %s allowed while running setuid", s);
2492 if (PL_egid != PL_gid)
2493 Perl_croak(aTHX_ "No %s allowed while running setgid", s);
2497 Perl_init_debugger(pTHX)
2500 HV *ostash = PL_curstash;
2502 PL_curstash = PL_debstash;
2503 PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2504 AvREAL_off(PL_dbargs);
2505 PL_DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2506 PL_DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2507 PL_DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2508 sv_upgrade(GvSV(PL_DBsub), SVt_IV); /* IVX accessed if PERLDB_SUB_NN */
2509 PL_DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2510 sv_setiv(PL_DBsingle, 0);
2511 PL_DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2512 sv_setiv(PL_DBtrace, 0);
2513 PL_DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2514 sv_setiv(PL_DBsignal, 0);
2515 PL_curstash = ostash;
2518 #ifndef STRESS_REALLOC
2519 #define REASONABLE(size) (size)
2521 #define REASONABLE(size) (1) /* unreasonable */
2525 Perl_init_stacks(pTHX)
2527 /* start with 128-item stack and 8K cxstack */
2528 PL_curstackinfo = new_stackinfo(REASONABLE(128),
2529 REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
2530 PL_curstackinfo->si_type = PERLSI_MAIN;
2531 PL_curstack = PL_curstackinfo->si_stack;
2532 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
2534 PL_stack_base = AvARRAY(PL_curstack);
2535 PL_stack_sp = PL_stack_base;
2536 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
2538 New(50,PL_tmps_stack,REASONABLE(128),SV*);
2541 PL_tmps_max = REASONABLE(128);
2543 New(54,PL_markstack,REASONABLE(32),I32);
2544 PL_markstack_ptr = PL_markstack;
2545 PL_markstack_max = PL_markstack + REASONABLE(32);
2549 New(54,PL_scopestack,REASONABLE(32),I32);
2550 PL_scopestack_ix = 0;
2551 PL_scopestack_max = REASONABLE(32);
2553 New(54,PL_savestack,REASONABLE(128),ANY);
2554 PL_savestack_ix = 0;
2555 PL_savestack_max = REASONABLE(128);
2557 New(54,PL_retstack,REASONABLE(16),OP*);
2559 PL_retstack_max = REASONABLE(16);
2568 while (PL_curstackinfo->si_next)
2569 PL_curstackinfo = PL_curstackinfo->si_next;
2570 while (PL_curstackinfo) {
2571 PERL_SI *p = PL_curstackinfo->si_prev;
2572 /* curstackinfo->si_stack got nuked by sv_free_arenas() */
2573 Safefree(PL_curstackinfo->si_cxstack);
2574 Safefree(PL_curstackinfo);
2575 PL_curstackinfo = p;
2577 Safefree(PL_tmps_stack);
2578 Safefree(PL_markstack);
2579 Safefree(PL_scopestack);
2580 Safefree(PL_savestack);
2581 Safefree(PL_retstack);
2583 Safefree(PL_debname);
2584 Safefree(PL_debdelim);
2589 static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
2600 lex_start(PL_linestr);
2602 PL_subname = newSVpvn("main",4);
2606 S_init_predump_symbols(pTHX)
2613 sv_setpvn(get_sv("\"", TRUE), " ", 1);
2614 PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2615 GvMULTI_on(PL_stdingv);
2616 io = GvIOp(PL_stdingv);
2617 IoIFP(io) = PerlIO_stdin();
2618 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2620 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
2622 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2625 IoOFP(io) = IoIFP(io) = PerlIO_stdout();
2627 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2629 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
2631 othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2632 GvMULTI_on(othergv);
2633 io = GvIOp(othergv);
2634 IoOFP(io) = IoIFP(io) = PerlIO_stderr();
2635 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2637 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
2639 PL_statname = NEWSV(66,0); /* last filename we did stat on */
2642 PL_osname = savepv(OSNAME);
2646 S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
2653 argc--,argv++; /* skip name of script */
2654 if (PL_doswitches) {
2655 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2658 if (argv[0][1] == '-') {
2662 if (s = strchr(argv[0], '=')) {
2664 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2667 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2670 PL_toptarget = NEWSV(0,0);
2671 sv_upgrade(PL_toptarget, SVt_PVFM);
2672 sv_setpvn(PL_toptarget, "", 0);
2673 PL_bodytarget = NEWSV(0,0);
2674 sv_upgrade(PL_bodytarget, SVt_PVFM);
2675 sv_setpvn(PL_bodytarget, "", 0);
2676 PL_formtarget = PL_bodytarget;
2679 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2680 sv_setpv(GvSV(tmpgv),PL_origfilename);
2681 magicname("0", "0", 1);
2683 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2684 sv_setpv(GvSV(tmpgv),PL_origargv[0]);
2685 if (PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2686 GvMULTI_on(PL_argvgv);
2687 (void)gv_AVadd(PL_argvgv);
2688 av_clear(GvAVn(PL_argvgv));
2689 for (; argc > 0; argc--,argv++) {
2690 av_push(GvAVn(PL_argvgv),newSVpv(argv[0],0));
2693 if (PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2695 GvMULTI_on(PL_envgv);
2696 hv = GvHVn(PL_envgv);
2697 hv_magic(hv, PL_envgv, 'E');
2698 #if !defined( VMS) && !defined(EPOC) /* VMS doesn't have environ array */
2699 /* Note that if the supplied env parameter is actually a copy
2700 of the global environ then it may now point to free'd memory
2701 if the environment has been modified since. To avoid this
2702 problem we treat env==NULL as meaning 'use the default'
2707 environ[0] = Nullch;
2708 for (; *env; env++) {
2709 if (!(s = strchr(*env,'=')))
2715 sv = newSVpv(s--,0);
2716 (void)hv_store(hv, *env, s - *env, sv, 0);
2718 #if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
2719 /* Sins of the RTL. See note in my_setenv(). */
2720 (void)PerlEnv_putenv(savepv(*env));
2724 #ifdef DYNAMIC_ENV_FETCH
2725 HvNAME(hv) = savepv(ENV_HV_NAME);
2729 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2730 sv_setiv(GvSV(tmpgv), (IV)getpid());
2734 S_init_perllib(pTHX)
2739 s = PerlEnv_getenv("PERL5LIB");
2743 incpush(PerlEnv_getenv("PERLLIB"), FALSE);
2745 /* Treat PERL5?LIB as a possible search list logical name -- the
2746 * "natural" VMS idiom for a Unix path string. We allow each
2747 * element to be a set of |-separated directories for compatibility.
2751 if (my_trnlnm("PERL5LIB",buf,0))
2752 do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2754 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2758 /* Use the ~-expanded versions of APPLLIB (undocumented),
2759 ARCHLIB PRIVLIB SITEARCH and SITELIB
2762 incpush(APPLLIB_EXP, TRUE);
2766 incpush(ARCHLIB_EXP, FALSE);
2769 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2772 incpush(PRIVLIB_EXP, TRUE);
2774 incpush(PRIVLIB_EXP, FALSE);
2778 incpush(SITEARCH_EXP, FALSE);
2782 incpush(SITELIB_EXP, TRUE);
2784 incpush(SITELIB_EXP, FALSE);
2787 #if defined(PERL_VENDORLIB_EXP)
2789 incpush(PERL_VENDORLIB_EXP, TRUE);
2791 incpush(PERL_VENDORLIB_EXP, FALSE);
2795 incpush(".", FALSE);
2799 # define PERLLIB_SEP ';'
2802 # define PERLLIB_SEP '|'
2804 # define PERLLIB_SEP ':'
2807 #ifndef PERLLIB_MANGLE
2808 # define PERLLIB_MANGLE(s,n) (s)
2812 S_incpush(pTHX_ char *p, int addsubdirs)
2814 SV *subdir = Nullsv;
2820 subdir = sv_newmortal();
2821 if (!PL_archpat_auto) {
2822 STRLEN len = (sizeof(ARCHNAME) + strlen(PL_patchlevel)
2823 + sizeof("//auto"));
2824 New(55, PL_archpat_auto, len, char);
2825 sprintf(PL_archpat_auto, "/%s/%s/auto", ARCHNAME, PL_patchlevel);
2827 for (len = sizeof(ARCHNAME) + 2;
2828 PL_archpat_auto[len] != '\0' && PL_archpat_auto[len] != '/'; len++)
2829 if (PL_archpat_auto[len] == '.') PL_archpat_auto[len] = '_';
2834 /* Break at all separators */
2836 SV *libdir = NEWSV(55,0);
2839 /* skip any consecutive separators */
2840 while ( *p == PERLLIB_SEP ) {
2841 /* Uncomment the next line for PATH semantics */
2842 /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */
2846 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2847 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2852 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2853 p = Nullch; /* break out */
2857 * BEFORE pushing libdir onto @INC we may first push version- and
2858 * archname-specific sub-directories.
2861 struct stat tmpstatbuf;
2866 if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) {
2868 while (unix[len-1] == '/') len--; /* Cosmetic */
2869 sv_usepvn(libdir,unix,len);
2872 PerlIO_printf(PerlIO_stderr(),
2873 "Failed to unixify @INC element \"%s\"\n",
2876 /* .../archname/version if -d .../archname/version/auto */
2877 sv_setsv(subdir, libdir);
2878 sv_catpv(subdir, PL_archpat_auto);
2879 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2880 S_ISDIR(tmpstatbuf.st_mode))
2881 av_push(GvAVn(PL_incgv),
2882 newSVpvn(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2884 /* .../archname if -d .../archname/auto */
2885 sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
2886 strlen(PL_patchlevel) + 1, "", 0);
2887 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2888 S_ISDIR(tmpstatbuf.st_mode))
2889 av_push(GvAVn(PL_incgv),
2890 newSVpvn(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2893 /* finally push this lib directory on the end of @INC */
2894 av_push(GvAVn(PL_incgv), libdir);
2899 STATIC struct perl_thread *
2900 S_init_main_thread(pTHX)
2902 #if !defined(PERL_IMPLICIT_CONTEXT)
2903 struct perl_thread *thr;
2907 Newz(53, thr, 1, struct perl_thread);
2908 PL_curcop = &PL_compiling;
2909 thr->interp = PERL_GET_INTERP;
2910 thr->cvcache = newHV();
2911 thr->threadsv = newAV();
2912 /* thr->threadsvp is set when find_threadsv is called */
2913 thr->specific = newAV();
2914 thr->errhv = newHV();
2915 thr->flags = THRf_R_JOINABLE;
2916 MUTEX_INIT(&thr->mutex);
2917 /* Handcraft thrsv similarly to mess_sv */
2918 New(53, PL_thrsv, 1, SV);
2919 Newz(53, xpv, 1, XPV);
2920 SvFLAGS(PL_thrsv) = SVt_PV;
2921 SvANY(PL_thrsv) = (void*)xpv;
2922 SvREFCNT(PL_thrsv) = 1 << 30; /* practically infinite */
2923 SvPVX(PL_thrsv) = (char*)thr;
2924 SvCUR_set(PL_thrsv, sizeof(thr));
2925 SvLEN_set(PL_thrsv, sizeof(thr));
2926 *SvEND(PL_thrsv) = '\0'; /* in the trailing_nul field */
2927 thr->oursv = PL_thrsv;
2928 PL_chopset = " \n-";
2931 MUTEX_LOCK(&PL_threads_mutex);
2936 MUTEX_UNLOCK(&PL_threads_mutex);
2938 #ifdef HAVE_THREAD_INTERN
2939 Perl_init_thread_intern(thr);
2942 #ifdef SET_THREAD_SELF
2943 SET_THREAD_SELF(thr);
2945 thr->self = pthread_self();
2946 #endif /* SET_THREAD_SELF */
2950 * These must come after the SET_THR because sv_setpvn does
2951 * SvTAINT and the taint fields require dTHR.
2953 PL_toptarget = NEWSV(0,0);
2954 sv_upgrade(PL_toptarget, SVt_PVFM);
2955 sv_setpvn(PL_toptarget, "", 0);
2956 PL_bodytarget = NEWSV(0,0);
2957 sv_upgrade(PL_bodytarget, SVt_PVFM);
2958 sv_setpvn(PL_bodytarget, "", 0);
2959 PL_formtarget = PL_bodytarget;
2960 thr->errsv = newSVpvn("", 0);
2961 (void) find_threadsv("@"); /* Ensure $@ is initialised early */
2964 PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
2965 PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
2966 PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
2967 PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
2968 PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
2970 PL_reginterp_cnt = 0;
2974 #endif /* USE_THREADS */
2977 Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
2981 line_t oldline = PL_curcop->cop_line;
2986 while (AvFILL(paramList) >= 0) {
2987 cv = (CV*)av_shift(paramList);
2989 CALLPROTECT(aTHX_ &ret, MEMBER_TO_FPTR(S_call_list_body), cv);
2992 (void)SvPV(atsv, len);
2994 PL_curcop = &PL_compiling;
2995 PL_curcop->cop_line = oldline;
2996 if (paramList == PL_beginav)
2997 sv_catpv(atsv, "BEGIN failed--compilation aborted");
2999 sv_catpv(atsv, "END failed--cleanup aborted");
3000 while (PL_scopestack_ix > oldscope)
3002 Perl_croak(aTHX_ "%s", SvPVX(atsv));
3009 /* my_exit() was called */
3010 while (PL_scopestack_ix > oldscope)
3013 PL_curstash = PL_defstash;
3015 call_list(oldscope, PL_endav);
3016 PL_curcop = &PL_compiling;
3017 PL_curcop->cop_line = oldline;
3018 if (PL_statusvalue) {
3019 if (paramList == PL_beginav)
3020 Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
3022 Perl_croak(aTHX_ "END failed--cleanup aborted");
3028 PL_curcop = &PL_compiling;
3029 PL_curcop->cop_line = oldline;
3032 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
3040 S_call_list_body(pTHX_ va_list args)
3043 CV *cv = va_arg(args, CV*);
3045 PUSHMARK(PL_stack_sp);
3046 call_sv((SV*)cv, G_EVAL|G_DISCARD);
3051 Perl_my_exit(pTHX_ U32 status)
3055 DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
3056 thr, (unsigned long) status));
3065 STATUS_NATIVE_SET(status);
3072 Perl_my_failure_exit(pTHX)
3075 if (vaxc$errno & 1) {
3076 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
3077 STATUS_NATIVE_SET(44);
3080 if (!vaxc$errno && errno) /* unlikely */
3081 STATUS_NATIVE_SET(44);
3083 STATUS_NATIVE_SET(vaxc$errno);
3088 STATUS_POSIX_SET(errno);
3090 exitstatus = STATUS_POSIX >> 8;
3091 if (exitstatus & 255)
3092 STATUS_POSIX_SET(exitstatus);
3094 STATUS_POSIX_SET(255);
3101 S_my_exit_jump(pTHX)
3104 register PERL_CONTEXT *cx;
3109 SvREFCNT_dec(PL_e_script);
3110 PL_e_script = Nullsv;
3113 POPSTACK_TO(PL_mainstack);
3114 if (cxstack_ix >= 0) {
3117 POPBLOCK(cx,PL_curpm);
3130 read_e_script(pTHXo_ int idx, SV *buf_sv, int maxlen)
3133 p = SvPVX(PL_e_script);
3134 nl = strchr(p, '\n');
3135 nl = (nl) ? nl+1 : SvEND(PL_e_script);
3137 filter_del(read_e_script);
3140 sv_catpvn(buf_sv, p, nl-p);
3141 sv_chop(PL_e_script, nl);