3 * Copyright (c) 1987-2000 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);
36 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
43 #define perl_construct Perl_construct
44 #define perl_parse Perl_parse
45 #define perl_run Perl_run
46 #define perl_destruct Perl_destruct
47 #define perl_free Perl_free
50 #if defined(USE_THREADS)
51 # define INIT_TLS_AND_INTERP \
53 if (!PL_curinterp) { \
54 PERL_SET_INTERP(my_perl); \
60 # if defined(USE_ITHREADS)
61 # define INIT_TLS_AND_INTERP \
63 if (!PL_curinterp) { \
64 PERL_SET_INTERP(my_perl); \
68 PERL_SET_THX(my_perl); \
71 # define INIT_TLS_AND_INTERP \
73 if (!PL_curinterp) { \
74 PERL_SET_INTERP(my_perl); \
76 PERL_SET_THX(my_perl); \
81 #ifdef PERL_IMPLICIT_SYS
83 perl_alloc_using(struct IPerlMem* ipM, struct IPerlMem* ipMS,
84 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
85 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
86 struct IPerlDir* ipD, struct IPerlSock* ipS,
87 struct IPerlProc* ipP)
89 PerlInterpreter *my_perl;
91 my_perl = (PerlInterpreter*)new(ipM) CPerlObj(ipM, ipMS, ipMP, ipE, ipStd,
92 ipLIO, ipD, ipS, ipP);
95 /* New() needs interpreter, so call malloc() instead */
96 my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
98 Zero(my_perl, 1, PerlInterpreter);
115 =for apidoc perl_alloc
117 Allocates a new Perl interpreter. See L<perlembed>.
125 PerlInterpreter *my_perl;
127 /* New() needs interpreter, so call malloc() instead */
128 my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
131 Zero(my_perl, 1, PerlInterpreter);
134 #endif /* PERL_IMPLICIT_SYS */
137 =for apidoc perl_construct
139 Initializes a new Perl interpreter. See L<perlembed>.
145 perl_construct(pTHXx)
150 struct perl_thread *thr = NULL;
151 #endif /* FAKE_THREADS */
152 #endif /* USE_THREADS */
156 PL_perl_destruct_level = 1;
158 if (PL_perl_destruct_level > 0)
162 /* Init the real globals (and main thread)? */
165 MUTEX_INIT(&PL_sv_mutex);
167 * Safe to use basic SV functions from now on (though
168 * not things like mortals or tainting yet).
170 MUTEX_INIT(&PL_eval_mutex);
171 COND_INIT(&PL_eval_cond);
172 MUTEX_INIT(&PL_threads_mutex);
173 COND_INIT(&PL_nthreads_cond);
174 # ifdef EMULATE_ATOMIC_REFCOUNTS
175 MUTEX_INIT(&PL_svref_mutex);
176 # endif /* EMULATE_ATOMIC_REFCOUNTS */
178 MUTEX_INIT(&PL_cred_mutex);
180 thr = init_main_thread();
181 #endif /* USE_THREADS */
183 #ifdef PERL_FLEXIBLE_EXCEPTIONS
184 PL_protect = MEMBER_TO_FPTR(Perl_default_protect); /* for exceptions */
187 PL_curcop = &PL_compiling; /* needed by ckWARN, right away */
189 PL_linestr = NEWSV(65,79);
190 sv_upgrade(PL_linestr,SVt_PVIV);
192 if (!SvREADONLY(&PL_sv_undef)) {
193 /* set read-only and try to insure than we wont see REFCNT==0
196 SvREADONLY_on(&PL_sv_undef);
197 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
199 sv_setpv(&PL_sv_no,PL_No);
201 SvREADONLY_on(&PL_sv_no);
202 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
204 sv_setpv(&PL_sv_yes,PL_Yes);
206 SvREADONLY_on(&PL_sv_yes);
207 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
212 /* PL_sighandlerp = sighandler; */
214 PL_sighandlerp = Perl_sighandler;
216 PL_pidstatus = newHV();
220 * There is no way we can refer to them from Perl so close them to save
221 * space. The other alternative would be to provide STDAUX and STDPRN
224 (void)fclose(stdaux);
225 (void)fclose(stdprn);
229 PL_nrs = newSVpvn("\n", 1);
230 PL_rs = SvREFCNT_inc(PL_nrs);
235 PL_lex_state = LEX_NOTPARSING;
241 SET_NUMERIC_STANDARD();
245 PL_patchlevel = NEWSV(0,4);
246 (void)SvUPGRADE(PL_patchlevel, SVt_PVNV);
247 if (PERL_REVISION > 127 || PERL_VERSION > 127 || PERL_SUBVERSION > 127)
248 SvGROW(PL_patchlevel, UTF8_MAXLEN*3+1);
249 s = (U8*)SvPVX(PL_patchlevel);
250 s = uv_to_utf8(s, (UV)PERL_REVISION);
251 s = uv_to_utf8(s, (UV)PERL_VERSION);
252 s = uv_to_utf8(s, (UV)PERL_SUBVERSION);
254 SvCUR_set(PL_patchlevel, s - (U8*)SvPVX(PL_patchlevel));
255 SvPOK_on(PL_patchlevel);
256 SvNVX(PL_patchlevel) = (NV)PERL_REVISION
257 + ((NV)PERL_VERSION / (NV)1000)
258 #if defined(PERL_SUBVERSION) && PERL_SUBVERSION > 0
259 + ((NV)PERL_SUBVERSION / (NV)1000000)
262 SvNOK_on(PL_patchlevel); /* dual valued */
263 SvUTF8_on(PL_patchlevel);
264 SvREADONLY_on(PL_patchlevel);
267 #if defined(LOCAL_PATCH_COUNT)
268 PL_localpatches = local_patches; /* For possible -v */
271 PerlIO_init(); /* Hook to IO system */
273 PL_fdpid = newAV(); /* for remembering popen pids by fd */
274 PL_modglobal = newHV(); /* pointers to per-interpreter module globals */
280 =for apidoc perl_destruct
282 Shuts down a Perl interpreter. See L<perlembed>.
291 int destruct_level; /* 0=none, 1=full, 2=full with checks */
297 #endif /* USE_THREADS */
299 /* wait for all pseudo-forked children to finish */
300 PERL_WAIT_FOR_CHILDREN;
304 /* Pass 1 on any remaining threads: detach joinables, join zombies */
306 MUTEX_LOCK(&PL_threads_mutex);
307 DEBUG_S(PerlIO_printf(Perl_debug_log,
308 "perl_destruct: waiting for %d threads...\n",
310 for (t = thr->next; t != thr; t = t->next) {
311 MUTEX_LOCK(&t->mutex);
312 switch (ThrSTATE(t)) {
315 DEBUG_S(PerlIO_printf(Perl_debug_log,
316 "perl_destruct: joining zombie %p\n", t));
317 ThrSETSTATE(t, THRf_DEAD);
318 MUTEX_UNLOCK(&t->mutex);
321 * The SvREFCNT_dec below may take a long time (e.g. av
322 * may contain an object scalar whose destructor gets
323 * called) so we have to unlock threads_mutex and start
326 MUTEX_UNLOCK(&PL_threads_mutex);
328 SvREFCNT_dec((SV*)av);
329 DEBUG_S(PerlIO_printf(Perl_debug_log,
330 "perl_destruct: joined zombie %p OK\n", t));
332 case THRf_R_JOINABLE:
333 DEBUG_S(PerlIO_printf(Perl_debug_log,
334 "perl_destruct: detaching thread %p\n", t));
335 ThrSETSTATE(t, THRf_R_DETACHED);
337 * We unlock threads_mutex and t->mutex in the opposite order
338 * from which we locked them just so that DETACH won't
339 * deadlock if it panics. It's only a breach of good style
340 * not a bug since they are unlocks not locks.
342 MUTEX_UNLOCK(&PL_threads_mutex);
344 MUTEX_UNLOCK(&t->mutex);
347 DEBUG_S(PerlIO_printf(Perl_debug_log,
348 "perl_destruct: ignoring %p (state %u)\n",
350 MUTEX_UNLOCK(&t->mutex);
351 /* fall through and out */
354 /* We leave the above "Pass 1" loop with threads_mutex still locked */
356 /* Pass 2 on remaining threads: wait for the thread count to drop to one */
357 while (PL_nthreads > 1)
359 DEBUG_S(PerlIO_printf(Perl_debug_log,
360 "perl_destruct: final wait for %d threads\n",
362 COND_WAIT(&PL_nthreads_cond, &PL_threads_mutex);
364 /* At this point, we're the last thread */
365 MUTEX_UNLOCK(&PL_threads_mutex);
366 DEBUG_S(PerlIO_printf(Perl_debug_log, "perl_destruct: armageddon has arrived\n"));
367 MUTEX_DESTROY(&PL_threads_mutex);
368 COND_DESTROY(&PL_nthreads_cond);
369 #endif /* !defined(FAKE_THREADS) */
370 #endif /* USE_THREADS */
372 destruct_level = PL_perl_destruct_level;
376 if ((s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL"))) {
378 if (destruct_level < i)
387 /* We must account for everything. */
389 /* Destroy the main CV and syntax tree */
391 PL_curpad = AvARRAY(PL_comppad);
392 op_free(PL_main_root);
393 PL_main_root = Nullop;
395 PL_curcop = &PL_compiling;
396 PL_main_start = Nullop;
397 SvREFCNT_dec(PL_main_cv);
401 if (PL_sv_objcount) {
403 * Try to destruct global references. We do this first so that the
404 * destructors and destructees still exist. Some sv's might remain.
405 * Non-referenced objects are on their own.
410 /* unhook hooks which will soon be, or use, destroyed data */
411 SvREFCNT_dec(PL_warnhook);
412 PL_warnhook = Nullsv;
413 SvREFCNT_dec(PL_diehook);
416 /* call exit list functions */
417 while (PL_exitlistlen-- > 0)
418 PL_exitlist[PL_exitlistlen].fn(aTHXo_ PL_exitlist[PL_exitlistlen].ptr);
420 Safefree(PL_exitlist);
422 if (destruct_level == 0){
424 DEBUG_P(debprofdump());
426 /* The exit() function will do everything that needs doing. */
430 /* loosen bonds of global variables */
433 (void)PerlIO_close(PL_rsfp);
437 /* Filters for program text */
438 SvREFCNT_dec(PL_rsfp_filters);
439 PL_rsfp_filters = Nullav;
442 PL_preprocess = FALSE;
448 PL_doswitches = FALSE;
449 PL_dowarn = G_WARN_OFF;
450 PL_doextract = FALSE;
451 PL_sawampersand = FALSE; /* must save all match strings */
454 Safefree(PL_inplace);
456 SvREFCNT_dec(PL_patchlevel);
459 SvREFCNT_dec(PL_e_script);
460 PL_e_script = Nullsv;
463 /* magical thingies */
465 Safefree(PL_ofs); /* $, */
468 Safefree(PL_ors); /* $\ */
471 SvREFCNT_dec(PL_rs); /* $/ */
474 SvREFCNT_dec(PL_nrs); /* $/ helper */
477 PL_multiline = 0; /* $* */
478 Safefree(PL_osname); /* $^O */
481 SvREFCNT_dec(PL_statname);
482 PL_statname = Nullsv;
485 /* defgv, aka *_ should be taken care of elsewhere */
487 /* clean up after study() */
488 SvREFCNT_dec(PL_lastscream);
489 PL_lastscream = Nullsv;
490 Safefree(PL_screamfirst);
492 Safefree(PL_screamnext);
496 Safefree(PL_efloatbuf);
497 PL_efloatbuf = Nullch;
500 /* startup and shutdown function lists */
501 SvREFCNT_dec(PL_beginav);
502 SvREFCNT_dec(PL_endav);
503 SvREFCNT_dec(PL_checkav);
504 SvREFCNT_dec(PL_initav);
510 /* shortcuts just get cleared */
516 PL_argvoutgv = Nullgv;
518 PL_stderrgv = Nullgv;
519 PL_last_in_gv = Nullgv;
521 PL_debstash = Nullhv;
523 /* reset so print() ends up where we expect */
526 SvREFCNT_dec(PL_argvout_stack);
527 PL_argvout_stack = Nullav;
529 SvREFCNT_dec(PL_modglobal);
530 PL_modglobal = Nullhv;
531 SvREFCNT_dec(PL_preambleav);
532 PL_preambleav = Nullav;
533 SvREFCNT_dec(PL_subname);
535 SvREFCNT_dec(PL_linestr);
537 SvREFCNT_dec(PL_pidstatus);
538 PL_pidstatus = Nullhv;
539 SvREFCNT_dec(PL_toptarget);
540 PL_toptarget = Nullsv;
541 SvREFCNT_dec(PL_bodytarget);
542 PL_bodytarget = Nullsv;
543 PL_formtarget = Nullsv;
545 /* free locale stuff */
546 #ifdef USE_LOCALE_COLLATE
547 Safefree(PL_collation_name);
548 PL_collation_name = Nullch;
551 #ifdef USE_LOCALE_NUMERIC
552 Safefree(PL_numeric_name);
553 PL_numeric_name = Nullch;
556 /* clear utf8 character classes */
557 SvREFCNT_dec(PL_utf8_alnum);
558 SvREFCNT_dec(PL_utf8_alnumc);
559 SvREFCNT_dec(PL_utf8_ascii);
560 SvREFCNT_dec(PL_utf8_alpha);
561 SvREFCNT_dec(PL_utf8_space);
562 SvREFCNT_dec(PL_utf8_cntrl);
563 SvREFCNT_dec(PL_utf8_graph);
564 SvREFCNT_dec(PL_utf8_digit);
565 SvREFCNT_dec(PL_utf8_upper);
566 SvREFCNT_dec(PL_utf8_lower);
567 SvREFCNT_dec(PL_utf8_print);
568 SvREFCNT_dec(PL_utf8_punct);
569 SvREFCNT_dec(PL_utf8_xdigit);
570 SvREFCNT_dec(PL_utf8_mark);
571 SvREFCNT_dec(PL_utf8_toupper);
572 SvREFCNT_dec(PL_utf8_tolower);
573 PL_utf8_alnum = Nullsv;
574 PL_utf8_alnumc = Nullsv;
575 PL_utf8_ascii = Nullsv;
576 PL_utf8_alpha = Nullsv;
577 PL_utf8_space = Nullsv;
578 PL_utf8_cntrl = Nullsv;
579 PL_utf8_graph = Nullsv;
580 PL_utf8_digit = Nullsv;
581 PL_utf8_upper = Nullsv;
582 PL_utf8_lower = Nullsv;
583 PL_utf8_print = Nullsv;
584 PL_utf8_punct = Nullsv;
585 PL_utf8_xdigit = Nullsv;
586 PL_utf8_mark = Nullsv;
587 PL_utf8_toupper = Nullsv;
588 PL_utf8_totitle = Nullsv;
589 PL_utf8_tolower = Nullsv;
591 if (!specialWARN(PL_compiling.cop_warnings))
592 SvREFCNT_dec(PL_compiling.cop_warnings);
593 PL_compiling.cop_warnings = Nullsv;
595 SvREFCNT_dec(CopFILEGV(&PL_compiling));
596 CopFILEGV_set(&PL_compiling, Nullgv);
599 /* Prepare to destruct main symbol table. */
604 SvREFCNT_dec(PL_curstname);
605 PL_curstname = Nullsv;
607 /* clear queued errors */
608 SvREFCNT_dec(PL_errors);
612 if (destruct_level >= 2 && ckWARN_d(WARN_INTERNAL)) {
613 if (PL_scopestack_ix != 0)
614 Perl_warner(aTHX_ WARN_INTERNAL,
615 "Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
616 (long)PL_scopestack_ix);
617 if (PL_savestack_ix != 0)
618 Perl_warner(aTHX_ WARN_INTERNAL,
619 "Unbalanced saves: %ld more saves than restores\n",
620 (long)PL_savestack_ix);
621 if (PL_tmps_floor != -1)
622 Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced tmps: %ld more allocs than frees\n",
623 (long)PL_tmps_floor + 1);
624 if (cxstack_ix != -1)
625 Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced context: %ld more PUSHes than POPs\n",
626 (long)cxstack_ix + 1);
629 /* Now absolutely destruct everything, somehow or other, loops or no. */
631 SvFLAGS(PL_fdpid) |= SVTYPEMASK; /* don't clean out pid table now */
632 SvFLAGS(PL_strtab) |= SVTYPEMASK; /* don't clean out strtab now */
633 while (PL_sv_count != 0 && PL_sv_count != last_sv_count) {
634 last_sv_count = PL_sv_count;
637 SvFLAGS(PL_fdpid) &= ~SVTYPEMASK;
638 SvFLAGS(PL_fdpid) |= SVt_PVAV;
639 SvFLAGS(PL_strtab) &= ~SVTYPEMASK;
640 SvFLAGS(PL_strtab) |= SVt_PVHV;
642 AvREAL_off(PL_fdpid); /* no surviving entries */
643 SvREFCNT_dec(PL_fdpid); /* needed in io_close() */
646 /* Destruct the global string table. */
648 /* Yell and reset the HeVAL() slots that are still holding refcounts,
649 * so that sv_free() won't fail on them.
657 max = HvMAX(PL_strtab);
658 array = HvARRAY(PL_strtab);
661 if (hent && ckWARN_d(WARN_INTERNAL)) {
662 Perl_warner(aTHX_ WARN_INTERNAL,
663 "Unbalanced string table refcount: (%d) for \"%s\"",
664 HeVAL(hent) - Nullsv, HeKEY(hent));
665 HeVAL(hent) = Nullsv;
675 SvREFCNT_dec(PL_strtab);
677 /* free special SVs */
679 SvREFCNT(&PL_sv_yes) = 0;
680 sv_clear(&PL_sv_yes);
681 SvANY(&PL_sv_yes) = NULL;
682 SvREADONLY_off(&PL_sv_yes);
684 SvREFCNT(&PL_sv_no) = 0;
686 SvANY(&PL_sv_no) = NULL;
687 SvREADONLY_off(&PL_sv_no);
689 SvREFCNT(&PL_sv_undef) = 0;
690 SvREADONLY_off(&PL_sv_undef);
692 if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL))
693 Perl_warner(aTHX_ WARN_INTERNAL,"Scalars leaked: %ld\n", (long)PL_sv_count);
697 /* No SVs have survived, need to clean out */
698 Safefree(PL_origfilename);
699 Safefree(PL_reg_start_tmp);
701 Safefree(PL_reg_curpm);
702 Safefree(PL_reg_poscache);
703 Safefree(HeKEY_hek(&PL_hv_fetch_ent_mh));
704 Safefree(PL_op_mask);
706 PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */
708 DEBUG_P(debprofdump());
710 MUTEX_DESTROY(&PL_strtab_mutex);
711 MUTEX_DESTROY(&PL_sv_mutex);
712 MUTEX_DESTROY(&PL_eval_mutex);
713 MUTEX_DESTROY(&PL_cred_mutex);
714 COND_DESTROY(&PL_eval_cond);
715 #ifdef EMULATE_ATOMIC_REFCOUNTS
716 MUTEX_DESTROY(&PL_svref_mutex);
717 #endif /* EMULATE_ATOMIC_REFCOUNTS */
719 /* As the penultimate thing, free the non-arena SV for thrsv */
720 Safefree(SvPVX(PL_thrsv));
721 Safefree(SvANY(PL_thrsv));
724 #endif /* USE_THREADS */
726 /* As the absolutely last thing, free the non-arena SV for mess() */
729 /* it could have accumulated taint magic */
730 if (SvTYPE(PL_mess_sv) >= SVt_PVMG) {
733 for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) {
734 moremagic = mg->mg_moremagic;
735 if (mg->mg_ptr && mg->mg_type != 'g' && mg->mg_len >= 0)
736 Safefree(mg->mg_ptr);
740 /* we know that type >= SVt_PV */
741 (void)SvOOK_off(PL_mess_sv);
742 Safefree(SvPVX(PL_mess_sv));
743 Safefree(SvANY(PL_mess_sv));
744 Safefree(PL_mess_sv);
750 =for apidoc perl_free
752 Releases a Perl interpreter. See L<perlembed>.
760 #if defined(PERL_OBJECT)
768 Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
770 Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry);
771 PL_exitlist[PL_exitlistlen].fn = fn;
772 PL_exitlist[PL_exitlistlen].ptr = ptr;
777 =for apidoc perl_parse
779 Tells a Perl interpreter to parse a Perl script. See L<perlembed>.
785 perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
795 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
798 Perl_croak(aTHX_ "suidperl is no longer needed since the kernel can now execute\n\
799 setuid perl scripts securely.\n");
803 #if defined(__DYNAMIC__) && (defined(NeXT) || defined(__NeXT__))
804 _dyld_lookup_and_bind
805 ("__environ", (unsigned long *) &environ_pointer, NULL);
810 #ifndef VMS /* VMS doesn't have environ array */
811 PL_origenviron = environ;
816 /* Come here if running an undumped a.out. */
818 PL_origfilename = savepv(argv[0]);
819 PL_do_undump = FALSE;
820 cxstack_ix = -1; /* start label stack again */
822 init_postdump_symbols(argc,argv,env);
827 PL_curpad = AvARRAY(PL_comppad);
828 op_free(PL_main_root);
829 PL_main_root = Nullop;
831 PL_main_start = Nullop;
832 SvREFCNT_dec(PL_main_cv);
836 oldscope = PL_scopestack_ix;
837 PL_dowarn = G_WARN_OFF;
839 #ifdef PERL_FLEXIBLE_EXCEPTIONS
840 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vparse_body), env, xsinit);
846 #ifndef PERL_FLEXIBLE_EXCEPTIONS
847 parse_body(env,xsinit);
850 call_list(oldscope, PL_checkav);
857 /* my_exit() was called */
858 while (PL_scopestack_ix > oldscope)
861 PL_curstash = PL_defstash;
863 call_list(oldscope, PL_checkav);
864 ret = STATUS_NATIVE_EXPORT;
867 PerlIO_printf(Perl_error_log, "panic: top_env\n");
875 #ifdef PERL_FLEXIBLE_EXCEPTIONS
877 S_vparse_body(pTHX_ va_list args)
879 char **env = va_arg(args, char**);
880 XSINIT_t xsinit = va_arg(args, XSINIT_t);
882 return parse_body(env, xsinit);
887 S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
890 int argc = PL_origargc;
891 char **argv = PL_origargv;
892 char *scriptname = NULL;
894 VOL bool dosearch = FALSE;
899 char *cddir = Nullch;
901 sv_setpvn(PL_linestr,"",0);
902 sv = newSVpvn("",0); /* first used for -I flags */
906 for (argc--,argv++; argc > 0; argc--,argv++) {
907 if (argv[0][0] != '-' || !argv[0][1])
911 validarg = " PHOOEY ";
920 win32_argv2utf8(argc-1, argv+1);
923 #ifndef PERL_STRICT_CR
947 if ((s = moreswitches(s)))
957 if (PL_euid != PL_uid || PL_egid != PL_gid)
958 Perl_croak(aTHX_ "No -e allowed in setuid scripts");
960 PL_e_script = newSVpvn("",0);
961 filter_add(read_e_script, NULL);
964 sv_catpv(PL_e_script, s);
966 sv_catpv(PL_e_script, argv[1]);
970 Perl_croak(aTHX_ "No code specified for -e");
971 sv_catpv(PL_e_script, "\n");
974 case 'I': /* -I handled both here and in moreswitches() */
976 if (!*++s && (s=argv[1]) != Nullch) {
981 STRLEN len = strlen(s);
983 incpush(p, TRUE, TRUE);
984 sv_catpvn(sv, "-I", 2);
985 sv_catpvn(sv, p, len);
986 sv_catpvn(sv, " ", 1);
990 Perl_croak(aTHX_ "No directory specified for -I");
994 PL_preprocess = TRUE;
1004 PL_preambleav = newAV();
1005 av_push(PL_preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
1007 PL_Sv = newSVpv("print myconfig();",0);
1009 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
1011 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
1013 sv_catpv(PL_Sv,"\" Compile-time options:");
1015 sv_catpv(PL_Sv," DEBUGGING");
1017 # ifdef MULTIPLICITY
1018 sv_catpv(PL_Sv," MULTIPLICITY");
1021 sv_catpv(PL_Sv," USE_THREADS");
1023 # ifdef USE_ITHREADS
1024 sv_catpv(PL_Sv," USE_ITHREADS");
1026 # ifdef USE_64_BIT_INT
1027 sv_catpv(PL_Sv," USE_64_BIT_INT");
1029 # ifdef USE_64_BIT_ALL
1030 sv_catpv(PL_Sv," USE_64_BIT_ALL");
1032 # ifdef USE_LONG_DOUBLE
1033 sv_catpv(PL_Sv," USE_LONG_DOUBLE");
1035 # ifdef USE_LARGE_FILES
1036 sv_catpv(PL_Sv," USE_LARGE_FILES");
1039 sv_catpv(PL_Sv," USE_SOCKS");
1042 sv_catpv(PL_Sv," PERL_OBJECT");
1044 # ifdef PERL_IMPLICIT_CONTEXT
1045 sv_catpv(PL_Sv," PERL_IMPLICIT_CONTEXT");
1047 # ifdef PERL_IMPLICIT_SYS
1048 sv_catpv(PL_Sv," PERL_IMPLICIT_SYS");
1050 sv_catpv(PL_Sv,"\\n\",");
1052 #if defined(LOCAL_PATCH_COUNT)
1053 if (LOCAL_PATCH_COUNT > 0) {
1055 sv_catpv(PL_Sv,"\" Locally applied patches:\\n\",");
1056 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
1057 if (PL_localpatches[i])
1058 Perl_sv_catpvf(aTHX_ PL_Sv,"q\" \t%s\n\",",PL_localpatches[i]);
1062 Perl_sv_catpvf(aTHX_ PL_Sv,"\" Built under %s\\n\"",OSNAME);
1065 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
1067 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled on %s\\n\"",__DATE__);
1070 sv_catpv(PL_Sv, "; \
1072 @env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; \
1073 print \" \\%ENV:\\n @env\\n\" if @env; \
1074 print \" \\@INC:\\n @INC\\n\";");
1077 PL_Sv = newSVpv("config_vars(qw(",0);
1078 sv_catpv(PL_Sv, ++s);
1079 sv_catpv(PL_Sv, "))");
1082 av_push(PL_preambleav, PL_Sv);
1083 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
1086 PL_doextract = TRUE;
1094 if (!*++s || isSPACE(*s)) {
1098 /* catch use of gnu style long options */
1099 if (strEQ(s, "version")) {
1103 if (strEQ(s, "help")) {
1110 Perl_croak(aTHX_ "Unrecognized switch: -%s (-h will show valid options)",s);
1116 #ifndef SECURE_INTERNAL_GETENV
1119 (s = PerlEnv_getenv("PERL5OPT")))
1123 if (*s == '-' && *(s+1) == 'T')
1136 if (!strchr("DIMUdmw", *s))
1137 Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
1138 s = moreswitches(s);
1144 scriptname = argv[0];
1147 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
1149 else if (scriptname == Nullch) {
1151 if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
1159 open_script(scriptname,dosearch,sv,&fdscript);
1161 validate_suid(validarg, scriptname,fdscript);
1163 #if defined(SIGCHLD) || defined(SIGCLD)
1166 # define SIGCHLD SIGCLD
1168 Sighandler_t sigstate = rsignal_state(SIGCHLD);
1169 if (sigstate == SIG_IGN) {
1170 if (ckWARN(WARN_SIGNAL))
1171 Perl_warner(aTHX_ WARN_SIGNAL,
1172 "Can't ignore signal CHLD, forcing to default");
1173 (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL);
1180 if (cddir && PerlDir_chdir(cddir) < 0)
1181 Perl_croak(aTHX_ "Can't chdir to %s",cddir);
1185 PL_main_cv = PL_compcv = (CV*)NEWSV(1104,0);
1186 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
1187 CvUNIQUE_on(PL_compcv);
1189 PL_comppad = newAV();
1190 av_push(PL_comppad, Nullsv);
1191 PL_curpad = AvARRAY(PL_comppad);
1192 PL_comppad_name = newAV();
1193 PL_comppad_name_fill = 0;
1194 PL_min_intro_pending = 0;
1197 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
1198 PL_curpad[0] = (SV*)newAV();
1199 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
1200 CvOWNER(PL_compcv) = 0;
1201 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
1202 MUTEX_INIT(CvMUTEXP(PL_compcv));
1203 #endif /* USE_THREADS */
1205 comppadlist = newAV();
1206 AvREAL_off(comppadlist);
1207 av_store(comppadlist, 0, (SV*)PL_comppad_name);
1208 av_store(comppadlist, 1, (SV*)PL_comppad);
1209 CvPADLIST(PL_compcv) = comppadlist;
1211 boot_core_UNIVERSAL();
1213 boot_core_xsutils();
1217 (*xsinit)(aTHXo); /* in case linked C routines want magical variables */
1218 #if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__)
1226 init_predump_symbols();
1227 /* init_postdump_symbols not currently designed to be called */
1228 /* more than once (ENV isn't cleared first, for example) */
1229 /* But running with -u leaves %ENV & @ARGV undefined! XXX */
1231 init_postdump_symbols(argc,argv,env);
1235 /* now parse the script */
1237 SETERRNO(0,SS$_NORMAL);
1239 if (yyparse() || PL_error_count) {
1241 Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
1243 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
1247 CopLINE_set(PL_curcop, 0);
1248 PL_curstash = PL_defstash;
1249 PL_preprocess = FALSE;
1251 SvREFCNT_dec(PL_e_script);
1252 PL_e_script = Nullsv;
1255 /* now that script is parsed, we can modify record separator */
1256 SvREFCNT_dec(PL_rs);
1257 PL_rs = SvREFCNT_inc(PL_nrs);
1258 sv_setsv(get_sv("/", TRUE), PL_rs);
1263 SAVECOPFILE(PL_curcop);
1264 SAVECOPLINE(PL_curcop);
1265 gv_check(PL_defstash);
1272 if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
1273 dump_mstats("after compilation:");
1282 =for apidoc perl_run
1284 Tells a Perl interpreter to run. See L<perlembed>.
1300 oldscope = PL_scopestack_ix;
1302 #ifdef PERL_FLEXIBLE_EXCEPTIONS
1304 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vrun_body), oldscope);
1310 cxstack_ix = -1; /* start context stack again */
1312 case 0: /* normal completion */
1313 #ifndef PERL_FLEXIBLE_EXCEPTIONS
1318 case 2: /* my_exit() */
1319 while (PL_scopestack_ix > oldscope)
1322 PL_curstash = PL_defstash;
1323 if (PL_endav && !PL_minus_c)
1324 call_list(oldscope, PL_endav);
1326 if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
1327 dump_mstats("after execution: ");
1329 ret = STATUS_NATIVE_EXPORT;
1333 POPSTACK_TO(PL_mainstack);
1336 PerlIO_printf(Perl_error_log, "panic: restartop\n");
1346 #ifdef PERL_FLEXIBLE_EXCEPTIONS
1348 S_vrun_body(pTHX_ va_list args)
1350 I32 oldscope = va_arg(args, I32);
1352 return run_body(oldscope);
1358 S_run_body(pTHX_ I32 oldscope)
1362 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
1363 PL_sawampersand ? "Enabling" : "Omitting"));
1365 if (!PL_restartop) {
1366 DEBUG_x(dump_all());
1367 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
1368 DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%"UVxf"\n",
1372 PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
1375 if (PERLDB_SINGLE && PL_DBsingle)
1376 sv_setiv(PL_DBsingle, 1);
1378 call_list(oldscope, PL_initav);
1384 PL_op = PL_restartop;
1388 else if (PL_main_start) {
1389 CvDEPTH(PL_main_cv) = 1;
1390 PL_op = PL_main_start;
1400 =for apidoc p||get_sv
1402 Returns the SV of the specified Perl scalar. If C<create> is set and the
1403 Perl variable does not exist then it will be created. If C<create> is not
1404 set and the variable does not exist then NULL is returned.
1410 Perl_get_sv(pTHX_ const char *name, I32 create)
1414 if (name[1] == '\0' && !isALPHA(name[0])) {
1415 PADOFFSET tmp = find_threadsv(name);
1416 if (tmp != NOT_IN_PAD) {
1418 return THREADSV(tmp);
1421 #endif /* USE_THREADS */
1422 gv = gv_fetchpv(name, create, SVt_PV);
1429 =for apidoc p||get_av
1431 Returns the AV of the specified Perl array. If C<create> is set and the
1432 Perl variable does not exist then it will be created. If C<create> is not
1433 set and the variable does not exist then NULL is returned.
1439 Perl_get_av(pTHX_ const char *name, I32 create)
1441 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1450 =for apidoc p||get_hv
1452 Returns the HV of the specified Perl hash. If C<create> is set and the
1453 Perl variable does not exist then it will be created. If C<create> is not
1454 set and the variable does not exist then NULL is returned.
1460 Perl_get_hv(pTHX_ const char *name, I32 create)
1462 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1471 =for apidoc p||get_cv
1473 Returns the CV of the specified Perl subroutine. If C<create> is set and
1474 the Perl subroutine does not exist then it will be declared (which has the
1475 same effect as saying C<sub name;>). If C<create> is not set and the
1476 subroutine does not exist then NULL is returned.
1482 Perl_get_cv(pTHX_ const char *name, I32 create)
1484 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
1485 /* XXX unsafe for threads if eval_owner isn't held */
1486 /* XXX this is probably not what they think they're getting.
1487 * It has the same effect as "sub name;", i.e. just a forward
1489 if (create && !GvCVu(gv))
1490 return newSUB(start_subparse(FALSE, 0),
1491 newSVOP(OP_CONST, 0, newSVpv(name,0)),
1499 /* Be sure to refetch the stack pointer after calling these routines. */
1502 =for apidoc p||call_argv
1504 Performs a callback to the specified Perl sub. See L<perlcall>.
1510 Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv)
1512 /* See G_* flags in cop.h */
1513 /* null terminated arg list */
1520 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
1525 return call_pv(sub_name, flags);
1529 =for apidoc p||call_pv
1531 Performs a callback to the specified Perl sub. See L<perlcall>.
1537 Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
1538 /* name of the subroutine */
1539 /* See G_* flags in cop.h */
1541 return call_sv((SV*)get_cv(sub_name, TRUE), flags);
1545 =for apidoc p||call_method
1547 Performs a callback to the specified Perl method. The blessed object must
1548 be on the stack. See L<perlcall>.
1554 Perl_call_method(pTHX_ const char *methname, I32 flags)
1555 /* name of the subroutine */
1556 /* See G_* flags in cop.h */
1564 XPUSHs(sv_2mortal(newSVpv(methname,0)));
1569 return call_sv(*PL_stack_sp--, flags);
1572 /* May be called with any of a CV, a GV, or an SV containing the name. */
1574 =for apidoc p||call_sv
1576 Performs a callback to the Perl sub whose name is in the SV. See
1583 Perl_call_sv(pTHX_ SV *sv, I32 flags)
1585 /* See G_* flags in cop.h */
1588 LOGOP myop; /* fake syntax tree node */
1592 bool oldcatch = CATCH_GET;
1597 if (flags & G_DISCARD) {
1602 Zero(&myop, 1, LOGOP);
1603 myop.op_next = Nullop;
1604 if (!(flags & G_NOARGS))
1605 myop.op_flags |= OPf_STACKED;
1606 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1607 (flags & G_ARRAY) ? OPf_WANT_LIST :
1612 EXTEND(PL_stack_sp, 1);
1613 *++PL_stack_sp = sv;
1615 oldscope = PL_scopestack_ix;
1617 if (PERLDB_SUB && PL_curstash != PL_debstash
1618 /* Handle first BEGIN of -d. */
1619 && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
1620 /* Try harder, since this may have been a sighandler, thus
1621 * curstash may be meaningless. */
1622 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != PL_debstash)
1623 && !(flags & G_NODEBUG))
1624 PL_op->op_private |= OPpENTERSUB_DB;
1626 if (!(flags & G_EVAL)) {
1628 call_body((OP*)&myop, FALSE);
1629 retval = PL_stack_sp - (PL_stack_base + oldmark);
1630 CATCH_SET(oldcatch);
1633 cLOGOP->op_other = PL_op;
1635 /* we're trying to emulate pp_entertry() here */
1637 register PERL_CONTEXT *cx;
1638 I32 gimme = GIMME_V;
1643 push_return(PL_op->op_next);
1644 PUSHBLOCK(cx, CXt_EVAL, PL_stack_sp);
1646 PL_eval_root = PL_op; /* Only needed so that goto works right. */
1648 PL_in_eval = EVAL_INEVAL;
1649 if (flags & G_KEEPERR)
1650 PL_in_eval |= EVAL_KEEPERR;
1656 #ifdef PERL_FLEXIBLE_EXCEPTIONS
1658 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_body),
1665 #ifndef PERL_FLEXIBLE_EXCEPTIONS
1667 call_body((OP*)&myop, FALSE);
1669 retval = PL_stack_sp - (PL_stack_base + oldmark);
1670 if (!(flags & G_KEEPERR))
1677 /* my_exit() was called */
1678 PL_curstash = PL_defstash;
1681 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
1682 Perl_croak(aTHX_ "Callback called exit");
1687 PL_op = PL_restartop;
1691 PL_stack_sp = PL_stack_base + oldmark;
1692 if (flags & G_ARRAY)
1696 *++PL_stack_sp = &PL_sv_undef;
1701 if (PL_scopestack_ix > oldscope) {
1705 register PERL_CONTEXT *cx;
1717 if (flags & G_DISCARD) {
1718 PL_stack_sp = PL_stack_base + oldmark;
1727 #ifdef PERL_FLEXIBLE_EXCEPTIONS
1729 S_vcall_body(pTHX_ va_list args)
1731 OP *myop = va_arg(args, OP*);
1732 int is_eval = va_arg(args, int);
1734 call_body(myop, is_eval);
1740 S_call_body(pTHX_ OP *myop, int is_eval)
1744 if (PL_op == myop) {
1746 PL_op = Perl_pp_entereval(aTHX);
1748 PL_op = Perl_pp_entersub(aTHX);
1754 /* Eval a string. The G_EVAL flag is always assumed. */
1757 =for apidoc p||eval_sv
1759 Tells Perl to C<eval> the string in the SV.
1765 Perl_eval_sv(pTHX_ SV *sv, I32 flags)
1767 /* See G_* flags in cop.h */
1770 UNOP myop; /* fake syntax tree node */
1771 I32 oldmark = SP - PL_stack_base;
1778 if (flags & G_DISCARD) {
1785 Zero(PL_op, 1, UNOP);
1786 EXTEND(PL_stack_sp, 1);
1787 *++PL_stack_sp = sv;
1788 oldscope = PL_scopestack_ix;
1790 if (!(flags & G_NOARGS))
1791 myop.op_flags = OPf_STACKED;
1792 myop.op_next = Nullop;
1793 myop.op_type = OP_ENTEREVAL;
1794 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1795 (flags & G_ARRAY) ? OPf_WANT_LIST :
1797 if (flags & G_KEEPERR)
1798 myop.op_flags |= OPf_SPECIAL;
1800 #ifdef PERL_FLEXIBLE_EXCEPTIONS
1802 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_body),
1809 #ifndef PERL_FLEXIBLE_EXCEPTIONS
1811 call_body((OP*)&myop,TRUE);
1813 retval = PL_stack_sp - (PL_stack_base + oldmark);
1814 if (!(flags & G_KEEPERR))
1821 /* my_exit() was called */
1822 PL_curstash = PL_defstash;
1825 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
1826 Perl_croak(aTHX_ "Callback called exit");
1831 PL_op = PL_restartop;
1835 PL_stack_sp = PL_stack_base + oldmark;
1836 if (flags & G_ARRAY)
1840 *++PL_stack_sp = &PL_sv_undef;
1846 if (flags & G_DISCARD) {
1847 PL_stack_sp = PL_stack_base + oldmark;
1857 =for apidoc p||eval_pv
1859 Tells Perl to C<eval> the given string and return an SV* result.
1865 Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
1868 SV* sv = newSVpv(p, 0);
1871 eval_sv(sv, G_SCALAR);
1878 if (croak_on_error && SvTRUE(ERRSV)) {
1880 Perl_croak(aTHX_ SvPVx(ERRSV, n_a));
1886 /* Require a module. */
1889 =for apidoc p||require_pv
1891 Tells Perl to C<require> a module.
1897 Perl_require_pv(pTHX_ const char *pv)
1901 PUSHSTACKi(PERLSI_REQUIRE);
1903 sv = sv_newmortal();
1904 sv_setpv(sv, "require '");
1907 eval_sv(sv, G_DISCARD);
1913 Perl_magicname(pTHX_ char *sym, char *name, I32 namlen)
1917 if ((gv = gv_fetchpv(sym,TRUE, SVt_PV)))
1918 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1922 S_usage(pTHX_ char *name) /* XXX move this out into a module ? */
1924 /* This message really ought to be max 23 lines.
1925 * Removed -h because the user already knows that opton. Others? */
1927 static char *usage_msg[] = {
1928 "-0[octal] specify record separator (\\0, if no argument)",
1929 "-a autosplit mode with -n or -p (splits $_ into @F)",
1930 "-C enable native wide character system interfaces",
1931 "-c check syntax only (runs BEGIN and END blocks)",
1932 "-d[:debugger] run program under debugger",
1933 "-D[number/list] set debugging flags (argument is a bit mask or alphabets)",
1934 "-e 'command' one line of program (several -e's allowed, omit programfile)",
1935 "-F/pattern/ split() pattern for -a switch (//'s are optional)",
1936 "-i[extension] edit <> files in place (makes backup if extension supplied)",
1937 "-Idirectory specify @INC/#include directory (several -I's allowed)",
1938 "-l[octal] enable line ending processing, specifies line terminator",
1939 "-[mM][-]module execute `use/no module...' before executing program",
1940 "-n assume 'while (<>) { ... }' loop around program",
1941 "-p assume loop like -n but print line also, like sed",
1942 "-P run program through C preprocessor before compilation",
1943 "-s enable rudimentary parsing for switches after programfile",
1944 "-S look for programfile using PATH environment variable",
1945 "-T enable tainting checks",
1946 "-u dump core after parsing program",
1947 "-U allow unsafe operations",
1948 "-v print version, subversion (includes VERY IMPORTANT perl info)",
1949 "-V[:variable] print configuration summary (or a single Config.pm variable)",
1950 "-w enable many useful warnings (RECOMMENDED)",
1951 "-W enable all warnings",
1952 "-X disable all warnings",
1953 "-x[directory] strip off text before #!perl line and perhaps cd to directory",
1957 char **p = usage_msg;
1959 printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1961 printf("\n %s", *p++);
1964 /* This routine handles any switches that can be given during run */
1967 Perl_moreswitches(pTHX_ char *s)
1976 rschar = (U32)scan_oct(s, 4, &numlen);
1977 SvREFCNT_dec(PL_nrs);
1978 if (rschar & ~((U8)~0))
1979 PL_nrs = &PL_sv_undef;
1980 else if (!rschar && numlen >= 2)
1981 PL_nrs = newSVpvn("", 0);
1984 PL_nrs = newSVpvn(&ch, 1);
1989 PL_widesyscalls = TRUE;
1994 PL_splitstr = savepv(s + 1);
2008 if (*s == ':' || *s == '=') {
2009 my_setenv("PERL5DB", Perl_form(aTHX_ "use Devel::%s;", ++s));
2013 PL_perldb = PERLDB_ALL;
2021 if (isALPHA(s[1])) {
2022 static char debopts[] = "psltocPmfrxuLHXDS";
2025 for (s++; *s && (d = strchr(debopts,*s)); s++)
2026 PL_debug |= 1 << (d - debopts);
2029 PL_debug = atoi(s+1);
2030 for (s++; isDIGIT(*s); s++) ;
2032 PL_debug |= 0x80000000;
2035 if (ckWARN_d(WARN_DEBUGGING))
2036 Perl_warner(aTHX_ WARN_DEBUGGING,
2037 "Recompile perl with -DDEBUGGING to use -D switch\n");
2038 for (s++; isALNUM(*s); s++) ;
2044 usage(PL_origargv[0]);
2048 Safefree(PL_inplace);
2049 PL_inplace = savepv(s+1);
2051 for (s = PL_inplace; *s && !isSPACE(*s); s++) ;
2054 if (*s == '-') /* Additional switches on #! line. */
2058 case 'I': /* -I handled both here and in parse_perl() */
2061 while (*s && isSPACE(*s))
2066 /* ignore trailing spaces (possibly followed by other switches) */
2068 for (e = p; *e && !isSPACE(*e); e++) ;
2072 } while (*p && *p != '-');
2073 e = savepvn(s, e-s);
2074 incpush(e, TRUE, TRUE);
2081 Perl_croak(aTHX_ "No directory specified for -I");
2089 PL_ors = savepv("\n");
2091 *PL_ors = (char)scan_oct(s, 3 + (*s == '0'), &numlen);
2096 if (RsPARA(PL_nrs)) {
2101 PL_ors = SvPV(PL_nrs, PL_orslen);
2102 PL_ors = savepvn(PL_ors, PL_orslen);
2106 forbid_setid("-M"); /* XXX ? */
2109 forbid_setid("-m"); /* XXX ? */
2114 /* -M-foo == 'no foo' */
2115 if (*s == '-') { use = "no "; ++s; }
2116 sv = newSVpv(use,0);
2118 /* We allow -M'Module qw(Foo Bar)' */
2119 while(isALNUM(*s) || *s==':') ++s;
2121 sv_catpv(sv, start);
2122 if (*(start-1) == 'm') {
2124 Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
2125 sv_catpv( sv, " ()");
2128 sv_catpvn(sv, start, s-start);
2129 sv_catpv(sv, " split(/,/,q{");
2135 PL_preambleav = newAV();
2136 av_push(PL_preambleav, sv);
2139 Perl_croak(aTHX_ "No space allowed after -%c", *(s-1));
2151 PL_doswitches = TRUE;
2156 Perl_croak(aTHX_ "Too late for \"-T\" option");
2160 PL_do_undump = TRUE;
2168 printf(Perl_form(aTHX_ "\nThis is perl, v%vd built for %s",
2169 PL_patchlevel, ARCHNAME));
2170 #if defined(LOCAL_PATCH_COUNT)
2171 if (LOCAL_PATCH_COUNT > 0)
2172 printf("\n(with %d registered patch%s, see perl -V for more detail)",
2173 (int)LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : "");
2176 printf("\n\nCopyright 1987-2000, Larry Wall\n");
2178 printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
2181 printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
2182 printf("djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
2185 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
2186 "Version 5 port Copyright (c) 1994-1999, Andreas Kaiser, Ilya Zakharevich\n");
2189 printf("atariST series port, ++jrb bammi@cadence.com\n");
2192 printf("BeOS port Copyright Tom Spindler, 1997-1999\n");
2195 printf("MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-1999\n");
2198 printf("MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
2201 printf("Stratus VOS port by Paul_Green@stratus.com, 1997-1999\n");
2204 printf("VM/ESA port by Neale Ferguson, 1998-1999\n");
2207 printf("BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
2210 printf("MiNT port by Guido Flohr, 1997-1999\n");
2213 printf("EPOC port by Olaf Flebbe, 1999-2000\n");
2215 #ifdef BINARY_BUILD_NOTICE
2216 BINARY_BUILD_NOTICE;
2219 Perl may be copied only under the terms of either the Artistic License or the\n\
2220 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n\
2221 Complete documentation for Perl, including FAQ lists, should be found on\n\
2222 this system using `man perl' or `perldoc perl'. If you have access to the\n\
2223 Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
2226 if (! (PL_dowarn & G_WARN_ALL_MASK))
2227 PL_dowarn |= G_WARN_ON;
2231 PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
2232 PL_compiling.cop_warnings = WARN_ALL ;
2236 PL_dowarn = G_WARN_ALL_OFF;
2237 PL_compiling.cop_warnings = WARN_NONE ;
2242 if (s[1] == '-') /* Additional switches on #! line. */
2247 #if defined(WIN32) || !defined(PERL_STRICT_CR)
2253 #ifdef ALTERNATE_SHEBANG
2254 case 'S': /* OS/2 needs -S on "extproc" line. */
2262 Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
2267 /* compliments of Tom Christiansen */
2269 /* unexec() can be found in the Gnu emacs distribution */
2270 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
2273 Perl_my_unexec(pTHX)
2281 prog = newSVpv(BIN_EXP, 0);
2282 sv_catpv(prog, "/perl");
2283 file = newSVpv(PL_origfilename, 0);
2284 sv_catpv(file, ".perldump");
2286 unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
2287 /* unexec prints msg to stderr in case of failure */
2288 PerlProc_exit(status);
2291 # include <lib$routines.h>
2292 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
2294 ABORT(); /* for use with undump */
2299 /* initialize curinterp */
2304 #ifdef PERL_OBJECT /* XXX kludge */
2307 PL_chopset = " \n-"; \
2308 PL_copline = NOLINE; \
2309 PL_curcop = &PL_compiling;\
2310 PL_curcopdb = NULL; \
2312 PL_dumpindent = 4; \
2313 PL_laststatval = -1; \
2314 PL_laststype = OP_STAT; \
2315 PL_maxscream = -1; \
2316 PL_maxsysfd = MAXSYSFD; \
2317 PL_statname = Nullsv; \
2318 PL_tmps_floor = -1; \
2320 PL_op_mask = NULL; \
2321 PL_laststatval = -1; \
2322 PL_laststype = OP_STAT; \
2323 PL_mess_sv = Nullsv; \
2324 PL_splitstr = " "; \
2325 PL_generation = 100; \
2326 PL_exitlist = NULL; \
2327 PL_exitlistlen = 0; \
2329 PL_in_clean_objs = FALSE; \
2330 PL_in_clean_all = FALSE; \
2331 PL_profiledata = NULL; \
2333 PL_rsfp_filters = Nullav; \
2338 # ifdef MULTIPLICITY
2339 # define PERLVAR(var,type)
2340 # define PERLVARA(var,n,type)
2341 # if defined(PERL_IMPLICIT_CONTEXT)
2342 # if defined(USE_THREADS)
2343 # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
2344 # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
2345 # else /* !USE_THREADS */
2346 # define PERLVARI(var,type,init) aTHX->var = init;
2347 # define PERLVARIC(var,type,init) aTHX->var = init;
2348 # endif /* USE_THREADS */
2350 # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
2351 # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
2353 # include "intrpvar.h"
2354 # ifndef USE_THREADS
2355 # include "thrdvar.h"
2362 # define PERLVAR(var,type)
2363 # define PERLVARA(var,n,type)
2364 # define PERLVARI(var,type,init) PL_##var = init;
2365 # define PERLVARIC(var,type,init) PL_##var = init;
2366 # include "intrpvar.h"
2367 # ifndef USE_THREADS
2368 # include "thrdvar.h"
2380 S_init_main_stash(pTHX)
2385 /* Note that strtab is a rather special HV. Assumptions are made
2386 about not iterating on it, and not adding tie magic to it.
2387 It is properly deallocated in perl_destruct() */
2388 PL_strtab = newHV();
2390 MUTEX_INIT(&PL_strtab_mutex);
2392 HvSHAREKEYS_off(PL_strtab); /* mandatory */
2393 hv_ksplit(PL_strtab, 512);
2395 PL_curstash = PL_defstash = newHV();
2396 PL_curstname = newSVpvn("main",4);
2397 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
2398 SvREFCNT_dec(GvHV(gv));
2399 GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
2401 HvNAME(PL_defstash) = savepv("main");
2402 PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
2403 GvMULTI_on(PL_incgv);
2404 PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
2405 GvMULTI_on(PL_hintgv);
2406 PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
2407 PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
2408 GvMULTI_on(PL_errgv);
2409 PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
2410 GvMULTI_on(PL_replgv);
2411 (void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */
2412 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
2413 sv_setpvn(ERRSV, "", 0);
2414 PL_curstash = PL_defstash;
2415 CopSTASH_set(&PL_compiling, PL_defstash);
2416 PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
2417 PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
2418 /* We must init $/ before switches are processed. */
2419 sv_setpvn(get_sv("/", TRUE), "\n", 1);
2423 S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
2430 PL_origfilename = savepv("-e");
2433 /* if find_script() returns, it returns a malloc()-ed value */
2434 PL_origfilename = scriptname = find_script(scriptname, dosearch, NULL, 1);
2436 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
2437 char *s = scriptname + 8;
2438 *fdscript = atoi(s);
2442 scriptname = savepv(s + 1);
2443 Safefree(PL_origfilename);
2444 PL_origfilename = scriptname;
2449 CopFILE_set(PL_curcop, PL_origfilename);
2450 if (strEQ(PL_origfilename,"-"))
2452 if (*fdscript >= 0) {
2453 PL_rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE);
2454 #if defined(HAS_FCNTL) && defined(F_SETFD)
2456 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); /* ensure close-on-exec */
2459 else if (PL_preprocess) {
2460 char *cpp_cfg = CPPSTDIN;
2461 SV *cpp = newSVpvn("",0);
2462 SV *cmd = NEWSV(0,0);
2464 if (strEQ(cpp_cfg, "cppstdin"))
2465 Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
2466 sv_catpv(cpp, cpp_cfg);
2468 sv_catpvn(sv, "-I", 2);
2469 sv_catpv(sv,PRIVLIB_EXP);
2472 Perl_sv_setpvf(aTHX_ cmd, "\
2473 sed %s -e \"/^[^#]/b\" \
2474 -e \"/^#[ ]*include[ ]/b\" \
2475 -e \"/^#[ ]*define[ ]/b\" \
2476 -e \"/^#[ ]*if[ ]/b\" \
2477 -e \"/^#[ ]*ifdef[ ]/b\" \
2478 -e \"/^#[ ]*ifndef[ ]/b\" \
2479 -e \"/^#[ ]*else/b\" \
2480 -e \"/^#[ ]*elif[ ]/b\" \
2481 -e \"/^#[ ]*undef[ ]/b\" \
2482 -e \"/^#[ ]*endif/b\" \
2484 %s | %"SVf" -C %"SVf" %s",
2485 (PL_doextract ? "-e \"1,/^#/d\n\"" : ""),
2488 Perl_sv_setpvf(aTHX_ cmd, "\
2489 %s %s -e '/^[^#]/b' \
2490 -e '/^#[ ]*include[ ]/b' \
2491 -e '/^#[ ]*define[ ]/b' \
2492 -e '/^#[ ]*if[ ]/b' \
2493 -e '/^#[ ]*ifdef[ ]/b' \
2494 -e '/^#[ ]*ifndef[ ]/b' \
2495 -e '/^#[ ]*else/b' \
2496 -e '/^#[ ]*elif[ ]/b' \
2497 -e '/^#[ ]*undef[ ]/b' \
2498 -e '/^#[ ]*endif/b' \
2500 %s | %"SVf" %"SVf" %s",
2502 Perl_sv_setpvf(aTHX_ cmd, "\
2503 %s %s -e '/^[^#]/b' \
2504 -e '/^#[ ]*include[ ]/b' \
2505 -e '/^#[ ]*define[ ]/b' \
2506 -e '/^#[ ]*if[ ]/b' \
2507 -e '/^#[ ]*ifdef[ ]/b' \
2508 -e '/^#[ ]*ifndef[ ]/b' \
2509 -e '/^#[ ]*else/b' \
2510 -e '/^#[ ]*elif[ ]/b' \
2511 -e '/^#[ ]*undef[ ]/b' \
2512 -e '/^#[ ]*endif/b' \
2514 %s | %"SVf" -C %"SVf" %s",
2521 (PL_doextract ? "-e '1,/^#/d\n'" : ""),
2523 scriptname, cpp, sv, CPPMINUS);
2524 PL_doextract = FALSE;
2525 #ifdef IAMSUID /* actually, this is caught earlier */
2526 if (PL_euid != PL_uid && !PL_euid) { /* if running suidperl */
2528 (void)seteuid(PL_uid); /* musn't stay setuid root */
2531 (void)setreuid((Uid_t)-1, PL_uid);
2533 #ifdef HAS_SETRESUID
2534 (void)setresuid((Uid_t)-1, PL_uid, (Uid_t)-1);
2536 PerlProc_setuid(PL_uid);
2540 if (PerlProc_geteuid() != PL_uid)
2541 Perl_croak(aTHX_ "Can't do seteuid!\n");
2543 #endif /* IAMSUID */
2544 PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
2548 else if (!*scriptname) {
2549 forbid_setid("program input from stdin");
2550 PL_rsfp = PerlIO_stdin();
2553 PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
2554 #if defined(HAS_FCNTL) && defined(F_SETFD)
2556 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); /* ensure close-on-exec */
2561 #ifndef IAMSUID /* in case script is not readable before setuid */
2563 PerlLIO_stat(CopFILE(PL_curcop),&PL_statbuf) >= 0 &&
2564 PL_statbuf.st_mode & (S_ISUID|S_ISGID))
2567 PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
2568 (int)PERL_REVISION, (int)PERL_VERSION,
2569 (int)PERL_SUBVERSION), PL_origargv);
2570 Perl_croak(aTHX_ "Can't do setuid\n");
2574 Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
2575 CopFILE(PL_curcop), Strerror(errno));
2580 * I_SYSSTATVFS HAS_FSTATVFS
2582 * I_STATFS HAS_FSTATFS HAS_GETFSSTAT
2583 * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT
2584 * here so that metaconfig picks them up. */
2588 S_fd_on_nosuid_fs(pTHX_ int fd)
2590 int check_okay = 0; /* able to do all the required sys/libcalls */
2591 int on_nosuid = 0; /* the fd is on a nosuid fs */
2593 * Preferred order: fstatvfs(), fstatfs(), ustat()+getmnt(), getmntent().
2594 * fstatvfs() is UNIX98.
2595 * fstatfs() is 4.3 BSD.
2596 * ustat()+getmnt() is pre-4.3 BSD.
2597 * getmntent() is O(number-of-mounted-filesystems) and can hang on
2598 * an irrelevant filesystem while trying to reach the right one.
2601 # ifdef HAS_FSTATVFS
2602 struct statvfs stfs;
2603 check_okay = fstatvfs(fd, &stfs) == 0;
2604 on_nosuid = check_okay && (stfs.f_flag & ST_NOSUID);
2606 # ifdef PERL_MOUNT_NOSUID
2607 # if defined(HAS_FSTATFS) && \
2608 defined(HAS_STRUCT_STATFS) && \
2609 defined(HAS_STRUCT_STATFS_F_FLAGS)
2611 check_okay = fstatfs(fd, &stfs) == 0;
2612 on_nosuid = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
2614 # if defined(HAS_FSTAT) && \
2615 defined(HAS_USTAT) && \
2616 defined(HAS_GETMNT) && \
2617 defined(HAS_STRUCT_FS_DATA) && \
2620 if (fstat(fd, &fdst) == 0) {
2622 if (ustat(fdst.st_dev, &us) == 0) {
2624 /* NOSTAT_ONE here because we're not examining fields which
2625 * vary between that case and STAT_ONE. */
2626 if (getmnt((int*)0, &fsd, (int)0, NOSTAT_ONE, us.f_fname) == 0) {
2627 size_t cmplen = sizeof(us.f_fname);
2628 if (sizeof(fsd.fd_req.path) < cmplen)
2629 cmplen = sizeof(fsd.fd_req.path);
2630 if (strnEQ(fsd.fd_req.path, us.f_fname, cmplen) &&
2631 fdst.st_dev == fsd.fd_req.dev) {
2633 on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID;
2639 # endif /* fstat+ustat+getmnt */
2640 # endif /* fstatfs */
2642 # if defined(HAS_GETMNTENT) && \
2643 defined(HAS_HASMNTOPT) && \
2644 defined(MNTOPT_NOSUID)
2645 FILE *mtab = fopen("/etc/mtab", "r");
2646 struct mntent *entry;
2647 struct stat stb, fsb;
2649 if (mtab && (fstat(fd, &stb) == 0)) {
2650 while (entry = getmntent(mtab)) {
2651 if (stat(entry->mnt_dir, &fsb) == 0
2652 && fsb.st_dev == stb.st_dev)
2654 /* found the filesystem */
2656 if (hasmntopt(entry, MNTOPT_NOSUID))
2659 } /* A single fs may well fail its stat(). */
2664 # endif /* getmntent+hasmntopt */
2665 # endif /* PERL_MOUNT_NOSUID: fstatfs or fstat+ustat+statfs */
2666 # endif /* statvfs */
2669 Perl_croak(aTHX_ "Can't check filesystem of script \"%s\" for nosuid", PL_origfilename);
2672 #endif /* IAMSUID */
2675 S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript)
2681 /* do we need to emulate setuid on scripts? */
2683 /* This code is for those BSD systems that have setuid #! scripts disabled
2684 * in the kernel because of a security problem. Merely defining DOSUID
2685 * in perl will not fix that problem, but if you have disabled setuid
2686 * scripts in the kernel, this will attempt to emulate setuid and setgid
2687 * on scripts that have those now-otherwise-useless bits set. The setuid
2688 * root version must be called suidperl or sperlN.NNN. If regular perl
2689 * discovers that it has opened a setuid script, it calls suidperl with
2690 * the same argv that it had. If suidperl finds that the script it has
2691 * just opened is NOT setuid root, it sets the effective uid back to the
2692 * uid. We don't just make perl setuid root because that loses the
2693 * effective uid we had before invoking perl, if it was different from the
2696 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
2697 * be defined in suidperl only. suidperl must be setuid root. The
2698 * Configure script will set this up for you if you want it.
2705 if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */
2706 Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
2707 if (fdscript < 0 && PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
2712 #ifndef HAS_SETREUID
2713 /* On this access check to make sure the directories are readable,
2714 * there is actually a small window that the user could use to make
2715 * filename point to an accessible directory. So there is a faint
2716 * chance that someone could execute a setuid script down in a
2717 * non-accessible directory. I don't know what to do about that.
2718 * But I don't think it's too important. The manual lies when
2719 * it says access() is useful in setuid programs.
2721 if (PerlLIO_access(CopFILE(PL_curcop),1)) /*double check*/
2722 Perl_croak(aTHX_ "Permission denied");
2724 /* If we can swap euid and uid, then we can determine access rights
2725 * with a simple stat of the file, and then compare device and
2726 * inode to make sure we did stat() on the same file we opened.
2727 * Then we just have to make sure he or she can execute it.
2730 struct stat tmpstatbuf;
2734 setreuid(PL_euid,PL_uid) < 0
2737 setresuid(PL_euid,PL_uid,(Uid_t)-1) < 0
2740 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
2741 Perl_croak(aTHX_ "Can't swap uid and euid"); /* really paranoid */
2742 if (PerlLIO_stat(CopFILE(PL_curcop),&tmpstatbuf) < 0)
2743 Perl_croak(aTHX_ "Permission denied"); /* testing full pathname here */
2744 #if defined(IAMSUID) && !defined(NO_NOSUID_CHECK)
2745 if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp)))
2746 Perl_croak(aTHX_ "Permission denied");
2748 if (tmpstatbuf.st_dev != PL_statbuf.st_dev ||
2749 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
2750 (void)PerlIO_close(PL_rsfp);
2751 if (PL_rsfp = PerlProc_popen("/bin/mail root","w")) { /* heh, heh */
2752 PerlIO_printf(PL_rsfp,
2753 "User %"Uid_t_f" tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2754 (Filename of set-id script was %s, uid %"Uid_t_f" gid %"Gid_t_f".)\n\nSincerely,\nperl\n",
2755 PL_uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
2756 (long)PL_statbuf.st_dev, (long)PL_statbuf.st_ino,
2758 PL_statbuf.st_uid, PL_statbuf.st_gid);
2759 (void)PerlProc_pclose(PL_rsfp);
2761 Perl_croak(aTHX_ "Permission denied\n");
2765 setreuid(PL_uid,PL_euid) < 0
2767 # if defined(HAS_SETRESUID)
2768 setresuid(PL_uid,PL_euid,(Uid_t)-1) < 0
2771 || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
2772 Perl_croak(aTHX_ "Can't reswap uid and euid");
2773 if (!cando(S_IXUSR,FALSE,&PL_statbuf)) /* can real uid exec? */
2774 Perl_croak(aTHX_ "Permission denied\n");
2776 #endif /* HAS_SETREUID */
2777 #endif /* IAMSUID */
2779 if (!S_ISREG(PL_statbuf.st_mode))
2780 Perl_croak(aTHX_ "Permission denied");
2781 if (PL_statbuf.st_mode & S_IWOTH)
2782 Perl_croak(aTHX_ "Setuid/gid script is writable by world");
2783 PL_doswitches = FALSE; /* -s is insecure in suid */
2784 CopLINE_inc(PL_curcop);
2785 if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
2786 strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */
2787 Perl_croak(aTHX_ "No #! line");
2788 s = SvPV(PL_linestr,n_a)+2;
2790 while (!isSPACE(*s)) s++;
2791 for (s2 = s; (s2 > SvPV(PL_linestr,n_a)+2 &&
2792 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
2793 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
2794 Perl_croak(aTHX_ "Not a perl script");
2795 while (*s == ' ' || *s == '\t') s++;
2797 * #! arg must be what we saw above. They can invoke it by
2798 * mentioning suidperl explicitly, but they may not add any strange
2799 * arguments beyond what #! says if they do invoke suidperl that way.
2801 len = strlen(validarg);
2802 if (strEQ(validarg," PHOOEY ") ||
2803 strnNE(s,validarg,len) || !isSPACE(s[len]))
2804 Perl_croak(aTHX_ "Args must match #! line");
2807 if (PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
2808 PL_euid == PL_statbuf.st_uid)
2810 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2811 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2812 #endif /* IAMSUID */
2814 if (PL_euid) { /* oops, we're not the setuid root perl */
2815 (void)PerlIO_close(PL_rsfp);
2818 PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
2819 (int)PERL_REVISION, (int)PERL_VERSION,
2820 (int)PERL_SUBVERSION), PL_origargv);
2822 Perl_croak(aTHX_ "Can't do setuid\n");
2825 if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
2827 (void)setegid(PL_statbuf.st_gid);
2830 (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
2832 #ifdef HAS_SETRESGID
2833 (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
2835 PerlProc_setgid(PL_statbuf.st_gid);
2839 if (PerlProc_getegid() != PL_statbuf.st_gid)
2840 Perl_croak(aTHX_ "Can't do setegid!\n");
2842 if (PL_statbuf.st_mode & S_ISUID) {
2843 if (PL_statbuf.st_uid != PL_euid)
2845 (void)seteuid(PL_statbuf.st_uid); /* all that for this */
2848 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
2850 #ifdef HAS_SETRESUID
2851 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
2853 PerlProc_setuid(PL_statbuf.st_uid);
2857 if (PerlProc_geteuid() != PL_statbuf.st_uid)
2858 Perl_croak(aTHX_ "Can't do seteuid!\n");
2860 else if (PL_uid) { /* oops, mustn't run as root */
2862 (void)seteuid((Uid_t)PL_uid);
2865 (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
2867 #ifdef HAS_SETRESUID
2868 (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
2870 PerlProc_setuid((Uid_t)PL_uid);
2874 if (PerlProc_geteuid() != PL_uid)
2875 Perl_croak(aTHX_ "Can't do seteuid!\n");
2878 if (!cando(S_IXUSR,TRUE,&PL_statbuf))
2879 Perl_croak(aTHX_ "Permission denied\n"); /* they can't do this */
2882 else if (PL_preprocess)
2883 Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
2884 else if (fdscript >= 0)
2885 Perl_croak(aTHX_ "fd script not allowed in suidperl\n");
2887 Perl_croak(aTHX_ "Script is not setuid/setgid in suidperl\n");
2889 /* We absolutely must clear out any saved ids here, so we */
2890 /* exec the real perl, substituting fd script for scriptname. */
2891 /* (We pass script name as "subdir" of fd, which perl will grok.) */
2892 PerlIO_rewind(PL_rsfp);
2893 PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0); /* just in case rewind didn't */
2894 for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
2895 if (!PL_origargv[which])
2896 Perl_croak(aTHX_ "Permission denied");
2897 PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
2898 PerlIO_fileno(PL_rsfp), PL_origargv[which]));
2899 #if defined(HAS_FCNTL) && defined(F_SETFD)
2900 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */
2902 PerlProc_execv(Perl_form(aTHX_ "%s/perl"PERL_FS_VER_FMT, BIN_EXP,
2903 (int)PERL_REVISION, (int)PERL_VERSION,
2904 (int)PERL_SUBVERSION), PL_origargv);/* try again */
2905 Perl_croak(aTHX_ "Can't do setuid\n");
2906 #endif /* IAMSUID */
2908 if (PL_euid != PL_uid || PL_egid != PL_gid) { /* (suidperl doesn't exist, in fact) */
2909 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2911 PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf); /* may be either wrapped or real suid */
2912 if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
2914 (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
2917 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2918 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2919 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2920 /* not set-id, must be wrapped */
2926 S_find_beginning(pTHX)
2928 register char *s, *s2;
2930 /* skip forward in input to the real script? */
2933 while (PL_doextract) {
2934 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
2935 Perl_croak(aTHX_ "No Perl script found in input\n");
2936 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2937 PerlIO_ungetc(PL_rsfp, '\n'); /* to keep line count right */
2938 PL_doextract = FALSE;
2939 while (*s && !(isSPACE (*s) || *s == '#')) s++;
2941 while (*s == ' ' || *s == '\t') s++;
2943 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2944 if (strnEQ(s2-4,"perl",4))
2946 while ((s = moreswitches(s)))
2957 PL_uid = PerlProc_getuid();
2958 PL_euid = PerlProc_geteuid();
2959 PL_gid = PerlProc_getgid();
2960 PL_egid = PerlProc_getegid();
2962 PL_uid |= PL_gid << 16;
2963 PL_euid |= PL_egid << 16;
2965 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2969 S_forbid_setid(pTHX_ char *s)
2971 if (PL_euid != PL_uid)
2972 Perl_croak(aTHX_ "No %s allowed while running setuid", s);
2973 if (PL_egid != PL_gid)
2974 Perl_croak(aTHX_ "No %s allowed while running setgid", s);
2978 Perl_init_debugger(pTHX)
2981 HV *ostash = PL_curstash;
2983 PL_curstash = PL_debstash;
2984 PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2985 AvREAL_off(PL_dbargs);
2986 PL_DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2987 PL_DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2988 PL_DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2989 sv_upgrade(GvSV(PL_DBsub), SVt_IV); /* IVX accessed if PERLDB_SUB_NN */
2990 PL_DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2991 sv_setiv(PL_DBsingle, 0);
2992 PL_DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2993 sv_setiv(PL_DBtrace, 0);
2994 PL_DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2995 sv_setiv(PL_DBsignal, 0);
2996 PL_curstash = ostash;
2999 #ifndef STRESS_REALLOC
3000 #define REASONABLE(size) (size)
3002 #define REASONABLE(size) (1) /* unreasonable */
3006 Perl_init_stacks(pTHX)
3008 /* start with 128-item stack and 8K cxstack */
3009 PL_curstackinfo = new_stackinfo(REASONABLE(128),
3010 REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
3011 PL_curstackinfo->si_type = PERLSI_MAIN;
3012 PL_curstack = PL_curstackinfo->si_stack;
3013 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
3015 PL_stack_base = AvARRAY(PL_curstack);
3016 PL_stack_sp = PL_stack_base;
3017 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
3019 New(50,PL_tmps_stack,REASONABLE(128),SV*);
3022 PL_tmps_max = REASONABLE(128);
3024 New(54,PL_markstack,REASONABLE(32),I32);
3025 PL_markstack_ptr = PL_markstack;
3026 PL_markstack_max = PL_markstack + REASONABLE(32);
3030 New(54,PL_scopestack,REASONABLE(32),I32);
3031 PL_scopestack_ix = 0;
3032 PL_scopestack_max = REASONABLE(32);
3034 New(54,PL_savestack,REASONABLE(128),ANY);
3035 PL_savestack_ix = 0;
3036 PL_savestack_max = REASONABLE(128);
3038 New(54,PL_retstack,REASONABLE(16),OP*);
3040 PL_retstack_max = REASONABLE(16);
3049 while (PL_curstackinfo->si_next)
3050 PL_curstackinfo = PL_curstackinfo->si_next;
3051 while (PL_curstackinfo) {
3052 PERL_SI *p = PL_curstackinfo->si_prev;
3053 /* curstackinfo->si_stack got nuked by sv_free_arenas() */
3054 Safefree(PL_curstackinfo->si_cxstack);
3055 Safefree(PL_curstackinfo);
3056 PL_curstackinfo = p;
3058 Safefree(PL_tmps_stack);
3059 Safefree(PL_markstack);
3060 Safefree(PL_scopestack);
3061 Safefree(PL_savestack);
3062 Safefree(PL_retstack);
3066 static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
3077 lex_start(PL_linestr);
3079 PL_subname = newSVpvn("main",4);
3083 S_init_predump_symbols(pTHX)
3089 sv_setpvn(get_sv("\"", TRUE), " ", 1);
3090 PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
3091 GvMULTI_on(PL_stdingv);
3092 io = GvIOp(PL_stdingv);
3093 IoIFP(io) = PerlIO_stdin();
3094 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
3096 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
3098 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
3101 IoOFP(io) = IoIFP(io) = PerlIO_stdout();
3103 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
3105 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
3107 PL_stderrgv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
3108 GvMULTI_on(PL_stderrgv);
3109 io = GvIOp(PL_stderrgv);
3110 IoOFP(io) = IoIFP(io) = PerlIO_stderr();
3111 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
3113 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
3115 PL_statname = NEWSV(66,0); /* last filename we did stat on */
3118 PL_osname = savepv(OSNAME);
3122 S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
3129 argc--,argv++; /* skip name of script */
3130 if (PL_doswitches) {
3131 for (; argc > 0 && **argv == '-'; argc--,argv++) {
3134 if (argv[0][1] == '-' && !argv[0][2]) {
3138 if ((s = strchr(argv[0], '='))) {
3140 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
3143 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
3146 PL_toptarget = NEWSV(0,0);
3147 sv_upgrade(PL_toptarget, SVt_PVFM);
3148 sv_setpvn(PL_toptarget, "", 0);
3149 PL_bodytarget = NEWSV(0,0);
3150 sv_upgrade(PL_bodytarget, SVt_PVFM);
3151 sv_setpvn(PL_bodytarget, "", 0);
3152 PL_formtarget = PL_bodytarget;
3155 if ((tmpgv = gv_fetchpv("0",TRUE, SVt_PV))) {
3156 sv_setpv(GvSV(tmpgv),PL_origfilename);
3157 magicname("0", "0", 1);
3159 if ((tmpgv = gv_fetchpv("\030",TRUE, SVt_PV)))
3161 sv_setpv(GvSV(tmpgv), os2_execname());
3163 sv_setpv(GvSV(tmpgv),PL_origargv[0]);
3165 if ((PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV))) {
3166 GvMULTI_on(PL_argvgv);
3167 (void)gv_AVadd(PL_argvgv);
3168 av_clear(GvAVn(PL_argvgv));
3169 for (; argc > 0; argc--,argv++) {
3170 SV *sv = newSVpv(argv[0],0);
3171 av_push(GvAVn(PL_argvgv),sv);
3172 if (PL_widesyscalls)
3173 sv_utf8_upgrade(sv);
3176 if ((PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV))) {
3178 GvMULTI_on(PL_envgv);
3179 hv = GvHVn(PL_envgv);
3180 hv_magic(hv, PL_envgv, 'E');
3181 #if !defined( VMS) && !defined(EPOC) /* VMS doesn't have environ array */
3182 /* Note that if the supplied env parameter is actually a copy
3183 of the global environ then it may now point to free'd memory
3184 if the environment has been modified since. To avoid this
3185 problem we treat env==NULL as meaning 'use the default'
3190 environ[0] = Nullch;
3191 for (; *env; env++) {
3192 if (!(s = strchr(*env,'=')))
3198 sv = newSVpv(s--,0);
3199 (void)hv_store(hv, *env, s - *env, sv, 0);
3201 #if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
3202 /* Sins of the RTL. See note in my_setenv(). */
3203 (void)PerlEnv_putenv(savepv(*env));
3207 #ifdef DYNAMIC_ENV_FETCH
3208 HvNAME(hv) = savepv(ENV_HV_NAME);
3212 if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV)))
3213 sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
3217 S_init_perllib(pTHX)
3222 s = PerlEnv_getenv("PERL5LIB");
3224 incpush(s, TRUE, TRUE);
3226 incpush(PerlEnv_getenv("PERLLIB"), FALSE, FALSE);
3228 /* Treat PERL5?LIB as a possible search list logical name -- the
3229 * "natural" VMS idiom for a Unix path string. We allow each
3230 * element to be a set of |-separated directories for compatibility.
3234 if (my_trnlnm("PERL5LIB",buf,0))
3235 do { incpush(buf,TRUE,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
3237 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE,FALSE);
3241 /* Use the ~-expanded versions of APPLLIB (undocumented),
3242 ARCHLIB PRIVLIB SITEARCH SITELIB VENDORARCH and VENDORLIB
3245 incpush(APPLLIB_EXP, TRUE, TRUE);
3249 incpush(ARCHLIB_EXP, FALSE, FALSE);
3252 # define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
3255 incpush(PRIVLIB_EXP, TRUE, FALSE);
3257 incpush(PRIVLIB_EXP, FALSE, FALSE);
3261 /* sitearch is always relative to sitelib on Windows for
3262 * DLL-based path intuition to work correctly */
3263 # if !defined(WIN32)
3264 incpush(SITEARCH_EXP, FALSE, FALSE);
3270 incpush(SITELIB_EXP, TRUE, FALSE); /* this picks up sitearch as well */
3272 incpush(SITELIB_EXP, FALSE, FALSE);
3276 #ifdef SITELIB_STEM /* Search for version-specific dirs below here */
3277 incpush(SITELIB_STEM, FALSE, TRUE);
3280 #ifdef PERL_VENDORARCH_EXP
3281 /* vendorarch is always relative to vendorlib on Windows for
3282 * DLL-based path intuition to work correctly */
3283 # if !defined(WIN32)
3284 incpush(PERL_VENDORARCH_EXP, FALSE, FALSE);
3288 #ifdef PERL_VENDORLIB_EXP
3290 incpush(PERL_VENDORLIB_EXP, TRUE, FALSE); /* this picks up vendorarch as well */
3292 incpush(PERL_VENDORLIB_EXP, FALSE, FALSE);
3296 #ifdef PERL_VENDORLIB_STEM /* Search for version-specific dirs below here */
3297 incpush(PERL_VENDORLIB_STEM, FALSE, TRUE);
3301 incpush(".", FALSE, FALSE);
3305 # define PERLLIB_SEP ';'
3308 # define PERLLIB_SEP '|'
3310 # define PERLLIB_SEP ':'
3313 #ifndef PERLLIB_MANGLE
3314 # define PERLLIB_MANGLE(s,n) (s)
3318 S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers)
3320 SV *subdir = Nullsv;
3325 if (addsubdirs || addoldvers) {
3326 subdir = sv_newmortal();
3329 /* Break at all separators */
3331 SV *libdir = NEWSV(55,0);
3334 /* skip any consecutive separators */
3335 while ( *p == PERLLIB_SEP ) {
3336 /* Uncomment the next line for PATH semantics */
3337 /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */
3341 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
3342 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
3347 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
3348 p = Nullch; /* break out */
3352 * BEFORE pushing libdir onto @INC we may first push version- and
3353 * archname-specific sub-directories.
3355 if (addsubdirs || addoldvers) {
3356 #ifdef PERL_INC_VERSION_LIST
3357 /* Configure terminates PERL_INC_VERSION_LIST with a NULL */
3358 const char *incverlist[] = { PERL_INC_VERSION_LIST };
3359 const char **incver;
3361 struct stat tmpstatbuf;
3366 if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) {
3368 while (unix[len-1] == '/') len--; /* Cosmetic */
3369 sv_usepvn(libdir,unix,len);
3372 PerlIO_printf(Perl_error_log,
3373 "Failed to unixify @INC element \"%s\"\n",
3377 /* .../version/archname if -d .../version/archname */
3378 Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/"PERL_FS_VER_FMT"/%s",
3380 (int)PERL_REVISION, (int)PERL_VERSION,
3381 (int)PERL_SUBVERSION, ARCHNAME);
3382 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3383 S_ISDIR(tmpstatbuf.st_mode))
3384 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3386 /* .../version if -d .../version */
3387 Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/"PERL_FS_VER_FMT, libdir,
3388 (int)PERL_REVISION, (int)PERL_VERSION,
3389 (int)PERL_SUBVERSION);
3390 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3391 S_ISDIR(tmpstatbuf.st_mode))
3392 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3394 /* .../archname if -d .../archname */
3395 Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/%s", libdir, ARCHNAME);
3396 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3397 S_ISDIR(tmpstatbuf.st_mode))
3398 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3402 #ifdef PERL_INC_VERSION_LIST
3403 for (incver = incverlist; *incver; incver++) {
3404 /* .../xxx if -d .../xxx */
3405 Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/%s", libdir, *incver);
3406 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3407 S_ISDIR(tmpstatbuf.st_mode))
3408 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3414 /* finally push this lib directory on the end of @INC */
3415 av_push(GvAVn(PL_incgv), libdir);
3420 STATIC struct perl_thread *
3421 S_init_main_thread(pTHX)
3423 #if !defined(PERL_IMPLICIT_CONTEXT)
3424 struct perl_thread *thr;
3428 Newz(53, thr, 1, struct perl_thread);
3429 PL_curcop = &PL_compiling;
3430 thr->interp = PERL_GET_INTERP;
3431 thr->cvcache = newHV();
3432 thr->threadsv = newAV();
3433 /* thr->threadsvp is set when find_threadsv is called */
3434 thr->specific = newAV();
3435 thr->flags = THRf_R_JOINABLE;
3436 MUTEX_INIT(&thr->mutex);
3437 /* Handcraft thrsv similarly to mess_sv */
3438 New(53, PL_thrsv, 1, SV);
3439 Newz(53, xpv, 1, XPV);
3440 SvFLAGS(PL_thrsv) = SVt_PV;
3441 SvANY(PL_thrsv) = (void*)xpv;
3442 SvREFCNT(PL_thrsv) = 1 << 30; /* practically infinite */
3443 SvPVX(PL_thrsv) = (char*)thr;
3444 SvCUR_set(PL_thrsv, sizeof(thr));
3445 SvLEN_set(PL_thrsv, sizeof(thr));
3446 *SvEND(PL_thrsv) = '\0'; /* in the trailing_nul field */
3447 thr->oursv = PL_thrsv;
3448 PL_chopset = " \n-";
3451 MUTEX_LOCK(&PL_threads_mutex);
3456 MUTEX_UNLOCK(&PL_threads_mutex);
3458 #ifdef HAVE_THREAD_INTERN
3459 Perl_init_thread_intern(thr);
3462 #ifdef SET_THREAD_SELF
3463 SET_THREAD_SELF(thr);
3465 thr->self = pthread_self();
3466 #endif /* SET_THREAD_SELF */
3470 * These must come after the SET_THR because sv_setpvn does
3471 * SvTAINT and the taint fields require dTHR.
3473 PL_toptarget = NEWSV(0,0);
3474 sv_upgrade(PL_toptarget, SVt_PVFM);
3475 sv_setpvn(PL_toptarget, "", 0);
3476 PL_bodytarget = NEWSV(0,0);
3477 sv_upgrade(PL_bodytarget, SVt_PVFM);
3478 sv_setpvn(PL_bodytarget, "", 0);
3479 PL_formtarget = PL_bodytarget;
3480 thr->errsv = newSVpvn("", 0);
3481 (void) find_threadsv("@"); /* Ensure $@ is initialised early */
3484 PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
3485 PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
3486 PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
3487 PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
3488 PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
3490 PL_reginterp_cnt = 0;
3494 #endif /* USE_THREADS */
3497 Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
3501 line_t oldline = CopLINE(PL_curcop);
3507 while (AvFILL(paramList) >= 0) {
3508 cv = (CV*)av_shift(paramList);
3510 #ifdef PERL_FLEXIBLE_EXCEPTIONS
3511 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_list_body), cv);
3517 #ifndef PERL_FLEXIBLE_EXCEPTIONS
3521 (void)SvPV(atsv, len);
3524 PL_curcop = &PL_compiling;
3525 CopLINE_set(PL_curcop, oldline);
3526 if (paramList == PL_beginav)
3527 sv_catpv(atsv, "BEGIN failed--compilation aborted");
3529 Perl_sv_catpvf(aTHX_ atsv,
3530 "%s failed--call queue aborted",
3531 paramList == PL_checkav ? "CHECK"
3532 : paramList == PL_initav ? "INIT"
3534 while (PL_scopestack_ix > oldscope)
3537 Perl_croak(aTHX_ "%s", SvPVx(atsv, n_a));
3544 /* my_exit() was called */
3545 while (PL_scopestack_ix > oldscope)
3548 PL_curstash = PL_defstash;
3549 PL_curcop = &PL_compiling;
3550 CopLINE_set(PL_curcop, oldline);
3552 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) {
3553 if (paramList == PL_beginav)
3554 Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
3556 Perl_croak(aTHX_ "%s failed--call queue aborted",
3557 paramList == PL_checkav ? "CHECK"
3558 : paramList == PL_initav ? "INIT"
3565 PL_curcop = &PL_compiling;
3566 CopLINE_set(PL_curcop, oldline);
3569 PerlIO_printf(Perl_error_log, "panic: restartop\n");
3577 #ifdef PERL_FLEXIBLE_EXCEPTIONS
3579 S_vcall_list_body(pTHX_ va_list args)
3581 CV *cv = va_arg(args, CV*);
3582 return call_list_body(cv);
3587 S_call_list_body(pTHX_ CV *cv)
3589 PUSHMARK(PL_stack_sp);
3590 call_sv((SV*)cv, G_EVAL|G_DISCARD);
3595 Perl_my_exit(pTHX_ U32 status)
3599 DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
3600 thr, (unsigned long) status));
3609 STATUS_NATIVE_SET(status);
3616 Perl_my_failure_exit(pTHX)
3619 if (vaxc$errno & 1) {
3620 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
3621 STATUS_NATIVE_SET(44);
3624 if (!vaxc$errno && errno) /* unlikely */
3625 STATUS_NATIVE_SET(44);
3627 STATUS_NATIVE_SET(vaxc$errno);
3632 STATUS_POSIX_SET(errno);
3634 exitstatus = STATUS_POSIX >> 8;
3635 if (exitstatus & 255)
3636 STATUS_POSIX_SET(exitstatus);
3638 STATUS_POSIX_SET(255);
3645 S_my_exit_jump(pTHX)
3648 register PERL_CONTEXT *cx;
3653 SvREFCNT_dec(PL_e_script);
3654 PL_e_script = Nullsv;
3657 POPSTACK_TO(PL_mainstack);
3658 if (cxstack_ix >= 0) {
3661 POPBLOCK(cx,PL_curpm);
3673 read_e_script(pTHXo_ int idx, SV *buf_sv, int maxlen)
3676 p = SvPVX(PL_e_script);
3677 nl = strchr(p, '\n');
3678 nl = (nl) ? nl+1 : SvEND(PL_e_script);
3680 filter_del(read_e_script);
3683 sv_catpvn(buf_sv, p, nl-p);
3684 sv_chop(PL_e_script, nl);