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)) {
1245 call_xbody((OP*)&myop, FALSE);
1246 retval = PL_stack_sp - (PL_stack_base + oldmark);
1247 CATCH_SET(oldcatch);
1250 cLOGOP->op_other = PL_op;
1252 /* we're trying to emulate pp_entertry() here */
1254 register PERL_CONTEXT *cx;
1255 I32 gimme = GIMME_V;
1260 push_return(PL_op->op_next);
1261 PUSHBLOCK(cx, CXt_EVAL, PL_stack_sp);
1263 PL_eval_root = PL_op; /* Only needed so that goto works right. */
1265 PL_in_eval = EVAL_INEVAL;
1266 if (flags & G_KEEPERR)
1267 PL_in_eval |= EVAL_KEEPERR;
1274 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_body),
1278 retval = PL_stack_sp - (PL_stack_base + oldmark);
1279 if (!(flags & G_KEEPERR))
1286 /* my_exit() was called */
1287 PL_curstash = PL_defstash;
1290 Perl_croak(aTHX_ "Callback called exit");
1295 PL_op = PL_restartop;
1299 PL_stack_sp = PL_stack_base + oldmark;
1300 if (flags & G_ARRAY)
1304 *++PL_stack_sp = &PL_sv_undef;
1309 if (PL_scopestack_ix > oldscope) {
1313 register PERL_CONTEXT *cx;
1324 if (flags & G_DISCARD) {
1325 PL_stack_sp = PL_stack_base + oldmark;
1335 S_call_body(pTHX_ va_list args)
1337 OP *myop = va_arg(args, OP*);
1338 int is_eval = va_arg(args, int);
1340 call_xbody(myop, is_eval);
1345 S_call_xbody(pTHX_ OP *myop, int is_eval)
1349 if (PL_op == myop) {
1351 PL_op = Perl_pp_entereval(aTHX);
1353 PL_op = Perl_pp_entersub(aTHX);
1359 /* Eval a string. The G_EVAL flag is always assumed. */
1362 Perl_eval_sv(pTHX_ SV *sv, I32 flags)
1364 /* See G_* flags in cop.h */
1367 UNOP myop; /* fake syntax tree node */
1368 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_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_body),
1402 retval = PL_stack_sp - (PL_stack_base + oldmark);
1403 if (!(flags & G_KEEPERR))
1410 /* my_exit() was called */
1411 PL_curstash = PL_defstash;
1414 Perl_croak(aTHX_ "Callback called exit");
1419 PL_op = PL_restartop;
1423 PL_stack_sp = PL_stack_base + oldmark;
1424 if (flags & G_ARRAY)
1428 *++PL_stack_sp = &PL_sv_undef;
1433 if (flags & G_DISCARD) {
1434 PL_stack_sp = PL_stack_base + oldmark;
1444 Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
1447 SV* sv = newSVpv(p, 0);
1450 eval_sv(sv, G_SCALAR);
1457 if (croak_on_error && SvTRUE(ERRSV)) {
1459 Perl_croak(aTHX_ SvPVx(ERRSV, n_a));
1465 /* Require a module. */
1468 Perl_require_pv(pTHX_ const char *pv)
1472 PUSHSTACKi(PERLSI_REQUIRE);
1474 sv = sv_newmortal();
1475 sv_setpv(sv, "require '");
1478 eval_sv(sv, G_DISCARD);
1484 Perl_magicname(pTHX_ char *sym, char *name, I32 namlen)
1488 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1489 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1493 S_usage(pTHX_ char *name) /* XXX move this out into a module ? */
1495 /* This message really ought to be max 23 lines.
1496 * Removed -h because the user already knows that opton. Others? */
1498 static char *usage_msg[] = {
1499 "-0[octal] specify record separator (\\0, if no argument)",
1500 "-a autosplit mode with -n or -p (splits $_ into @F)",
1501 "-c check syntax only (runs BEGIN and END blocks)",
1502 "-d[:debugger] run program under debugger",
1503 "-D[number/list] set debugging flags (argument is a bit mask or alphabets)",
1504 "-e 'command' one line of program (several -e's allowed, omit programfile)",
1505 "-F/pattern/ split() pattern for -a switch (//'s are optional)",
1506 "-i[extension] edit <> files in place (makes backup if extension supplied)",
1507 "-Idirectory specify @INC/#include directory (several -I's allowed)",
1508 "-l[octal] enable line ending processing, specifies line terminator",
1509 "-[mM][-]module execute `use/no module...' before executing program",
1510 "-n assume 'while (<>) { ... }' loop around program",
1511 "-p assume loop like -n but print line also, like sed",
1512 "-P run program through C preprocessor before compilation",
1513 "-s enable rudimentary parsing for switches after programfile",
1514 "-S look for programfile using PATH environment variable",
1515 "-T enable tainting checks",
1516 "-u dump core after parsing program",
1517 "-U allow unsafe operations",
1518 "-v print version, subversion (includes VERY IMPORTANT perl info)",
1519 "-V[:variable] print configuration summary (or a single Config.pm variable)",
1520 "-w enable many useful warnings (RECOMMENDED)",
1521 "-x[directory] strip off text before #!perl line and perhaps cd to directory",
1525 char **p = usage_msg;
1527 printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1529 printf("\n %s", *p++);
1532 /* This routine handles any switches that can be given during run */
1535 Perl_moreswitches(pTHX_ char *s)
1544 rschar = scan_oct(s, 4, &numlen);
1545 SvREFCNT_dec(PL_nrs);
1546 if (rschar & ~((U8)~0))
1547 PL_nrs = &PL_sv_undef;
1548 else if (!rschar && numlen >= 2)
1549 PL_nrs = newSVpvn("", 0);
1552 PL_nrs = newSVpvn(&ch, 1);
1558 PL_splitstr = savepv(s + 1);
1572 if (*s == ':' || *s == '=') {
1573 my_setenv("PERL5DB", Perl_form(aTHX_ "use Devel::%s;", ++s));
1577 PL_perldb = PERLDB_ALL;
1585 if (isALPHA(s[1])) {
1586 static char debopts[] = "psltocPmfrxuLHXDS";
1589 for (s++; *s && (d = strchr(debopts,*s)); s++)
1590 PL_debug |= 1 << (d - debopts);
1593 PL_debug = atoi(s+1);
1594 for (s++; isDIGIT(*s); s++) ;
1596 PL_debug |= 0x80000000;
1599 if (ckWARN_d(WARN_DEBUGGING))
1600 Perl_warner(aTHX_ WARN_DEBUGGING,
1601 "Recompile perl with -DDEBUGGING to use -D switch\n");
1602 for (s++; isALNUM(*s); s++) ;
1608 usage(PL_origargv[0]);
1612 Safefree(PL_inplace);
1613 PL_inplace = savepv(s+1);
1615 for (s = PL_inplace; *s && !isSPACE(*s); s++) ;
1618 if (*s == '-') /* Additional switches on #! line. */
1622 case 'I': /* -I handled both here and in parse_perl() */
1625 while (*s && isSPACE(*s))
1629 for (e = s; *e && !isSPACE(*e); e++) ;
1630 p = savepvn(s, e-s);
1636 Perl_croak(aTHX_ "No space allowed after -I");
1644 PL_ors = savepv("\n");
1646 *PL_ors = scan_oct(s, 3 + (*s == '0'), &numlen);
1651 if (RsPARA(PL_nrs)) {
1656 PL_ors = SvPV(PL_nrs, PL_orslen);
1657 PL_ors = savepvn(PL_ors, PL_orslen);
1661 forbid_setid("-M"); /* XXX ? */
1664 forbid_setid("-m"); /* XXX ? */
1669 /* -M-foo == 'no foo' */
1670 if (*s == '-') { use = "no "; ++s; }
1671 sv = newSVpv(use,0);
1673 /* We allow -M'Module qw(Foo Bar)' */
1674 while(isALNUM(*s) || *s==':') ++s;
1676 sv_catpv(sv, start);
1677 if (*(start-1) == 'm') {
1679 Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
1680 sv_catpv( sv, " ()");
1683 sv_catpvn(sv, start, s-start);
1684 sv_catpv(sv, " split(/,/,q{");
1689 if (PL_preambleav == NULL)
1690 PL_preambleav = newAV();
1691 av_push(PL_preambleav, sv);
1694 Perl_croak(aTHX_ "No space allowed after -%c", *(s-1));
1706 PL_doswitches = TRUE;
1711 Perl_croak(aTHX_ "Too late for \"-T\" option");
1715 PL_do_undump = TRUE;
1723 #if defined(PERL_SUBVERSION) && PERL_SUBVERSION > 0
1724 printf("\nThis is perl, version %d.%03d_%02d built for %s",
1725 PERL_REVISION, PERL_VERSION, PERL_SUBVERSION, ARCHNAME);
1727 printf("\nThis is perl, version %s built for %s",
1728 PL_patchlevel, ARCHNAME);
1730 #if defined(LOCAL_PATCH_COUNT)
1731 if (LOCAL_PATCH_COUNT > 0)
1732 printf("\n(with %d registered patch%s, see perl -V for more detail)",
1733 LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : "");
1736 printf("\n\nCopyright 1987-1999, Larry Wall\n");
1738 printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1741 printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
1742 printf("djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
1745 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1746 "Version 5 port Copyright (c) 1994-1999, Andreas Kaiser, Ilya Zakharevich\n");
1749 printf("atariST series port, ++jrb bammi@cadence.com\n");
1752 printf("BeOS port Copyright Tom Spindler, 1997-1999\n");
1755 printf("MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-1999\n");
1758 printf("MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
1761 printf("Stratus VOS port by Paul_Green@stratus.com, 1997-1999\n");
1764 printf("VM/ESA port by Neale Ferguson, 1998-1999\n");
1767 printf("BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
1770 printf("MiNT port by Guido Flohr, 1997-1999\n");
1772 #ifdef BINARY_BUILD_NOTICE
1773 BINARY_BUILD_NOTICE;
1776 Perl may be copied only under the terms of either the Artistic License or the\n\
1777 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n\
1778 Complete documentation for Perl, including FAQ lists, should be found on\n\
1779 this system using `man perl' or `perldoc perl'. If you have access to the\n\
1780 Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
1783 if (! (PL_dowarn & G_WARN_ALL_MASK))
1784 PL_dowarn |= G_WARN_ON;
1788 PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
1789 PL_compiling.cop_warnings = WARN_ALL ;
1793 PL_dowarn = G_WARN_ALL_OFF;
1794 PL_compiling.cop_warnings = WARN_NONE ;
1799 if (s[1] == '-') /* Additional switches on #! line. */
1804 #if defined(WIN32) || !defined(PERL_STRICT_CR)
1810 #ifdef ALTERNATE_SHEBANG
1811 case 'S': /* OS/2 needs -S on "extproc" line. */
1819 Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
1824 /* compliments of Tom Christiansen */
1826 /* unexec() can be found in the Gnu emacs distribution */
1827 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
1830 Perl_my_unexec(pTHX)
1838 prog = newSVpv(BIN_EXP, 0);
1839 sv_catpv(prog, "/perl");
1840 file = newSVpv(PL_origfilename, 0);
1841 sv_catpv(file, ".perldump");
1843 unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
1844 /* unexec prints msg to stderr in case of failure */
1845 PerlProc_exit(status);
1848 # include <lib$routines.h>
1849 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
1851 ABORT(); /* for use with undump */
1856 /* initialize curinterp */
1861 #ifdef PERL_OBJECT /* XXX kludge */
1864 PL_chopset = " \n-"; \
1865 PL_copline = NOLINE; \
1866 PL_curcop = &PL_compiling;\
1867 PL_curcopdb = NULL; \
1870 PL_dumpindent = 4; \
1871 PL_laststatval = -1; \
1872 PL_laststype = OP_STAT; \
1873 PL_maxscream = -1; \
1874 PL_maxsysfd = MAXSYSFD; \
1875 PL_statname = Nullsv; \
1876 PL_tmps_floor = -1; \
1878 PL_op_mask = NULL; \
1880 PL_laststatval = -1; \
1881 PL_laststype = OP_STAT; \
1882 PL_mess_sv = Nullsv; \
1883 PL_splitstr = " "; \
1884 PL_generation = 100; \
1885 PL_exitlist = NULL; \
1886 PL_exitlistlen = 0; \
1888 PL_in_clean_objs = FALSE; \
1889 PL_in_clean_all = FALSE; \
1890 PL_profiledata = NULL; \
1892 PL_rsfp_filters = Nullav; \
1897 # ifdef MULTIPLICITY
1898 # define PERLVAR(var,type)
1899 # define PERLVARA(var,n,type)
1900 # if defined(PERL_IMPLICIT_CONTEXT)
1901 # if defined(USE_THREADS)
1902 # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
1903 # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
1904 # else /* !USE_THREADS */
1905 # define PERLVARI(var,type,init) aTHX->var = init;
1906 # define PERLVARIC(var,type,init) aTHX->var = init;
1907 # endif /* USE_THREADS */
1909 # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
1910 # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
1912 # include "intrpvar.h"
1913 # ifndef USE_THREADS
1914 # include "thrdvar.h"
1921 # define PERLVAR(var,type)
1922 # define PERLVARA(var,n,type)
1923 # define PERLVARI(var,type,init) PL_##var = init;
1924 # define PERLVARIC(var,type,init) PL_##var = init;
1925 # include "intrpvar.h"
1926 # ifndef USE_THREADS
1927 # include "thrdvar.h"
1939 S_init_main_stash(pTHX)
1944 /* Note that strtab is a rather special HV. Assumptions are made
1945 about not iterating on it, and not adding tie magic to it.
1946 It is properly deallocated in perl_destruct() */
1947 PL_strtab = newHV();
1949 MUTEX_INIT(&PL_strtab_mutex);
1951 HvSHAREKEYS_off(PL_strtab); /* mandatory */
1952 hv_ksplit(PL_strtab, 512);
1954 PL_curstash = PL_defstash = newHV();
1955 PL_curstname = newSVpvn("main",4);
1956 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1957 SvREFCNT_dec(GvHV(gv));
1958 GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
1960 HvNAME(PL_defstash) = savepv("main");
1961 PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1962 GvMULTI_on(PL_incgv);
1963 PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
1964 GvMULTI_on(PL_hintgv);
1965 PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1966 PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1967 GvMULTI_on(PL_errgv);
1968 PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
1969 GvMULTI_on(PL_replgv);
1970 (void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */
1971 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
1972 sv_setpvn(ERRSV, "", 0);
1973 PL_curstash = PL_defstash;
1974 PL_compiling.cop_stash = PL_defstash;
1975 PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
1976 PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
1977 /* We must init $/ before switches are processed. */
1978 sv_setpvn(get_sv("/", TRUE), "\n", 1);
1982 S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
1990 PL_origfilename = savepv("-e");
1993 /* if find_script() returns, it returns a malloc()-ed value */
1994 PL_origfilename = scriptname = find_script(scriptname, dosearch, NULL, 1);
1996 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
1997 char *s = scriptname + 8;
1998 *fdscript = atoi(s);
2002 scriptname = savepv(s + 1);
2003 Safefree(PL_origfilename);
2004 PL_origfilename = scriptname;
2009 PL_curcop->cop_filegv = gv_fetchfile(PL_origfilename);
2010 if (strEQ(PL_origfilename,"-"))
2012 if (*fdscript >= 0) {
2013 PL_rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE);
2014 #if defined(HAS_FCNTL) && defined(F_SETFD)
2016 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); /* ensure close-on-exec */
2019 else if (PL_preprocess) {
2020 char *cpp_cfg = CPPSTDIN;
2021 SV *cpp = newSVpvn("",0);
2022 SV *cmd = NEWSV(0,0);
2024 if (strEQ(cpp_cfg, "cppstdin"))
2025 Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
2026 sv_catpv(cpp, cpp_cfg);
2029 sv_catpv(sv,PRIVLIB_EXP);
2032 Perl_sv_setpvf(aTHX_ cmd, "\
2033 sed %s -e \"/^[^#]/b\" \
2034 -e \"/^#[ ]*include[ ]/b\" \
2035 -e \"/^#[ ]*define[ ]/b\" \
2036 -e \"/^#[ ]*if[ ]/b\" \
2037 -e \"/^#[ ]*ifdef[ ]/b\" \
2038 -e \"/^#[ ]*ifndef[ ]/b\" \
2039 -e \"/^#[ ]*else/b\" \
2040 -e \"/^#[ ]*elif[ ]/b\" \
2041 -e \"/^#[ ]*undef[ ]/b\" \
2042 -e \"/^#[ ]*endif/b\" \
2045 (PL_doextract ? "-e \"1,/^#/d\n\"" : ""),
2048 Perl_sv_setpvf(aTHX_ cmd, "\
2049 %s %s -e '/^[^#]/b' \
2050 -e '/^#[ ]*include[ ]/b' \
2051 -e '/^#[ ]*define[ ]/b' \
2052 -e '/^#[ ]*if[ ]/b' \
2053 -e '/^#[ ]*ifdef[ ]/b' \
2054 -e '/^#[ ]*ifndef[ ]/b' \
2055 -e '/^#[ ]*else/b' \
2056 -e '/^#[ ]*elif[ ]/b' \
2057 -e '/^#[ ]*undef[ ]/b' \
2058 -e '/^#[ ]*endif/b' \
2062 Perl_sv_setpvf(aTHX_ cmd, "\
2063 %s %s -e '/^[^#]/b' \
2064 -e '/^#[ ]*include[ ]/b' \
2065 -e '/^#[ ]*define[ ]/b' \
2066 -e '/^#[ ]*if[ ]/b' \
2067 -e '/^#[ ]*ifdef[ ]/b' \
2068 -e '/^#[ ]*ifndef[ ]/b' \
2069 -e '/^#[ ]*else/b' \
2070 -e '/^#[ ]*elif[ ]/b' \
2071 -e '/^#[ ]*undef[ ]/b' \
2072 -e '/^#[ ]*endif/b' \
2081 (PL_doextract ? "-e '1,/^#/d\n'" : ""),
2083 scriptname, cpp, sv, CPPMINUS);
2084 PL_doextract = FALSE;
2085 #ifdef IAMSUID /* actually, this is caught earlier */
2086 if (PL_euid != PL_uid && !PL_euid) { /* if running suidperl */
2088 (void)seteuid(PL_uid); /* musn't stay setuid root */
2091 (void)setreuid((Uid_t)-1, PL_uid);
2093 #ifdef HAS_SETRESUID
2094 (void)setresuid((Uid_t)-1, PL_uid, (Uid_t)-1);
2096 PerlProc_setuid(PL_uid);
2100 if (PerlProc_geteuid() != PL_uid)
2101 Perl_croak(aTHX_ "Can't do seteuid!\n");
2103 #endif /* IAMSUID */
2104 PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
2108 else if (!*scriptname) {
2109 forbid_setid("program input from stdin");
2110 PL_rsfp = PerlIO_stdin();
2113 PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
2114 #if defined(HAS_FCNTL) && defined(F_SETFD)
2116 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); /* ensure close-on-exec */
2121 #ifndef IAMSUID /* in case script is not readable before setuid */
2123 PerlLIO_stat(SvPVX(GvSV(PL_curcop->cop_filegv)),&PL_statbuf) >= 0 &&
2124 PL_statbuf.st_mode & (S_ISUID|S_ISGID))
2127 PerlProc_execv(Perl_form(aTHX_ "%s/sperl%s", BIN_EXP, PL_patchlevel), PL_origargv);
2128 Perl_croak(aTHX_ "Can't do setuid\n");
2132 Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
2133 SvPVX(GvSV(PL_curcop->cop_filegv)), Strerror(errno));
2138 * I_SYSSTATVFS HAS_FSTATVFS
2140 * I_STATFS HAS_FSTATFS
2141 * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT
2142 * here so that metaconfig picks them up. */
2146 S_fd_on_nosuid_fs(pTHX_ int fd)
2151 * Preferred order: fstatvfs(), fstatfs(), getmntent().
2152 * fstatvfs() is UNIX98.
2154 * getmntent() is O(number-of-mounted-filesystems) and can hang.
2157 # ifdef HAS_FSTATVFS
2158 struct statvfs stfs;
2159 check_okay = fstatvfs(fd, &stfs) == 0;
2160 on_nosuid = check_okay && (stfs.f_flag & ST_NOSUID);
2162 # if defined(HAS_FSTATFS) && defined(HAS_STRUCT_STATFS_FLAGS)
2164 check_okay = fstatfs(fd, &stfs) == 0;
2165 # undef PERL_MOUNT_NOSUID
2166 # if !defined(PERL_MOUNT_NOSUID) && defined(MNT_NOSUID)
2167 # define PERL_MOUNT_NOSUID MNT_NOSUID
2169 # if !defined(PERL_MOUNT_NOSUID) && defined(MS_NOSUID)
2170 # define PERL_MOUNT_NOSUID MS_NOSUID
2172 # if !defined(PERL_MOUNT_NOSUID) && defined(M_NOSUID)
2173 # define PERL_MOUNT_NOSUID M_NOSUID
2175 # ifdef PERL_MOUNT_NOSUID
2176 on_nosuid = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
2179 # if defined(HAS_GETMNTENT) && defined(HAS_HASMNTOPT) && defined(MNTOPT_NOSUID)
2180 FILE *mtab = fopen("/etc/mtab", "r");
2181 struct mntent *entry;
2182 struct stat stb, fsb;
2184 if (mtab && (fstat(fd, &stb) == 0)) {
2185 while (entry = getmntent(mtab)) {
2186 if (stat(entry->mnt_dir, &fsb) == 0
2187 && fsb.st_dev == stb.st_dev)
2189 /* found the filesystem */
2191 if (hasmntopt(entry, MNTOPT_NOSUID))
2194 } /* A single fs may well fail its stat(). */
2199 # endif /* mntent */
2200 # endif /* statfs */
2201 # endif /* statvfs */
2203 Perl_croak(aTHX_ "Can't check filesystem of script \"%s\"", PL_origfilename);
2206 #endif /* IAMSUID */
2209 S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript)
2213 /* do we need to emulate setuid on scripts? */
2215 /* This code is for those BSD systems that have setuid #! scripts disabled
2216 * in the kernel because of a security problem. Merely defining DOSUID
2217 * in perl will not fix that problem, but if you have disabled setuid
2218 * scripts in the kernel, this will attempt to emulate setuid and setgid
2219 * on scripts that have those now-otherwise-useless bits set. The setuid
2220 * root version must be called suidperl or sperlN.NNN. If regular perl
2221 * discovers that it has opened a setuid script, it calls suidperl with
2222 * the same argv that it had. If suidperl finds that the script it has
2223 * just opened is NOT setuid root, it sets the effective uid back to the
2224 * uid. We don't just make perl setuid root because that loses the
2225 * effective uid we had before invoking perl, if it was different from the
2228 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
2229 * be defined in suidperl only. suidperl must be setuid root. The
2230 * Configure script will set this up for you if you want it.
2237 if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */
2238 Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
2239 if (fdscript < 0 && PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
2244 #ifndef HAS_SETREUID
2245 /* On this access check to make sure the directories are readable,
2246 * there is actually a small window that the user could use to make
2247 * filename point to an accessible directory. So there is a faint
2248 * chance that someone could execute a setuid script down in a
2249 * non-accessible directory. I don't know what to do about that.
2250 * But I don't think it's too important. The manual lies when
2251 * it says access() is useful in setuid programs.
2253 if (PerlLIO_access(SvPVX(GvSV(PL_curcop->cop_filegv)),1)) /*double check*/
2254 Perl_croak(aTHX_ "Permission denied");
2256 /* If we can swap euid and uid, then we can determine access rights
2257 * with a simple stat of the file, and then compare device and
2258 * inode to make sure we did stat() on the same file we opened.
2259 * Then we just have to make sure he or she can execute it.
2262 struct stat tmpstatbuf;
2266 setreuid(PL_euid,PL_uid) < 0
2269 setresuid(PL_euid,PL_uid,(Uid_t)-1) < 0
2272 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
2273 Perl_croak(aTHX_ "Can't swap uid and euid"); /* really paranoid */
2274 if (PerlLIO_stat(SvPVX(GvSV(PL_curcop->cop_filegv)),&tmpstatbuf) < 0)
2275 Perl_croak(aTHX_ "Permission denied"); /* testing full pathname here */
2276 #if defined(IAMSUID) && !defined(NO_NOSUID_CHECK)
2277 if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp)))
2278 Perl_croak(aTHX_ "Permission denied");
2280 if (tmpstatbuf.st_dev != PL_statbuf.st_dev ||
2281 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
2282 (void)PerlIO_close(PL_rsfp);
2283 if (PL_rsfp = PerlProc_popen("/bin/mail root","w")) { /* heh, heh */
2284 PerlIO_printf(PL_rsfp,
2285 "User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2286 (Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
2287 (long)PL_uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
2288 (long)PL_statbuf.st_dev, (long)PL_statbuf.st_ino,
2289 SvPVX(GvSV(PL_curcop->cop_filegv)),
2290 (long)PL_statbuf.st_uid, (long)PL_statbuf.st_gid);
2291 (void)PerlProc_pclose(PL_rsfp);
2293 Perl_croak(aTHX_ "Permission denied\n");
2297 setreuid(PL_uid,PL_euid) < 0
2299 # if defined(HAS_SETRESUID)
2300 setresuid(PL_uid,PL_euid,(Uid_t)-1) < 0
2303 || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
2304 Perl_croak(aTHX_ "Can't reswap uid and euid");
2305 if (!cando(S_IXUSR,FALSE,&PL_statbuf)) /* can real uid exec? */
2306 Perl_croak(aTHX_ "Permission denied\n");
2308 #endif /* HAS_SETREUID */
2309 #endif /* IAMSUID */
2311 if (!S_ISREG(PL_statbuf.st_mode))
2312 Perl_croak(aTHX_ "Permission denied");
2313 if (PL_statbuf.st_mode & S_IWOTH)
2314 Perl_croak(aTHX_ "Setuid/gid script is writable by world");
2315 PL_doswitches = FALSE; /* -s is insecure in suid */
2316 PL_curcop->cop_line++;
2317 if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
2318 strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */
2319 Perl_croak(aTHX_ "No #! line");
2320 s = SvPV(PL_linestr,n_a)+2;
2322 while (!isSPACE(*s)) s++;
2323 for (s2 = s; (s2 > SvPV(PL_linestr,n_a)+2 &&
2324 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
2325 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
2326 Perl_croak(aTHX_ "Not a perl script");
2327 while (*s == ' ' || *s == '\t') s++;
2329 * #! arg must be what we saw above. They can invoke it by
2330 * mentioning suidperl explicitly, but they may not add any strange
2331 * arguments beyond what #! says if they do invoke suidperl that way.
2333 len = strlen(validarg);
2334 if (strEQ(validarg," PHOOEY ") ||
2335 strnNE(s,validarg,len) || !isSPACE(s[len]))
2336 Perl_croak(aTHX_ "Args must match #! line");
2339 if (PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
2340 PL_euid == PL_statbuf.st_uid)
2342 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2343 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2344 #endif /* IAMSUID */
2346 if (PL_euid) { /* oops, we're not the setuid root perl */
2347 (void)PerlIO_close(PL_rsfp);
2350 PerlProc_execv(Perl_form(aTHX_ "%s/sperl%s", BIN_EXP, PL_patchlevel), PL_origargv);
2352 Perl_croak(aTHX_ "Can't do setuid\n");
2355 if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
2357 (void)setegid(PL_statbuf.st_gid);
2360 (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
2362 #ifdef HAS_SETRESGID
2363 (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
2365 PerlProc_setgid(PL_statbuf.st_gid);
2369 if (PerlProc_getegid() != PL_statbuf.st_gid)
2370 Perl_croak(aTHX_ "Can't do setegid!\n");
2372 if (PL_statbuf.st_mode & S_ISUID) {
2373 if (PL_statbuf.st_uid != PL_euid)
2375 (void)seteuid(PL_statbuf.st_uid); /* all that for this */
2378 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
2380 #ifdef HAS_SETRESUID
2381 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
2383 PerlProc_setuid(PL_statbuf.st_uid);
2387 if (PerlProc_geteuid() != PL_statbuf.st_uid)
2388 Perl_croak(aTHX_ "Can't do seteuid!\n");
2390 else if (PL_uid) { /* oops, mustn't run as root */
2392 (void)seteuid((Uid_t)PL_uid);
2395 (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
2397 #ifdef HAS_SETRESUID
2398 (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
2400 PerlProc_setuid((Uid_t)PL_uid);
2404 if (PerlProc_geteuid() != PL_uid)
2405 Perl_croak(aTHX_ "Can't do seteuid!\n");
2408 if (!cando(S_IXUSR,TRUE,&PL_statbuf))
2409 Perl_croak(aTHX_ "Permission denied\n"); /* they can't do this */
2412 else if (PL_preprocess)
2413 Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
2414 else if (fdscript >= 0)
2415 Perl_croak(aTHX_ "fd script not allowed in suidperl\n");
2417 Perl_croak(aTHX_ "Script is not setuid/setgid in suidperl\n");
2419 /* We absolutely must clear out any saved ids here, so we */
2420 /* exec the real perl, substituting fd script for scriptname. */
2421 /* (We pass script name as "subdir" of fd, which perl will grok.) */
2422 PerlIO_rewind(PL_rsfp);
2423 PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0); /* just in case rewind didn't */
2424 for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
2425 if (!PL_origargv[which])
2426 Perl_croak(aTHX_ "Permission denied");
2427 PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
2428 PerlIO_fileno(PL_rsfp), PL_origargv[which]));
2429 #if defined(HAS_FCNTL) && defined(F_SETFD)
2430 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */
2432 PerlProc_execv(Perl_form(aTHX_ "%s/perl%s", BIN_EXP, PL_patchlevel), PL_origargv);/* try again */
2433 Perl_croak(aTHX_ "Can't do setuid\n");
2434 #endif /* IAMSUID */
2436 if (PL_euid != PL_uid || PL_egid != PL_gid) { /* (suidperl doesn't exist, in fact) */
2437 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2439 PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf); /* may be either wrapped or real suid */
2440 if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
2442 (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
2445 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2446 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2447 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2448 /* not set-id, must be wrapped */
2454 S_find_beginning(pTHX)
2456 register char *s, *s2;
2458 /* skip forward in input to the real script? */
2461 while (PL_doextract) {
2462 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
2463 Perl_croak(aTHX_ "No Perl script found in input\n");
2464 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2465 PerlIO_ungetc(PL_rsfp, '\n'); /* to keep line count right */
2466 PL_doextract = FALSE;
2467 while (*s && !(isSPACE (*s) || *s == '#')) s++;
2469 while (*s == ' ' || *s == '\t') s++;
2471 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2472 if (strnEQ(s2-4,"perl",4))
2474 while (s = moreswitches(s)) ;
2476 if (PL_cddir && PerlDir_chdir(PL_cddir) < 0)
2477 Perl_croak(aTHX_ "Can't chdir to %s",PL_cddir);
2486 PL_uid = PerlProc_getuid();
2487 PL_euid = PerlProc_geteuid();
2488 PL_gid = PerlProc_getgid();
2489 PL_egid = PerlProc_getegid();
2491 PL_uid |= PL_gid << 16;
2492 PL_euid |= PL_egid << 16;
2494 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2498 S_forbid_setid(pTHX_ char *s)
2500 if (PL_euid != PL_uid)
2501 Perl_croak(aTHX_ "No %s allowed while running setuid", s);
2502 if (PL_egid != PL_gid)
2503 Perl_croak(aTHX_ "No %s allowed while running setgid", s);
2507 Perl_init_debugger(pTHX)
2510 HV *ostash = PL_curstash;
2512 PL_curstash = PL_debstash;
2513 PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2514 AvREAL_off(PL_dbargs);
2515 PL_DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2516 PL_DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2517 PL_DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2518 sv_upgrade(GvSV(PL_DBsub), SVt_IV); /* IVX accessed if PERLDB_SUB_NN */
2519 PL_DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2520 sv_setiv(PL_DBsingle, 0);
2521 PL_DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2522 sv_setiv(PL_DBtrace, 0);
2523 PL_DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2524 sv_setiv(PL_DBsignal, 0);
2525 PL_curstash = ostash;
2528 #ifndef STRESS_REALLOC
2529 #define REASONABLE(size) (size)
2531 #define REASONABLE(size) (1) /* unreasonable */
2535 Perl_init_stacks(pTHX)
2537 /* start with 128-item stack and 8K cxstack */
2538 PL_curstackinfo = new_stackinfo(REASONABLE(128),
2539 REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
2540 PL_curstackinfo->si_type = PERLSI_MAIN;
2541 PL_curstack = PL_curstackinfo->si_stack;
2542 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
2544 PL_stack_base = AvARRAY(PL_curstack);
2545 PL_stack_sp = PL_stack_base;
2546 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
2548 New(50,PL_tmps_stack,REASONABLE(128),SV*);
2551 PL_tmps_max = REASONABLE(128);
2553 New(54,PL_markstack,REASONABLE(32),I32);
2554 PL_markstack_ptr = PL_markstack;
2555 PL_markstack_max = PL_markstack + REASONABLE(32);
2559 New(54,PL_scopestack,REASONABLE(32),I32);
2560 PL_scopestack_ix = 0;
2561 PL_scopestack_max = REASONABLE(32);
2563 New(54,PL_savestack,REASONABLE(128),ANY);
2564 PL_savestack_ix = 0;
2565 PL_savestack_max = REASONABLE(128);
2567 New(54,PL_retstack,REASONABLE(16),OP*);
2569 PL_retstack_max = REASONABLE(16);
2578 while (PL_curstackinfo->si_next)
2579 PL_curstackinfo = PL_curstackinfo->si_next;
2580 while (PL_curstackinfo) {
2581 PERL_SI *p = PL_curstackinfo->si_prev;
2582 /* curstackinfo->si_stack got nuked by sv_free_arenas() */
2583 Safefree(PL_curstackinfo->si_cxstack);
2584 Safefree(PL_curstackinfo);
2585 PL_curstackinfo = p;
2587 Safefree(PL_tmps_stack);
2588 Safefree(PL_markstack);
2589 Safefree(PL_scopestack);
2590 Safefree(PL_savestack);
2591 Safefree(PL_retstack);
2593 Safefree(PL_debname);
2594 Safefree(PL_debdelim);
2599 static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
2610 lex_start(PL_linestr);
2612 PL_subname = newSVpvn("main",4);
2616 S_init_predump_symbols(pTHX)
2623 sv_setpvn(get_sv("\"", TRUE), " ", 1);
2624 PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2625 GvMULTI_on(PL_stdingv);
2626 io = GvIOp(PL_stdingv);
2627 IoIFP(io) = PerlIO_stdin();
2628 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2630 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
2632 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2635 IoOFP(io) = IoIFP(io) = PerlIO_stdout();
2637 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2639 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
2641 PL_stderrgv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2642 GvMULTI_on(PL_stderrgv);
2643 io = GvIOp(PL_stderrgv);
2644 IoOFP(io) = IoIFP(io) = PerlIO_stderr();
2645 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2647 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
2649 PL_statname = NEWSV(66,0); /* last filename we did stat on */
2652 PL_osname = savepv(OSNAME);
2656 S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
2663 argc--,argv++; /* skip name of script */
2664 if (PL_doswitches) {
2665 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2668 if (argv[0][1] == '-') {
2672 if (s = strchr(argv[0], '=')) {
2674 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2677 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2680 PL_toptarget = NEWSV(0,0);
2681 sv_upgrade(PL_toptarget, SVt_PVFM);
2682 sv_setpvn(PL_toptarget, "", 0);
2683 PL_bodytarget = NEWSV(0,0);
2684 sv_upgrade(PL_bodytarget, SVt_PVFM);
2685 sv_setpvn(PL_bodytarget, "", 0);
2686 PL_formtarget = PL_bodytarget;
2689 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2690 sv_setpv(GvSV(tmpgv),PL_origfilename);
2691 magicname("0", "0", 1);
2693 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2694 sv_setpv(GvSV(tmpgv),PL_origargv[0]);
2695 if (PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2696 GvMULTI_on(PL_argvgv);
2697 (void)gv_AVadd(PL_argvgv);
2698 av_clear(GvAVn(PL_argvgv));
2699 for (; argc > 0; argc--,argv++) {
2700 av_push(GvAVn(PL_argvgv),newSVpv(argv[0],0));
2703 if (PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2705 GvMULTI_on(PL_envgv);
2706 hv = GvHVn(PL_envgv);
2707 hv_magic(hv, PL_envgv, 'E');
2708 #if !defined( VMS) && !defined(EPOC) /* VMS doesn't have environ array */
2709 /* Note that if the supplied env parameter is actually a copy
2710 of the global environ then it may now point to free'd memory
2711 if the environment has been modified since. To avoid this
2712 problem we treat env==NULL as meaning 'use the default'
2717 environ[0] = Nullch;
2718 for (; *env; env++) {
2719 if (!(s = strchr(*env,'=')))
2725 sv = newSVpv(s--,0);
2726 (void)hv_store(hv, *env, s - *env, sv, 0);
2728 #if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
2729 /* Sins of the RTL. See note in my_setenv(). */
2730 (void)PerlEnv_putenv(savepv(*env));
2734 #ifdef DYNAMIC_ENV_FETCH
2735 HvNAME(hv) = savepv(ENV_HV_NAME);
2739 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2740 sv_setiv(GvSV(tmpgv), (IV)getpid());
2744 S_init_perllib(pTHX)
2749 s = PerlEnv_getenv("PERL5LIB");
2753 incpush(PerlEnv_getenv("PERLLIB"), FALSE);
2755 /* Treat PERL5?LIB as a possible search list logical name -- the
2756 * "natural" VMS idiom for a Unix path string. We allow each
2757 * element to be a set of |-separated directories for compatibility.
2761 if (my_trnlnm("PERL5LIB",buf,0))
2762 do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2764 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2768 /* Use the ~-expanded versions of APPLLIB (undocumented),
2769 ARCHLIB PRIVLIB SITEARCH and SITELIB
2772 incpush(APPLLIB_EXP, TRUE);
2776 incpush(ARCHLIB_EXP, FALSE);
2779 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2782 incpush(PRIVLIB_EXP, TRUE);
2784 incpush(PRIVLIB_EXP, FALSE);
2788 incpush(SITEARCH_EXP, FALSE);
2792 incpush(SITELIB_EXP, TRUE);
2794 incpush(SITELIB_EXP, FALSE);
2797 #if defined(PERL_VENDORLIB_EXP)
2799 incpush(PERL_VENDORLIB_EXP, TRUE);
2801 incpush(PERL_VENDORLIB_EXP, FALSE);
2805 incpush(".", FALSE);
2809 # define PERLLIB_SEP ';'
2812 # define PERLLIB_SEP '|'
2814 # define PERLLIB_SEP ':'
2817 #ifndef PERLLIB_MANGLE
2818 # define PERLLIB_MANGLE(s,n) (s)
2822 S_incpush(pTHX_ char *p, int addsubdirs)
2824 SV *subdir = Nullsv;
2830 subdir = sv_newmortal();
2831 if (!PL_archpat_auto) {
2832 STRLEN len = (sizeof(ARCHNAME) + strlen(PL_patchlevel)
2833 + sizeof("//auto"));
2834 New(55, PL_archpat_auto, len, char);
2835 sprintf(PL_archpat_auto, "/%s/%s/auto", ARCHNAME, PL_patchlevel);
2837 for (len = sizeof(ARCHNAME) + 2;
2838 PL_archpat_auto[len] != '\0' && PL_archpat_auto[len] != '/'; len++)
2839 if (PL_archpat_auto[len] == '.') PL_archpat_auto[len] = '_';
2844 /* Break at all separators */
2846 SV *libdir = NEWSV(55,0);
2849 /* skip any consecutive separators */
2850 while ( *p == PERLLIB_SEP ) {
2851 /* Uncomment the next line for PATH semantics */
2852 /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */
2856 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2857 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2862 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2863 p = Nullch; /* break out */
2867 * BEFORE pushing libdir onto @INC we may first push version- and
2868 * archname-specific sub-directories.
2871 struct stat tmpstatbuf;
2876 if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) {
2878 while (unix[len-1] == '/') len--; /* Cosmetic */
2879 sv_usepvn(libdir,unix,len);
2882 PerlIO_printf(Perl_error_log,
2883 "Failed to unixify @INC element \"%s\"\n",
2886 /* .../archname/version if -d .../archname/version/auto */
2887 sv_setsv(subdir, libdir);
2888 sv_catpv(subdir, PL_archpat_auto);
2889 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2890 S_ISDIR(tmpstatbuf.st_mode))
2891 av_push(GvAVn(PL_incgv),
2892 newSVpvn(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2894 /* .../archname if -d .../archname/auto */
2895 sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
2896 strlen(PL_patchlevel) + 1, "", 0);
2897 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2898 S_ISDIR(tmpstatbuf.st_mode))
2899 av_push(GvAVn(PL_incgv),
2900 newSVpvn(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2903 /* finally push this lib directory on the end of @INC */
2904 av_push(GvAVn(PL_incgv), libdir);
2909 STATIC struct perl_thread *
2910 S_init_main_thread(pTHX)
2912 #if !defined(PERL_IMPLICIT_CONTEXT)
2913 struct perl_thread *thr;
2917 Newz(53, thr, 1, struct perl_thread);
2918 PL_curcop = &PL_compiling;
2919 thr->interp = PERL_GET_INTERP;
2920 thr->cvcache = newHV();
2921 thr->threadsv = newAV();
2922 /* thr->threadsvp is set when find_threadsv is called */
2923 thr->specific = newAV();
2924 thr->flags = THRf_R_JOINABLE;
2925 MUTEX_INIT(&thr->mutex);
2926 /* Handcraft thrsv similarly to mess_sv */
2927 New(53, PL_thrsv, 1, SV);
2928 Newz(53, xpv, 1, XPV);
2929 SvFLAGS(PL_thrsv) = SVt_PV;
2930 SvANY(PL_thrsv) = (void*)xpv;
2931 SvREFCNT(PL_thrsv) = 1 << 30; /* practically infinite */
2932 SvPVX(PL_thrsv) = (char*)thr;
2933 SvCUR_set(PL_thrsv, sizeof(thr));
2934 SvLEN_set(PL_thrsv, sizeof(thr));
2935 *SvEND(PL_thrsv) = '\0'; /* in the trailing_nul field */
2936 thr->oursv = PL_thrsv;
2937 PL_chopset = " \n-";
2940 MUTEX_LOCK(&PL_threads_mutex);
2945 MUTEX_UNLOCK(&PL_threads_mutex);
2947 #ifdef HAVE_THREAD_INTERN
2948 Perl_init_thread_intern(thr);
2951 #ifdef SET_THREAD_SELF
2952 SET_THREAD_SELF(thr);
2954 thr->self = pthread_self();
2955 #endif /* SET_THREAD_SELF */
2959 * These must come after the SET_THR because sv_setpvn does
2960 * SvTAINT and the taint fields require dTHR.
2962 PL_toptarget = NEWSV(0,0);
2963 sv_upgrade(PL_toptarget, SVt_PVFM);
2964 sv_setpvn(PL_toptarget, "", 0);
2965 PL_bodytarget = NEWSV(0,0);
2966 sv_upgrade(PL_bodytarget, SVt_PVFM);
2967 sv_setpvn(PL_bodytarget, "", 0);
2968 PL_formtarget = PL_bodytarget;
2969 thr->errsv = newSVpvn("", 0);
2970 (void) find_threadsv("@"); /* Ensure $@ is initialised early */
2973 PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
2974 PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
2975 PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
2976 PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
2977 PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
2979 PL_reginterp_cnt = 0;
2983 #endif /* USE_THREADS */
2986 Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
2990 line_t oldline = PL_curcop->cop_line;
2996 while (AvFILL(paramList) >= 0) {
2997 cv = (CV*)av_shift(paramList);
2999 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_list_body), cv);
3002 (void)SvPV(atsv, len);
3004 PL_curcop = &PL_compiling;
3005 PL_curcop->cop_line = oldline;
3006 if (paramList == PL_beginav)
3007 sv_catpv(atsv, "BEGIN failed--compilation aborted");
3009 sv_catpv(atsv, "END failed--cleanup aborted");
3010 while (PL_scopestack_ix > oldscope)
3012 Perl_croak(aTHX_ "%s", SvPVX(atsv));
3019 /* my_exit() was called */
3020 while (PL_scopestack_ix > oldscope)
3023 PL_curstash = PL_defstash;
3024 if (PL_endav && !PL_minus_c)
3025 call_list(oldscope, PL_endav);
3026 PL_curcop = &PL_compiling;
3027 PL_curcop->cop_line = oldline;
3028 if (PL_statusvalue) {
3029 if (paramList == PL_beginav)
3030 Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
3032 Perl_croak(aTHX_ "END failed--cleanup aborted");
3038 PL_curcop = &PL_compiling;
3039 PL_curcop->cop_line = oldline;
3042 PerlIO_printf(Perl_error_log, "panic: restartop\n");
3050 S_call_list_body(pTHX_ va_list args)
3053 CV *cv = va_arg(args, CV*);
3055 PUSHMARK(PL_stack_sp);
3056 call_sv((SV*)cv, G_EVAL|G_DISCARD);
3061 Perl_my_exit(pTHX_ U32 status)
3065 DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
3066 thr, (unsigned long) status));
3075 STATUS_NATIVE_SET(status);
3082 Perl_my_failure_exit(pTHX)
3085 if (vaxc$errno & 1) {
3086 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
3087 STATUS_NATIVE_SET(44);
3090 if (!vaxc$errno && errno) /* unlikely */
3091 STATUS_NATIVE_SET(44);
3093 STATUS_NATIVE_SET(vaxc$errno);
3098 STATUS_POSIX_SET(errno);
3100 exitstatus = STATUS_POSIX >> 8;
3101 if (exitstatus & 255)
3102 STATUS_POSIX_SET(exitstatus);
3104 STATUS_POSIX_SET(255);
3111 S_my_exit_jump(pTHX)
3114 register PERL_CONTEXT *cx;
3119 SvREFCNT_dec(PL_e_script);
3120 PL_e_script = Nullsv;
3123 POPSTACK_TO(PL_mainstack);
3124 if (cxstack_ix >= 0) {
3127 POPBLOCK(cx,PL_curpm);
3140 read_e_script(pTHXo_ int idx, SV *buf_sv, int maxlen)
3143 p = SvPVX(PL_e_script);
3144 nl = strchr(p, '\n');
3145 nl = (nl) ? nl+1 : SvEND(PL_e_script);
3147 filter_del(read_e_script);
3150 sv_catpvn(buf_sv, p, nl-p);
3151 sv_chop(PL_e_script, nl);