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 = NULL;
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)
598 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
601 Perl_croak(aTHX_ "suidperl is no longer needed since the kernel can now execute\n\
602 setuid perl scripts securely.\n");
606 #if defined(__DYNAMIC__) && (defined(NeXT) || defined(__NeXT__))
607 _dyld_lookup_and_bind
608 ("__environ", (unsigned long *) &environ_pointer, NULL);
613 #ifndef VMS /* VMS doesn't have environ array */
614 PL_origenviron = environ;
619 /* Come here if running an undumped a.out. */
621 PL_origfilename = savepv(argv[0]);
622 PL_do_undump = FALSE;
623 cxstack_ix = -1; /* start label stack again */
625 init_postdump_symbols(argc,argv,env);
630 PL_curpad = AvARRAY(PL_comppad);
631 op_free(PL_main_root);
632 PL_main_root = Nullop;
634 PL_main_start = Nullop;
635 SvREFCNT_dec(PL_main_cv);
639 oldscope = PL_scopestack_ix;
640 PL_dowarn = G_WARN_OFF;
642 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_parse_body),
651 /* my_exit() was called */
652 while (PL_scopestack_ix > oldscope)
655 PL_curstash = PL_defstash;
656 if (PL_endav && !PL_minus_c)
657 call_list(oldscope, PL_endav);
658 return STATUS_NATIVE_EXPORT;
660 PerlIO_printf(Perl_error_log, "panic: top_env\n");
667 S_parse_body(pTHX_ va_list args)
670 int argc = PL_origargc;
671 char **argv = PL_origargv;
672 char **env = va_arg(args, char**);
673 char *scriptname = NULL;
675 VOL bool dosearch = FALSE;
681 XSINIT_t xsinit = va_arg(args, XSINIT_t);
683 sv_setpvn(PL_linestr,"",0);
684 sv = newSVpvn("",0); /* first used for -I flags */
688 for (argc--,argv++; argc > 0; argc--,argv++) {
689 if (argv[0][0] != '-' || !argv[0][1])
693 validarg = " PHOOEY ";
700 #ifndef PERL_STRICT_CR
724 if (s = moreswitches(s))
734 if (PL_euid != PL_uid || PL_egid != PL_gid)
735 Perl_croak(aTHX_ "No -e allowed in setuid scripts");
737 PL_e_script = newSVpvn("",0);
738 filter_add(read_e_script, NULL);
741 sv_catpv(PL_e_script, s);
743 sv_catpv(PL_e_script, argv[1]);
747 Perl_croak(aTHX_ "No code specified for -e");
748 sv_catpv(PL_e_script, "\n");
751 case 'I': /* -I handled both here and in moreswitches() */
753 if (!*++s && (s=argv[1]) != Nullch) {
756 while (s && isSPACE(*s))
760 for (e = s; *e && !isSPACE(*e); e++) ;
767 } /* XXX else croak? */
771 PL_preprocess = TRUE;
781 PL_preambleav = newAV();
782 av_push(PL_preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
784 PL_Sv = newSVpv("print myconfig();",0);
786 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
788 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
790 #if defined(DEBUGGING) || defined(MULTIPLICITY)
791 sv_catpv(PL_Sv,"\" Compile-time options:");
793 sv_catpv(PL_Sv," DEBUGGING");
796 sv_catpv(PL_Sv," MULTIPLICITY");
798 sv_catpv(PL_Sv,"\\n\",");
800 #if defined(LOCAL_PATCH_COUNT)
801 if (LOCAL_PATCH_COUNT > 0) {
803 sv_catpv(PL_Sv,"\" Locally applied patches:\\n\",");
804 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
805 if (PL_localpatches[i])
806 Perl_sv_catpvf(aTHX_ PL_Sv,"q\" \t%s\n\",",PL_localpatches[i]);
810 Perl_sv_catpvf(aTHX_ PL_Sv,"\" Built under %s\\n\"",OSNAME);
813 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
815 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled on %s\\n\"",__DATE__);
820 @env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; \
821 print \" \\%ENV:\\n @env\\n\" if @env; \
822 print \" \\@INC:\\n @INC\\n\";");
825 PL_Sv = newSVpv("config_vars(qw(",0);
826 sv_catpv(PL_Sv, ++s);
827 sv_catpv(PL_Sv, "))");
830 av_push(PL_preambleav, PL_Sv);
831 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
837 PL_cddir = savepv(s);
842 if (!*++s || isSPACE(*s)) {
846 /* catch use of gnu style long options */
847 if (strEQ(s, "version")) {
851 if (strEQ(s, "help")) {
858 Perl_croak(aTHX_ "Unrecognized switch: -%s (-h will show valid options)",s);
864 #ifndef SECURE_INTERNAL_GETENV
867 (s = PerlEnv_getenv("PERL5OPT"))) {
870 if (*s == '-' && *(s+1) == 'T')
883 if (!strchr("DIMUdmw", *s))
884 Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
891 scriptname = argv[0];
894 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
896 else if (scriptname == Nullch) {
898 if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
906 open_script(scriptname,dosearch,sv,&fdscript);
908 validate_suid(validarg, scriptname,fdscript);
913 PL_main_cv = PL_compcv = (CV*)NEWSV(1104,0);
914 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
915 CvUNIQUE_on(PL_compcv);
917 PL_comppad = newAV();
918 av_push(PL_comppad, Nullsv);
919 PL_curpad = AvARRAY(PL_comppad);
920 PL_comppad_name = newAV();
921 PL_comppad_name_fill = 0;
922 PL_min_intro_pending = 0;
925 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
926 PL_curpad[0] = (SV*)newAV();
927 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
928 CvOWNER(PL_compcv) = 0;
929 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
930 MUTEX_INIT(CvMUTEXP(PL_compcv));
931 #endif /* USE_THREADS */
933 comppadlist = newAV();
934 AvREAL_off(comppadlist);
935 av_store(comppadlist, 0, (SV*)PL_comppad_name);
936 av_store(comppadlist, 1, (SV*)PL_comppad);
937 CvPADLIST(PL_compcv) = comppadlist;
939 boot_core_UNIVERSAL();
943 (*xsinit)(aTHXo); /* in case linked C routines want magical variables */
944 #if defined(VMS) || defined(WIN32) || defined(DJGPP)
952 init_predump_symbols();
953 /* init_postdump_symbols not currently designed to be called */
954 /* more than once (ENV isn't cleared first, for example) */
955 /* But running with -u leaves %ENV & @ARGV undefined! XXX */
957 init_postdump_symbols(argc,argv,env);
961 /* now parse the script */
963 SETERRNO(0,SS$_NORMAL);
965 if (yyparse() || PL_error_count) {
967 Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
969 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
973 PL_curcop->cop_line = 0;
974 PL_curstash = PL_defstash;
975 PL_preprocess = FALSE;
977 SvREFCNT_dec(PL_e_script);
978 PL_e_script = Nullsv;
981 /* now that script is parsed, we can modify record separator */
983 PL_rs = SvREFCNT_inc(PL_nrs);
984 sv_setsv(get_sv("/", TRUE), PL_rs);
989 gv_check(PL_defstash);
995 if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
996 dump_mstats("after compilation:");
1015 oldscope = PL_scopestack_ix;
1018 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_run_body), oldscope);
1021 cxstack_ix = -1; /* start context stack again */
1023 case 0: /* normal completion */
1024 case 2: /* my_exit() */
1025 while (PL_scopestack_ix > oldscope)
1028 PL_curstash = PL_defstash;
1029 if (PL_endav && !PL_minus_c)
1030 call_list(oldscope, PL_endav);
1032 if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
1033 dump_mstats("after execution: ");
1035 return STATUS_NATIVE_EXPORT;
1038 POPSTACK_TO(PL_mainstack);
1041 PerlIO_printf(Perl_error_log, "panic: restartop\n");
1051 S_run_body(pTHX_ va_list args)
1054 I32 oldscope = va_arg(args, I32);
1056 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
1057 PL_sawampersand ? "Enabling" : "Omitting"));
1059 if (!PL_restartop) {
1060 DEBUG_x(dump_all());
1061 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
1062 DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%lx\n",
1063 (unsigned long) thr));
1066 PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
1069 if (PERLDB_SINGLE && PL_DBsingle)
1070 sv_setiv(PL_DBsingle, 1);
1072 call_list(oldscope, PL_initav);
1078 PL_op = PL_restartop;
1082 else if (PL_main_start) {
1083 CvDEPTH(PL_main_cv) = 1;
1084 PL_op = PL_main_start;
1094 Perl_get_sv(pTHX_ const char *name, I32 create)
1098 if (name[1] == '\0' && !isALPHA(name[0])) {
1099 PADOFFSET tmp = find_threadsv(name);
1100 if (tmp != NOT_IN_PAD) {
1102 return THREADSV(tmp);
1105 #endif /* USE_THREADS */
1106 gv = gv_fetchpv(name, create, SVt_PV);
1113 Perl_get_av(pTHX_ const char *name, I32 create)
1115 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1124 Perl_get_hv(pTHX_ const char *name, I32 create)
1126 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1135 Perl_get_cv(pTHX_ const char *name, I32 create)
1137 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
1138 /* XXX unsafe for threads if eval_owner isn't held */
1139 /* XXX this is probably not what they think they're getting.
1140 * It has the same effect as "sub name;", i.e. just a forward
1142 if (create && !GvCVu(gv))
1143 return newSUB(start_subparse(FALSE, 0),
1144 newSVOP(OP_CONST, 0, newSVpv(name,0)),
1152 /* Be sure to refetch the stack pointer after calling these routines. */
1155 Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv)
1157 /* See G_* flags in cop.h */
1158 /* null terminated arg list */
1165 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
1170 return call_pv(sub_name, flags);
1174 Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
1175 /* name of the subroutine */
1176 /* See G_* flags in cop.h */
1178 return call_sv((SV*)get_cv(sub_name, TRUE), flags);
1182 Perl_call_method(pTHX_ const char *methname, I32 flags)
1183 /* name of the subroutine */
1184 /* See G_* flags in cop.h */
1190 XPUSHs(sv_2mortal(newSVpv(methname,0)));
1195 return call_sv(*PL_stack_sp--, flags);
1198 /* May be called with any of a CV, a GV, or an SV containing the name. */
1200 Perl_call_sv(pTHX_ SV *sv, I32 flags)
1202 /* See G_* flags in cop.h */
1205 LOGOP myop; /* fake syntax tree node */
1209 bool oldcatch = CATCH_GET;
1214 if (flags & G_DISCARD) {
1219 Zero(&myop, 1, LOGOP);
1220 myop.op_next = Nullop;
1221 if (!(flags & G_NOARGS))
1222 myop.op_flags |= OPf_STACKED;
1223 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1224 (flags & G_ARRAY) ? OPf_WANT_LIST :
1229 EXTEND(PL_stack_sp, 1);
1230 *++PL_stack_sp = sv;
1232 oldscope = PL_scopestack_ix;
1234 if (PERLDB_SUB && PL_curstash != PL_debstash
1235 /* Handle first BEGIN of -d. */
1236 && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
1237 /* Try harder, since this may have been a sighandler, thus
1238 * curstash may be meaningless. */
1239 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != PL_debstash)
1240 && !(flags & G_NODEBUG))
1241 PL_op->op_private |= OPpENTERSUB_DB;
1243 if (!(flags & G_EVAL)) {
1244 /* G_NOCATCH is a hack for perl_vdie using this path to call
1245 a __DIE__ handler */
1246 if (!(flags & G_NOCATCH)) {
1249 call_xbody((OP*)&myop, FALSE);
1250 retval = PL_stack_sp - (PL_stack_base + oldmark);
1251 if (!(flags & G_NOCATCH)) {
1256 cLOGOP->op_other = PL_op;
1258 /* we're trying to emulate pp_entertry() here */
1260 register PERL_CONTEXT *cx;
1261 I32 gimme = GIMME_V;
1266 push_return(PL_op->op_next);
1267 PUSHBLOCK(cx, CXt_EVAL, PL_stack_sp);
1269 PL_eval_root = PL_op; /* Only needed so that goto works right. */
1271 PL_in_eval = EVAL_INEVAL;
1272 if (flags & G_KEEPERR)
1273 PL_in_eval |= EVAL_KEEPERR;
1280 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_body),
1284 retval = PL_stack_sp - (PL_stack_base + oldmark);
1285 if (!(flags & G_KEEPERR))
1292 /* my_exit() was called */
1293 PL_curstash = PL_defstash;
1296 Perl_croak(aTHX_ "Callback called exit");
1301 PL_op = PL_restartop;
1305 PL_stack_sp = PL_stack_base + oldmark;
1306 if (flags & G_ARRAY)
1310 *++PL_stack_sp = &PL_sv_undef;
1315 if (PL_scopestack_ix > oldscope) {
1319 register PERL_CONTEXT *cx;
1330 if (flags & G_DISCARD) {
1331 PL_stack_sp = PL_stack_base + oldmark;
1341 S_call_body(pTHX_ va_list args)
1343 OP *myop = va_arg(args, OP*);
1344 int is_eval = va_arg(args, int);
1346 call_xbody(myop, is_eval);
1351 S_call_xbody(pTHX_ OP *myop, int is_eval)
1355 if (PL_op == myop) {
1357 PL_op = Perl_pp_entereval(aTHX);
1359 PL_op = Perl_pp_entersub(aTHX);
1365 /* Eval a string. The G_EVAL flag is always assumed. */
1368 Perl_eval_sv(pTHX_ SV *sv, I32 flags)
1370 /* See G_* flags in cop.h */
1373 UNOP myop; /* fake syntax tree node */
1374 I32 oldmark = SP - PL_stack_base;
1381 if (flags & G_DISCARD) {
1388 Zero(PL_op, 1, UNOP);
1389 EXTEND(PL_stack_sp, 1);
1390 *++PL_stack_sp = sv;
1391 oldscope = PL_scopestack_ix;
1393 if (!(flags & G_NOARGS))
1394 myop.op_flags = OPf_STACKED;
1395 myop.op_next = Nullop;
1396 myop.op_type = OP_ENTEREVAL;
1397 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1398 (flags & G_ARRAY) ? OPf_WANT_LIST :
1400 if (flags & G_KEEPERR)
1401 myop.op_flags |= OPf_SPECIAL;
1404 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_body),
1408 retval = PL_stack_sp - (PL_stack_base + oldmark);
1409 if (!(flags & G_KEEPERR))
1416 /* my_exit() was called */
1417 PL_curstash = PL_defstash;
1420 Perl_croak(aTHX_ "Callback called exit");
1425 PL_op = PL_restartop;
1429 PL_stack_sp = PL_stack_base + oldmark;
1430 if (flags & G_ARRAY)
1434 *++PL_stack_sp = &PL_sv_undef;
1439 if (flags & G_DISCARD) {
1440 PL_stack_sp = PL_stack_base + oldmark;
1450 Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
1453 SV* sv = newSVpv(p, 0);
1456 eval_sv(sv, G_SCALAR);
1463 if (croak_on_error && SvTRUE(ERRSV)) {
1465 Perl_croak(aTHX_ SvPVx(ERRSV, n_a));
1471 /* Require a module. */
1474 Perl_require_pv(pTHX_ const char *pv)
1478 PUSHSTACKi(PERLSI_REQUIRE);
1480 sv = sv_newmortal();
1481 sv_setpv(sv, "require '");
1484 eval_sv(sv, G_DISCARD);
1490 Perl_magicname(pTHX_ char *sym, char *name, I32 namlen)
1494 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1495 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1499 S_usage(pTHX_ char *name) /* XXX move this out into a module ? */
1501 /* This message really ought to be max 23 lines.
1502 * Removed -h because the user already knows that opton. Others? */
1504 static char *usage_msg[] = {
1505 "-0[octal] specify record separator (\\0, if no argument)",
1506 "-a autosplit mode with -n or -p (splits $_ into @F)",
1507 "-c check syntax only (runs BEGIN and END blocks)",
1508 "-d[:debugger] run program under debugger",
1509 "-D[number/list] set debugging flags (argument is a bit mask or alphabets)",
1510 "-e 'command' one line of program (several -e's allowed, omit programfile)",
1511 "-F/pattern/ split() pattern for -a switch (//'s are optional)",
1512 "-i[extension] edit <> files in place (makes backup if extension supplied)",
1513 "-Idirectory specify @INC/#include directory (several -I's allowed)",
1514 "-l[octal] enable line ending processing, specifies line terminator",
1515 "-[mM][-]module execute `use/no module...' before executing program",
1516 "-n assume 'while (<>) { ... }' loop around program",
1517 "-p assume loop like -n but print line also, like sed",
1518 "-P run program through C preprocessor before compilation",
1519 "-s enable rudimentary parsing for switches after programfile",
1520 "-S look for programfile using PATH environment variable",
1521 "-T enable tainting checks",
1522 "-u dump core after parsing program",
1523 "-U allow unsafe operations",
1524 "-v print version, subversion (includes VERY IMPORTANT perl info)",
1525 "-V[:variable] print configuration summary (or a single Config.pm variable)",
1526 "-w enable many useful warnings (RECOMMENDED)",
1527 "-x[directory] strip off text before #!perl line and perhaps cd to directory",
1531 char **p = usage_msg;
1533 printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1535 printf("\n %s", *p++);
1538 /* This routine handles any switches that can be given during run */
1541 Perl_moreswitches(pTHX_ char *s)
1550 rschar = scan_oct(s, 4, &numlen);
1551 SvREFCNT_dec(PL_nrs);
1552 if (rschar & ~((U8)~0))
1553 PL_nrs = &PL_sv_undef;
1554 else if (!rschar && numlen >= 2)
1555 PL_nrs = newSVpvn("", 0);
1558 PL_nrs = newSVpvn(&ch, 1);
1564 PL_splitstr = savepv(s + 1);
1578 if (*s == ':' || *s == '=') {
1579 my_setenv("PERL5DB", Perl_form(aTHX_ "use Devel::%s;", ++s));
1583 PL_perldb = PERLDB_ALL;
1591 if (isALPHA(s[1])) {
1592 static char debopts[] = "psltocPmfrxuLHXDS";
1595 for (s++; *s && (d = strchr(debopts,*s)); s++)
1596 PL_debug |= 1 << (d - debopts);
1599 PL_debug = atoi(s+1);
1600 for (s++; isDIGIT(*s); s++) ;
1602 PL_debug |= 0x80000000;
1605 if (ckWARN_d(WARN_DEBUGGING))
1606 Perl_warner(aTHX_ WARN_DEBUGGING,
1607 "Recompile perl with -DDEBUGGING to use -D switch\n");
1608 for (s++; isALNUM(*s); s++) ;
1614 usage(PL_origargv[0]);
1618 Safefree(PL_inplace);
1619 PL_inplace = savepv(s+1);
1621 for (s = PL_inplace; *s && !isSPACE(*s); s++) ;
1624 if (*s == '-') /* Additional switches on #! line. */
1628 case 'I': /* -I handled both here and in parse_perl() */
1631 while (*s && isSPACE(*s))
1635 for (e = s; *e && !isSPACE(*e); e++) ;
1636 p = savepvn(s, e-s);
1642 Perl_croak(aTHX_ "No space allowed after -I");
1650 PL_ors = savepv("\n");
1652 *PL_ors = scan_oct(s, 3 + (*s == '0'), &numlen);
1657 if (RsPARA(PL_nrs)) {
1662 PL_ors = SvPV(PL_nrs, PL_orslen);
1663 PL_ors = savepvn(PL_ors, PL_orslen);
1667 forbid_setid("-M"); /* XXX ? */
1670 forbid_setid("-m"); /* XXX ? */
1675 /* -M-foo == 'no foo' */
1676 if (*s == '-') { use = "no "; ++s; }
1677 sv = newSVpv(use,0);
1679 /* We allow -M'Module qw(Foo Bar)' */
1680 while(isALNUM(*s) || *s==':') ++s;
1682 sv_catpv(sv, start);
1683 if (*(start-1) == 'm') {
1685 Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
1686 sv_catpv( sv, " ()");
1689 sv_catpvn(sv, start, s-start);
1690 sv_catpv(sv, " split(/,/,q{");
1695 if (PL_preambleav == NULL)
1696 PL_preambleav = newAV();
1697 av_push(PL_preambleav, sv);
1700 Perl_croak(aTHX_ "No space allowed after -%c", *(s-1));
1712 PL_doswitches = TRUE;
1717 Perl_croak(aTHX_ "Too late for \"-T\" option");
1721 PL_do_undump = TRUE;
1729 #if defined(PERL_SUBVERSION) && PERL_SUBVERSION > 0
1730 printf("\nThis is perl, version %d.%03d_%02d built for %s",
1731 PERL_REVISION, PERL_VERSION, PERL_SUBVERSION, ARCHNAME);
1733 printf("\nThis is perl, version %s built for %s",
1734 PL_patchlevel, ARCHNAME);
1736 #if defined(LOCAL_PATCH_COUNT)
1737 if (LOCAL_PATCH_COUNT > 0)
1738 printf("\n(with %d registered patch%s, see perl -V for more detail)",
1739 LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : "");
1742 printf("\n\nCopyright 1987-1999, Larry Wall\n");
1744 printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1747 printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
1748 printf("djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
1751 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1752 "Version 5 port Copyright (c) 1994-1999, Andreas Kaiser, Ilya Zakharevich\n");
1755 printf("atariST series port, ++jrb bammi@cadence.com\n");
1758 printf("BeOS port Copyright Tom Spindler, 1997-1999\n");
1761 printf("MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-1999\n");
1764 printf("MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
1767 printf("Stratus VOS port by Paul_Green@stratus.com, 1997-1999\n");
1770 printf("VM/ESA port by Neale Ferguson, 1998-1999\n");
1773 printf("BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
1776 printf("MiNT port by Guido Flohr, 1997-1999\n");
1778 #ifdef BINARY_BUILD_NOTICE
1779 BINARY_BUILD_NOTICE;
1782 Perl may be copied only under the terms of either the Artistic License or the\n\
1783 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n\
1784 Complete documentation for Perl, including FAQ lists, should be found on\n\
1785 this system using `man perl' or `perldoc perl'. If you have access to the\n\
1786 Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
1789 if (! (PL_dowarn & G_WARN_ALL_MASK))
1790 PL_dowarn |= G_WARN_ON;
1794 PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
1795 PL_compiling.cop_warnings = WARN_ALL ;
1799 PL_dowarn = G_WARN_ALL_OFF;
1800 PL_compiling.cop_warnings = WARN_NONE ;
1805 if (s[1] == '-') /* Additional switches on #! line. */
1810 #if defined(WIN32) || !defined(PERL_STRICT_CR)
1816 #ifdef ALTERNATE_SHEBANG
1817 case 'S': /* OS/2 needs -S on "extproc" line. */
1825 Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
1830 /* compliments of Tom Christiansen */
1832 /* unexec() can be found in the Gnu emacs distribution */
1833 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
1836 Perl_my_unexec(pTHX)
1844 prog = newSVpv(BIN_EXP, 0);
1845 sv_catpv(prog, "/perl");
1846 file = newSVpv(PL_origfilename, 0);
1847 sv_catpv(file, ".perldump");
1849 unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
1850 /* unexec prints msg to stderr in case of failure */
1851 PerlProc_exit(status);
1854 # include <lib$routines.h>
1855 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
1857 ABORT(); /* for use with undump */
1862 /* initialize curinterp */
1867 #ifdef PERL_OBJECT /* XXX kludge */
1870 PL_chopset = " \n-"; \
1871 PL_copline = NOLINE; \
1872 PL_curcop = &PL_compiling;\
1873 PL_curcopdb = NULL; \
1876 PL_dumpindent = 4; \
1877 PL_laststatval = -1; \
1878 PL_laststype = OP_STAT; \
1879 PL_maxscream = -1; \
1880 PL_maxsysfd = MAXSYSFD; \
1881 PL_statname = Nullsv; \
1882 PL_tmps_floor = -1; \
1884 PL_op_mask = NULL; \
1886 PL_laststatval = -1; \
1887 PL_laststype = OP_STAT; \
1888 PL_mess_sv = Nullsv; \
1889 PL_splitstr = " "; \
1890 PL_generation = 100; \
1891 PL_exitlist = NULL; \
1892 PL_exitlistlen = 0; \
1894 PL_in_clean_objs = FALSE; \
1895 PL_in_clean_all = FALSE; \
1896 PL_profiledata = NULL; \
1898 PL_rsfp_filters = Nullav; \
1903 # ifdef MULTIPLICITY
1904 # define PERLVAR(var,type)
1905 # define PERLVARA(var,n,type)
1906 # if defined(PERL_IMPLICIT_CONTEXT)
1907 # if defined(USE_THREADS)
1908 # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
1909 # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
1910 # else /* !USE_THREADS */
1911 # define PERLVARI(var,type,init) aTHX->var = init;
1912 # define PERLVARIC(var,type,init) aTHX->var = init;
1913 # endif /* USE_THREADS */
1915 # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
1916 # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
1918 # include "intrpvar.h"
1919 # ifndef USE_THREADS
1920 # include "thrdvar.h"
1927 # define PERLVAR(var,type)
1928 # define PERLVARA(var,n,type)
1929 # define PERLVARI(var,type,init) PL_##var = init;
1930 # define PERLVARIC(var,type,init) PL_##var = init;
1931 # include "intrpvar.h"
1932 # ifndef USE_THREADS
1933 # include "thrdvar.h"
1945 S_init_main_stash(pTHX)
1950 /* Note that strtab is a rather special HV. Assumptions are made
1951 about not iterating on it, and not adding tie magic to it.
1952 It is properly deallocated in perl_destruct() */
1953 PL_strtab = newHV();
1955 MUTEX_INIT(&PL_strtab_mutex);
1957 HvSHAREKEYS_off(PL_strtab); /* mandatory */
1958 hv_ksplit(PL_strtab, 512);
1960 PL_curstash = PL_defstash = newHV();
1961 PL_curstname = newSVpvn("main",4);
1962 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1963 SvREFCNT_dec(GvHV(gv));
1964 GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
1966 HvNAME(PL_defstash) = savepv("main");
1967 PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1968 GvMULTI_on(PL_incgv);
1969 PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
1970 GvMULTI_on(PL_hintgv);
1971 PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1972 PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1973 GvMULTI_on(PL_errgv);
1974 PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
1975 GvMULTI_on(PL_replgv);
1976 (void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */
1977 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
1978 sv_setpvn(ERRSV, "", 0);
1979 PL_curstash = PL_defstash;
1980 PL_compiling.cop_stash = PL_defstash;
1981 PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
1982 PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
1983 /* We must init $/ before switches are processed. */
1984 sv_setpvn(get_sv("/", TRUE), "\n", 1);
1988 S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
1996 PL_origfilename = savepv("-e");
1999 /* if find_script() returns, it returns a malloc()-ed value */
2000 PL_origfilename = scriptname = find_script(scriptname, dosearch, NULL, 1);
2002 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
2003 char *s = scriptname + 8;
2004 *fdscript = atoi(s);
2008 scriptname = savepv(s + 1);
2009 Safefree(PL_origfilename);
2010 PL_origfilename = scriptname;
2015 PL_curcop->cop_filegv = gv_fetchfile(PL_origfilename);
2016 if (strEQ(PL_origfilename,"-"))
2018 if (*fdscript >= 0) {
2019 PL_rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE);
2020 #if defined(HAS_FCNTL) && defined(F_SETFD)
2022 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); /* ensure close-on-exec */
2025 else if (PL_preprocess) {
2026 char *cpp_cfg = CPPSTDIN;
2027 SV *cpp = newSVpvn("",0);
2028 SV *cmd = NEWSV(0,0);
2030 if (strEQ(cpp_cfg, "cppstdin"))
2031 Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
2032 sv_catpv(cpp, cpp_cfg);
2035 sv_catpv(sv,PRIVLIB_EXP);
2038 Perl_sv_setpvf(aTHX_ cmd, "\
2039 sed %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\" \
2051 (PL_doextract ? "-e \"1,/^#/d\n\"" : ""),
2054 Perl_sv_setpvf(aTHX_ cmd, "\
2055 %s %s -e '/^[^#]/b' \
2056 -e '/^#[ ]*include[ ]/b' \
2057 -e '/^#[ ]*define[ ]/b' \
2058 -e '/^#[ ]*if[ ]/b' \
2059 -e '/^#[ ]*ifdef[ ]/b' \
2060 -e '/^#[ ]*ifndef[ ]/b' \
2061 -e '/^#[ ]*else/b' \
2062 -e '/^#[ ]*elif[ ]/b' \
2063 -e '/^#[ ]*undef[ ]/b' \
2064 -e '/^#[ ]*endif/b' \
2068 Perl_sv_setpvf(aTHX_ cmd, "\
2069 %s %s -e '/^[^#]/b' \
2070 -e '/^#[ ]*include[ ]/b' \
2071 -e '/^#[ ]*define[ ]/b' \
2072 -e '/^#[ ]*if[ ]/b' \
2073 -e '/^#[ ]*ifdef[ ]/b' \
2074 -e '/^#[ ]*ifndef[ ]/b' \
2075 -e '/^#[ ]*else/b' \
2076 -e '/^#[ ]*elif[ ]/b' \
2077 -e '/^#[ ]*undef[ ]/b' \
2078 -e '/^#[ ]*endif/b' \
2087 (PL_doextract ? "-e '1,/^#/d\n'" : ""),
2089 scriptname, cpp, sv, CPPMINUS);
2090 PL_doextract = FALSE;
2091 #ifdef IAMSUID /* actually, this is caught earlier */
2092 if (PL_euid != PL_uid && !PL_euid) { /* if running suidperl */
2094 (void)seteuid(PL_uid); /* musn't stay setuid root */
2097 (void)setreuid((Uid_t)-1, PL_uid);
2099 #ifdef HAS_SETRESUID
2100 (void)setresuid((Uid_t)-1, PL_uid, (Uid_t)-1);
2102 PerlProc_setuid(PL_uid);
2106 if (PerlProc_geteuid() != PL_uid)
2107 Perl_croak(aTHX_ "Can't do seteuid!\n");
2109 #endif /* IAMSUID */
2110 PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
2114 else if (!*scriptname) {
2115 forbid_setid("program input from stdin");
2116 PL_rsfp = PerlIO_stdin();
2119 PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
2120 #if defined(HAS_FCNTL) && defined(F_SETFD)
2122 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); /* ensure close-on-exec */
2127 #ifndef IAMSUID /* in case script is not readable before setuid */
2129 PerlLIO_stat(SvPVX(GvSV(PL_curcop->cop_filegv)),&PL_statbuf) >= 0 &&
2130 PL_statbuf.st_mode & (S_ISUID|S_ISGID))
2133 PerlProc_execv(Perl_form(aTHX_ "%s/sperl%s", BIN_EXP, PL_patchlevel), PL_origargv);
2134 Perl_croak(aTHX_ "Can't do setuid\n");
2138 Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
2139 SvPVX(GvSV(PL_curcop->cop_filegv)), Strerror(errno));
2144 * I_SYSSTATVFS HAS_FSTATVFS
2146 * I_STATFS HAS_FSTATFS
2147 * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT
2148 * here so that metaconfig picks them up. */
2152 S_fd_on_nosuid_fs(pTHX_ int fd)
2157 * Preferred order: fstatvfs(), fstatfs(), getmntent().
2158 * fstatvfs() is UNIX98.
2160 * getmntent() is O(number-of-mounted-filesystems) and can hang.
2163 # ifdef HAS_FSTATVFS
2164 struct statvfs stfs;
2165 check_okay = fstatvfs(fd, &stfs) == 0;
2166 on_nosuid = check_okay && (stfs.f_flag & ST_NOSUID);
2168 # if defined(HAS_FSTATFS) && defined(HAS_STRUCT_STATFS_FLAGS)
2170 check_okay = fstatfs(fd, &stfs) == 0;
2171 # undef PERL_MOUNT_NOSUID
2172 # if !defined(PERL_MOUNT_NOSUID) && defined(MNT_NOSUID)
2173 # define PERL_MOUNT_NOSUID MNT_NOSUID
2175 # if !defined(PERL_MOUNT_NOSUID) && defined(MS_NOSUID)
2176 # define PERL_MOUNT_NOSUID MS_NOSUID
2178 # if !defined(PERL_MOUNT_NOSUID) && defined(M_NOSUID)
2179 # define PERL_MOUNT_NOSUID M_NOSUID
2181 # ifdef PERL_MOUNT_NOSUID
2182 on_nosuid = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
2185 # if defined(HAS_GETMNTENT) && defined(HAS_HASMNTOPT) && defined(MNTOPT_NOSUID)
2186 FILE *mtab = fopen("/etc/mtab", "r");
2187 struct mntent *entry;
2188 struct stat stb, fsb;
2190 if (mtab && (fstat(fd, &stb) == 0)) {
2191 while (entry = getmntent(mtab)) {
2192 if (stat(entry->mnt_dir, &fsb) == 0
2193 && fsb.st_dev == stb.st_dev)
2195 /* found the filesystem */
2197 if (hasmntopt(entry, MNTOPT_NOSUID))
2200 } /* A single fs may well fail its stat(). */
2205 # endif /* mntent */
2206 # endif /* statfs */
2207 # endif /* statvfs */
2209 Perl_croak(aTHX_ "Can't check filesystem of script \"%s\"", PL_origfilename);
2212 #endif /* IAMSUID */
2215 S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript)
2219 /* do we need to emulate setuid on scripts? */
2221 /* This code is for those BSD systems that have setuid #! scripts disabled
2222 * in the kernel because of a security problem. Merely defining DOSUID
2223 * in perl will not fix that problem, but if you have disabled setuid
2224 * scripts in the kernel, this will attempt to emulate setuid and setgid
2225 * on scripts that have those now-otherwise-useless bits set. The setuid
2226 * root version must be called suidperl or sperlN.NNN. If regular perl
2227 * discovers that it has opened a setuid script, it calls suidperl with
2228 * the same argv that it had. If suidperl finds that the script it has
2229 * just opened is NOT setuid root, it sets the effective uid back to the
2230 * uid. We don't just make perl setuid root because that loses the
2231 * effective uid we had before invoking perl, if it was different from the
2234 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
2235 * be defined in suidperl only. suidperl must be setuid root. The
2236 * Configure script will set this up for you if you want it.
2243 if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */
2244 Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
2245 if (fdscript < 0 && PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
2250 #ifndef HAS_SETREUID
2251 /* On this access check to make sure the directories are readable,
2252 * there is actually a small window that the user could use to make
2253 * filename point to an accessible directory. So there is a faint
2254 * chance that someone could execute a setuid script down in a
2255 * non-accessible directory. I don't know what to do about that.
2256 * But I don't think it's too important. The manual lies when
2257 * it says access() is useful in setuid programs.
2259 if (PerlLIO_access(SvPVX(GvSV(PL_curcop->cop_filegv)),1)) /*double check*/
2260 Perl_croak(aTHX_ "Permission denied");
2262 /* If we can swap euid and uid, then we can determine access rights
2263 * with a simple stat of the file, and then compare device and
2264 * inode to make sure we did stat() on the same file we opened.
2265 * Then we just have to make sure he or she can execute it.
2268 struct stat tmpstatbuf;
2272 setreuid(PL_euid,PL_uid) < 0
2275 setresuid(PL_euid,PL_uid,(Uid_t)-1) < 0
2278 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
2279 Perl_croak(aTHX_ "Can't swap uid and euid"); /* really paranoid */
2280 if (PerlLIO_stat(SvPVX(GvSV(PL_curcop->cop_filegv)),&tmpstatbuf) < 0)
2281 Perl_croak(aTHX_ "Permission denied"); /* testing full pathname here */
2282 #if defined(IAMSUID) && !defined(NO_NOSUID_CHECK)
2283 if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp)))
2284 Perl_croak(aTHX_ "Permission denied");
2286 if (tmpstatbuf.st_dev != PL_statbuf.st_dev ||
2287 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
2288 (void)PerlIO_close(PL_rsfp);
2289 if (PL_rsfp = PerlProc_popen("/bin/mail root","w")) { /* heh, heh */
2290 PerlIO_printf(PL_rsfp,
2291 "User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2292 (Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
2293 (long)PL_uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
2294 (long)PL_statbuf.st_dev, (long)PL_statbuf.st_ino,
2295 SvPVX(GvSV(PL_curcop->cop_filegv)),
2296 (long)PL_statbuf.st_uid, (long)PL_statbuf.st_gid);
2297 (void)PerlProc_pclose(PL_rsfp);
2299 Perl_croak(aTHX_ "Permission denied\n");
2303 setreuid(PL_uid,PL_euid) < 0
2305 # if defined(HAS_SETRESUID)
2306 setresuid(PL_uid,PL_euid,(Uid_t)-1) < 0
2309 || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
2310 Perl_croak(aTHX_ "Can't reswap uid and euid");
2311 if (!cando(S_IXUSR,FALSE,&PL_statbuf)) /* can real uid exec? */
2312 Perl_croak(aTHX_ "Permission denied\n");
2314 #endif /* HAS_SETREUID */
2315 #endif /* IAMSUID */
2317 if (!S_ISREG(PL_statbuf.st_mode))
2318 Perl_croak(aTHX_ "Permission denied");
2319 if (PL_statbuf.st_mode & S_IWOTH)
2320 Perl_croak(aTHX_ "Setuid/gid script is writable by world");
2321 PL_doswitches = FALSE; /* -s is insecure in suid */
2322 PL_curcop->cop_line++;
2323 if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
2324 strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */
2325 Perl_croak(aTHX_ "No #! line");
2326 s = SvPV(PL_linestr,n_a)+2;
2328 while (!isSPACE(*s)) s++;
2329 for (s2 = s; (s2 > SvPV(PL_linestr,n_a)+2 &&
2330 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
2331 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
2332 Perl_croak(aTHX_ "Not a perl script");
2333 while (*s == ' ' || *s == '\t') s++;
2335 * #! arg must be what we saw above. They can invoke it by
2336 * mentioning suidperl explicitly, but they may not add any strange
2337 * arguments beyond what #! says if they do invoke suidperl that way.
2339 len = strlen(validarg);
2340 if (strEQ(validarg," PHOOEY ") ||
2341 strnNE(s,validarg,len) || !isSPACE(s[len]))
2342 Perl_croak(aTHX_ "Args must match #! line");
2345 if (PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
2346 PL_euid == PL_statbuf.st_uid)
2348 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2349 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2350 #endif /* IAMSUID */
2352 if (PL_euid) { /* oops, we're not the setuid root perl */
2353 (void)PerlIO_close(PL_rsfp);
2356 PerlProc_execv(Perl_form(aTHX_ "%s/sperl%s", BIN_EXP, PL_patchlevel), PL_origargv);
2358 Perl_croak(aTHX_ "Can't do setuid\n");
2361 if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
2363 (void)setegid(PL_statbuf.st_gid);
2366 (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
2368 #ifdef HAS_SETRESGID
2369 (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
2371 PerlProc_setgid(PL_statbuf.st_gid);
2375 if (PerlProc_getegid() != PL_statbuf.st_gid)
2376 Perl_croak(aTHX_ "Can't do setegid!\n");
2378 if (PL_statbuf.st_mode & S_ISUID) {
2379 if (PL_statbuf.st_uid != PL_euid)
2381 (void)seteuid(PL_statbuf.st_uid); /* all that for this */
2384 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
2386 #ifdef HAS_SETRESUID
2387 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
2389 PerlProc_setuid(PL_statbuf.st_uid);
2393 if (PerlProc_geteuid() != PL_statbuf.st_uid)
2394 Perl_croak(aTHX_ "Can't do seteuid!\n");
2396 else if (PL_uid) { /* oops, mustn't run as root */
2398 (void)seteuid((Uid_t)PL_uid);
2401 (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
2403 #ifdef HAS_SETRESUID
2404 (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
2406 PerlProc_setuid((Uid_t)PL_uid);
2410 if (PerlProc_geteuid() != PL_uid)
2411 Perl_croak(aTHX_ "Can't do seteuid!\n");
2414 if (!cando(S_IXUSR,TRUE,&PL_statbuf))
2415 Perl_croak(aTHX_ "Permission denied\n"); /* they can't do this */
2418 else if (PL_preprocess)
2419 Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
2420 else if (fdscript >= 0)
2421 Perl_croak(aTHX_ "fd script not allowed in suidperl\n");
2423 Perl_croak(aTHX_ "Script is not setuid/setgid in suidperl\n");
2425 /* We absolutely must clear out any saved ids here, so we */
2426 /* exec the real perl, substituting fd script for scriptname. */
2427 /* (We pass script name as "subdir" of fd, which perl will grok.) */
2428 PerlIO_rewind(PL_rsfp);
2429 PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0); /* just in case rewind didn't */
2430 for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
2431 if (!PL_origargv[which])
2432 Perl_croak(aTHX_ "Permission denied");
2433 PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
2434 PerlIO_fileno(PL_rsfp), PL_origargv[which]));
2435 #if defined(HAS_FCNTL) && defined(F_SETFD)
2436 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */
2438 PerlProc_execv(Perl_form(aTHX_ "%s/perl%s", BIN_EXP, PL_patchlevel), PL_origargv);/* try again */
2439 Perl_croak(aTHX_ "Can't do setuid\n");
2440 #endif /* IAMSUID */
2442 if (PL_euid != PL_uid || PL_egid != PL_gid) { /* (suidperl doesn't exist, in fact) */
2443 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2445 PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf); /* may be either wrapped or real suid */
2446 if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
2448 (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
2451 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2452 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2453 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2454 /* not set-id, must be wrapped */
2460 S_find_beginning(pTHX)
2462 register char *s, *s2;
2464 /* skip forward in input to the real script? */
2467 while (PL_doextract) {
2468 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
2469 Perl_croak(aTHX_ "No Perl script found in input\n");
2470 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2471 PerlIO_ungetc(PL_rsfp, '\n'); /* to keep line count right */
2472 PL_doextract = FALSE;
2473 while (*s && !(isSPACE (*s) || *s == '#')) s++;
2475 while (*s == ' ' || *s == '\t') s++;
2477 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2478 if (strnEQ(s2-4,"perl",4))
2480 while (s = moreswitches(s)) ;
2482 if (PL_cddir && PerlDir_chdir(PL_cddir) < 0)
2483 Perl_croak(aTHX_ "Can't chdir to %s",PL_cddir);
2492 PL_uid = PerlProc_getuid();
2493 PL_euid = PerlProc_geteuid();
2494 PL_gid = PerlProc_getgid();
2495 PL_egid = PerlProc_getegid();
2497 PL_uid |= PL_gid << 16;
2498 PL_euid |= PL_egid << 16;
2500 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2504 S_forbid_setid(pTHX_ char *s)
2506 if (PL_euid != PL_uid)
2507 Perl_croak(aTHX_ "No %s allowed while running setuid", s);
2508 if (PL_egid != PL_gid)
2509 Perl_croak(aTHX_ "No %s allowed while running setgid", s);
2513 Perl_init_debugger(pTHX)
2516 HV *ostash = PL_curstash;
2518 PL_curstash = PL_debstash;
2519 PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2520 AvREAL_off(PL_dbargs);
2521 PL_DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2522 PL_DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2523 PL_DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2524 sv_upgrade(GvSV(PL_DBsub), SVt_IV); /* IVX accessed if PERLDB_SUB_NN */
2525 PL_DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2526 sv_setiv(PL_DBsingle, 0);
2527 PL_DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2528 sv_setiv(PL_DBtrace, 0);
2529 PL_DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2530 sv_setiv(PL_DBsignal, 0);
2531 PL_curstash = ostash;
2534 #ifndef STRESS_REALLOC
2535 #define REASONABLE(size) (size)
2537 #define REASONABLE(size) (1) /* unreasonable */
2541 Perl_init_stacks(pTHX)
2543 /* start with 128-item stack and 8K cxstack */
2544 PL_curstackinfo = new_stackinfo(REASONABLE(128),
2545 REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
2546 PL_curstackinfo->si_type = PERLSI_MAIN;
2547 PL_curstack = PL_curstackinfo->si_stack;
2548 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
2550 PL_stack_base = AvARRAY(PL_curstack);
2551 PL_stack_sp = PL_stack_base;
2552 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
2554 New(50,PL_tmps_stack,REASONABLE(128),SV*);
2557 PL_tmps_max = REASONABLE(128);
2559 New(54,PL_markstack,REASONABLE(32),I32);
2560 PL_markstack_ptr = PL_markstack;
2561 PL_markstack_max = PL_markstack + REASONABLE(32);
2565 New(54,PL_scopestack,REASONABLE(32),I32);
2566 PL_scopestack_ix = 0;
2567 PL_scopestack_max = REASONABLE(32);
2569 New(54,PL_savestack,REASONABLE(128),ANY);
2570 PL_savestack_ix = 0;
2571 PL_savestack_max = REASONABLE(128);
2573 New(54,PL_retstack,REASONABLE(16),OP*);
2575 PL_retstack_max = REASONABLE(16);
2584 while (PL_curstackinfo->si_next)
2585 PL_curstackinfo = PL_curstackinfo->si_next;
2586 while (PL_curstackinfo) {
2587 PERL_SI *p = PL_curstackinfo->si_prev;
2588 /* curstackinfo->si_stack got nuked by sv_free_arenas() */
2589 Safefree(PL_curstackinfo->si_cxstack);
2590 Safefree(PL_curstackinfo);
2591 PL_curstackinfo = p;
2593 Safefree(PL_tmps_stack);
2594 Safefree(PL_markstack);
2595 Safefree(PL_scopestack);
2596 Safefree(PL_savestack);
2597 Safefree(PL_retstack);
2599 Safefree(PL_debname);
2600 Safefree(PL_debdelim);
2605 static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
2616 lex_start(PL_linestr);
2618 PL_subname = newSVpvn("main",4);
2622 S_init_predump_symbols(pTHX)
2629 sv_setpvn(get_sv("\"", TRUE), " ", 1);
2630 PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2631 GvMULTI_on(PL_stdingv);
2632 io = GvIOp(PL_stdingv);
2633 IoIFP(io) = PerlIO_stdin();
2634 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2636 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
2638 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2641 IoOFP(io) = IoIFP(io) = PerlIO_stdout();
2643 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2645 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
2647 PL_stderrgv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2648 GvMULTI_on(PL_stderrgv);
2649 io = GvIOp(PL_stderrgv);
2650 IoOFP(io) = IoIFP(io) = PerlIO_stderr();
2651 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2653 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
2655 PL_statname = NEWSV(66,0); /* last filename we did stat on */
2658 PL_osname = savepv(OSNAME);
2662 S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
2669 argc--,argv++; /* skip name of script */
2670 if (PL_doswitches) {
2671 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2674 if (argv[0][1] == '-') {
2678 if (s = strchr(argv[0], '=')) {
2680 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2683 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2686 PL_toptarget = NEWSV(0,0);
2687 sv_upgrade(PL_toptarget, SVt_PVFM);
2688 sv_setpvn(PL_toptarget, "", 0);
2689 PL_bodytarget = NEWSV(0,0);
2690 sv_upgrade(PL_bodytarget, SVt_PVFM);
2691 sv_setpvn(PL_bodytarget, "", 0);
2692 PL_formtarget = PL_bodytarget;
2695 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2696 sv_setpv(GvSV(tmpgv),PL_origfilename);
2697 magicname("0", "0", 1);
2699 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2700 sv_setpv(GvSV(tmpgv),PL_origargv[0]);
2701 if (PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2702 GvMULTI_on(PL_argvgv);
2703 (void)gv_AVadd(PL_argvgv);
2704 av_clear(GvAVn(PL_argvgv));
2705 for (; argc > 0; argc--,argv++) {
2706 av_push(GvAVn(PL_argvgv),newSVpv(argv[0],0));
2709 if (PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2711 GvMULTI_on(PL_envgv);
2712 hv = GvHVn(PL_envgv);
2713 hv_magic(hv, PL_envgv, 'E');
2714 #if !defined( VMS) && !defined(EPOC) /* VMS doesn't have environ array */
2715 /* Note that if the supplied env parameter is actually a copy
2716 of the global environ then it may now point to free'd memory
2717 if the environment has been modified since. To avoid this
2718 problem we treat env==NULL as meaning 'use the default'
2723 environ[0] = Nullch;
2724 for (; *env; env++) {
2725 if (!(s = strchr(*env,'=')))
2731 sv = newSVpv(s--,0);
2732 (void)hv_store(hv, *env, s - *env, sv, 0);
2734 #if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
2735 /* Sins of the RTL. See note in my_setenv(). */
2736 (void)PerlEnv_putenv(savepv(*env));
2740 #ifdef DYNAMIC_ENV_FETCH
2741 HvNAME(hv) = savepv(ENV_HV_NAME);
2745 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2746 sv_setiv(GvSV(tmpgv), (IV)getpid());
2750 S_init_perllib(pTHX)
2755 s = PerlEnv_getenv("PERL5LIB");
2759 incpush(PerlEnv_getenv("PERLLIB"), FALSE);
2761 /* Treat PERL5?LIB as a possible search list logical name -- the
2762 * "natural" VMS idiom for a Unix path string. We allow each
2763 * element to be a set of |-separated directories for compatibility.
2767 if (my_trnlnm("PERL5LIB",buf,0))
2768 do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2770 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2774 /* Use the ~-expanded versions of APPLLIB (undocumented),
2775 ARCHLIB PRIVLIB SITEARCH and SITELIB
2778 incpush(APPLLIB_EXP, TRUE);
2782 incpush(ARCHLIB_EXP, FALSE);
2785 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2788 incpush(PRIVLIB_EXP, TRUE);
2790 incpush(PRIVLIB_EXP, FALSE);
2794 incpush(SITEARCH_EXP, FALSE);
2798 incpush(SITELIB_EXP, TRUE);
2800 incpush(SITELIB_EXP, FALSE);
2803 #if defined(PERL_VENDORLIB_EXP)
2805 incpush(PERL_VENDORLIB_EXP, TRUE);
2807 incpush(PERL_VENDORLIB_EXP, FALSE);
2811 incpush(".", FALSE);
2815 # define PERLLIB_SEP ';'
2818 # define PERLLIB_SEP '|'
2820 # define PERLLIB_SEP ':'
2823 #ifndef PERLLIB_MANGLE
2824 # define PERLLIB_MANGLE(s,n) (s)
2828 S_incpush(pTHX_ char *p, int addsubdirs)
2830 SV *subdir = Nullsv;
2836 subdir = sv_newmortal();
2837 if (!PL_archpat_auto) {
2838 STRLEN len = (sizeof(ARCHNAME) + strlen(PL_patchlevel)
2839 + sizeof("//auto"));
2840 New(55, PL_archpat_auto, len, char);
2841 sprintf(PL_archpat_auto, "/%s/%s/auto", ARCHNAME, PL_patchlevel);
2843 for (len = sizeof(ARCHNAME) + 2;
2844 PL_archpat_auto[len] != '\0' && PL_archpat_auto[len] != '/'; len++)
2845 if (PL_archpat_auto[len] == '.') PL_archpat_auto[len] = '_';
2850 /* Break at all separators */
2852 SV *libdir = NEWSV(55,0);
2855 /* skip any consecutive separators */
2856 while ( *p == PERLLIB_SEP ) {
2857 /* Uncomment the next line for PATH semantics */
2858 /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */
2862 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2863 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2868 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2869 p = Nullch; /* break out */
2873 * BEFORE pushing libdir onto @INC we may first push version- and
2874 * archname-specific sub-directories.
2877 struct stat tmpstatbuf;
2882 if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) {
2884 while (unix[len-1] == '/') len--; /* Cosmetic */
2885 sv_usepvn(libdir,unix,len);
2888 PerlIO_printf(Perl_error_log,
2889 "Failed to unixify @INC element \"%s\"\n",
2892 /* .../archname/version if -d .../archname/version/auto */
2893 sv_setsv(subdir, libdir);
2894 sv_catpv(subdir, PL_archpat_auto);
2895 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2896 S_ISDIR(tmpstatbuf.st_mode))
2897 av_push(GvAVn(PL_incgv),
2898 newSVpvn(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2900 /* .../archname if -d .../archname/auto */
2901 sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
2902 strlen(PL_patchlevel) + 1, "", 0);
2903 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2904 S_ISDIR(tmpstatbuf.st_mode))
2905 av_push(GvAVn(PL_incgv),
2906 newSVpvn(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2909 /* finally push this lib directory on the end of @INC */
2910 av_push(GvAVn(PL_incgv), libdir);
2915 STATIC struct perl_thread *
2916 S_init_main_thread(pTHX)
2918 #if !defined(PERL_IMPLICIT_CONTEXT)
2919 struct perl_thread *thr;
2923 Newz(53, thr, 1, struct perl_thread);
2924 PL_curcop = &PL_compiling;
2925 thr->interp = PERL_GET_INTERP;
2926 thr->cvcache = newHV();
2927 thr->threadsv = newAV();
2928 /* thr->threadsvp is set when find_threadsv is called */
2929 thr->specific = newAV();
2930 thr->flags = THRf_R_JOINABLE;
2931 MUTEX_INIT(&thr->mutex);
2932 /* Handcraft thrsv similarly to mess_sv */
2933 New(53, PL_thrsv, 1, SV);
2934 Newz(53, xpv, 1, XPV);
2935 SvFLAGS(PL_thrsv) = SVt_PV;
2936 SvANY(PL_thrsv) = (void*)xpv;
2937 SvREFCNT(PL_thrsv) = 1 << 30; /* practically infinite */
2938 SvPVX(PL_thrsv) = (char*)thr;
2939 SvCUR_set(PL_thrsv, sizeof(thr));
2940 SvLEN_set(PL_thrsv, sizeof(thr));
2941 *SvEND(PL_thrsv) = '\0'; /* in the trailing_nul field */
2942 thr->oursv = PL_thrsv;
2943 PL_chopset = " \n-";
2946 MUTEX_LOCK(&PL_threads_mutex);
2951 MUTEX_UNLOCK(&PL_threads_mutex);
2953 #ifdef HAVE_THREAD_INTERN
2954 Perl_init_thread_intern(thr);
2957 #ifdef SET_THREAD_SELF
2958 SET_THREAD_SELF(thr);
2960 thr->self = pthread_self();
2961 #endif /* SET_THREAD_SELF */
2965 * These must come after the SET_THR because sv_setpvn does
2966 * SvTAINT and the taint fields require dTHR.
2968 PL_toptarget = NEWSV(0,0);
2969 sv_upgrade(PL_toptarget, SVt_PVFM);
2970 sv_setpvn(PL_toptarget, "", 0);
2971 PL_bodytarget = NEWSV(0,0);
2972 sv_upgrade(PL_bodytarget, SVt_PVFM);
2973 sv_setpvn(PL_bodytarget, "", 0);
2974 PL_formtarget = PL_bodytarget;
2975 thr->errsv = newSVpvn("", 0);
2976 (void) find_threadsv("@"); /* Ensure $@ is initialised early */
2979 PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
2980 PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
2981 PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
2982 PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
2983 PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
2985 PL_reginterp_cnt = 0;
2989 #endif /* USE_THREADS */
2992 Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
2996 line_t oldline = PL_curcop->cop_line;
3002 while (AvFILL(paramList) >= 0) {
3003 cv = (CV*)av_shift(paramList);
3005 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_list_body), cv);
3008 (void)SvPV(atsv, len);
3010 PL_curcop = &PL_compiling;
3011 PL_curcop->cop_line = oldline;
3012 if (paramList == PL_beginav)
3013 sv_catpv(atsv, "BEGIN failed--compilation aborted");
3015 sv_catpv(atsv, "END failed--cleanup aborted");
3016 while (PL_scopestack_ix > oldscope)
3018 Perl_croak(aTHX_ "%s", SvPVX(atsv));
3025 /* my_exit() was called */
3026 while (PL_scopestack_ix > oldscope)
3029 PL_curstash = PL_defstash;
3030 if (PL_endav && !PL_minus_c)
3031 call_list(oldscope, PL_endav);
3032 PL_curcop = &PL_compiling;
3033 PL_curcop->cop_line = oldline;
3034 if (PL_statusvalue) {
3035 if (paramList == PL_beginav)
3036 Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
3038 Perl_croak(aTHX_ "END failed--cleanup aborted");
3044 PL_curcop = &PL_compiling;
3045 PL_curcop->cop_line = oldline;
3048 PerlIO_printf(Perl_error_log, "panic: restartop\n");
3056 S_call_list_body(pTHX_ va_list args)
3059 CV *cv = va_arg(args, CV*);
3061 PUSHMARK(PL_stack_sp);
3062 call_sv((SV*)cv, G_EVAL|G_DISCARD);
3067 Perl_my_exit(pTHX_ U32 status)
3071 DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
3072 thr, (unsigned long) status));
3081 STATUS_NATIVE_SET(status);
3088 Perl_my_failure_exit(pTHX)
3091 if (vaxc$errno & 1) {
3092 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
3093 STATUS_NATIVE_SET(44);
3096 if (!vaxc$errno && errno) /* unlikely */
3097 STATUS_NATIVE_SET(44);
3099 STATUS_NATIVE_SET(vaxc$errno);
3104 STATUS_POSIX_SET(errno);
3106 exitstatus = STATUS_POSIX >> 8;
3107 if (exitstatus & 255)
3108 STATUS_POSIX_SET(exitstatus);
3110 STATUS_POSIX_SET(255);
3117 S_my_exit_jump(pTHX)
3120 register PERL_CONTEXT *cx;
3125 SvREFCNT_dec(PL_e_script);
3126 PL_e_script = Nullsv;
3129 POPSTACK_TO(PL_mainstack);
3130 if (cxstack_ix >= 0) {
3133 POPBLOCK(cx,PL_curpm);
3146 read_e_script(pTHXo_ int idx, SV *buf_sv, int maxlen)
3149 p = SvPVX(PL_e_script);
3150 nl = strchr(p, '\n');
3151 nl = (nl) ? nl+1 : SvEND(PL_e_script);
3153 filter_del(read_e_script);
3156 sv_catpvn(buf_sv, p, nl-p);
3157 sv_chop(PL_e_script, nl);