3 * Copyright (c) 1987-1999 Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * "A ship then new they built for him/of mithril and of elven glass" --Bilbo
15 #define PERL_IN_PERL_C
17 #include "patchlevel.h" /* for local_patches */
19 /* XXX If this causes problems, set i_unistd=undef in the hint file. */
24 #if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE)
25 char *getenv (char *); /* Usually in <stdlib.h> */
28 static I32 read_e_script(pTHXo_ int idx, SV *buf_sv, int maxlen);
43 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
50 CPerlObj* perl_alloc(IPerlMem* ipM, IPerlEnv* ipE, IPerlStdIO* ipStd,
51 IPerlLIO* ipLIO, IPerlDir* ipD, IPerlSock* ipS, IPerlProc* ipP)
53 CPerlObj* pPerl = new(ipM) CPerlObj(ipM, ipE, ipStd, ipLIO, ipD, ipS, ipP);
63 PerlInterpreter *my_perl;
65 /* New() needs interpreter, so call malloc() instead */
66 my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
67 PERL_SET_INTERP(my_perl);
70 #endif /* PERL_OBJECT */
78 struct perl_thread *thr;
79 #endif /* FAKE_THREADS */
80 #endif /* USE_THREADS */
83 Zero(my_perl, 1, PerlInterpreter);
88 PL_perl_destruct_level = 1;
90 if (PL_perl_destruct_level > 0)
94 /* Init the real globals (and main thread)? */
99 #ifdef ALLOC_THREAD_KEY
102 if (pthread_key_create(&PL_thr_key, 0))
103 Perl_croak(aTHX_ "panic: pthread_key_create");
105 MUTEX_INIT(&PL_sv_mutex);
107 * Safe to use basic SV functions from now on (though
108 * not things like mortals or tainting yet).
110 MUTEX_INIT(&PL_eval_mutex);
111 COND_INIT(&PL_eval_cond);
112 MUTEX_INIT(&PL_threads_mutex);
113 COND_INIT(&PL_nthreads_cond);
114 #ifdef EMULATE_ATOMIC_REFCOUNTS
115 MUTEX_INIT(&PL_svref_mutex);
116 #endif /* EMULATE_ATOMIC_REFCOUNTS */
118 MUTEX_INIT(&PL_cred_mutex);
120 thr = init_main_thread();
121 #endif /* USE_THREADS */
123 PL_protect = MEMBER_TO_FPTR(Perl_default_protect); /* for exceptions */
125 PL_curcop = &PL_compiling; /* needed by ckWARN, right away */
127 PL_linestr = NEWSV(65,79);
128 sv_upgrade(PL_linestr,SVt_PVIV);
130 if (!SvREADONLY(&PL_sv_undef)) {
131 /* set read-only and try to insure than we wont see REFCNT==0
134 SvREADONLY_on(&PL_sv_undef);
135 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
137 sv_setpv(&PL_sv_no,PL_No);
139 SvREADONLY_on(&PL_sv_no);
140 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
142 sv_setpv(&PL_sv_yes,PL_Yes);
144 SvREADONLY_on(&PL_sv_yes);
145 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
150 /* PL_sighandlerp = sighandler; */
152 PL_sighandlerp = Perl_sighandler;
154 PL_pidstatus = newHV();
158 * There is no way we can refer to them from Perl so close them to save
159 * space. The other alternative would be to provide STDAUX and STDPRN
162 (void)fclose(stdaux);
163 (void)fclose(stdprn);
167 PL_nrs = newSVpvn("\n", 1);
168 PL_rs = SvREFCNT_inc(PL_nrs);
173 PL_lex_state = LEX_NOTPARSING;
179 SET_NUMERIC_STANDARD();
180 #if defined(PERL_SUBVERSION) && PERL_SUBVERSION > 0
181 sprintf(PL_patchlevel, "%7.5f", (double) PERL_REVISION
182 + ((double) PERL_VERSION / (double) 1000)
183 + ((double) PERL_SUBVERSION / (double) 100000));
185 sprintf(PL_patchlevel, "%5.3f", (double) PERL_REVISION +
186 ((double) PERL_VERSION / (double) 1000));
189 #if defined(LOCAL_PATCH_COUNT)
190 PL_localpatches = local_patches; /* For possible -v */
193 PerlIO_init(); /* Hook to IO system */
195 PL_fdpid = newAV(); /* for remembering popen pids by fd */
196 PL_modglobal = newHV(); /* pointers to per-interpreter module globals */
199 New(51,PL_debname,128,char);
200 New(52,PL_debdelim,128,char);
210 int destruct_level; /* 0=none, 1=full, 2=full with checks */
216 #endif /* USE_THREADS */
220 /* Pass 1 on any remaining threads: detach joinables, join zombies */
222 MUTEX_LOCK(&PL_threads_mutex);
223 DEBUG_S(PerlIO_printf(Perl_debug_log,
224 "perl_destruct: waiting for %d threads...\n",
226 for (t = thr->next; t != thr; t = t->next) {
227 MUTEX_LOCK(&t->mutex);
228 switch (ThrSTATE(t)) {
231 DEBUG_S(PerlIO_printf(Perl_debug_log,
232 "perl_destruct: joining zombie %p\n", t));
233 ThrSETSTATE(t, THRf_DEAD);
234 MUTEX_UNLOCK(&t->mutex);
237 * The SvREFCNT_dec below may take a long time (e.g. av
238 * may contain an object scalar whose destructor gets
239 * called) so we have to unlock threads_mutex and start
242 MUTEX_UNLOCK(&PL_threads_mutex);
244 SvREFCNT_dec((SV*)av);
245 DEBUG_S(PerlIO_printf(Perl_debug_log,
246 "perl_destruct: joined zombie %p OK\n", t));
248 case THRf_R_JOINABLE:
249 DEBUG_S(PerlIO_printf(Perl_debug_log,
250 "perl_destruct: detaching thread %p\n", t));
251 ThrSETSTATE(t, THRf_R_DETACHED);
253 * We unlock threads_mutex and t->mutex in the opposite order
254 * from which we locked them just so that DETACH won't
255 * deadlock if it panics. It's only a breach of good style
256 * not a bug since they are unlocks not locks.
258 MUTEX_UNLOCK(&PL_threads_mutex);
260 MUTEX_UNLOCK(&t->mutex);
263 DEBUG_S(PerlIO_printf(Perl_debug_log,
264 "perl_destruct: ignoring %p (state %u)\n",
266 MUTEX_UNLOCK(&t->mutex);
267 /* fall through and out */
270 /* We leave the above "Pass 1" loop with threads_mutex still locked */
272 /* Pass 2 on remaining threads: wait for the thread count to drop to one */
273 while (PL_nthreads > 1)
275 DEBUG_S(PerlIO_printf(Perl_debug_log,
276 "perl_destruct: final wait for %d threads\n",
278 COND_WAIT(&PL_nthreads_cond, &PL_threads_mutex);
280 /* At this point, we're the last thread */
281 MUTEX_UNLOCK(&PL_threads_mutex);
282 DEBUG_S(PerlIO_printf(Perl_debug_log, "perl_destruct: armageddon has arrived\n"));
283 MUTEX_DESTROY(&PL_threads_mutex);
284 COND_DESTROY(&PL_nthreads_cond);
285 #endif /* !defined(FAKE_THREADS) */
286 #endif /* USE_THREADS */
288 destruct_level = PL_perl_destruct_level;
292 if (s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL")) {
294 if (destruct_level < i)
303 /* We must account for everything. */
305 /* Destroy the main CV and syntax tree */
307 PL_curpad = AvARRAY(PL_comppad);
308 op_free(PL_main_root);
309 PL_main_root = Nullop;
311 PL_curcop = &PL_compiling;
312 PL_main_start = Nullop;
313 SvREFCNT_dec(PL_main_cv);
317 if (PL_sv_objcount) {
319 * Try to destruct global references. We do this first so that the
320 * destructors and destructees still exist. Some sv's might remain.
321 * Non-referenced objects are on their own.
326 /* unhook hooks which will soon be, or use, destroyed data */
327 SvREFCNT_dec(PL_warnhook);
328 PL_warnhook = Nullsv;
329 SvREFCNT_dec(PL_diehook);
332 /* call exit list functions */
333 while (PL_exitlistlen-- > 0)
334 PL_exitlist[PL_exitlistlen].fn(aTHXo_ PL_exitlist[PL_exitlistlen].ptr);
336 Safefree(PL_exitlist);
338 if (destruct_level == 0){
340 DEBUG_P(debprofdump());
342 /* The exit() function will do everything that needs doing. */
346 /* loosen bonds of global variables */
349 (void)PerlIO_close(PL_rsfp);
353 /* Filters for program text */
354 SvREFCNT_dec(PL_rsfp_filters);
355 PL_rsfp_filters = Nullav;
358 PL_preprocess = FALSE;
364 PL_doswitches = FALSE;
365 PL_dowarn = G_WARN_OFF;
366 PL_doextract = FALSE;
367 PL_sawampersand = FALSE; /* must save all match strings */
368 PL_sawstudy = FALSE; /* do fbm_instr on all strings */
372 Safefree(PL_inplace);
376 SvREFCNT_dec(PL_e_script);
377 PL_e_script = Nullsv;
380 /* magical thingies */
382 Safefree(PL_ofs); /* $, */
385 Safefree(PL_ors); /* $\ */
388 SvREFCNT_dec(PL_rs); /* $/ */
391 SvREFCNT_dec(PL_nrs); /* $/ helper */
394 PL_multiline = 0; /* $* */
396 SvREFCNT_dec(PL_statname);
397 PL_statname = Nullsv;
400 /* defgv, aka *_ should be taken care of elsewhere */
402 /* clean up after study() */
403 SvREFCNT_dec(PL_lastscream);
404 PL_lastscream = Nullsv;
405 Safefree(PL_screamfirst);
407 Safefree(PL_screamnext);
411 Safefree(PL_efloatbuf);
412 PL_efloatbuf = Nullch;
415 /* startup and shutdown function lists */
416 SvREFCNT_dec(PL_beginav);
417 SvREFCNT_dec(PL_endav);
418 SvREFCNT_dec(PL_initav);
423 /* shortcuts just get cleared */
430 PL_argvoutgv = Nullgv;
432 PL_stderrgv = Nullgv;
433 PL_last_in_gv = Nullgv;
436 /* reset so print() ends up where we expect */
439 /* Prepare to destruct main symbol table. */
445 /* clear queued errors */
446 SvREFCNT_dec(PL_errors);
450 if (destruct_level >= 2 && ckWARN_d(WARN_INTERNAL)) {
451 if (PL_scopestack_ix != 0)
452 Perl_warner(aTHX_ WARN_INTERNAL,
453 "Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
454 (long)PL_scopestack_ix);
455 if (PL_savestack_ix != 0)
456 Perl_warner(aTHX_ WARN_INTERNAL,
457 "Unbalanced saves: %ld more saves than restores\n",
458 (long)PL_savestack_ix);
459 if (PL_tmps_floor != -1)
460 Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced tmps: %ld more allocs than frees\n",
461 (long)PL_tmps_floor + 1);
462 if (cxstack_ix != -1)
463 Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced context: %ld more PUSHes than POPs\n",
464 (long)cxstack_ix + 1);
467 /* Now absolutely destruct everything, somehow or other, loops or no. */
469 SvFLAGS(PL_strtab) |= SVTYPEMASK; /* don't clean out strtab now */
470 while (PL_sv_count != 0 && PL_sv_count != last_sv_count) {
471 last_sv_count = PL_sv_count;
474 SvFLAGS(PL_strtab) &= ~SVTYPEMASK;
475 SvFLAGS(PL_strtab) |= SVt_PVHV;
477 /* Destruct the global string table. */
479 /* Yell and reset the HeVAL() slots that are still holding refcounts,
480 * so that sv_free() won't fail on them.
488 max = HvMAX(PL_strtab);
489 array = HvARRAY(PL_strtab);
492 if (hent && ckWARN_d(WARN_INTERNAL)) {
493 Perl_warner(aTHX_ WARN_INTERNAL,
494 "Unbalanced string table refcount: (%d) for \"%s\"",
495 HeVAL(hent) - Nullsv, HeKEY(hent));
496 HeVAL(hent) = Nullsv;
506 SvREFCNT_dec(PL_strtab);
508 if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL))
509 Perl_warner(aTHX_ WARN_INTERNAL,"Scalars leaked: %ld\n", (long)PL_sv_count);
513 /* No SVs have survived, need to clean out */
515 PL_pidstatus = Nullhv;
516 Safefree(PL_origfilename);
517 Safefree(PL_archpat_auto);
518 Safefree(PL_reg_start_tmp);
520 Safefree(PL_reg_curpm);
521 Safefree(PL_reg_poscache);
522 Safefree(HeKEY_hek(&PL_hv_fetch_ent_mh));
523 Safefree(PL_op_mask);
525 PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */
527 DEBUG_P(debprofdump());
529 MUTEX_DESTROY(&PL_strtab_mutex);
530 MUTEX_DESTROY(&PL_sv_mutex);
531 MUTEX_DESTROY(&PL_eval_mutex);
532 MUTEX_DESTROY(&PL_cred_mutex);
533 COND_DESTROY(&PL_eval_cond);
534 #ifdef EMULATE_ATOMIC_REFCOUNTS
535 MUTEX_DESTROY(&PL_svref_mutex);
536 #endif /* EMULATE_ATOMIC_REFCOUNTS */
538 /* As the penultimate thing, free the non-arena SV for thrsv */
539 Safefree(SvPVX(PL_thrsv));
540 Safefree(SvANY(PL_thrsv));
543 #endif /* USE_THREADS */
545 /* As the absolutely last thing, free the non-arena SV for mess() */
548 /* it could have accumulated taint magic */
549 if (SvTYPE(PL_mess_sv) >= SVt_PVMG) {
552 for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) {
553 moremagic = mg->mg_moremagic;
554 if (mg->mg_ptr && mg->mg_type != 'g' && mg->mg_len >= 0)
555 Safefree(mg->mg_ptr);
559 /* we know that type >= SVt_PV */
560 SvOOK_off(PL_mess_sv);
561 Safefree(SvPVX(PL_mess_sv));
562 Safefree(SvANY(PL_mess_sv));
563 Safefree(PL_mess_sv);
571 #if defined(PERL_OBJECT)
579 Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
581 Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry);
582 PL_exitlist[PL_exitlistlen].fn = fn;
583 PL_exitlist[PL_exitlistlen].ptr = ptr;
588 perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
597 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
600 Perl_croak(aTHX_ "suidperl is no longer needed since the kernel can now execute\n\
601 setuid perl scripts securely.\n");
605 #if defined(__DYNAMIC__) && (defined(NeXT) || defined(__NeXT__))
606 _dyld_lookup_and_bind
607 ("__environ", (unsigned long *) &environ_pointer, NULL);
612 #ifndef VMS /* VMS doesn't have environ array */
613 PL_origenviron = environ;
618 /* Come here if running an undumped a.out. */
620 PL_origfilename = savepv(argv[0]);
621 PL_do_undump = FALSE;
622 cxstack_ix = -1; /* start label stack again */
624 init_postdump_symbols(argc,argv,env);
629 PL_curpad = AvARRAY(PL_comppad);
630 op_free(PL_main_root);
631 PL_main_root = Nullop;
633 PL_main_start = Nullop;
634 SvREFCNT_dec(PL_main_cv);
638 oldscope = PL_scopestack_ix;
639 PL_dowarn = G_WARN_OFF;
641 CALLPROTECT(aTHX_ &ret, MEMBER_TO_FPTR(S_parse_body), env, xsinit);
649 /* my_exit() was called */
650 while (PL_scopestack_ix > oldscope)
653 PL_curstash = PL_defstash;
654 if (PL_endav && !PL_minus_c)
655 call_list(oldscope, PL_endav);
656 return STATUS_NATIVE_EXPORT;
658 PerlIO_printf(Perl_error_log, "panic: top_env\n");
665 S_parse_body(pTHX_ va_list args)
668 int argc = PL_origargc;
669 char **argv = PL_origargv;
670 char **env = va_arg(args, char**);
671 char *scriptname = NULL;
673 VOL bool dosearch = FALSE;
679 XSINIT_t xsinit = va_arg(args, XSINIT_t);
681 sv_setpvn(PL_linestr,"",0);
682 sv = newSVpvn("",0); /* first used for -I flags */
686 for (argc--,argv++; argc > 0; argc--,argv++) {
687 if (argv[0][0] != '-' || !argv[0][1])
691 validarg = " PHOOEY ";
698 #ifndef PERL_STRICT_CR
722 if (s = moreswitches(s))
732 if (PL_euid != PL_uid || PL_egid != PL_gid)
733 Perl_croak(aTHX_ "No -e allowed in setuid scripts");
735 PL_e_script = newSVpvn("",0);
736 filter_add(read_e_script, NULL);
739 sv_catpv(PL_e_script, s);
741 sv_catpv(PL_e_script, argv[1]);
745 Perl_croak(aTHX_ "No code specified for -e");
746 sv_catpv(PL_e_script, "\n");
749 case 'I': /* -I handled both here and in moreswitches() */
751 if (!*++s && (s=argv[1]) != Nullch) {
754 while (s && isSPACE(*s))
758 for (e = s; *e && !isSPACE(*e); e++) ;
765 } /* XXX else croak? */
769 PL_preprocess = TRUE;
779 PL_preambleav = newAV();
780 av_push(PL_preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
782 PL_Sv = newSVpv("print myconfig();",0);
784 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
786 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
788 #if defined(DEBUGGING) || defined(MULTIPLICITY)
789 sv_catpv(PL_Sv,"\" Compile-time options:");
791 sv_catpv(PL_Sv," DEBUGGING");
794 sv_catpv(PL_Sv," MULTIPLICITY");
796 sv_catpv(PL_Sv,"\\n\",");
798 #if defined(LOCAL_PATCH_COUNT)
799 if (LOCAL_PATCH_COUNT > 0) {
801 sv_catpv(PL_Sv,"\" Locally applied patches:\\n\",");
802 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
803 if (PL_localpatches[i])
804 Perl_sv_catpvf(aTHX_ PL_Sv,"q\" \t%s\n\",",PL_localpatches[i]);
808 Perl_sv_catpvf(aTHX_ PL_Sv,"\" Built under %s\\n\"",OSNAME);
811 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
813 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled on %s\\n\"",__DATE__);
818 @env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; \
819 print \" \\%ENV:\\n @env\\n\" if @env; \
820 print \" \\@INC:\\n @INC\\n\";");
823 PL_Sv = newSVpv("config_vars(qw(",0);
824 sv_catpv(PL_Sv, ++s);
825 sv_catpv(PL_Sv, "))");
828 av_push(PL_preambleav, PL_Sv);
829 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
835 PL_cddir = savepv(s);
840 if (!*++s || isSPACE(*s)) {
844 /* catch use of gnu style long options */
845 if (strEQ(s, "version")) {
849 if (strEQ(s, "help")) {
856 Perl_croak(aTHX_ "Unrecognized switch: -%s (-h will show valid options)",s);
862 #ifndef SECURE_INTERNAL_GETENV
865 (s = PerlEnv_getenv("PERL5OPT"))) {
868 if (*s == '-' && *(s+1) == 'T')
881 if (!strchr("DIMUdmw", *s))
882 Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
889 scriptname = argv[0];
892 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
894 else if (scriptname == Nullch) {
896 if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
904 open_script(scriptname,dosearch,sv,&fdscript);
906 validate_suid(validarg, scriptname,fdscript);
911 PL_main_cv = PL_compcv = (CV*)NEWSV(1104,0);
912 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
913 CvUNIQUE_on(PL_compcv);
915 PL_comppad = newAV();
916 av_push(PL_comppad, Nullsv);
917 PL_curpad = AvARRAY(PL_comppad);
918 PL_comppad_name = newAV();
919 PL_comppad_name_fill = 0;
920 PL_min_intro_pending = 0;
923 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
924 PL_curpad[0] = (SV*)newAV();
925 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
926 CvOWNER(PL_compcv) = 0;
927 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
928 MUTEX_INIT(CvMUTEXP(PL_compcv));
929 #endif /* USE_THREADS */
931 comppadlist = newAV();
932 AvREAL_off(comppadlist);
933 av_store(comppadlist, 0, (SV*)PL_comppad_name);
934 av_store(comppadlist, 1, (SV*)PL_comppad);
935 CvPADLIST(PL_compcv) = comppadlist;
937 boot_core_UNIVERSAL();
941 (*xsinit)(aTHXo); /* in case linked C routines want magical variables */
942 #if defined(VMS) || defined(WIN32) || defined(DJGPP)
950 init_predump_symbols();
951 /* init_postdump_symbols not currently designed to be called */
952 /* more than once (ENV isn't cleared first, for example) */
953 /* But running with -u leaves %ENV & @ARGV undefined! XXX */
955 init_postdump_symbols(argc,argv,env);
959 /* now parse the script */
961 SETERRNO(0,SS$_NORMAL);
963 if (yyparse() || PL_error_count) {
965 Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
967 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
971 PL_curcop->cop_line = 0;
972 PL_curstash = PL_defstash;
973 PL_preprocess = FALSE;
975 SvREFCNT_dec(PL_e_script);
976 PL_e_script = Nullsv;
979 /* now that script is parsed, we can modify record separator */
981 PL_rs = SvREFCNT_inc(PL_nrs);
982 sv_setsv(get_sv("/", TRUE), PL_rs);
987 gv_check(PL_defstash);
993 if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
994 dump_mstats("after compilation:");
1012 oldscope = PL_scopestack_ix;
1015 CALLPROTECT(aTHX_ &ret, MEMBER_TO_FPTR(S_run_body), oldscope);
1018 cxstack_ix = -1; /* start context stack again */
1020 case 0: /* normal completion */
1021 case 2: /* my_exit() */
1022 while (PL_scopestack_ix > oldscope)
1025 PL_curstash = PL_defstash;
1026 if (PL_endav && !PL_minus_c)
1027 call_list(oldscope, PL_endav);
1029 if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
1030 dump_mstats("after execution: ");
1032 return STATUS_NATIVE_EXPORT;
1035 POPSTACK_TO(PL_mainstack);
1038 PerlIO_printf(Perl_error_log, "panic: restartop\n");
1048 S_run_body(pTHX_ va_list args)
1051 I32 oldscope = va_arg(args, I32);
1053 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
1054 PL_sawampersand ? "Enabling" : "Omitting"));
1056 if (!PL_restartop) {
1057 DEBUG_x(dump_all());
1058 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
1059 DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%lx\n",
1060 (unsigned long) thr));
1063 PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
1066 if (PERLDB_SINGLE && PL_DBsingle)
1067 sv_setiv(PL_DBsingle, 1);
1069 call_list(oldscope, PL_initav);
1075 PL_op = PL_restartop;
1079 else if (PL_main_start) {
1080 CvDEPTH(PL_main_cv) = 1;
1081 PL_op = PL_main_start;
1091 Perl_get_sv(pTHX_ const char *name, I32 create)
1095 if (name[1] == '\0' && !isALPHA(name[0])) {
1096 PADOFFSET tmp = find_threadsv(name);
1097 if (tmp != NOT_IN_PAD) {
1099 return THREADSV(tmp);
1102 #endif /* USE_THREADS */
1103 gv = gv_fetchpv(name, create, SVt_PV);
1110 Perl_get_av(pTHX_ const char *name, I32 create)
1112 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1121 Perl_get_hv(pTHX_ const char *name, I32 create)
1123 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1132 Perl_get_cv(pTHX_ const char *name, I32 create)
1134 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
1135 /* XXX unsafe for threads if eval_owner isn't held */
1136 /* XXX this is probably not what they think they're getting.
1137 * It has the same effect as "sub name;", i.e. just a forward
1139 if (create && !GvCVu(gv))
1140 return newSUB(start_subparse(FALSE, 0),
1141 newSVOP(OP_CONST, 0, newSVpv(name,0)),
1149 /* Be sure to refetch the stack pointer after calling these routines. */
1152 Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv)
1154 /* See G_* flags in cop.h */
1155 /* null terminated arg list */
1162 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
1167 return call_pv(sub_name, flags);
1171 Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
1172 /* name of the subroutine */
1173 /* See G_* flags in cop.h */
1175 return call_sv((SV*)get_cv(sub_name, TRUE), flags);
1179 Perl_call_method(pTHX_ const char *methname, I32 flags)
1180 /* name of the subroutine */
1181 /* See G_* flags in cop.h */
1187 XPUSHs(sv_2mortal(newSVpv(methname,0)));
1192 return call_sv(*PL_stack_sp--, flags);
1195 /* May be called with any of a CV, a GV, or an SV containing the name. */
1197 Perl_call_sv(pTHX_ SV *sv, I32 flags)
1199 /* See G_* flags in cop.h */
1202 LOGOP myop; /* fake syntax tree node */
1206 bool oldcatch = CATCH_GET;
1210 if (flags & G_DISCARD) {
1215 Zero(&myop, 1, LOGOP);
1216 myop.op_next = Nullop;
1217 if (!(flags & G_NOARGS))
1218 myop.op_flags |= OPf_STACKED;
1219 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1220 (flags & G_ARRAY) ? OPf_WANT_LIST :
1225 EXTEND(PL_stack_sp, 1);
1226 *++PL_stack_sp = sv;
1228 oldscope = PL_scopestack_ix;
1230 if (PERLDB_SUB && PL_curstash != PL_debstash
1231 /* Handle first BEGIN of -d. */
1232 && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
1233 /* Try harder, since this may have been a sighandler, thus
1234 * curstash may be meaningless. */
1235 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != PL_debstash)
1236 && !(flags & G_NODEBUG))
1237 PL_op->op_private |= OPpENTERSUB_DB;
1239 if (!(flags & G_EVAL)) {
1240 /* G_NOCATCH is a hack for perl_vdie using this path to call
1241 a __DIE__ handler */
1242 if (!(flags & G_NOCATCH)) {
1245 call_xbody((OP*)&myop, FALSE);
1246 retval = PL_stack_sp - (PL_stack_base + oldmark);
1247 if (!(flags & G_NOCATCH)) {
1252 cLOGOP->op_other = PL_op;
1254 /* we're trying to emulate pp_entertry() here */
1256 register PERL_CONTEXT *cx;
1257 I32 gimme = GIMME_V;
1262 push_return(PL_op->op_next);
1263 PUSHBLOCK(cx, CXt_EVAL, PL_stack_sp);
1265 PL_eval_root = PL_op; /* Only needed so that goto works right. */
1267 PL_in_eval = EVAL_INEVAL;
1268 if (flags & G_KEEPERR)
1269 PL_in_eval |= EVAL_KEEPERR;
1276 CALLPROTECT(aTHX_ &ret, MEMBER_TO_FPTR(S_call_body), (OP*)&myop, FALSE);
1279 retval = PL_stack_sp - (PL_stack_base + oldmark);
1280 if (!(flags & G_KEEPERR))
1287 /* my_exit() was called */
1288 PL_curstash = PL_defstash;
1291 Perl_croak(aTHX_ "Callback called exit");
1296 PL_op = PL_restartop;
1300 PL_stack_sp = PL_stack_base + oldmark;
1301 if (flags & G_ARRAY)
1305 *++PL_stack_sp = &PL_sv_undef;
1310 if (PL_scopestack_ix > oldscope) {
1314 register PERL_CONTEXT *cx;
1325 if (flags & G_DISCARD) {
1326 PL_stack_sp = PL_stack_base + oldmark;
1336 S_call_body(pTHX_ va_list args)
1338 OP *myop = va_arg(args, OP*);
1339 int is_eval = va_arg(args, int);
1341 call_xbody(myop, is_eval);
1346 S_call_xbody(pTHX_ OP *myop, int is_eval)
1350 if (PL_op == myop) {
1352 PL_op = Perl_pp_entereval(aTHX);
1354 PL_op = Perl_pp_entersub(aTHX);
1360 /* Eval a string. The G_EVAL flag is always assumed. */
1363 Perl_eval_sv(pTHX_ SV *sv, I32 flags)
1365 /* See G_* flags in cop.h */
1368 UNOP myop; /* fake syntax tree node */
1369 I32 oldmark = SP - PL_stack_base;
1375 if (flags & G_DISCARD) {
1382 Zero(PL_op, 1, UNOP);
1383 EXTEND(PL_stack_sp, 1);
1384 *++PL_stack_sp = sv;
1385 oldscope = PL_scopestack_ix;
1387 if (!(flags & G_NOARGS))
1388 myop.op_flags = OPf_STACKED;
1389 myop.op_next = Nullop;
1390 myop.op_type = OP_ENTEREVAL;
1391 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1392 (flags & G_ARRAY) ? OPf_WANT_LIST :
1394 if (flags & G_KEEPERR)
1395 myop.op_flags |= OPf_SPECIAL;
1398 CALLPROTECT(aTHX_ &ret, MEMBER_TO_FPTR(S_call_body), (OP*)&myop, TRUE);
1401 retval = PL_stack_sp - (PL_stack_base + oldmark);
1402 if (!(flags & G_KEEPERR))
1409 /* my_exit() was called */
1410 PL_curstash = PL_defstash;
1413 Perl_croak(aTHX_ "Callback called exit");
1418 PL_op = PL_restartop;
1422 PL_stack_sp = PL_stack_base + oldmark;
1423 if (flags & G_ARRAY)
1427 *++PL_stack_sp = &PL_sv_undef;
1432 if (flags & G_DISCARD) {
1433 PL_stack_sp = PL_stack_base + oldmark;
1443 Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
1446 SV* sv = newSVpv(p, 0);
1449 eval_sv(sv, G_SCALAR);
1456 if (croak_on_error && SvTRUE(ERRSV)) {
1458 Perl_croak(aTHX_ SvPVx(ERRSV, n_a));
1464 /* Require a module. */
1467 Perl_require_pv(pTHX_ const char *pv)
1471 PUSHSTACKi(PERLSI_REQUIRE);
1473 sv = sv_newmortal();
1474 sv_setpv(sv, "require '");
1477 eval_sv(sv, G_DISCARD);
1483 Perl_magicname(pTHX_ char *sym, char *name, I32 namlen)
1487 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1488 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1492 S_usage(pTHX_ char *name) /* XXX move this out into a module ? */
1494 /* This message really ought to be max 23 lines.
1495 * Removed -h because the user already knows that opton. Others? */
1497 static char *usage_msg[] = {
1498 "-0[octal] specify record separator (\\0, if no argument)",
1499 "-a autosplit mode with -n or -p (splits $_ into @F)",
1500 "-c check syntax only (runs BEGIN and END blocks)",
1501 "-d[:debugger] run program under debugger",
1502 "-D[number/list] set debugging flags (argument is a bit mask or alphabets)",
1503 "-e 'command' one line of program (several -e's allowed, omit programfile)",
1504 "-F/pattern/ split() pattern for -a switch (//'s are optional)",
1505 "-i[extension] edit <> files in place (makes backup if extension supplied)",
1506 "-Idirectory specify @INC/#include directory (several -I's allowed)",
1507 "-l[octal] enable line ending processing, specifies line terminator",
1508 "-[mM][-]module execute `use/no module...' before executing program",
1509 "-n assume 'while (<>) { ... }' loop around program",
1510 "-p assume loop like -n but print line also, like sed",
1511 "-P run program through C preprocessor before compilation",
1512 "-s enable rudimentary parsing for switches after programfile",
1513 "-S look for programfile using PATH environment variable",
1514 "-T enable tainting checks",
1515 "-u dump core after parsing program",
1516 "-U allow unsafe operations",
1517 "-v print version, subversion (includes VERY IMPORTANT perl info)",
1518 "-V[:variable] print configuration summary (or a single Config.pm variable)",
1519 "-w enable many useful warnings (RECOMMENDED)",
1520 "-x[directory] strip off text before #!perl line and perhaps cd to directory",
1524 char **p = usage_msg;
1526 printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1528 printf("\n %s", *p++);
1531 /* This routine handles any switches that can be given during run */
1534 Perl_moreswitches(pTHX_ char *s)
1543 rschar = scan_oct(s, 4, &numlen);
1544 SvREFCNT_dec(PL_nrs);
1545 if (rschar & ~((U8)~0))
1546 PL_nrs = &PL_sv_undef;
1547 else if (!rschar && numlen >= 2)
1548 PL_nrs = newSVpvn("", 0);
1551 PL_nrs = newSVpvn(&ch, 1);
1557 PL_splitstr = savepv(s + 1);
1571 if (*s == ':' || *s == '=') {
1572 my_setenv("PERL5DB", Perl_form(aTHX_ "use Devel::%s;", ++s));
1576 PL_perldb = PERLDB_ALL;
1584 if (isALPHA(s[1])) {
1585 static char debopts[] = "psltocPmfrxuLHXDS";
1588 for (s++; *s && (d = strchr(debopts,*s)); s++)
1589 PL_debug |= 1 << (d - debopts);
1592 PL_debug = atoi(s+1);
1593 for (s++; isDIGIT(*s); s++) ;
1595 PL_debug |= 0x80000000;
1598 if (ckWARN_d(WARN_DEBUGGING))
1599 Perl_warner(aTHX_ WARN_DEBUGGING,
1600 "Recompile perl with -DDEBUGGING to use -D switch\n");
1601 for (s++; isALNUM(*s); s++) ;
1607 usage(PL_origargv[0]);
1611 Safefree(PL_inplace);
1612 PL_inplace = savepv(s+1);
1614 for (s = PL_inplace; *s && !isSPACE(*s); s++) ;
1617 if (*s == '-') /* Additional switches on #! line. */
1621 case 'I': /* -I handled both here and in parse_perl() */
1624 while (*s && isSPACE(*s))
1628 for (e = s; *e && !isSPACE(*e); e++) ;
1629 p = savepvn(s, e-s);
1635 Perl_croak(aTHX_ "No space allowed after -I");
1643 PL_ors = savepv("\n");
1645 *PL_ors = scan_oct(s, 3 + (*s == '0'), &numlen);
1650 if (RsPARA(PL_nrs)) {
1655 PL_ors = SvPV(PL_nrs, PL_orslen);
1656 PL_ors = savepvn(PL_ors, PL_orslen);
1660 forbid_setid("-M"); /* XXX ? */
1663 forbid_setid("-m"); /* XXX ? */
1668 /* -M-foo == 'no foo' */
1669 if (*s == '-') { use = "no "; ++s; }
1670 sv = newSVpv(use,0);
1672 /* We allow -M'Module qw(Foo Bar)' */
1673 while(isALNUM(*s) || *s==':') ++s;
1675 sv_catpv(sv, start);
1676 if (*(start-1) == 'm') {
1678 Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
1679 sv_catpv( sv, " ()");
1682 sv_catpvn(sv, start, s-start);
1683 sv_catpv(sv, " split(/,/,q{");
1688 if (PL_preambleav == NULL)
1689 PL_preambleav = newAV();
1690 av_push(PL_preambleav, sv);
1693 Perl_croak(aTHX_ "No space allowed after -%c", *(s-1));
1705 PL_doswitches = TRUE;
1710 Perl_croak(aTHX_ "Too late for \"-T\" option");
1714 PL_do_undump = TRUE;
1722 #if defined(PERL_SUBVERSION) && PERL_SUBVERSION > 0
1723 printf("\nThis is perl, version %d.%03d_%02d built for %s",
1724 PERL_REVISION, PERL_VERSION, PERL_SUBVERSION, ARCHNAME);
1726 printf("\nThis is perl, version %s built for %s",
1727 PL_patchlevel, ARCHNAME);
1729 #if defined(LOCAL_PATCH_COUNT)
1730 if (LOCAL_PATCH_COUNT > 0)
1731 printf("\n(with %d registered patch%s, see perl -V for more detail)",
1732 LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : "");
1735 printf("\n\nCopyright 1987-1999, Larry Wall\n");
1737 printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1740 printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
1741 printf("djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
1744 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1745 "Version 5 port Copyright (c) 1994-1999, Andreas Kaiser, Ilya Zakharevich\n");
1748 printf("atariST series port, ++jrb bammi@cadence.com\n");
1751 printf("BeOS port Copyright Tom Spindler, 1997-1999\n");
1754 printf("MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-1999\n");
1757 printf("MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
1760 printf("Stratus VOS port by Paul_Green@stratus.com, 1997-1999\n");
1763 printf("VM/ESA port by Neale Ferguson, 1998-1999\n");
1766 printf("BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
1769 printf("MiNT port by Guido Flohr, 1997-1999\n");
1771 #ifdef BINARY_BUILD_NOTICE
1772 BINARY_BUILD_NOTICE;
1775 Perl may be copied only under the terms of either the Artistic License or the\n\
1776 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n\
1777 Complete documentation for Perl, including FAQ lists, should be found on\n\
1778 this system using `man perl' or `perldoc perl'. If you have access to the\n\
1779 Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
1782 if (! (PL_dowarn & G_WARN_ALL_MASK))
1783 PL_dowarn |= G_WARN_ON;
1787 PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
1788 PL_compiling.cop_warnings = WARN_ALL ;
1792 PL_dowarn = G_WARN_ALL_OFF;
1793 PL_compiling.cop_warnings = WARN_NONE ;
1798 if (s[1] == '-') /* Additional switches on #! line. */
1803 #if defined(WIN32) || !defined(PERL_STRICT_CR)
1809 #ifdef ALTERNATE_SHEBANG
1810 case 'S': /* OS/2 needs -S on "extproc" line. */
1818 Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
1823 /* compliments of Tom Christiansen */
1825 /* unexec() can be found in the Gnu emacs distribution */
1826 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
1829 Perl_my_unexec(pTHX)
1837 prog = newSVpv(BIN_EXP, 0);
1838 sv_catpv(prog, "/perl");
1839 file = newSVpv(PL_origfilename, 0);
1840 sv_catpv(file, ".perldump");
1842 unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
1843 /* unexec prints msg to stderr in case of failure */
1844 PerlProc_exit(status);
1847 # include <lib$routines.h>
1848 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
1850 ABORT(); /* for use with undump */
1855 /* initialize curinterp */
1860 #ifdef PERL_OBJECT /* XXX kludge */
1863 PL_chopset = " \n-"; \
1864 PL_copline = NOLINE; \
1865 PL_curcop = &PL_compiling;\
1866 PL_curcopdb = NULL; \
1869 PL_dumpindent = 4; \
1870 PL_laststatval = -1; \
1871 PL_laststype = OP_STAT; \
1872 PL_maxscream = -1; \
1873 PL_maxsysfd = MAXSYSFD; \
1874 PL_statname = Nullsv; \
1875 PL_tmps_floor = -1; \
1877 PL_op_mask = NULL; \
1879 PL_laststatval = -1; \
1880 PL_laststype = OP_STAT; \
1881 PL_mess_sv = Nullsv; \
1882 PL_splitstr = " "; \
1883 PL_generation = 100; \
1884 PL_exitlist = NULL; \
1885 PL_exitlistlen = 0; \
1887 PL_in_clean_objs = FALSE; \
1888 PL_in_clean_all = FALSE; \
1889 PL_profiledata = NULL; \
1891 PL_rsfp_filters = Nullav; \
1896 # ifdef MULTIPLICITY
1897 # define PERLVAR(var,type)
1898 # define PERLVARA(var,n,type)
1899 # if defined(PERL_IMPLICIT_CONTEXT)
1900 # if defined(USE_THREADS)
1901 # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
1902 # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
1903 # else /* !USE_THREADS */
1904 # define PERLVARI(var,type,init) aTHX->var = init;
1905 # define PERLVARIC(var,type,init) aTHX->var = init;
1906 # endif /* USE_THREADS */
1908 # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
1909 # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
1911 # include "intrpvar.h"
1912 # ifndef USE_THREADS
1913 # include "thrdvar.h"
1920 # define PERLVAR(var,type)
1921 # define PERLVARA(var,n,type)
1922 # define PERLVARI(var,type,init) PL_##var = init;
1923 # define PERLVARIC(var,type,init) PL_##var = init;
1924 # include "intrpvar.h"
1925 # ifndef USE_THREADS
1926 # include "thrdvar.h"
1938 S_init_main_stash(pTHX)
1943 /* Note that strtab is a rather special HV. Assumptions are made
1944 about not iterating on it, and not adding tie magic to it.
1945 It is properly deallocated in perl_destruct() */
1946 PL_strtab = newHV();
1948 MUTEX_INIT(&PL_strtab_mutex);
1950 HvSHAREKEYS_off(PL_strtab); /* mandatory */
1951 hv_ksplit(PL_strtab, 512);
1953 PL_curstash = PL_defstash = newHV();
1954 PL_curstname = newSVpvn("main",4);
1955 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1956 SvREFCNT_dec(GvHV(gv));
1957 GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
1959 HvNAME(PL_defstash) = savepv("main");
1960 PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1961 GvMULTI_on(PL_incgv);
1962 PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
1963 GvMULTI_on(PL_hintgv);
1964 PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1965 PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1966 GvMULTI_on(PL_errgv);
1967 PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
1968 GvMULTI_on(PL_replgv);
1969 (void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */
1970 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
1971 sv_setpvn(ERRSV, "", 0);
1972 PL_curstash = PL_defstash;
1973 PL_compiling.cop_stash = PL_defstash;
1974 PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
1975 PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
1976 /* We must init $/ before switches are processed. */
1977 sv_setpvn(get_sv("/", TRUE), "\n", 1);
1981 S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
1989 PL_origfilename = savepv("-e");
1992 /* if find_script() returns, it returns a malloc()-ed value */
1993 PL_origfilename = scriptname = find_script(scriptname, dosearch, NULL, 1);
1995 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
1996 char *s = scriptname + 8;
1997 *fdscript = atoi(s);
2001 scriptname = savepv(s + 1);
2002 Safefree(PL_origfilename);
2003 PL_origfilename = scriptname;
2008 PL_curcop->cop_filegv = gv_fetchfile(PL_origfilename);
2009 if (strEQ(PL_origfilename,"-"))
2011 if (*fdscript >= 0) {
2012 PL_rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE);
2013 #if defined(HAS_FCNTL) && defined(F_SETFD)
2015 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); /* ensure close-on-exec */
2018 else if (PL_preprocess) {
2019 char *cpp_cfg = CPPSTDIN;
2020 SV *cpp = newSVpvn("",0);
2021 SV *cmd = NEWSV(0,0);
2023 if (strEQ(cpp_cfg, "cppstdin"))
2024 Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
2025 sv_catpv(cpp, cpp_cfg);
2028 sv_catpv(sv,PRIVLIB_EXP);
2031 Perl_sv_setpvf(aTHX_ cmd, "\
2032 sed %s -e \"/^[^#]/b\" \
2033 -e \"/^#[ ]*include[ ]/b\" \
2034 -e \"/^#[ ]*define[ ]/b\" \
2035 -e \"/^#[ ]*if[ ]/b\" \
2036 -e \"/^#[ ]*ifdef[ ]/b\" \
2037 -e \"/^#[ ]*ifndef[ ]/b\" \
2038 -e \"/^#[ ]*else/b\" \
2039 -e \"/^#[ ]*elif[ ]/b\" \
2040 -e \"/^#[ ]*undef[ ]/b\" \
2041 -e \"/^#[ ]*endif/b\" \
2044 (PL_doextract ? "-e \"1,/^#/d\n\"" : ""),
2047 Perl_sv_setpvf(aTHX_ cmd, "\
2048 %s %s -e '/^[^#]/b' \
2049 -e '/^#[ ]*include[ ]/b' \
2050 -e '/^#[ ]*define[ ]/b' \
2051 -e '/^#[ ]*if[ ]/b' \
2052 -e '/^#[ ]*ifdef[ ]/b' \
2053 -e '/^#[ ]*ifndef[ ]/b' \
2054 -e '/^#[ ]*else/b' \
2055 -e '/^#[ ]*elif[ ]/b' \
2056 -e '/^#[ ]*undef[ ]/b' \
2057 -e '/^#[ ]*endif/b' \
2061 Perl_sv_setpvf(aTHX_ cmd, "\
2062 %s %s -e '/^[^#]/b' \
2063 -e '/^#[ ]*include[ ]/b' \
2064 -e '/^#[ ]*define[ ]/b' \
2065 -e '/^#[ ]*if[ ]/b' \
2066 -e '/^#[ ]*ifdef[ ]/b' \
2067 -e '/^#[ ]*ifndef[ ]/b' \
2068 -e '/^#[ ]*else/b' \
2069 -e '/^#[ ]*elif[ ]/b' \
2070 -e '/^#[ ]*undef[ ]/b' \
2071 -e '/^#[ ]*endif/b' \
2080 (PL_doextract ? "-e '1,/^#/d\n'" : ""),
2082 scriptname, cpp, sv, CPPMINUS);
2083 PL_doextract = FALSE;
2084 #ifdef IAMSUID /* actually, this is caught earlier */
2085 if (PL_euid != PL_uid && !PL_euid) { /* if running suidperl */
2087 (void)seteuid(PL_uid); /* musn't stay setuid root */
2090 (void)setreuid((Uid_t)-1, PL_uid);
2092 #ifdef HAS_SETRESUID
2093 (void)setresuid((Uid_t)-1, PL_uid, (Uid_t)-1);
2095 PerlProc_setuid(PL_uid);
2099 if (PerlProc_geteuid() != PL_uid)
2100 Perl_croak(aTHX_ "Can't do seteuid!\n");
2102 #endif /* IAMSUID */
2103 PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
2107 else if (!*scriptname) {
2108 forbid_setid("program input from stdin");
2109 PL_rsfp = PerlIO_stdin();
2112 PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
2113 #if defined(HAS_FCNTL) && defined(F_SETFD)
2115 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); /* ensure close-on-exec */
2120 #ifndef IAMSUID /* in case script is not readable before setuid */
2122 PerlLIO_stat(SvPVX(GvSV(PL_curcop->cop_filegv)),&PL_statbuf) >= 0 &&
2123 PL_statbuf.st_mode & (S_ISUID|S_ISGID))
2126 PerlProc_execv(Perl_form(aTHX_ "%s/sperl%s", BIN_EXP, PL_patchlevel), PL_origargv);
2127 Perl_croak(aTHX_ "Can't do setuid\n");
2131 Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
2132 SvPVX(GvSV(PL_curcop->cop_filegv)), Strerror(errno));
2137 * I_SYSSTATVFS HAS_FSTATVFS
2139 * I_STATFS HAS_FSTATFS
2140 * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT
2141 * here so that metaconfig picks them up. */
2145 S_fd_on_nosuid_fs(pTHX_ int fd)
2150 * Preferred order: fstatvfs(), fstatfs(), getmntent().
2151 * fstatvfs() is UNIX98.
2153 * getmntent() is O(number-of-mounted-filesystems) and can hang.
2156 # ifdef HAS_FSTATVFS
2157 struct statvfs stfs;
2158 check_okay = fstatvfs(fd, &stfs) == 0;
2159 on_nosuid = check_okay && (stfs.f_flag & ST_NOSUID);
2161 # if defined(HAS_FSTATFS) && defined(HAS_STRUCT_STATFS_FLAGS)
2163 check_okay = fstatfs(fd, &stfs) == 0;
2164 # undef PERL_MOUNT_NOSUID
2165 # if !defined(PERL_MOUNT_NOSUID) && defined(MNT_NOSUID)
2166 # define PERL_MOUNT_NOSUID MNT_NOSUID
2168 # if !defined(PERL_MOUNT_NOSUID) && defined(MS_NOSUID)
2169 # define PERL_MOUNT_NOSUID MS_NOSUID
2171 # if !defined(PERL_MOUNT_NOSUID) && defined(M_NOSUID)
2172 # define PERL_MOUNT_NOSUID M_NOSUID
2174 # ifdef PERL_MOUNT_NOSUID
2175 on_nosuid = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
2178 # if defined(HAS_GETMNTENT) && defined(HAS_HASMNTOPT) && defined(MNTOPT_NOSUID)
2179 FILE *mtab = fopen("/etc/mtab", "r");
2180 struct mntent *entry;
2181 struct stat stb, fsb;
2183 if (mtab && (fstat(fd, &stb) == 0)) {
2184 while (entry = getmntent(mtab)) {
2185 if (stat(entry->mnt_dir, &fsb) == 0
2186 && fsb.st_dev == stb.st_dev)
2188 /* found the filesystem */
2190 if (hasmntopt(entry, MNTOPT_NOSUID))
2193 } /* A single fs may well fail its stat(). */
2198 # endif /* mntent */
2199 # endif /* statfs */
2200 # endif /* statvfs */
2202 Perl_croak(aTHX_ "Can't check filesystem of script \"%s\"", PL_origfilename);
2205 #endif /* IAMSUID */
2208 S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript)
2212 /* do we need to emulate setuid on scripts? */
2214 /* This code is for those BSD systems that have setuid #! scripts disabled
2215 * in the kernel because of a security problem. Merely defining DOSUID
2216 * in perl will not fix that problem, but if you have disabled setuid
2217 * scripts in the kernel, this will attempt to emulate setuid and setgid
2218 * on scripts that have those now-otherwise-useless bits set. The setuid
2219 * root version must be called suidperl or sperlN.NNN. If regular perl
2220 * discovers that it has opened a setuid script, it calls suidperl with
2221 * the same argv that it had. If suidperl finds that the script it has
2222 * just opened is NOT setuid root, it sets the effective uid back to the
2223 * uid. We don't just make perl setuid root because that loses the
2224 * effective uid we had before invoking perl, if it was different from the
2227 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
2228 * be defined in suidperl only. suidperl must be setuid root. The
2229 * Configure script will set this up for you if you want it.
2236 if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */
2237 Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
2238 if (fdscript < 0 && PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
2243 #ifndef HAS_SETREUID
2244 /* On this access check to make sure the directories are readable,
2245 * there is actually a small window that the user could use to make
2246 * filename point to an accessible directory. So there is a faint
2247 * chance that someone could execute a setuid script down in a
2248 * non-accessible directory. I don't know what to do about that.
2249 * But I don't think it's too important. The manual lies when
2250 * it says access() is useful in setuid programs.
2252 if (PerlLIO_access(SvPVX(GvSV(PL_curcop->cop_filegv)),1)) /*double check*/
2253 Perl_croak(aTHX_ "Permission denied");
2255 /* If we can swap euid and uid, then we can determine access rights
2256 * with a simple stat of the file, and then compare device and
2257 * inode to make sure we did stat() on the same file we opened.
2258 * Then we just have to make sure he or she can execute it.
2261 struct stat tmpstatbuf;
2265 setreuid(PL_euid,PL_uid) < 0
2268 setresuid(PL_euid,PL_uid,(Uid_t)-1) < 0
2271 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
2272 Perl_croak(aTHX_ "Can't swap uid and euid"); /* really paranoid */
2273 if (PerlLIO_stat(SvPVX(GvSV(PL_curcop->cop_filegv)),&tmpstatbuf) < 0)
2274 Perl_croak(aTHX_ "Permission denied"); /* testing full pathname here */
2275 #if defined(IAMSUID) && !defined(NO_NOSUID_CHECK)
2276 if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp)))
2277 Perl_croak(aTHX_ "Permission denied");
2279 if (tmpstatbuf.st_dev != PL_statbuf.st_dev ||
2280 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
2281 (void)PerlIO_close(PL_rsfp);
2282 if (PL_rsfp = PerlProc_popen("/bin/mail root","w")) { /* heh, heh */
2283 PerlIO_printf(PL_rsfp,
2284 "User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2285 (Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
2286 (long)PL_uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
2287 (long)PL_statbuf.st_dev, (long)PL_statbuf.st_ino,
2288 SvPVX(GvSV(PL_curcop->cop_filegv)),
2289 (long)PL_statbuf.st_uid, (long)PL_statbuf.st_gid);
2290 (void)PerlProc_pclose(PL_rsfp);
2292 Perl_croak(aTHX_ "Permission denied\n");
2296 setreuid(PL_uid,PL_euid) < 0
2298 # if defined(HAS_SETRESUID)
2299 setresuid(PL_uid,PL_euid,(Uid_t)-1) < 0
2302 || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
2303 Perl_croak(aTHX_ "Can't reswap uid and euid");
2304 if (!cando(S_IXUSR,FALSE,&PL_statbuf)) /* can real uid exec? */
2305 Perl_croak(aTHX_ "Permission denied\n");
2307 #endif /* HAS_SETREUID */
2308 #endif /* IAMSUID */
2310 if (!S_ISREG(PL_statbuf.st_mode))
2311 Perl_croak(aTHX_ "Permission denied");
2312 if (PL_statbuf.st_mode & S_IWOTH)
2313 Perl_croak(aTHX_ "Setuid/gid script is writable by world");
2314 PL_doswitches = FALSE; /* -s is insecure in suid */
2315 PL_curcop->cop_line++;
2316 if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
2317 strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */
2318 Perl_croak(aTHX_ "No #! line");
2319 s = SvPV(PL_linestr,n_a)+2;
2321 while (!isSPACE(*s)) s++;
2322 for (s2 = s; (s2 > SvPV(PL_linestr,n_a)+2 &&
2323 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
2324 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
2325 Perl_croak(aTHX_ "Not a perl script");
2326 while (*s == ' ' || *s == '\t') s++;
2328 * #! arg must be what we saw above. They can invoke it by
2329 * mentioning suidperl explicitly, but they may not add any strange
2330 * arguments beyond what #! says if they do invoke suidperl that way.
2332 len = strlen(validarg);
2333 if (strEQ(validarg," PHOOEY ") ||
2334 strnNE(s,validarg,len) || !isSPACE(s[len]))
2335 Perl_croak(aTHX_ "Args must match #! line");
2338 if (PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
2339 PL_euid == PL_statbuf.st_uid)
2341 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2342 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2343 #endif /* IAMSUID */
2345 if (PL_euid) { /* oops, we're not the setuid root perl */
2346 (void)PerlIO_close(PL_rsfp);
2349 PerlProc_execv(Perl_form(aTHX_ "%s/sperl%s", BIN_EXP, PL_patchlevel), PL_origargv);
2351 Perl_croak(aTHX_ "Can't do setuid\n");
2354 if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
2356 (void)setegid(PL_statbuf.st_gid);
2359 (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
2361 #ifdef HAS_SETRESGID
2362 (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
2364 PerlProc_setgid(PL_statbuf.st_gid);
2368 if (PerlProc_getegid() != PL_statbuf.st_gid)
2369 Perl_croak(aTHX_ "Can't do setegid!\n");
2371 if (PL_statbuf.st_mode & S_ISUID) {
2372 if (PL_statbuf.st_uid != PL_euid)
2374 (void)seteuid(PL_statbuf.st_uid); /* all that for this */
2377 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
2379 #ifdef HAS_SETRESUID
2380 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
2382 PerlProc_setuid(PL_statbuf.st_uid);
2386 if (PerlProc_geteuid() != PL_statbuf.st_uid)
2387 Perl_croak(aTHX_ "Can't do seteuid!\n");
2389 else if (PL_uid) { /* oops, mustn't run as root */
2391 (void)seteuid((Uid_t)PL_uid);
2394 (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
2396 #ifdef HAS_SETRESUID
2397 (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
2399 PerlProc_setuid((Uid_t)PL_uid);
2403 if (PerlProc_geteuid() != PL_uid)
2404 Perl_croak(aTHX_ "Can't do seteuid!\n");
2407 if (!cando(S_IXUSR,TRUE,&PL_statbuf))
2408 Perl_croak(aTHX_ "Permission denied\n"); /* they can't do this */
2411 else if (PL_preprocess)
2412 Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
2413 else if (fdscript >= 0)
2414 Perl_croak(aTHX_ "fd script not allowed in suidperl\n");
2416 Perl_croak(aTHX_ "Script is not setuid/setgid in suidperl\n");
2418 /* We absolutely must clear out any saved ids here, so we */
2419 /* exec the real perl, substituting fd script for scriptname. */
2420 /* (We pass script name as "subdir" of fd, which perl will grok.) */
2421 PerlIO_rewind(PL_rsfp);
2422 PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0); /* just in case rewind didn't */
2423 for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
2424 if (!PL_origargv[which])
2425 Perl_croak(aTHX_ "Permission denied");
2426 PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
2427 PerlIO_fileno(PL_rsfp), PL_origargv[which]));
2428 #if defined(HAS_FCNTL) && defined(F_SETFD)
2429 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */
2431 PerlProc_execv(Perl_form(aTHX_ "%s/perl%s", BIN_EXP, PL_patchlevel), PL_origargv);/* try again */
2432 Perl_croak(aTHX_ "Can't do setuid\n");
2433 #endif /* IAMSUID */
2435 if (PL_euid != PL_uid || PL_egid != PL_gid) { /* (suidperl doesn't exist, in fact) */
2436 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2438 PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf); /* may be either wrapped or real suid */
2439 if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
2441 (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
2444 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2445 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2446 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2447 /* not set-id, must be wrapped */
2453 S_find_beginning(pTHX)
2455 register char *s, *s2;
2457 /* skip forward in input to the real script? */
2460 while (PL_doextract) {
2461 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
2462 Perl_croak(aTHX_ "No Perl script found in input\n");
2463 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2464 PerlIO_ungetc(PL_rsfp, '\n'); /* to keep line count right */
2465 PL_doextract = FALSE;
2466 while (*s && !(isSPACE (*s) || *s == '#')) s++;
2468 while (*s == ' ' || *s == '\t') s++;
2470 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2471 if (strnEQ(s2-4,"perl",4))
2473 while (s = moreswitches(s)) ;
2475 if (PL_cddir && PerlDir_chdir(PL_cddir) < 0)
2476 Perl_croak(aTHX_ "Can't chdir to %s",PL_cddir);
2485 PL_uid = PerlProc_getuid();
2486 PL_euid = PerlProc_geteuid();
2487 PL_gid = PerlProc_getgid();
2488 PL_egid = PerlProc_getegid();
2490 PL_uid |= PL_gid << 16;
2491 PL_euid |= PL_egid << 16;
2493 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2497 S_forbid_setid(pTHX_ char *s)
2499 if (PL_euid != PL_uid)
2500 Perl_croak(aTHX_ "No %s allowed while running setuid", s);
2501 if (PL_egid != PL_gid)
2502 Perl_croak(aTHX_ "No %s allowed while running setgid", s);
2506 Perl_init_debugger(pTHX)
2509 HV *ostash = PL_curstash;
2511 PL_curstash = PL_debstash;
2512 PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2513 AvREAL_off(PL_dbargs);
2514 PL_DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2515 PL_DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2516 PL_DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2517 sv_upgrade(GvSV(PL_DBsub), SVt_IV); /* IVX accessed if PERLDB_SUB_NN */
2518 PL_DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2519 sv_setiv(PL_DBsingle, 0);
2520 PL_DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2521 sv_setiv(PL_DBtrace, 0);
2522 PL_DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2523 sv_setiv(PL_DBsignal, 0);
2524 PL_curstash = ostash;
2527 #ifndef STRESS_REALLOC
2528 #define REASONABLE(size) (size)
2530 #define REASONABLE(size) (1) /* unreasonable */
2534 Perl_init_stacks(pTHX)
2536 /* start with 128-item stack and 8K cxstack */
2537 PL_curstackinfo = new_stackinfo(REASONABLE(128),
2538 REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
2539 PL_curstackinfo->si_type = PERLSI_MAIN;
2540 PL_curstack = PL_curstackinfo->si_stack;
2541 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
2543 PL_stack_base = AvARRAY(PL_curstack);
2544 PL_stack_sp = PL_stack_base;
2545 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
2547 New(50,PL_tmps_stack,REASONABLE(128),SV*);
2550 PL_tmps_max = REASONABLE(128);
2552 New(54,PL_markstack,REASONABLE(32),I32);
2553 PL_markstack_ptr = PL_markstack;
2554 PL_markstack_max = PL_markstack + REASONABLE(32);
2558 New(54,PL_scopestack,REASONABLE(32),I32);
2559 PL_scopestack_ix = 0;
2560 PL_scopestack_max = REASONABLE(32);
2562 New(54,PL_savestack,REASONABLE(128),ANY);
2563 PL_savestack_ix = 0;
2564 PL_savestack_max = REASONABLE(128);
2566 New(54,PL_retstack,REASONABLE(16),OP*);
2568 PL_retstack_max = REASONABLE(16);
2577 while (PL_curstackinfo->si_next)
2578 PL_curstackinfo = PL_curstackinfo->si_next;
2579 while (PL_curstackinfo) {
2580 PERL_SI *p = PL_curstackinfo->si_prev;
2581 /* curstackinfo->si_stack got nuked by sv_free_arenas() */
2582 Safefree(PL_curstackinfo->si_cxstack);
2583 Safefree(PL_curstackinfo);
2584 PL_curstackinfo = p;
2586 Safefree(PL_tmps_stack);
2587 Safefree(PL_markstack);
2588 Safefree(PL_scopestack);
2589 Safefree(PL_savestack);
2590 Safefree(PL_retstack);
2592 Safefree(PL_debname);
2593 Safefree(PL_debdelim);
2598 static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
2609 lex_start(PL_linestr);
2611 PL_subname = newSVpvn("main",4);
2615 S_init_predump_symbols(pTHX)
2622 sv_setpvn(get_sv("\"", TRUE), " ", 1);
2623 PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2624 GvMULTI_on(PL_stdingv);
2625 io = GvIOp(PL_stdingv);
2626 IoIFP(io) = PerlIO_stdin();
2627 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2629 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
2631 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2634 IoOFP(io) = IoIFP(io) = PerlIO_stdout();
2636 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2638 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
2640 PL_stderrgv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2641 GvMULTI_on(PL_stderrgv);
2642 io = GvIOp(PL_stderrgv);
2643 IoOFP(io) = IoIFP(io) = PerlIO_stderr();
2644 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2646 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
2648 PL_statname = NEWSV(66,0); /* last filename we did stat on */
2651 PL_osname = savepv(OSNAME);
2655 S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
2662 argc--,argv++; /* skip name of script */
2663 if (PL_doswitches) {
2664 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2667 if (argv[0][1] == '-') {
2671 if (s = strchr(argv[0], '=')) {
2673 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2676 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2679 PL_toptarget = NEWSV(0,0);
2680 sv_upgrade(PL_toptarget, SVt_PVFM);
2681 sv_setpvn(PL_toptarget, "", 0);
2682 PL_bodytarget = NEWSV(0,0);
2683 sv_upgrade(PL_bodytarget, SVt_PVFM);
2684 sv_setpvn(PL_bodytarget, "", 0);
2685 PL_formtarget = PL_bodytarget;
2688 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2689 sv_setpv(GvSV(tmpgv),PL_origfilename);
2690 magicname("0", "0", 1);
2692 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2693 sv_setpv(GvSV(tmpgv),PL_origargv[0]);
2694 if (PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2695 GvMULTI_on(PL_argvgv);
2696 (void)gv_AVadd(PL_argvgv);
2697 av_clear(GvAVn(PL_argvgv));
2698 for (; argc > 0; argc--,argv++) {
2699 av_push(GvAVn(PL_argvgv),newSVpv(argv[0],0));
2702 if (PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2704 GvMULTI_on(PL_envgv);
2705 hv = GvHVn(PL_envgv);
2706 hv_magic(hv, PL_envgv, 'E');
2707 #if !defined( VMS) && !defined(EPOC) /* VMS doesn't have environ array */
2708 /* Note that if the supplied env parameter is actually a copy
2709 of the global environ then it may now point to free'd memory
2710 if the environment has been modified since. To avoid this
2711 problem we treat env==NULL as meaning 'use the default'
2716 environ[0] = Nullch;
2717 for (; *env; env++) {
2718 if (!(s = strchr(*env,'=')))
2724 sv = newSVpv(s--,0);
2725 (void)hv_store(hv, *env, s - *env, sv, 0);
2727 #if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
2728 /* Sins of the RTL. See note in my_setenv(). */
2729 (void)PerlEnv_putenv(savepv(*env));
2733 #ifdef DYNAMIC_ENV_FETCH
2734 HvNAME(hv) = savepv(ENV_HV_NAME);
2738 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2739 sv_setiv(GvSV(tmpgv), (IV)getpid());
2743 S_init_perllib(pTHX)
2748 s = PerlEnv_getenv("PERL5LIB");
2752 incpush(PerlEnv_getenv("PERLLIB"), FALSE);
2754 /* Treat PERL5?LIB as a possible search list logical name -- the
2755 * "natural" VMS idiom for a Unix path string. We allow each
2756 * element to be a set of |-separated directories for compatibility.
2760 if (my_trnlnm("PERL5LIB",buf,0))
2761 do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2763 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2767 /* Use the ~-expanded versions of APPLLIB (undocumented),
2768 ARCHLIB PRIVLIB SITEARCH and SITELIB
2771 incpush(APPLLIB_EXP, TRUE);
2775 incpush(ARCHLIB_EXP, FALSE);
2778 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2781 incpush(PRIVLIB_EXP, TRUE);
2783 incpush(PRIVLIB_EXP, FALSE);
2787 incpush(SITEARCH_EXP, FALSE);
2791 incpush(SITELIB_EXP, TRUE);
2793 incpush(SITELIB_EXP, FALSE);
2796 #if defined(PERL_VENDORLIB_EXP)
2798 incpush(PERL_VENDORLIB_EXP, TRUE);
2800 incpush(PERL_VENDORLIB_EXP, FALSE);
2804 incpush(".", FALSE);
2808 # define PERLLIB_SEP ';'
2811 # define PERLLIB_SEP '|'
2813 # define PERLLIB_SEP ':'
2816 #ifndef PERLLIB_MANGLE
2817 # define PERLLIB_MANGLE(s,n) (s)
2821 S_incpush(pTHX_ char *p, int addsubdirs)
2823 SV *subdir = Nullsv;
2829 subdir = sv_newmortal();
2830 if (!PL_archpat_auto) {
2831 STRLEN len = (sizeof(ARCHNAME) + strlen(PL_patchlevel)
2832 + sizeof("//auto"));
2833 New(55, PL_archpat_auto, len, char);
2834 sprintf(PL_archpat_auto, "/%s/%s/auto", ARCHNAME, PL_patchlevel);
2836 for (len = sizeof(ARCHNAME) + 2;
2837 PL_archpat_auto[len] != '\0' && PL_archpat_auto[len] != '/'; len++)
2838 if (PL_archpat_auto[len] == '.') PL_archpat_auto[len] = '_';
2843 /* Break at all separators */
2845 SV *libdir = NEWSV(55,0);
2848 /* skip any consecutive separators */
2849 while ( *p == PERLLIB_SEP ) {
2850 /* Uncomment the next line for PATH semantics */
2851 /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */
2855 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2856 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2861 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2862 p = Nullch; /* break out */
2866 * BEFORE pushing libdir onto @INC we may first push version- and
2867 * archname-specific sub-directories.
2870 struct stat tmpstatbuf;
2875 if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) {
2877 while (unix[len-1] == '/') len--; /* Cosmetic */
2878 sv_usepvn(libdir,unix,len);
2881 PerlIO_printf(Perl_error_log,
2882 "Failed to unixify @INC element \"%s\"\n",
2885 /* .../archname/version if -d .../archname/version/auto */
2886 sv_setsv(subdir, libdir);
2887 sv_catpv(subdir, PL_archpat_auto);
2888 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2889 S_ISDIR(tmpstatbuf.st_mode))
2890 av_push(GvAVn(PL_incgv),
2891 newSVpvn(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2893 /* .../archname if -d .../archname/auto */
2894 sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
2895 strlen(PL_patchlevel) + 1, "", 0);
2896 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2897 S_ISDIR(tmpstatbuf.st_mode))
2898 av_push(GvAVn(PL_incgv),
2899 newSVpvn(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2902 /* finally push this lib directory on the end of @INC */
2903 av_push(GvAVn(PL_incgv), libdir);
2908 STATIC struct perl_thread *
2909 S_init_main_thread(pTHX)
2911 #if !defined(PERL_IMPLICIT_CONTEXT)
2912 struct perl_thread *thr;
2916 Newz(53, thr, 1, struct perl_thread);
2917 PL_curcop = &PL_compiling;
2918 thr->interp = PERL_GET_INTERP;
2919 thr->cvcache = newHV();
2920 thr->threadsv = newAV();
2921 /* thr->threadsvp is set when find_threadsv is called */
2922 thr->specific = newAV();
2923 thr->flags = THRf_R_JOINABLE;
2924 MUTEX_INIT(&thr->mutex);
2925 /* Handcraft thrsv similarly to mess_sv */
2926 New(53, PL_thrsv, 1, SV);
2927 Newz(53, xpv, 1, XPV);
2928 SvFLAGS(PL_thrsv) = SVt_PV;
2929 SvANY(PL_thrsv) = (void*)xpv;
2930 SvREFCNT(PL_thrsv) = 1 << 30; /* practically infinite */
2931 SvPVX(PL_thrsv) = (char*)thr;
2932 SvCUR_set(PL_thrsv, sizeof(thr));
2933 SvLEN_set(PL_thrsv, sizeof(thr));
2934 *SvEND(PL_thrsv) = '\0'; /* in the trailing_nul field */
2935 thr->oursv = PL_thrsv;
2936 PL_chopset = " \n-";
2939 MUTEX_LOCK(&PL_threads_mutex);
2944 MUTEX_UNLOCK(&PL_threads_mutex);
2946 #ifdef HAVE_THREAD_INTERN
2947 Perl_init_thread_intern(thr);
2950 #ifdef SET_THREAD_SELF
2951 SET_THREAD_SELF(thr);
2953 thr->self = pthread_self();
2954 #endif /* SET_THREAD_SELF */
2958 * These must come after the SET_THR because sv_setpvn does
2959 * SvTAINT and the taint fields require dTHR.
2961 PL_toptarget = NEWSV(0,0);
2962 sv_upgrade(PL_toptarget, SVt_PVFM);
2963 sv_setpvn(PL_toptarget, "", 0);
2964 PL_bodytarget = NEWSV(0,0);
2965 sv_upgrade(PL_bodytarget, SVt_PVFM);
2966 sv_setpvn(PL_bodytarget, "", 0);
2967 PL_formtarget = PL_bodytarget;
2968 thr->errsv = newSVpvn("", 0);
2969 (void) find_threadsv("@"); /* Ensure $@ is initialised early */
2972 PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
2973 PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
2974 PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
2975 PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
2976 PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
2978 PL_reginterp_cnt = 0;
2982 #endif /* USE_THREADS */
2985 Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
2989 line_t oldline = PL_curcop->cop_line;
2994 while (AvFILL(paramList) >= 0) {
2995 cv = (CV*)av_shift(paramList);
2997 CALLPROTECT(aTHX_ &ret, MEMBER_TO_FPTR(S_call_list_body), cv);
3000 (void)SvPV(atsv, len);
3002 PL_curcop = &PL_compiling;
3003 PL_curcop->cop_line = oldline;
3004 if (paramList == PL_beginav)
3005 sv_catpv(atsv, "BEGIN failed--compilation aborted");
3007 sv_catpv(atsv, "END failed--cleanup aborted");
3008 while (PL_scopestack_ix > oldscope)
3010 Perl_croak(aTHX_ "%s", SvPVX(atsv));
3017 /* my_exit() was called */
3018 while (PL_scopestack_ix > oldscope)
3021 PL_curstash = PL_defstash;
3022 if (PL_endav && !PL_minus_c)
3023 call_list(oldscope, PL_endav);
3024 PL_curcop = &PL_compiling;
3025 PL_curcop->cop_line = oldline;
3026 if (PL_statusvalue) {
3027 if (paramList == PL_beginav)
3028 Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
3030 Perl_croak(aTHX_ "END failed--cleanup aborted");
3036 PL_curcop = &PL_compiling;
3037 PL_curcop->cop_line = oldline;
3040 PerlIO_printf(Perl_error_log, "panic: restartop\n");
3048 S_call_list_body(pTHX_ va_list args)
3051 CV *cv = va_arg(args, CV*);
3053 PUSHMARK(PL_stack_sp);
3054 call_sv((SV*)cv, G_EVAL|G_DISCARD);
3059 Perl_my_exit(pTHX_ U32 status)
3063 DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
3064 thr, (unsigned long) status));
3073 STATUS_NATIVE_SET(status);
3080 Perl_my_failure_exit(pTHX)
3083 if (vaxc$errno & 1) {
3084 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
3085 STATUS_NATIVE_SET(44);
3088 if (!vaxc$errno && errno) /* unlikely */
3089 STATUS_NATIVE_SET(44);
3091 STATUS_NATIVE_SET(vaxc$errno);
3096 STATUS_POSIX_SET(errno);
3098 exitstatus = STATUS_POSIX >> 8;
3099 if (exitstatus & 255)
3100 STATUS_POSIX_SET(exitstatus);
3102 STATUS_POSIX_SET(255);
3109 S_my_exit_jump(pTHX)
3112 register PERL_CONTEXT *cx;
3117 SvREFCNT_dec(PL_e_script);
3118 PL_e_script = Nullsv;
3121 POPSTACK_TO(PL_mainstack);
3122 if (cxstack_ix >= 0) {
3125 POPBLOCK(cx,PL_curpm);
3138 read_e_script(pTHXo_ int idx, SV *buf_sv, int maxlen)
3141 p = SvPVX(PL_e_script);
3142 nl = strchr(p, '\n');
3143 nl = (nl) ? nl+1 : SvEND(PL_e_script);
3145 filter_del(read_e_script);
3148 sv_catpvn(buf_sv, p, nl-p);
3149 sv_chop(PL_e_script, nl);