3 * Copyright (c) 1987-1999 Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * "A ship then new they built for him/of mithril and of elven glass" --Bilbo
15 #define PERL_IN_PERL_C
17 #include "patchlevel.h" /* for local_patches */
19 /* XXX If this causes problems, set i_unistd=undef in the hint file. */
24 #if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE)
25 char *getenv (char *); /* Usually in <stdlib.h> */
28 static I32 read_e_script(pTHXo_ int idx, SV *buf_sv, int maxlen);
43 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
50 CPerlObj* perl_alloc(IPerlMem* ipM, IPerlEnv* ipE, IPerlStdIO* ipStd,
51 IPerlLIO* ipLIO, IPerlDir* ipD, IPerlSock* ipS, IPerlProc* ipP)
53 CPerlObj* pPerl = new(ipM) CPerlObj(ipM, ipE, ipStd, ipLIO, ipD, ipS, ipP);
63 PerlInterpreter *my_perl;
65 /* New() needs interpreter, so call malloc() instead */
66 my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
67 PERL_SET_INTERP(my_perl);
70 #endif /* PERL_OBJECT */
78 struct perl_thread *thr;
79 #endif /* FAKE_THREADS */
80 #endif /* USE_THREADS */
83 Zero(my_perl, 1, PerlInterpreter);
88 PL_perl_destruct_level = 1;
90 if (PL_perl_destruct_level > 0)
94 /* Init the real globals (and main thread)? */
99 #ifdef ALLOC_THREAD_KEY
102 if (pthread_key_create(&PL_thr_key, 0))
103 Perl_croak(aTHX_ "panic: pthread_key_create");
105 MUTEX_INIT(&PL_sv_mutex);
107 * Safe to use basic SV functions from now on (though
108 * not things like mortals or tainting yet).
110 MUTEX_INIT(&PL_eval_mutex);
111 COND_INIT(&PL_eval_cond);
112 MUTEX_INIT(&PL_threads_mutex);
113 COND_INIT(&PL_nthreads_cond);
114 #ifdef EMULATE_ATOMIC_REFCOUNTS
115 MUTEX_INIT(&PL_svref_mutex);
116 #endif /* EMULATE_ATOMIC_REFCOUNTS */
118 MUTEX_INIT(&PL_cred_mutex);
120 thr = init_main_thread();
121 #endif /* USE_THREADS */
123 PL_protect = MEMBER_TO_FPTR(Perl_default_protect); /* for exceptions */
125 PL_curcop = &PL_compiling; /* needed by ckWARN, right away */
127 PL_linestr = NEWSV(65,79);
128 sv_upgrade(PL_linestr,SVt_PVIV);
130 if (!SvREADONLY(&PL_sv_undef)) {
131 /* set read-only and try to insure than we wont see REFCNT==0
134 SvREADONLY_on(&PL_sv_undef);
135 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
137 sv_setpv(&PL_sv_no,PL_No);
139 SvREADONLY_on(&PL_sv_no);
140 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
142 sv_setpv(&PL_sv_yes,PL_Yes);
144 SvREADONLY_on(&PL_sv_yes);
145 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
150 /* PL_sighandlerp = sighandler; */
152 PL_sighandlerp = Perl_sighandler;
154 PL_pidstatus = newHV();
158 * There is no way we can refer to them from Perl so close them to save
159 * space. The other alternative would be to provide STDAUX and STDPRN
162 (void)fclose(stdaux);
163 (void)fclose(stdprn);
167 PL_nrs = newSVpvn("\n", 1);
168 PL_rs = SvREFCNT_inc(PL_nrs);
173 PL_lex_state = LEX_NOTPARSING;
179 SET_NUMERIC_STANDARD();
180 #if defined(PERL_SUBVERSION) && PERL_SUBVERSION > 0
181 sprintf(PL_patchlevel, "%7.5f", (double) PERL_REVISION
182 + ((double) PERL_VERSION / (double) 1000)
183 + ((double) PERL_SUBVERSION / (double) 100000));
185 sprintf(PL_patchlevel, "%5.3f", (double) PERL_REVISION +
186 ((double) PERL_VERSION / (double) 1000));
189 #if defined(LOCAL_PATCH_COUNT)
190 PL_localpatches = local_patches; /* For possible -v */
193 PerlIO_init(); /* Hook to IO system */
195 PL_fdpid = newAV(); /* for remembering popen pids by fd */
196 PL_modglobal = newHV(); /* pointers to per-interpreter module globals */
199 New(51,PL_debname,128,char);
200 New(52,PL_debdelim,128,char);
210 int destruct_level; /* 0=none, 1=full, 2=full with checks */
216 #endif /* USE_THREADS */
220 /* Pass 1 on any remaining threads: detach joinables, join zombies */
222 MUTEX_LOCK(&PL_threads_mutex);
223 DEBUG_S(PerlIO_printf(PerlIO_stderr(),
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(PerlIO_stderr(),
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(PerlIO_stderr(),
246 "perl_destruct: joined zombie %p OK\n", t));
248 case THRf_R_JOINABLE:
249 DEBUG_S(PerlIO_printf(PerlIO_stderr(),
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(PerlIO_stderr(),
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(PerlIO_stderr(),
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(PerlIO_stderr(), "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_last_in_gv = Nullgv;
435 /* reset so print() ends up where we expect */
438 /* Prepare to destruct main symbol table. */
444 /* clear queued errors */
445 SvREFCNT_dec(PL_errors);
449 if (destruct_level >= 2 && ckWARN_d(WARN_INTERNAL)) {
450 if (PL_scopestack_ix != 0)
451 Perl_warner(aTHX_ WARN_INTERNAL,
452 "Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
453 (long)PL_scopestack_ix);
454 if (PL_savestack_ix != 0)
455 Perl_warner(aTHX_ WARN_INTERNAL,
456 "Unbalanced saves: %ld more saves than restores\n",
457 (long)PL_savestack_ix);
458 if (PL_tmps_floor != -1)
459 Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced tmps: %ld more allocs than frees\n",
460 (long)PL_tmps_floor + 1);
461 if (cxstack_ix != -1)
462 Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced context: %ld more PUSHes than POPs\n",
463 (long)cxstack_ix + 1);
466 /* Now absolutely destruct everything, somehow or other, loops or no. */
468 SvFLAGS(PL_strtab) |= SVTYPEMASK; /* don't clean out strtab now */
469 while (PL_sv_count != 0 && PL_sv_count != last_sv_count) {
470 last_sv_count = PL_sv_count;
473 SvFLAGS(PL_strtab) &= ~SVTYPEMASK;
474 SvFLAGS(PL_strtab) |= SVt_PVHV;
476 /* Destruct the global string table. */
478 /* Yell and reset the HeVAL() slots that are still holding refcounts,
479 * so that sv_free() won't fail on them.
487 max = HvMAX(PL_strtab);
488 array = HvARRAY(PL_strtab);
491 if (hent && ckWARN_d(WARN_INTERNAL)) {
492 Perl_warner(aTHX_ WARN_INTERNAL,
493 "Unbalanced string table refcount: (%d) for \"%s\"",
494 HeVAL(hent) - Nullsv, HeKEY(hent));
495 HeVAL(hent) = Nullsv;
505 SvREFCNT_dec(PL_strtab);
507 if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL))
508 Perl_warner(aTHX_ WARN_INTERNAL,"Scalars leaked: %ld\n", (long)PL_sv_count);
512 /* No SVs have survived, need to clean out */
514 PL_pidstatus = Nullhv;
515 Safefree(PL_origfilename);
516 Safefree(PL_archpat_auto);
517 Safefree(PL_reg_start_tmp);
519 Safefree(PL_reg_curpm);
520 Safefree(PL_reg_poscache);
521 Safefree(HeKEY_hek(&PL_hv_fetch_ent_mh));
522 Safefree(PL_op_mask);
524 PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */
526 DEBUG_P(debprofdump());
528 MUTEX_DESTROY(&PL_strtab_mutex);
529 MUTEX_DESTROY(&PL_sv_mutex);
530 MUTEX_DESTROY(&PL_eval_mutex);
531 MUTEX_DESTROY(&PL_cred_mutex);
532 COND_DESTROY(&PL_eval_cond);
533 #ifdef EMULATE_ATOMIC_REFCOUNTS
534 MUTEX_DESTROY(&PL_svref_mutex);
535 #endif /* EMULATE_ATOMIC_REFCOUNTS */
537 /* As the penultimate thing, free the non-arena SV for thrsv */
538 Safefree(SvPVX(PL_thrsv));
539 Safefree(SvANY(PL_thrsv));
542 #endif /* USE_THREADS */
544 /* As the absolutely last thing, free the non-arena SV for mess() */
547 /* it could have accumulated taint magic */
548 if (SvTYPE(PL_mess_sv) >= SVt_PVMG) {
551 for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) {
552 moremagic = mg->mg_moremagic;
553 if (mg->mg_ptr && mg->mg_type != 'g' && mg->mg_len >= 0)
554 Safefree(mg->mg_ptr);
558 /* we know that type >= SVt_PV */
559 SvOOK_off(PL_mess_sv);
560 Safefree(SvPVX(PL_mess_sv));
561 Safefree(SvANY(PL_mess_sv));
562 Safefree(PL_mess_sv);
570 #if defined(PERL_OBJECT)
578 Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
580 Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry);
581 PL_exitlist[PL_exitlistlen].fn = fn;
582 PL_exitlist[PL_exitlistlen].ptr = ptr;
587 perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
596 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
599 Perl_croak(aTHX_ "suidperl is no longer needed since the kernel can now execute\n\
600 setuid perl scripts securely.\n");
604 #if defined(__DYNAMIC__) && (defined(NeXT) || defined(__NeXT__))
605 _dyld_lookup_and_bind
606 ("__environ", (unsigned long *) &environ_pointer, NULL);
611 #ifndef VMS /* VMS doesn't have environ array */
612 PL_origenviron = environ;
617 /* Come here if running an undumped a.out. */
619 PL_origfilename = savepv(argv[0]);
620 PL_do_undump = FALSE;
621 cxstack_ix = -1; /* start label stack again */
623 init_postdump_symbols(argc,argv,env);
628 PL_curpad = AvARRAY(PL_comppad);
629 op_free(PL_main_root);
630 PL_main_root = Nullop;
632 PL_main_start = Nullop;
633 SvREFCNT_dec(PL_main_cv);
637 oldscope = PL_scopestack_ix;
638 PL_dowarn = G_WARN_OFF;
640 CALLPROTECT(aTHX_ &ret, MEMBER_TO_FPTR(S_parse_body), env, xsinit);
648 /* my_exit() was called */
649 while (PL_scopestack_ix > oldscope)
652 PL_curstash = PL_defstash;
654 call_list(oldscope, PL_endav);
655 return STATUS_NATIVE_EXPORT;
657 PerlIO_printf(PerlIO_stderr(), "panic: top_env\n");
664 S_parse_body(pTHX_ va_list args)
667 int argc = PL_origargc;
668 char **argv = PL_origargv;
669 char **env = va_arg(args, char**);
670 char *scriptname = NULL;
672 VOL bool dosearch = FALSE;
678 XSINIT_t xsinit = va_arg(args, XSINIT_t);
680 sv_setpvn(PL_linestr,"",0);
681 sv = newSVpvn("",0); /* first used for -I flags */
685 for (argc--,argv++; argc > 0; argc--,argv++) {
686 if (argv[0][0] != '-' || !argv[0][1])
690 validarg = " PHOOEY ";
697 #ifndef PERL_STRICT_CR
721 if (s = moreswitches(s))
731 if (PL_euid != PL_uid || PL_egid != PL_gid)
732 Perl_croak(aTHX_ "No -e allowed in setuid scripts");
734 PL_e_script = newSVpvn("",0);
735 filter_add(read_e_script, NULL);
738 sv_catpv(PL_e_script, s);
740 sv_catpv(PL_e_script, argv[1]);
744 Perl_croak(aTHX_ "No code specified for -e");
745 sv_catpv(PL_e_script, "\n");
748 case 'I': /* -I handled both here and in moreswitches() */
750 if (!*++s && (s=argv[1]) != Nullch) {
753 while (s && isSPACE(*s))
757 for (e = s; *e && !isSPACE(*e); e++) ;
764 } /* XXX else croak? */
768 PL_preprocess = TRUE;
778 PL_preambleav = newAV();
779 av_push(PL_preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
781 PL_Sv = newSVpv("print myconfig();",0);
783 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
785 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
787 #if defined(DEBUGGING) || defined(MULTIPLICITY)
788 sv_catpv(PL_Sv,"\" Compile-time options:");
790 sv_catpv(PL_Sv," DEBUGGING");
793 sv_catpv(PL_Sv," MULTIPLICITY");
795 sv_catpv(PL_Sv,"\\n\",");
797 #if defined(LOCAL_PATCH_COUNT)
798 if (LOCAL_PATCH_COUNT > 0) {
800 sv_catpv(PL_Sv,"\" Locally applied patches:\\n\",");
801 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
802 if (PL_localpatches[i])
803 Perl_sv_catpvf(aTHX_ PL_Sv,"q\" \t%s\n\",",PL_localpatches[i]);
807 Perl_sv_catpvf(aTHX_ PL_Sv,"\" Built under %s\\n\"",OSNAME);
810 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
812 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled on %s\\n\"",__DATE__);
817 @env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; \
818 print \" \\%ENV:\\n @env\\n\" if @env; \
819 print \" \\@INC:\\n @INC\\n\";");
822 PL_Sv = newSVpv("config_vars(qw(",0);
823 sv_catpv(PL_Sv, ++s);
824 sv_catpv(PL_Sv, "))");
827 av_push(PL_preambleav, PL_Sv);
828 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
834 PL_cddir = savepv(s);
839 if (!*++s || isSPACE(*s)) {
843 /* catch use of gnu style long options */
844 if (strEQ(s, "version")) {
848 if (strEQ(s, "help")) {
855 Perl_croak(aTHX_ "Unrecognized switch: -%s (-h will show valid options)",s);
861 #ifndef SECURE_INTERNAL_GETENV
864 (s = PerlEnv_getenv("PERL5OPT"))) {
867 if (*s == '-' && *(s+1) == 'T')
880 if (!strchr("DIMUdmw", *s))
881 Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
888 scriptname = argv[0];
891 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
893 else if (scriptname == Nullch) {
895 if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
903 open_script(scriptname,dosearch,sv,&fdscript);
905 validate_suid(validarg, scriptname,fdscript);
910 PL_main_cv = PL_compcv = (CV*)NEWSV(1104,0);
911 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
912 CvUNIQUE_on(PL_compcv);
914 PL_comppad = newAV();
915 av_push(PL_comppad, Nullsv);
916 PL_curpad = AvARRAY(PL_comppad);
917 PL_comppad_name = newAV();
918 PL_comppad_name_fill = 0;
919 PL_min_intro_pending = 0;
922 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
923 PL_curpad[0] = (SV*)newAV();
924 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
925 CvOWNER(PL_compcv) = 0;
926 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
927 MUTEX_INIT(CvMUTEXP(PL_compcv));
928 #endif /* USE_THREADS */
930 comppadlist = newAV();
931 AvREAL_off(comppadlist);
932 av_store(comppadlist, 0, (SV*)PL_comppad_name);
933 av_store(comppadlist, 1, (SV*)PL_comppad);
934 CvPADLIST(PL_compcv) = comppadlist;
936 boot_core_UNIVERSAL();
940 (*xsinit)(aTHXo); /* in case linked C routines want magical variables */
941 #if defined(VMS) || defined(WIN32) || defined(DJGPP)
949 init_predump_symbols();
950 /* init_postdump_symbols not currently designed to be called */
951 /* more than once (ENV isn't cleared first, for example) */
952 /* But running with -u leaves %ENV & @ARGV undefined! XXX */
954 init_postdump_symbols(argc,argv,env);
958 /* now parse the script */
960 SETERRNO(0,SS$_NORMAL);
962 if (yyparse() || PL_error_count) {
964 Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
966 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
970 PL_curcop->cop_line = 0;
971 PL_curstash = PL_defstash;
972 PL_preprocess = FALSE;
974 SvREFCNT_dec(PL_e_script);
975 PL_e_script = Nullsv;
978 /* now that script is parsed, we can modify record separator */
980 PL_rs = SvREFCNT_inc(PL_nrs);
981 sv_setsv(get_sv("/", TRUE), PL_rs);
986 gv_check(PL_defstash);
992 if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
993 dump_mstats("after compilation:");
1011 oldscope = PL_scopestack_ix;
1014 CALLPROTECT(aTHX_ &ret, MEMBER_TO_FPTR(S_run_body), oldscope);
1017 cxstack_ix = -1; /* start context stack again */
1019 case 0: /* normal completion */
1020 case 2: /* my_exit() */
1021 while (PL_scopestack_ix > oldscope)
1024 PL_curstash = PL_defstash;
1026 call_list(oldscope, PL_endav);
1028 if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
1029 dump_mstats("after execution: ");
1031 return STATUS_NATIVE_EXPORT;
1034 POPSTACK_TO(PL_mainstack);
1037 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
1047 S_run_body(pTHX_ va_list args)
1050 I32 oldscope = va_arg(args, I32);
1052 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
1053 PL_sawampersand ? "Enabling" : "Omitting"));
1055 if (!PL_restartop) {
1056 DEBUG_x(dump_all());
1057 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
1058 DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%lx\n",
1059 (unsigned long) thr));
1062 PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", PL_origfilename);
1065 if (PERLDB_SINGLE && PL_DBsingle)
1066 sv_setiv(PL_DBsingle, 1);
1068 call_list(oldscope, PL_initav);
1074 PL_op = PL_restartop;
1078 else if (PL_main_start) {
1079 CvDEPTH(PL_main_cv) = 1;
1080 PL_op = PL_main_start;
1090 Perl_get_sv(pTHX_ const char *name, I32 create)
1094 if (name[1] == '\0' && !isALPHA(name[0])) {
1095 PADOFFSET tmp = find_threadsv(name);
1096 if (tmp != NOT_IN_PAD) {
1098 return THREADSV(tmp);
1101 #endif /* USE_THREADS */
1102 gv = gv_fetchpv(name, create, SVt_PV);
1109 Perl_get_av(pTHX_ const char *name, I32 create)
1111 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1120 Perl_get_hv(pTHX_ const char *name, I32 create)
1122 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1131 Perl_get_cv(pTHX_ const char *name, I32 create)
1133 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
1134 /* XXX unsafe for threads if eval_owner isn't held */
1135 /* XXX this is probably not what they think they're getting.
1136 * It has the same effect as "sub name;", i.e. just a forward
1138 if (create && !GvCVu(gv))
1139 return newSUB(start_subparse(FALSE, 0),
1140 newSVOP(OP_CONST, 0, newSVpv(name,0)),
1148 /* Be sure to refetch the stack pointer after calling these routines. */
1151 Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv)
1153 /* See G_* flags in cop.h */
1154 /* null terminated arg list */
1161 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
1166 return call_pv(sub_name, flags);
1170 Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
1171 /* name of the subroutine */
1172 /* See G_* flags in cop.h */
1174 return call_sv((SV*)get_cv(sub_name, TRUE), flags);
1178 Perl_call_method(pTHX_ const char *methname, I32 flags)
1179 /* name of the subroutine */
1180 /* See G_* flags in cop.h */
1186 XPUSHs(sv_2mortal(newSVpv(methname,0)));
1191 return call_sv(*PL_stack_sp--, flags);
1194 /* May be called with any of a CV, a GV, or an SV containing the name. */
1196 Perl_call_sv(pTHX_ SV *sv, I32 flags)
1198 /* See G_* flags in cop.h */
1201 LOGOP myop; /* fake syntax tree node */
1205 bool oldcatch = CATCH_GET;
1209 if (flags & G_DISCARD) {
1214 Zero(&myop, 1, LOGOP);
1215 myop.op_next = Nullop;
1216 if (!(flags & G_NOARGS))
1217 myop.op_flags |= OPf_STACKED;
1218 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1219 (flags & G_ARRAY) ? OPf_WANT_LIST :
1224 EXTEND(PL_stack_sp, 1);
1225 *++PL_stack_sp = sv;
1227 oldscope = PL_scopestack_ix;
1229 if (PERLDB_SUB && PL_curstash != PL_debstash
1230 /* Handle first BEGIN of -d. */
1231 && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
1232 /* Try harder, since this may have been a sighandler, thus
1233 * curstash may be meaningless. */
1234 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != PL_debstash)
1235 && !(flags & G_NODEBUG))
1236 PL_op->op_private |= OPpENTERSUB_DB;
1238 if (!(flags & G_EVAL)) {
1239 /* G_NOCATCH is a hack for perl_vdie using this path to call
1240 a __DIE__ handler */
1241 if (!(flags & G_NOCATCH)) {
1244 call_xbody((OP*)&myop, FALSE);
1245 retval = PL_stack_sp - (PL_stack_base + oldmark);
1246 if (!(flags & G_NOCATCH)) {
1251 cLOGOP->op_other = PL_op;
1253 /* we're trying to emulate pp_entertry() here */
1255 register PERL_CONTEXT *cx;
1256 I32 gimme = GIMME_V;
1261 push_return(PL_op->op_next);
1262 PUSHBLOCK(cx, CXt_EVAL, PL_stack_sp);
1264 PL_eval_root = PL_op; /* Only needed so that goto works right. */
1266 PL_in_eval = EVAL_INEVAL;
1267 if (flags & G_KEEPERR)
1268 PL_in_eval |= EVAL_KEEPERR;
1275 CALLPROTECT(aTHX_ &ret, MEMBER_TO_FPTR(S_call_body), (OP*)&myop, FALSE);
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;
1374 if (flags & G_DISCARD) {
1381 Zero(PL_op, 1, UNOP);
1382 EXTEND(PL_stack_sp, 1);
1383 *++PL_stack_sp = sv;
1384 oldscope = PL_scopestack_ix;
1386 if (!(flags & G_NOARGS))
1387 myop.op_flags = OPf_STACKED;
1388 myop.op_next = Nullop;
1389 myop.op_type = OP_ENTEREVAL;
1390 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1391 (flags & G_ARRAY) ? OPf_WANT_LIST :
1393 if (flags & G_KEEPERR)
1394 myop.op_flags |= OPf_SPECIAL;
1397 CALLPROTECT(aTHX_ &ret, MEMBER_TO_FPTR(S_call_body), (OP*)&myop, TRUE);
1400 retval = PL_stack_sp - (PL_stack_base + oldmark);
1401 if (!(flags & G_KEEPERR))
1408 /* my_exit() was called */
1409 PL_curstash = PL_defstash;
1412 Perl_croak(aTHX_ "Callback called exit");
1417 PL_op = PL_restartop;
1421 PL_stack_sp = PL_stack_base + oldmark;
1422 if (flags & G_ARRAY)
1426 *++PL_stack_sp = &PL_sv_undef;
1431 if (flags & G_DISCARD) {
1432 PL_stack_sp = PL_stack_base + oldmark;
1442 Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
1445 SV* sv = newSVpv(p, 0);
1448 eval_sv(sv, G_SCALAR);
1455 if (croak_on_error && SvTRUE(ERRSV)) {
1457 Perl_croak(aTHX_ SvPVx(ERRSV, n_a));
1463 /* Require a module. */
1466 Perl_require_pv(pTHX_ const char *pv)
1470 PUSHSTACKi(PERLSI_REQUIRE);
1472 sv = sv_newmortal();
1473 sv_setpv(sv, "require '");
1476 eval_sv(sv, G_DISCARD);
1482 Perl_magicname(pTHX_ char *sym, char *name, I32 namlen)
1486 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1487 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1491 S_usage(pTHX_ char *name) /* XXX move this out into a module ? */
1493 /* This message really ought to be max 23 lines.
1494 * Removed -h because the user already knows that opton. Others? */
1496 static char *usage_msg[] = {
1497 "-0[octal] specify record separator (\\0, if no argument)",
1498 "-a autosplit mode with -n or -p (splits $_ into @F)",
1499 "-c check syntax only (runs BEGIN and END blocks)",
1500 "-d[:debugger] run program under debugger",
1501 "-D[number/list] set debugging flags (argument is a bit mask or alphabets)",
1502 "-e 'command' one line of program (several -e's allowed, omit programfile)",
1503 "-F/pattern/ split() pattern for -a switch (//'s are optional)",
1504 "-i[extension] edit <> files in place (makes backup if extension supplied)",
1505 "-Idirectory specify @INC/#include directory (several -I's allowed)",
1506 "-l[octal] enable line ending processing, specifies line terminator",
1507 "-[mM][-]module execute `use/no module...' before executing program",
1508 "-n assume 'while (<>) { ... }' loop around program",
1509 "-p assume loop like -n but print line also, like sed",
1510 "-P run program through C preprocessor before compilation",
1511 "-s enable rudimentary parsing for switches after programfile",
1512 "-S look for programfile using PATH environment variable",
1513 "-T enable tainting checks",
1514 "-u dump core after parsing program",
1515 "-U allow unsafe operations",
1516 "-v print version, subversion (includes VERY IMPORTANT perl info)",
1517 "-V[:variable] print configuration summary (or a single Config.pm variable)",
1518 "-w enable many useful warnings (RECOMMENDED)",
1519 "-x[directory] strip off text before #!perl line and perhaps cd to directory",
1523 char **p = usage_msg;
1525 printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1527 printf("\n %s", *p++);
1530 /* This routine handles any switches that can be given during run */
1533 Perl_moreswitches(pTHX_ char *s)
1542 rschar = scan_oct(s, 4, &numlen);
1543 SvREFCNT_dec(PL_nrs);
1544 if (rschar & ~((U8)~0))
1545 PL_nrs = &PL_sv_undef;
1546 else if (!rschar && numlen >= 2)
1547 PL_nrs = newSVpvn("", 0);
1550 PL_nrs = newSVpvn(&ch, 1);
1556 PL_splitstr = savepv(s + 1);
1570 if (*s == ':' || *s == '=') {
1571 my_setenv("PERL5DB", Perl_form(aTHX_ "use Devel::%s;", ++s));
1575 PL_perldb = PERLDB_ALL;
1583 if (isALPHA(s[1])) {
1584 static char debopts[] = "psltocPmfrxuLHXDS";
1587 for (s++; *s && (d = strchr(debopts,*s)); s++)
1588 PL_debug |= 1 << (d - debopts);
1591 PL_debug = atoi(s+1);
1592 for (s++; isDIGIT(*s); s++) ;
1594 PL_debug |= 0x80000000;
1597 if (ckWARN_d(WARN_DEBUGGING))
1598 Perl_warner(aTHX_ WARN_DEBUGGING,
1599 "Recompile perl with -DDEBUGGING to use -D switch\n");
1600 for (s++; isALNUM(*s); s++) ;
1606 usage(PL_origargv[0]);
1610 Safefree(PL_inplace);
1611 PL_inplace = savepv(s+1);
1613 for (s = PL_inplace; *s && !isSPACE(*s); s++) ;
1616 if (*s == '-') /* Additional switches on #! line. */
1620 case 'I': /* -I handled both here and in parse_perl() */
1623 while (*s && isSPACE(*s))
1627 for (e = s; *e && !isSPACE(*e); e++) ;
1628 p = savepvn(s, e-s);
1634 Perl_croak(aTHX_ "No space allowed after -I");
1642 PL_ors = savepv("\n");
1644 *PL_ors = scan_oct(s, 3 + (*s == '0'), &numlen);
1649 if (RsPARA(PL_nrs)) {
1654 PL_ors = SvPV(PL_nrs, PL_orslen);
1655 PL_ors = savepvn(PL_ors, PL_orslen);
1659 forbid_setid("-M"); /* XXX ? */
1662 forbid_setid("-m"); /* XXX ? */
1667 /* -M-foo == 'no foo' */
1668 if (*s == '-') { use = "no "; ++s; }
1669 sv = newSVpv(use,0);
1671 /* We allow -M'Module qw(Foo Bar)' */
1672 while(isALNUM(*s) || *s==':') ++s;
1674 sv_catpv(sv, start);
1675 if (*(start-1) == 'm') {
1677 Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
1678 sv_catpv( sv, " ()");
1681 sv_catpvn(sv, start, s-start);
1682 sv_catpv(sv, " split(/,/,q{");
1687 if (PL_preambleav == NULL)
1688 PL_preambleav = newAV();
1689 av_push(PL_preambleav, sv);
1692 Perl_croak(aTHX_ "No space allowed after -%c", *(s-1));
1704 PL_doswitches = TRUE;
1709 Perl_croak(aTHX_ "Too late for \"-T\" option");
1713 PL_do_undump = TRUE;
1721 #if defined(PERL_SUBVERSION) && PERL_SUBVERSION > 0
1722 printf("\nThis is perl, version %d.%03d_%02d built for %s",
1723 PERL_REVISION, PERL_VERSION, PERL_SUBVERSION, ARCHNAME);
1725 printf("\nThis is perl, version %s built for %s",
1726 PL_patchlevel, ARCHNAME);
1728 #if defined(LOCAL_PATCH_COUNT)
1729 if (LOCAL_PATCH_COUNT > 0)
1730 printf("\n(with %d registered patch%s, see perl -V for more detail)",
1731 LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : "");
1734 printf("\n\nCopyright 1987-1999, Larry Wall\n");
1736 printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1739 printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
1740 printf("djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
1743 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1744 "Version 5 port Copyright (c) 1994-1999, Andreas Kaiser, Ilya Zakharevich\n");
1747 printf("atariST series port, ++jrb bammi@cadence.com\n");
1750 printf("BeOS port Copyright Tom Spindler, 1997-1999\n");
1753 printf("MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-1999\n");
1756 printf("MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
1759 printf("Stratus VOS port by Paul_Green@stratus.com, 1997-1999\n");
1762 printf("VM/ESA port by Neale Ferguson, 1998-1999\n");
1765 printf("BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
1768 printf("MiNT port by Guido Flohr, 1997-1999\n");
1770 #ifdef BINARY_BUILD_NOTICE
1771 BINARY_BUILD_NOTICE;
1774 Perl may be copied only under the terms of either the Artistic License or the\n\
1775 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n\
1776 Complete documentation for Perl, including FAQ lists, should be found on\n\
1777 this system using `man perl' or `perldoc perl'. If you have access to the\n\
1778 Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
1781 if (! (PL_dowarn & G_WARN_ALL_MASK))
1782 PL_dowarn |= G_WARN_ON;
1786 PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
1787 PL_compiling.cop_warnings = WARN_ALL ;
1791 PL_dowarn = G_WARN_ALL_OFF;
1792 PL_compiling.cop_warnings = WARN_NONE ;
1797 if (s[1] == '-') /* Additional switches on #! line. */
1802 #if defined(WIN32) || !defined(PERL_STRICT_CR)
1808 #ifdef ALTERNATE_SHEBANG
1809 case 'S': /* OS/2 needs -S on "extproc" line. */
1817 Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
1822 /* compliments of Tom Christiansen */
1824 /* unexec() can be found in the Gnu emacs distribution */
1825 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
1828 Perl_my_unexec(pTHX)
1836 prog = newSVpv(BIN_EXP, 0);
1837 sv_catpv(prog, "/perl");
1838 file = newSVpv(PL_origfilename, 0);
1839 sv_catpv(file, ".perldump");
1841 unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
1842 /* unexec prints msg to stderr in case of failure */
1843 PerlProc_exit(status);
1846 # include <lib$routines.h>
1847 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
1849 ABORT(); /* for use with undump */
1854 /* initialize curinterp */
1859 #ifdef PERL_OBJECT /* XXX kludge */
1862 PL_chopset = " \n-"; \
1863 PL_copline = NOLINE; \
1864 PL_curcop = &PL_compiling;\
1865 PL_curcopdb = NULL; \
1868 PL_dumpindent = 4; \
1869 PL_laststatval = -1; \
1870 PL_laststype = OP_STAT; \
1871 PL_maxscream = -1; \
1872 PL_maxsysfd = MAXSYSFD; \
1873 PL_statname = Nullsv; \
1874 PL_tmps_floor = -1; \
1876 PL_op_mask = NULL; \
1878 PL_laststatval = -1; \
1879 PL_laststype = OP_STAT; \
1880 PL_mess_sv = Nullsv; \
1881 PL_splitstr = " "; \
1882 PL_generation = 100; \
1883 PL_exitlist = NULL; \
1884 PL_exitlistlen = 0; \
1886 PL_in_clean_objs = FALSE; \
1887 PL_in_clean_all = FALSE; \
1888 PL_profiledata = NULL; \
1890 PL_rsfp_filters = Nullav; \
1895 # ifdef MULTIPLICITY
1896 # define PERLVAR(var,type)
1897 # define PERLVARA(var,n,type)
1898 # if defined(PERL_IMPLICIT_CONTEXT)
1899 # if defined(USE_THREADS)
1900 # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
1901 # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
1902 # else /* !USE_THREADS */
1903 # define PERLVARI(var,type,init) aTHX->var = init;
1904 # define PERLVARIC(var,type,init) aTHX->var = init;
1905 # endif /* USE_THREADS */
1907 # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
1908 # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
1910 # include "intrpvar.h"
1911 # ifndef USE_THREADS
1912 # include "thrdvar.h"
1919 # define PERLVAR(var,type)
1920 # define PERLVARA(var,n,type)
1921 # define PERLVARI(var,type,init) PL_##var = init;
1922 # define PERLVARIC(var,type,init) PL_##var = init;
1923 # include "intrpvar.h"
1924 # ifndef USE_THREADS
1925 # include "thrdvar.h"
1937 S_init_main_stash(pTHX)
1942 /* Note that strtab is a rather special HV. Assumptions are made
1943 about not iterating on it, and not adding tie magic to it.
1944 It is properly deallocated in perl_destruct() */
1945 PL_strtab = newHV();
1947 MUTEX_INIT(&PL_strtab_mutex);
1949 HvSHAREKEYS_off(PL_strtab); /* mandatory */
1950 hv_ksplit(PL_strtab, 512);
1952 PL_curstash = PL_defstash = newHV();
1953 PL_curstname = newSVpvn("main",4);
1954 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1955 SvREFCNT_dec(GvHV(gv));
1956 GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
1958 HvNAME(PL_defstash) = savepv("main");
1959 PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1960 GvMULTI_on(PL_incgv);
1961 PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
1962 GvMULTI_on(PL_hintgv);
1963 PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1964 PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1965 GvMULTI_on(PL_errgv);
1966 PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
1967 GvMULTI_on(PL_replgv);
1968 (void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */
1969 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
1970 sv_setpvn(ERRSV, "", 0);
1971 PL_curstash = PL_defstash;
1972 PL_compiling.cop_stash = PL_defstash;
1973 PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
1974 PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
1975 /* We must init $/ before switches are processed. */
1976 sv_setpvn(get_sv("/", TRUE), "\n", 1);
1980 S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
1988 PL_origfilename = savepv("-e");
1991 /* if find_script() returns, it returns a malloc()-ed value */
1992 PL_origfilename = scriptname = find_script(scriptname, dosearch, NULL, 1);
1994 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
1995 char *s = scriptname + 8;
1996 *fdscript = atoi(s);
2000 scriptname = savepv(s + 1);
2001 Safefree(PL_origfilename);
2002 PL_origfilename = scriptname;
2007 PL_curcop->cop_filegv = gv_fetchfile(PL_origfilename);
2008 if (strEQ(PL_origfilename,"-"))
2010 if (*fdscript >= 0) {
2011 PL_rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE);
2012 #if defined(HAS_FCNTL) && defined(F_SETFD)
2014 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); /* ensure close-on-exec */
2017 else if (PL_preprocess) {
2018 char *cpp_cfg = CPPSTDIN;
2019 SV *cpp = newSVpvn("",0);
2020 SV *cmd = NEWSV(0,0);
2022 if (strEQ(cpp_cfg, "cppstdin"))
2023 Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
2024 sv_catpv(cpp, cpp_cfg);
2027 sv_catpv(sv,PRIVLIB_EXP);
2030 Perl_sv_setpvf(aTHX_ cmd, "\
2031 sed %s -e \"/^[^#]/b\" \
2032 -e \"/^#[ ]*include[ ]/b\" \
2033 -e \"/^#[ ]*define[ ]/b\" \
2034 -e \"/^#[ ]*if[ ]/b\" \
2035 -e \"/^#[ ]*ifdef[ ]/b\" \
2036 -e \"/^#[ ]*ifndef[ ]/b\" \
2037 -e \"/^#[ ]*else/b\" \
2038 -e \"/^#[ ]*elif[ ]/b\" \
2039 -e \"/^#[ ]*undef[ ]/b\" \
2040 -e \"/^#[ ]*endif/b\" \
2043 (PL_doextract ? "-e \"1,/^#/d\n\"" : ""),
2046 Perl_sv_setpvf(aTHX_ cmd, "\
2047 %s %s -e '/^[^#]/b' \
2048 -e '/^#[ ]*include[ ]/b' \
2049 -e '/^#[ ]*define[ ]/b' \
2050 -e '/^#[ ]*if[ ]/b' \
2051 -e '/^#[ ]*ifdef[ ]/b' \
2052 -e '/^#[ ]*ifndef[ ]/b' \
2053 -e '/^#[ ]*else/b' \
2054 -e '/^#[ ]*elif[ ]/b' \
2055 -e '/^#[ ]*undef[ ]/b' \
2056 -e '/^#[ ]*endif/b' \
2060 Perl_sv_setpvf(aTHX_ cmd, "\
2061 %s %s -e '/^[^#]/b' \
2062 -e '/^#[ ]*include[ ]/b' \
2063 -e '/^#[ ]*define[ ]/b' \
2064 -e '/^#[ ]*if[ ]/b' \
2065 -e '/^#[ ]*ifdef[ ]/b' \
2066 -e '/^#[ ]*ifndef[ ]/b' \
2067 -e '/^#[ ]*else/b' \
2068 -e '/^#[ ]*elif[ ]/b' \
2069 -e '/^#[ ]*undef[ ]/b' \
2070 -e '/^#[ ]*endif/b' \
2079 (PL_doextract ? "-e '1,/^#/d\n'" : ""),
2081 scriptname, cpp, sv, CPPMINUS);
2082 PL_doextract = FALSE;
2083 #ifdef IAMSUID /* actually, this is caught earlier */
2084 if (PL_euid != PL_uid && !PL_euid) { /* if running suidperl */
2086 (void)seteuid(PL_uid); /* musn't stay setuid root */
2089 (void)setreuid((Uid_t)-1, PL_uid);
2091 #ifdef HAS_SETRESUID
2092 (void)setresuid((Uid_t)-1, PL_uid, (Uid_t)-1);
2094 PerlProc_setuid(PL_uid);
2098 if (PerlProc_geteuid() != PL_uid)
2099 Perl_croak(aTHX_ "Can't do seteuid!\n");
2101 #endif /* IAMSUID */
2102 PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
2106 else if (!*scriptname) {
2107 forbid_setid("program input from stdin");
2108 PL_rsfp = PerlIO_stdin();
2111 PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
2112 #if defined(HAS_FCNTL) && defined(F_SETFD)
2114 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); /* ensure close-on-exec */
2119 #ifndef IAMSUID /* in case script is not readable before setuid */
2121 PerlLIO_stat(SvPVX(GvSV(PL_curcop->cop_filegv)),&PL_statbuf) >= 0 &&
2122 PL_statbuf.st_mode & (S_ISUID|S_ISGID))
2125 PerlProc_execv(Perl_form(aTHX_ "%s/sperl%s", BIN_EXP, PL_patchlevel), PL_origargv);
2126 Perl_croak(aTHX_ "Can't do setuid\n");
2130 Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
2131 SvPVX(GvSV(PL_curcop->cop_filegv)), Strerror(errno));
2136 * I_SYSSTATVFS HAS_FSTATVFS
2138 * I_STATFS HAS_FSTATFS
2139 * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT
2140 * here so that metaconfig picks them up. */
2144 S_fd_on_nosuid_fs(pTHX_ int fd)
2149 * Preferred order: fstatvfs(), fstatfs(), getmntent().
2150 * fstatvfs() is UNIX98.
2152 * getmntent() is O(number-of-mounted-filesystems) and can hang.
2155 # ifdef HAS_FSTATVFS
2156 struct statvfs stfs;
2157 check_okay = fstatvfs(fd, &stfs) == 0;
2158 on_nosuid = check_okay && (stfs.f_flag & ST_NOSUID);
2160 # if defined(HAS_FSTATFS) && defined(HAS_STRUCT_STATFS_FLAGS)
2162 check_okay = fstatfs(fd, &stfs) == 0;
2163 # undef PERL_MOUNT_NOSUID
2164 # if !defined(PERL_MOUNT_NOSUID) && defined(MNT_NOSUID)
2165 # define PERL_MOUNT_NOSUID MNT_NOSUID
2167 # if !defined(PERL_MOUNT_NOSUID) && defined(MS_NOSUID)
2168 # define PERL_MOUNT_NOSUID MS_NOSUID
2170 # if !defined(PERL_MOUNT_NOSUID) && defined(M_NOSUID)
2171 # define PERL_MOUNT_NOSUID M_NOSUID
2173 # ifdef PERL_MOUNT_NOSUID
2174 on_nosuid = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
2177 # if defined(HAS_GETMNTENT) && defined(HAS_HASMNTOPT) && defined(MNTOPT_NOSUID)
2178 FILE *mtab = fopen("/etc/mtab", "r");
2179 struct mntent *entry;
2180 struct stat stb, fsb;
2182 if (mtab && (fstat(fd, &stb) == 0)) {
2183 while (entry = getmntent(mtab)) {
2184 if (stat(entry->mnt_dir, &fsb) == 0
2185 && fsb.st_dev == stb.st_dev)
2187 /* found the filesystem */
2189 if (hasmntopt(entry, MNTOPT_NOSUID))
2192 } /* A single fs may well fail its stat(). */
2197 # endif /* mntent */
2198 # endif /* statfs */
2199 # endif /* statvfs */
2201 Perl_croak(aTHX_ "Can't check filesystem of script \"%s\"", PL_origfilename);
2204 #endif /* IAMSUID */
2207 S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript)
2211 /* do we need to emulate setuid on scripts? */
2213 /* This code is for those BSD systems that have setuid #! scripts disabled
2214 * in the kernel because of a security problem. Merely defining DOSUID
2215 * in perl will not fix that problem, but if you have disabled setuid
2216 * scripts in the kernel, this will attempt to emulate setuid and setgid
2217 * on scripts that have those now-otherwise-useless bits set. The setuid
2218 * root version must be called suidperl or sperlN.NNN. If regular perl
2219 * discovers that it has opened a setuid script, it calls suidperl with
2220 * the same argv that it had. If suidperl finds that the script it has
2221 * just opened is NOT setuid root, it sets the effective uid back to the
2222 * uid. We don't just make perl setuid root because that loses the
2223 * effective uid we had before invoking perl, if it was different from the
2226 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
2227 * be defined in suidperl only. suidperl must be setuid root. The
2228 * Configure script will set this up for you if you want it.
2235 if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */
2236 Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
2237 if (fdscript < 0 && PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
2242 #ifndef HAS_SETREUID
2243 /* On this access check to make sure the directories are readable,
2244 * there is actually a small window that the user could use to make
2245 * filename point to an accessible directory. So there is a faint
2246 * chance that someone could execute a setuid script down in a
2247 * non-accessible directory. I don't know what to do about that.
2248 * But I don't think it's too important. The manual lies when
2249 * it says access() is useful in setuid programs.
2251 if (PerlLIO_access(SvPVX(GvSV(PL_curcop->cop_filegv)),1)) /*double check*/
2252 Perl_croak(aTHX_ "Permission denied");
2254 /* If we can swap euid and uid, then we can determine access rights
2255 * with a simple stat of the file, and then compare device and
2256 * inode to make sure we did stat() on the same file we opened.
2257 * Then we just have to make sure he or she can execute it.
2260 struct stat tmpstatbuf;
2264 setreuid(PL_euid,PL_uid) < 0
2267 setresuid(PL_euid,PL_uid,(Uid_t)-1) < 0
2270 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
2271 Perl_croak(aTHX_ "Can't swap uid and euid"); /* really paranoid */
2272 if (PerlLIO_stat(SvPVX(GvSV(PL_curcop->cop_filegv)),&tmpstatbuf) < 0)
2273 Perl_croak(aTHX_ "Permission denied"); /* testing full pathname here */
2274 #if defined(IAMSUID) && !defined(NO_NOSUID_CHECK)
2275 if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp)))
2276 Perl_croak(aTHX_ "Permission denied");
2278 if (tmpstatbuf.st_dev != PL_statbuf.st_dev ||
2279 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
2280 (void)PerlIO_close(PL_rsfp);
2281 if (PL_rsfp = PerlProc_popen("/bin/mail root","w")) { /* heh, heh */
2282 PerlIO_printf(PL_rsfp,
2283 "User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2284 (Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
2285 (long)PL_uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
2286 (long)PL_statbuf.st_dev, (long)PL_statbuf.st_ino,
2287 SvPVX(GvSV(PL_curcop->cop_filegv)),
2288 (long)PL_statbuf.st_uid, (long)PL_statbuf.st_gid);
2289 (void)PerlProc_pclose(PL_rsfp);
2291 Perl_croak(aTHX_ "Permission denied\n");
2295 setreuid(PL_uid,PL_euid) < 0
2297 # if defined(HAS_SETRESUID)
2298 setresuid(PL_uid,PL_euid,(Uid_t)-1) < 0
2301 || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
2302 Perl_croak(aTHX_ "Can't reswap uid and euid");
2303 if (!cando(S_IXUSR,FALSE,&PL_statbuf)) /* can real uid exec? */
2304 Perl_croak(aTHX_ "Permission denied\n");
2306 #endif /* HAS_SETREUID */
2307 #endif /* IAMSUID */
2309 if (!S_ISREG(PL_statbuf.st_mode))
2310 Perl_croak(aTHX_ "Permission denied");
2311 if (PL_statbuf.st_mode & S_IWOTH)
2312 Perl_croak(aTHX_ "Setuid/gid script is writable by world");
2313 PL_doswitches = FALSE; /* -s is insecure in suid */
2314 PL_curcop->cop_line++;
2315 if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
2316 strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */
2317 Perl_croak(aTHX_ "No #! line");
2318 s = SvPV(PL_linestr,n_a)+2;
2320 while (!isSPACE(*s)) s++;
2321 for (s2 = s; (s2 > SvPV(PL_linestr,n_a)+2 &&
2322 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
2323 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
2324 Perl_croak(aTHX_ "Not a perl script");
2325 while (*s == ' ' || *s == '\t') s++;
2327 * #! arg must be what we saw above. They can invoke it by
2328 * mentioning suidperl explicitly, but they may not add any strange
2329 * arguments beyond what #! says if they do invoke suidperl that way.
2331 len = strlen(validarg);
2332 if (strEQ(validarg," PHOOEY ") ||
2333 strnNE(s,validarg,len) || !isSPACE(s[len]))
2334 Perl_croak(aTHX_ "Args must match #! line");
2337 if (PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
2338 PL_euid == PL_statbuf.st_uid)
2340 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2341 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2342 #endif /* IAMSUID */
2344 if (PL_euid) { /* oops, we're not the setuid root perl */
2345 (void)PerlIO_close(PL_rsfp);
2348 PerlProc_execv(Perl_form(aTHX_ "%s/sperl%s", BIN_EXP, PL_patchlevel), PL_origargv);
2350 Perl_croak(aTHX_ "Can't do setuid\n");
2353 if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
2355 (void)setegid(PL_statbuf.st_gid);
2358 (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
2360 #ifdef HAS_SETRESGID
2361 (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
2363 PerlProc_setgid(PL_statbuf.st_gid);
2367 if (PerlProc_getegid() != PL_statbuf.st_gid)
2368 Perl_croak(aTHX_ "Can't do setegid!\n");
2370 if (PL_statbuf.st_mode & S_ISUID) {
2371 if (PL_statbuf.st_uid != PL_euid)
2373 (void)seteuid(PL_statbuf.st_uid); /* all that for this */
2376 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
2378 #ifdef HAS_SETRESUID
2379 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
2381 PerlProc_setuid(PL_statbuf.st_uid);
2385 if (PerlProc_geteuid() != PL_statbuf.st_uid)
2386 Perl_croak(aTHX_ "Can't do seteuid!\n");
2388 else if (PL_uid) { /* oops, mustn't run as root */
2390 (void)seteuid((Uid_t)PL_uid);
2393 (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
2395 #ifdef HAS_SETRESUID
2396 (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
2398 PerlProc_setuid((Uid_t)PL_uid);
2402 if (PerlProc_geteuid() != PL_uid)
2403 Perl_croak(aTHX_ "Can't do seteuid!\n");
2406 if (!cando(S_IXUSR,TRUE,&PL_statbuf))
2407 Perl_croak(aTHX_ "Permission denied\n"); /* they can't do this */
2410 else if (PL_preprocess)
2411 Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
2412 else if (fdscript >= 0)
2413 Perl_croak(aTHX_ "fd script not allowed in suidperl\n");
2415 Perl_croak(aTHX_ "Script is not setuid/setgid in suidperl\n");
2417 /* We absolutely must clear out any saved ids here, so we */
2418 /* exec the real perl, substituting fd script for scriptname. */
2419 /* (We pass script name as "subdir" of fd, which perl will grok.) */
2420 PerlIO_rewind(PL_rsfp);
2421 PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0); /* just in case rewind didn't */
2422 for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
2423 if (!PL_origargv[which])
2424 Perl_croak(aTHX_ "Permission denied");
2425 PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
2426 PerlIO_fileno(PL_rsfp), PL_origargv[which]));
2427 #if defined(HAS_FCNTL) && defined(F_SETFD)
2428 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */
2430 PerlProc_execv(Perl_form(aTHX_ "%s/perl%s", BIN_EXP, PL_patchlevel), PL_origargv);/* try again */
2431 Perl_croak(aTHX_ "Can't do setuid\n");
2432 #endif /* IAMSUID */
2434 if (PL_euid != PL_uid || PL_egid != PL_gid) { /* (suidperl doesn't exist, in fact) */
2435 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2437 PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf); /* may be either wrapped or real suid */
2438 if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
2440 (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
2443 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2444 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2445 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2446 /* not set-id, must be wrapped */
2452 S_find_beginning(pTHX)
2454 register char *s, *s2;
2456 /* skip forward in input to the real script? */
2459 while (PL_doextract) {
2460 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
2461 Perl_croak(aTHX_ "No Perl script found in input\n");
2462 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2463 PerlIO_ungetc(PL_rsfp, '\n'); /* to keep line count right */
2464 PL_doextract = FALSE;
2465 while (*s && !(isSPACE (*s) || *s == '#')) s++;
2467 while (*s == ' ' || *s == '\t') s++;
2469 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2470 if (strnEQ(s2-4,"perl",4))
2472 while (s = moreswitches(s)) ;
2474 if (PL_cddir && PerlDir_chdir(PL_cddir) < 0)
2475 Perl_croak(aTHX_ "Can't chdir to %s",PL_cddir);
2484 PL_uid = PerlProc_getuid();
2485 PL_euid = PerlProc_geteuid();
2486 PL_gid = PerlProc_getgid();
2487 PL_egid = PerlProc_getegid();
2489 PL_uid |= PL_gid << 16;
2490 PL_euid |= PL_egid << 16;
2492 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2496 S_forbid_setid(pTHX_ char *s)
2498 if (PL_euid != PL_uid)
2499 Perl_croak(aTHX_ "No %s allowed while running setuid", s);
2500 if (PL_egid != PL_gid)
2501 Perl_croak(aTHX_ "No %s allowed while running setgid", s);
2505 Perl_init_debugger(pTHX)
2508 HV *ostash = PL_curstash;
2510 PL_curstash = PL_debstash;
2511 PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2512 AvREAL_off(PL_dbargs);
2513 PL_DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2514 PL_DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2515 PL_DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2516 sv_upgrade(GvSV(PL_DBsub), SVt_IV); /* IVX accessed if PERLDB_SUB_NN */
2517 PL_DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2518 sv_setiv(PL_DBsingle, 0);
2519 PL_DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2520 sv_setiv(PL_DBtrace, 0);
2521 PL_DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2522 sv_setiv(PL_DBsignal, 0);
2523 PL_curstash = ostash;
2526 #ifndef STRESS_REALLOC
2527 #define REASONABLE(size) (size)
2529 #define REASONABLE(size) (1) /* unreasonable */
2533 Perl_init_stacks(pTHX)
2535 /* start with 128-item stack and 8K cxstack */
2536 PL_curstackinfo = new_stackinfo(REASONABLE(128),
2537 REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
2538 PL_curstackinfo->si_type = PERLSI_MAIN;
2539 PL_curstack = PL_curstackinfo->si_stack;
2540 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
2542 PL_stack_base = AvARRAY(PL_curstack);
2543 PL_stack_sp = PL_stack_base;
2544 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
2546 New(50,PL_tmps_stack,REASONABLE(128),SV*);
2549 PL_tmps_max = REASONABLE(128);
2551 New(54,PL_markstack,REASONABLE(32),I32);
2552 PL_markstack_ptr = PL_markstack;
2553 PL_markstack_max = PL_markstack + REASONABLE(32);
2557 New(54,PL_scopestack,REASONABLE(32),I32);
2558 PL_scopestack_ix = 0;
2559 PL_scopestack_max = REASONABLE(32);
2561 New(54,PL_savestack,REASONABLE(128),ANY);
2562 PL_savestack_ix = 0;
2563 PL_savestack_max = REASONABLE(128);
2565 New(54,PL_retstack,REASONABLE(16),OP*);
2567 PL_retstack_max = REASONABLE(16);
2576 while (PL_curstackinfo->si_next)
2577 PL_curstackinfo = PL_curstackinfo->si_next;
2578 while (PL_curstackinfo) {
2579 PERL_SI *p = PL_curstackinfo->si_prev;
2580 /* curstackinfo->si_stack got nuked by sv_free_arenas() */
2581 Safefree(PL_curstackinfo->si_cxstack);
2582 Safefree(PL_curstackinfo);
2583 PL_curstackinfo = p;
2585 Safefree(PL_tmps_stack);
2586 Safefree(PL_markstack);
2587 Safefree(PL_scopestack);
2588 Safefree(PL_savestack);
2589 Safefree(PL_retstack);
2591 Safefree(PL_debname);
2592 Safefree(PL_debdelim);
2597 static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
2608 lex_start(PL_linestr);
2610 PL_subname = newSVpvn("main",4);
2614 S_init_predump_symbols(pTHX)
2621 sv_setpvn(get_sv("\"", TRUE), " ", 1);
2622 PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2623 GvMULTI_on(PL_stdingv);
2624 io = GvIOp(PL_stdingv);
2625 IoIFP(io) = PerlIO_stdin();
2626 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2628 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
2630 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2633 IoOFP(io) = IoIFP(io) = PerlIO_stdout();
2635 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2637 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
2639 othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2640 GvMULTI_on(othergv);
2641 io = GvIOp(othergv);
2642 IoOFP(io) = IoIFP(io) = PerlIO_stderr();
2643 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2645 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
2647 PL_statname = NEWSV(66,0); /* last filename we did stat on */
2650 PL_osname = savepv(OSNAME);
2654 S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
2661 argc--,argv++; /* skip name of script */
2662 if (PL_doswitches) {
2663 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2666 if (argv[0][1] == '-') {
2670 if (s = strchr(argv[0], '=')) {
2672 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2675 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2678 PL_toptarget = NEWSV(0,0);
2679 sv_upgrade(PL_toptarget, SVt_PVFM);
2680 sv_setpvn(PL_toptarget, "", 0);
2681 PL_bodytarget = NEWSV(0,0);
2682 sv_upgrade(PL_bodytarget, SVt_PVFM);
2683 sv_setpvn(PL_bodytarget, "", 0);
2684 PL_formtarget = PL_bodytarget;
2687 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2688 sv_setpv(GvSV(tmpgv),PL_origfilename);
2689 magicname("0", "0", 1);
2691 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2692 sv_setpv(GvSV(tmpgv),PL_origargv[0]);
2693 if (PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2694 GvMULTI_on(PL_argvgv);
2695 (void)gv_AVadd(PL_argvgv);
2696 av_clear(GvAVn(PL_argvgv));
2697 for (; argc > 0; argc--,argv++) {
2698 av_push(GvAVn(PL_argvgv),newSVpv(argv[0],0));
2701 if (PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2703 GvMULTI_on(PL_envgv);
2704 hv = GvHVn(PL_envgv);
2705 hv_magic(hv, PL_envgv, 'E');
2706 #if !defined( VMS) && !defined(EPOC) /* VMS doesn't have environ array */
2707 /* Note that if the supplied env parameter is actually a copy
2708 of the global environ then it may now point to free'd memory
2709 if the environment has been modified since. To avoid this
2710 problem we treat env==NULL as meaning 'use the default'
2715 environ[0] = Nullch;
2716 for (; *env; env++) {
2717 if (!(s = strchr(*env,'=')))
2723 sv = newSVpv(s--,0);
2724 (void)hv_store(hv, *env, s - *env, sv, 0);
2726 #if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
2727 /* Sins of the RTL. See note in my_setenv(). */
2728 (void)PerlEnv_putenv(savepv(*env));
2732 #ifdef DYNAMIC_ENV_FETCH
2733 HvNAME(hv) = savepv(ENV_HV_NAME);
2737 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2738 sv_setiv(GvSV(tmpgv), (IV)getpid());
2742 S_init_perllib(pTHX)
2747 s = PerlEnv_getenv("PERL5LIB");
2751 incpush(PerlEnv_getenv("PERLLIB"), FALSE);
2753 /* Treat PERL5?LIB as a possible search list logical name -- the
2754 * "natural" VMS idiom for a Unix path string. We allow each
2755 * element to be a set of |-separated directories for compatibility.
2759 if (my_trnlnm("PERL5LIB",buf,0))
2760 do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2762 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2766 /* Use the ~-expanded versions of APPLLIB (undocumented),
2767 ARCHLIB PRIVLIB SITEARCH and SITELIB
2770 incpush(APPLLIB_EXP, TRUE);
2774 incpush(ARCHLIB_EXP, FALSE);
2777 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2780 incpush(PRIVLIB_EXP, TRUE);
2782 incpush(PRIVLIB_EXP, FALSE);
2786 incpush(SITEARCH_EXP, FALSE);
2790 incpush(SITELIB_EXP, TRUE);
2792 incpush(SITELIB_EXP, FALSE);
2795 #if defined(PERL_VENDORLIB_EXP)
2797 incpush(PERL_VENDORLIB_EXP, TRUE);
2799 incpush(PERL_VENDORLIB_EXP, FALSE);
2803 incpush(".", FALSE);
2807 # define PERLLIB_SEP ';'
2810 # define PERLLIB_SEP '|'
2812 # define PERLLIB_SEP ':'
2815 #ifndef PERLLIB_MANGLE
2816 # define PERLLIB_MANGLE(s,n) (s)
2820 S_incpush(pTHX_ char *p, int addsubdirs)
2822 SV *subdir = Nullsv;
2828 subdir = sv_newmortal();
2829 if (!PL_archpat_auto) {
2830 STRLEN len = (sizeof(ARCHNAME) + strlen(PL_patchlevel)
2831 + sizeof("//auto"));
2832 New(55, PL_archpat_auto, len, char);
2833 sprintf(PL_archpat_auto, "/%s/%s/auto", ARCHNAME, PL_patchlevel);
2835 for (len = sizeof(ARCHNAME) + 2;
2836 PL_archpat_auto[len] != '\0' && PL_archpat_auto[len] != '/'; len++)
2837 if (PL_archpat_auto[len] == '.') PL_archpat_auto[len] = '_';
2842 /* Break at all separators */
2844 SV *libdir = NEWSV(55,0);
2847 /* skip any consecutive separators */
2848 while ( *p == PERLLIB_SEP ) {
2849 /* Uncomment the next line for PATH semantics */
2850 /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */
2854 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2855 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2860 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2861 p = Nullch; /* break out */
2865 * BEFORE pushing libdir onto @INC we may first push version- and
2866 * archname-specific sub-directories.
2869 struct stat tmpstatbuf;
2874 if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) {
2876 while (unix[len-1] == '/') len--; /* Cosmetic */
2877 sv_usepvn(libdir,unix,len);
2880 PerlIO_printf(PerlIO_stderr(),
2881 "Failed to unixify @INC element \"%s\"\n",
2884 /* .../archname/version if -d .../archname/version/auto */
2885 sv_setsv(subdir, libdir);
2886 sv_catpv(subdir, PL_archpat_auto);
2887 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2888 S_ISDIR(tmpstatbuf.st_mode))
2889 av_push(GvAVn(PL_incgv),
2890 newSVpvn(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2892 /* .../archname if -d .../archname/auto */
2893 sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
2894 strlen(PL_patchlevel) + 1, "", 0);
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"));
2901 /* finally push this lib directory on the end of @INC */
2902 av_push(GvAVn(PL_incgv), libdir);
2907 STATIC struct perl_thread *
2908 S_init_main_thread(pTHX)
2910 #if !defined(PERL_IMPLICIT_CONTEXT)
2911 struct perl_thread *thr;
2915 Newz(53, thr, 1, struct perl_thread);
2916 PL_curcop = &PL_compiling;
2917 thr->interp = PERL_GET_INTERP;
2918 thr->cvcache = newHV();
2919 thr->threadsv = newAV();
2920 /* thr->threadsvp is set when find_threadsv is called */
2921 thr->specific = newAV();
2922 thr->errhv = newHV();
2923 thr->flags = THRf_R_JOINABLE;
2924 MUTEX_INIT(&thr->mutex);
2925 /* Handcraft thrsv similarly to mess_sv */
2926 New(53, PL_thrsv, 1, SV);
2927 Newz(53, xpv, 1, XPV);
2928 SvFLAGS(PL_thrsv) = SVt_PV;
2929 SvANY(PL_thrsv) = (void*)xpv;
2930 SvREFCNT(PL_thrsv) = 1 << 30; /* practically infinite */
2931 SvPVX(PL_thrsv) = (char*)thr;
2932 SvCUR_set(PL_thrsv, sizeof(thr));
2933 SvLEN_set(PL_thrsv, sizeof(thr));
2934 *SvEND(PL_thrsv) = '\0'; /* in the trailing_nul field */
2935 thr->oursv = PL_thrsv;
2936 PL_chopset = " \n-";
2939 MUTEX_LOCK(&PL_threads_mutex);
2944 MUTEX_UNLOCK(&PL_threads_mutex);
2946 #ifdef HAVE_THREAD_INTERN
2947 Perl_init_thread_intern(thr);
2950 #ifdef SET_THREAD_SELF
2951 SET_THREAD_SELF(thr);
2953 thr->self = pthread_self();
2954 #endif /* SET_THREAD_SELF */
2958 * These must come after the SET_THR because sv_setpvn does
2959 * SvTAINT and the taint fields require dTHR.
2961 PL_toptarget = NEWSV(0,0);
2962 sv_upgrade(PL_toptarget, SVt_PVFM);
2963 sv_setpvn(PL_toptarget, "", 0);
2964 PL_bodytarget = NEWSV(0,0);
2965 sv_upgrade(PL_bodytarget, SVt_PVFM);
2966 sv_setpvn(PL_bodytarget, "", 0);
2967 PL_formtarget = PL_bodytarget;
2968 thr->errsv = newSVpvn("", 0);
2969 (void) find_threadsv("@"); /* Ensure $@ is initialised early */
2972 PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
2973 PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
2974 PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
2975 PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
2976 PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
2978 PL_reginterp_cnt = 0;
2982 #endif /* USE_THREADS */
2985 Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
2989 line_t oldline = PL_curcop->cop_line;
2994 while (AvFILL(paramList) >= 0) {
2995 cv = (CV*)av_shift(paramList);
2997 CALLPROTECT(aTHX_ &ret, MEMBER_TO_FPTR(S_call_list_body), cv);
3000 (void)SvPV(atsv, len);
3002 PL_curcop = &PL_compiling;
3003 PL_curcop->cop_line = oldline;
3004 if (paramList == PL_beginav)
3005 sv_catpv(atsv, "BEGIN failed--compilation aborted");
3007 sv_catpv(atsv, "END failed--cleanup aborted");
3008 while (PL_scopestack_ix > oldscope)
3010 Perl_croak(aTHX_ "%s", SvPVX(atsv));
3017 /* my_exit() was called */
3018 while (PL_scopestack_ix > oldscope)
3021 PL_curstash = PL_defstash;
3023 call_list(oldscope, PL_endav);
3024 PL_curcop = &PL_compiling;
3025 PL_curcop->cop_line = oldline;
3026 if (PL_statusvalue) {
3027 if (paramList == PL_beginav)
3028 Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
3030 Perl_croak(aTHX_ "END failed--cleanup aborted");
3036 PL_curcop = &PL_compiling;
3037 PL_curcop->cop_line = oldline;
3040 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
3048 S_call_list_body(pTHX_ va_list args)
3051 CV *cv = va_arg(args, CV*);
3053 PUSHMARK(PL_stack_sp);
3054 call_sv((SV*)cv, G_EVAL|G_DISCARD);
3059 Perl_my_exit(pTHX_ U32 status)
3063 DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
3064 thr, (unsigned long) status));
3073 STATUS_NATIVE_SET(status);
3080 Perl_my_failure_exit(pTHX)
3083 if (vaxc$errno & 1) {
3084 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
3085 STATUS_NATIVE_SET(44);
3088 if (!vaxc$errno && errno) /* unlikely */
3089 STATUS_NATIVE_SET(44);
3091 STATUS_NATIVE_SET(vaxc$errno);
3096 STATUS_POSIX_SET(errno);
3098 exitstatus = STATUS_POSIX >> 8;
3099 if (exitstatus & 255)
3100 STATUS_POSIX_SET(exitstatus);
3102 STATUS_POSIX_SET(255);
3109 S_my_exit_jump(pTHX)
3112 register PERL_CONTEXT *cx;
3117 SvREFCNT_dec(PL_e_script);
3118 PL_e_script = Nullsv;
3121 POPSTACK_TO(PL_mainstack);
3122 if (cxstack_ix >= 0) {
3125 POPBLOCK(cx,PL_curpm);
3138 read_e_script(pTHXo_ int idx, SV *buf_sv, int maxlen)
3141 p = SvPVX(PL_e_script);
3142 nl = strchr(p, '\n');
3143 nl = (nl) ? nl+1 : SvEND(PL_e_script);
3145 filter_del(read_e_script);
3148 sv_catpvn(buf_sv, p, nl-p);
3149 sv_chop(PL_e_script, nl);