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 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 /* Prepare to destruct main symbol table. */
600 SvREFCNT_dec(PL_curstname);
601 PL_curstname = Nullsv;
603 /* clear queued errors */
604 SvREFCNT_dec(PL_errors);
608 if (destruct_level >= 2 && ckWARN_d(WARN_INTERNAL)) {
609 if (PL_scopestack_ix != 0)
610 Perl_warner(aTHX_ WARN_INTERNAL,
611 "Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
612 (long)PL_scopestack_ix);
613 if (PL_savestack_ix != 0)
614 Perl_warner(aTHX_ WARN_INTERNAL,
615 "Unbalanced saves: %ld more saves than restores\n",
616 (long)PL_savestack_ix);
617 if (PL_tmps_floor != -1)
618 Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced tmps: %ld more allocs than frees\n",
619 (long)PL_tmps_floor + 1);
620 if (cxstack_ix != -1)
621 Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced context: %ld more PUSHes than POPs\n",
622 (long)cxstack_ix + 1);
625 /* Now absolutely destruct everything, somehow or other, loops or no. */
627 SvFLAGS(PL_fdpid) |= SVTYPEMASK; /* don't clean out pid table now */
628 SvFLAGS(PL_strtab) |= SVTYPEMASK; /* don't clean out strtab now */
629 while (PL_sv_count != 0 && PL_sv_count != last_sv_count) {
630 last_sv_count = PL_sv_count;
633 SvFLAGS(PL_fdpid) &= ~SVTYPEMASK;
634 SvFLAGS(PL_fdpid) |= SVt_PVAV;
635 SvFLAGS(PL_strtab) &= ~SVTYPEMASK;
636 SvFLAGS(PL_strtab) |= SVt_PVHV;
638 AvREAL_off(PL_fdpid); /* no surviving entries */
639 SvREFCNT_dec(PL_fdpid); /* needed in io_close() */
642 /* Destruct the global string table. */
644 /* Yell and reset the HeVAL() slots that are still holding refcounts,
645 * so that sv_free() won't fail on them.
653 max = HvMAX(PL_strtab);
654 array = HvARRAY(PL_strtab);
657 if (hent && ckWARN_d(WARN_INTERNAL)) {
658 Perl_warner(aTHX_ WARN_INTERNAL,
659 "Unbalanced string table refcount: (%d) for \"%s\"",
660 HeVAL(hent) - Nullsv, HeKEY(hent));
661 HeVAL(hent) = Nullsv;
671 SvREFCNT_dec(PL_strtab);
673 /* free special SVs */
675 SvREFCNT(&PL_sv_yes) = 0;
676 sv_clear(&PL_sv_yes);
677 SvANY(&PL_sv_yes) = NULL;
679 SvREFCNT(&PL_sv_no) = 0;
681 SvANY(&PL_sv_no) = NULL;
683 if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL))
684 Perl_warner(aTHX_ WARN_INTERNAL,"Scalars leaked: %ld\n", (long)PL_sv_count);
688 /* No SVs have survived, need to clean out */
689 Safefree(PL_origfilename);
690 Safefree(PL_reg_start_tmp);
692 Safefree(PL_reg_curpm);
693 Safefree(PL_reg_poscache);
694 Safefree(HeKEY_hek(&PL_hv_fetch_ent_mh));
695 Safefree(PL_op_mask);
697 PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */
699 DEBUG_P(debprofdump());
701 MUTEX_DESTROY(&PL_strtab_mutex);
702 MUTEX_DESTROY(&PL_sv_mutex);
703 MUTEX_DESTROY(&PL_eval_mutex);
704 MUTEX_DESTROY(&PL_cred_mutex);
705 COND_DESTROY(&PL_eval_cond);
706 #ifdef EMULATE_ATOMIC_REFCOUNTS
707 MUTEX_DESTROY(&PL_svref_mutex);
708 #endif /* EMULATE_ATOMIC_REFCOUNTS */
710 /* As the penultimate thing, free the non-arena SV for thrsv */
711 Safefree(SvPVX(PL_thrsv));
712 Safefree(SvANY(PL_thrsv));
715 #endif /* USE_THREADS */
717 /* As the absolutely last thing, free the non-arena SV for mess() */
720 /* it could have accumulated taint magic */
721 if (SvTYPE(PL_mess_sv) >= SVt_PVMG) {
724 for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) {
725 moremagic = mg->mg_moremagic;
726 if (mg->mg_ptr && mg->mg_type != 'g' && mg->mg_len >= 0)
727 Safefree(mg->mg_ptr);
731 /* we know that type >= SVt_PV */
732 SvOOK_off(PL_mess_sv);
733 Safefree(SvPVX(PL_mess_sv));
734 Safefree(SvANY(PL_mess_sv));
735 Safefree(PL_mess_sv);
741 =for apidoc perl_free
743 Releases a Perl interpreter. See L<perlembed>.
751 #if defined(PERL_OBJECT)
759 Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
761 Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry);
762 PL_exitlist[PL_exitlistlen].fn = fn;
763 PL_exitlist[PL_exitlistlen].ptr = ptr;
768 =for apidoc perl_parse
770 Tells a Perl interpreter to parse a Perl script. See L<perlembed>.
776 perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
786 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
789 Perl_croak(aTHX_ "suidperl is no longer needed since the kernel can now execute\n\
790 setuid perl scripts securely.\n");
794 #if defined(__DYNAMIC__) && (defined(NeXT) || defined(__NeXT__))
795 _dyld_lookup_and_bind
796 ("__environ", (unsigned long *) &environ_pointer, NULL);
801 #ifndef VMS /* VMS doesn't have environ array */
802 PL_origenviron = environ;
807 /* Come here if running an undumped a.out. */
809 PL_origfilename = savepv(argv[0]);
810 PL_do_undump = FALSE;
811 cxstack_ix = -1; /* start label stack again */
813 init_postdump_symbols(argc,argv,env);
818 PL_curpad = AvARRAY(PL_comppad);
819 op_free(PL_main_root);
820 PL_main_root = Nullop;
822 PL_main_start = Nullop;
823 SvREFCNT_dec(PL_main_cv);
827 oldscope = PL_scopestack_ix;
828 PL_dowarn = G_WARN_OFF;
830 #ifdef PERL_FLEXIBLE_EXCEPTIONS
831 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vparse_body), env, xsinit);
837 #ifndef PERL_FLEXIBLE_EXCEPTIONS
838 parse_body(env,xsinit);
841 call_list(oldscope, PL_checkav);
848 /* my_exit() was called */
849 while (PL_scopestack_ix > oldscope)
852 PL_curstash = PL_defstash;
854 call_list(oldscope, PL_checkav);
855 ret = STATUS_NATIVE_EXPORT;
858 PerlIO_printf(Perl_error_log, "panic: top_env\n");
866 #ifdef PERL_FLEXIBLE_EXCEPTIONS
868 S_vparse_body(pTHX_ va_list args)
870 char **env = va_arg(args, char**);
871 XSINIT_t xsinit = va_arg(args, XSINIT_t);
873 return parse_body(env, xsinit);
878 S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
881 int argc = PL_origargc;
882 char **argv = PL_origargv;
883 char *scriptname = NULL;
885 VOL bool dosearch = FALSE;
890 char *cddir = Nullch;
892 sv_setpvn(PL_linestr,"",0);
893 sv = newSVpvn("",0); /* first used for -I flags */
897 for (argc--,argv++; argc > 0; argc--,argv++) {
898 if (argv[0][0] != '-' || !argv[0][1])
902 validarg = " PHOOEY ";
909 #ifndef PERL_STRICT_CR
934 if (s = moreswitches(s))
944 if (PL_euid != PL_uid || PL_egid != PL_gid)
945 Perl_croak(aTHX_ "No -e allowed in setuid scripts");
947 PL_e_script = newSVpvn("",0);
948 filter_add(read_e_script, NULL);
951 sv_catpv(PL_e_script, s);
953 sv_catpv(PL_e_script, argv[1]);
957 Perl_croak(aTHX_ "No code specified for -e");
958 sv_catpv(PL_e_script, "\n");
961 case 'I': /* -I handled both here and in moreswitches() */
963 if (!*++s && (s=argv[1]) != Nullch) {
968 STRLEN len = strlen(s);
971 sv_catpvn(sv, "-I", 2);
972 sv_catpvn(sv, p, len);
973 sv_catpvn(sv, " ", 1);
977 Perl_croak(aTHX_ "No directory specified for -I");
981 PL_preprocess = TRUE;
991 PL_preambleav = newAV();
992 av_push(PL_preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
994 PL_Sv = newSVpv("print myconfig();",0);
996 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
998 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
1000 sv_catpv(PL_Sv,"\" Compile-time options:");
1002 sv_catpv(PL_Sv," DEBUGGING");
1004 # ifdef MULTIPLICITY
1005 sv_catpv(PL_Sv," MULTIPLICITY");
1008 sv_catpv(PL_Sv," USE_THREADS");
1010 # ifdef USE_ITHREADS
1011 sv_catpv(PL_Sv," USE_ITHREADS");
1013 # ifdef USE_64_BIT_INT
1014 sv_catpv(PL_Sv," USE_64_BIT_INT");
1016 # ifdef USE_64_BIT_ALL
1017 sv_catpv(PL_Sv," USE_64_BIT_ALL");
1019 # ifdef USE_LONG_DOUBLE
1020 sv_catpv(PL_Sv," USE_LONG_DOUBLE");
1022 # ifdef USE_LARGE_FILES
1023 sv_catpv(PL_Sv," USE_LARGE_FILES");
1026 sv_catpv(PL_Sv," USE_SOCKS");
1029 sv_catpv(PL_Sv," PERL_OBJECT");
1031 # ifdef PERL_IMPLICIT_CONTEXT
1032 sv_catpv(PL_Sv," PERL_IMPLICIT_CONTEXT");
1034 # ifdef PERL_IMPLICIT_SYS
1035 sv_catpv(PL_Sv," PERL_IMPLICIT_SYS");
1037 sv_catpv(PL_Sv,"\\n\",");
1039 #if defined(LOCAL_PATCH_COUNT)
1040 if (LOCAL_PATCH_COUNT > 0) {
1042 sv_catpv(PL_Sv,"\" Locally applied patches:\\n\",");
1043 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
1044 if (PL_localpatches[i])
1045 Perl_sv_catpvf(aTHX_ PL_Sv,"q\" \t%s\n\",",PL_localpatches[i]);
1049 Perl_sv_catpvf(aTHX_ PL_Sv,"\" Built under %s\\n\"",OSNAME);
1052 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
1054 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled on %s\\n\"",__DATE__);
1057 sv_catpv(PL_Sv, "; \
1059 @env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; \
1060 print \" \\%ENV:\\n @env\\n\" if @env; \
1061 print \" \\@INC:\\n @INC\\n\";");
1064 PL_Sv = newSVpv("config_vars(qw(",0);
1065 sv_catpv(PL_Sv, ++s);
1066 sv_catpv(PL_Sv, "))");
1069 av_push(PL_preambleav, PL_Sv);
1070 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
1073 PL_doextract = TRUE;
1081 if (!*++s || isSPACE(*s)) {
1085 /* catch use of gnu style long options */
1086 if (strEQ(s, "version")) {
1090 if (strEQ(s, "help")) {
1097 Perl_croak(aTHX_ "Unrecognized switch: -%s (-h will show valid options)",s);
1103 #ifndef SECURE_INTERNAL_GETENV
1106 (s = PerlEnv_getenv("PERL5OPT")))
1110 if (*s == '-' && *(s+1) == 'T')
1123 if (!strchr("DIMUdmw", *s))
1124 Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
1125 s = moreswitches(s);
1131 scriptname = argv[0];
1134 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
1136 else if (scriptname == Nullch) {
1138 if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
1146 open_script(scriptname,dosearch,sv,&fdscript);
1148 validate_suid(validarg, scriptname,fdscript);
1150 #if defined(SIGCHLD) || defined(SIGCLD)
1153 # define SIGCHLD SIGCLD
1155 Sighandler_t sigstate = rsignal_state(SIGCHLD);
1156 if (sigstate == SIG_IGN) {
1157 if (ckWARN(WARN_SIGNAL))
1158 Perl_warner(aTHX_ WARN_SIGNAL,
1159 "Can't ignore signal CHLD, forcing to default");
1160 (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL);
1167 if (cddir && PerlDir_chdir(cddir) < 0)
1168 Perl_croak(aTHX_ "Can't chdir to %s",cddir);
1172 PL_main_cv = PL_compcv = (CV*)NEWSV(1104,0);
1173 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
1174 CvUNIQUE_on(PL_compcv);
1176 PL_comppad = newAV();
1177 av_push(PL_comppad, Nullsv);
1178 PL_curpad = AvARRAY(PL_comppad);
1179 PL_comppad_name = newAV();
1180 PL_comppad_name_fill = 0;
1181 PL_min_intro_pending = 0;
1184 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
1185 PL_curpad[0] = (SV*)newAV();
1186 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
1187 CvOWNER(PL_compcv) = 0;
1188 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
1189 MUTEX_INIT(CvMUTEXP(PL_compcv));
1190 #endif /* USE_THREADS */
1192 comppadlist = newAV();
1193 AvREAL_off(comppadlist);
1194 av_store(comppadlist, 0, (SV*)PL_comppad_name);
1195 av_store(comppadlist, 1, (SV*)PL_comppad);
1196 CvPADLIST(PL_compcv) = comppadlist;
1198 boot_core_UNIVERSAL();
1200 boot_core_xsutils();
1204 (*xsinit)(aTHXo); /* in case linked C routines want magical variables */
1205 #if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__)
1213 init_predump_symbols();
1214 /* init_postdump_symbols not currently designed to be called */
1215 /* more than once (ENV isn't cleared first, for example) */
1216 /* But running with -u leaves %ENV & @ARGV undefined! XXX */
1218 init_postdump_symbols(argc,argv,env);
1222 /* now parse the script */
1224 SETERRNO(0,SS$_NORMAL);
1226 if (yyparse() || PL_error_count) {
1228 Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
1230 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
1234 CopLINE_set(PL_curcop, 0);
1235 PL_curstash = PL_defstash;
1236 PL_preprocess = FALSE;
1238 SvREFCNT_dec(PL_e_script);
1239 PL_e_script = Nullsv;
1242 /* now that script is parsed, we can modify record separator */
1243 SvREFCNT_dec(PL_rs);
1244 PL_rs = SvREFCNT_inc(PL_nrs);
1245 sv_setsv(get_sv("/", TRUE), PL_rs);
1250 SAVECOPFILE(PL_curcop);
1251 SAVECOPLINE(PL_curcop);
1252 gv_check(PL_defstash);
1259 if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
1260 dump_mstats("after compilation:");
1269 =for apidoc perl_run
1271 Tells a Perl interpreter to run. See L<perlembed>.
1287 oldscope = PL_scopestack_ix;
1289 #ifdef PERL_FLEXIBLE_EXCEPTIONS
1291 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vrun_body), oldscope);
1297 cxstack_ix = -1; /* start context stack again */
1299 case 0: /* normal completion */
1300 #ifndef PERL_FLEXIBLE_EXCEPTIONS
1305 case 2: /* my_exit() */
1306 while (PL_scopestack_ix > oldscope)
1309 PL_curstash = PL_defstash;
1310 if (PL_endav && !PL_minus_c)
1311 call_list(oldscope, PL_endav);
1313 if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
1314 dump_mstats("after execution: ");
1316 ret = STATUS_NATIVE_EXPORT;
1320 POPSTACK_TO(PL_mainstack);
1323 PerlIO_printf(Perl_error_log, "panic: restartop\n");
1333 #ifdef PERL_FLEXIBLE_EXCEPTIONS
1335 S_vrun_body(pTHX_ va_list args)
1337 I32 oldscope = va_arg(args, I32);
1339 return run_body(oldscope);
1345 S_run_body(pTHX_ I32 oldscope)
1349 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
1350 PL_sawampersand ? "Enabling" : "Omitting"));
1352 if (!PL_restartop) {
1353 DEBUG_x(dump_all());
1354 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
1355 DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%"UVxf"\n",
1359 PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
1362 if (PERLDB_SINGLE && PL_DBsingle)
1363 sv_setiv(PL_DBsingle, 1);
1365 call_list(oldscope, PL_initav);
1371 PL_op = PL_restartop;
1375 else if (PL_main_start) {
1376 CvDEPTH(PL_main_cv) = 1;
1377 PL_op = PL_main_start;
1387 =for apidoc p||get_sv
1389 Returns the SV of the specified Perl scalar. If C<create> is set and the
1390 Perl variable does not exist then it will be created. If C<create> is not
1391 set and the variable does not exist then NULL is returned.
1397 Perl_get_sv(pTHX_ const char *name, I32 create)
1401 if (name[1] == '\0' && !isALPHA(name[0])) {
1402 PADOFFSET tmp = find_threadsv(name);
1403 if (tmp != NOT_IN_PAD) {
1405 return THREADSV(tmp);
1408 #endif /* USE_THREADS */
1409 gv = gv_fetchpv(name, create, SVt_PV);
1416 =for apidoc p||get_av
1418 Returns the AV of the specified Perl array. If C<create> is set and the
1419 Perl variable does not exist then it will be created. If C<create> is not
1420 set and the variable does not exist then NULL is returned.
1426 Perl_get_av(pTHX_ const char *name, I32 create)
1428 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1437 =for apidoc p||get_hv
1439 Returns the HV of the specified Perl hash. If C<create> is set and the
1440 Perl variable does not exist then it will be created. If C<create> is not
1441 set and the variable does not exist then NULL is returned.
1447 Perl_get_hv(pTHX_ const char *name, I32 create)
1449 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1458 =for apidoc p||get_cv
1460 Returns the CV of the specified Perl subroutine. If C<create> is set and
1461 the Perl subroutine does not exist then it will be declared (which has the
1462 same effect as saying C<sub name;>). If C<create> is not set and the
1463 subroutine does not exist then NULL is returned.
1469 Perl_get_cv(pTHX_ const char *name, I32 create)
1471 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
1472 /* XXX unsafe for threads if eval_owner isn't held */
1473 /* XXX this is probably not what they think they're getting.
1474 * It has the same effect as "sub name;", i.e. just a forward
1476 if (create && !GvCVu(gv))
1477 return newSUB(start_subparse(FALSE, 0),
1478 newSVOP(OP_CONST, 0, newSVpv(name,0)),
1486 /* Be sure to refetch the stack pointer after calling these routines. */
1489 =for apidoc p||call_argv
1491 Performs a callback to the specified Perl sub. See L<perlcall>.
1497 Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv)
1499 /* See G_* flags in cop.h */
1500 /* null terminated arg list */
1507 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
1512 return call_pv(sub_name, flags);
1516 =for apidoc p||call_pv
1518 Performs a callback to the specified Perl sub. See L<perlcall>.
1524 Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
1525 /* name of the subroutine */
1526 /* See G_* flags in cop.h */
1528 return call_sv((SV*)get_cv(sub_name, TRUE), flags);
1532 =for apidoc p||call_method
1534 Performs a callback to the specified Perl method. The blessed object must
1535 be on the stack. See L<perlcall>.
1541 Perl_call_method(pTHX_ const char *methname, I32 flags)
1542 /* name of the subroutine */
1543 /* See G_* flags in cop.h */
1551 XPUSHs(sv_2mortal(newSVpv(methname,0)));
1556 return call_sv(*PL_stack_sp--, flags);
1559 /* May be called with any of a CV, a GV, or an SV containing the name. */
1561 =for apidoc p||call_sv
1563 Performs a callback to the Perl sub whose name is in the SV. See
1570 Perl_call_sv(pTHX_ SV *sv, I32 flags)
1572 /* See G_* flags in cop.h */
1575 LOGOP myop; /* fake syntax tree node */
1579 bool oldcatch = CATCH_GET;
1584 if (flags & G_DISCARD) {
1589 Zero(&myop, 1, LOGOP);
1590 myop.op_next = Nullop;
1591 if (!(flags & G_NOARGS))
1592 myop.op_flags |= OPf_STACKED;
1593 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1594 (flags & G_ARRAY) ? OPf_WANT_LIST :
1599 EXTEND(PL_stack_sp, 1);
1600 *++PL_stack_sp = sv;
1602 oldscope = PL_scopestack_ix;
1604 if (PERLDB_SUB && PL_curstash != PL_debstash
1605 /* Handle first BEGIN of -d. */
1606 && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
1607 /* Try harder, since this may have been a sighandler, thus
1608 * curstash may be meaningless. */
1609 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != PL_debstash)
1610 && !(flags & G_NODEBUG))
1611 PL_op->op_private |= OPpENTERSUB_DB;
1613 if (!(flags & G_EVAL)) {
1615 call_body((OP*)&myop, FALSE);
1616 retval = PL_stack_sp - (PL_stack_base + oldmark);
1617 CATCH_SET(oldcatch);
1620 cLOGOP->op_other = PL_op;
1622 /* we're trying to emulate pp_entertry() here */
1624 register PERL_CONTEXT *cx;
1625 I32 gimme = GIMME_V;
1630 push_return(PL_op->op_next);
1631 PUSHBLOCK(cx, CXt_EVAL, PL_stack_sp);
1633 PL_eval_root = PL_op; /* Only needed so that goto works right. */
1635 PL_in_eval = EVAL_INEVAL;
1636 if (flags & G_KEEPERR)
1637 PL_in_eval |= EVAL_KEEPERR;
1643 #ifdef PERL_FLEXIBLE_EXCEPTIONS
1645 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_body),
1652 #ifndef PERL_FLEXIBLE_EXCEPTIONS
1654 call_body((OP*)&myop, FALSE);
1656 retval = PL_stack_sp - (PL_stack_base + oldmark);
1657 if (!(flags & G_KEEPERR))
1664 /* my_exit() was called */
1665 PL_curstash = PL_defstash;
1668 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
1669 Perl_croak(aTHX_ "Callback called exit");
1674 PL_op = PL_restartop;
1678 PL_stack_sp = PL_stack_base + oldmark;
1679 if (flags & G_ARRAY)
1683 *++PL_stack_sp = &PL_sv_undef;
1688 if (PL_scopestack_ix > oldscope) {
1692 register PERL_CONTEXT *cx;
1704 if (flags & G_DISCARD) {
1705 PL_stack_sp = PL_stack_base + oldmark;
1714 #ifdef PERL_FLEXIBLE_EXCEPTIONS
1716 S_vcall_body(pTHX_ va_list args)
1718 OP *myop = va_arg(args, OP*);
1719 int is_eval = va_arg(args, int);
1721 call_body(myop, is_eval);
1727 S_call_body(pTHX_ OP *myop, int is_eval)
1731 if (PL_op == myop) {
1733 PL_op = Perl_pp_entereval(aTHX);
1735 PL_op = Perl_pp_entersub(aTHX);
1741 /* Eval a string. The G_EVAL flag is always assumed. */
1744 =for apidoc p||eval_sv
1746 Tells Perl to C<eval> the string in the SV.
1752 Perl_eval_sv(pTHX_ SV *sv, I32 flags)
1754 /* See G_* flags in cop.h */
1757 UNOP myop; /* fake syntax tree node */
1758 I32 oldmark = SP - PL_stack_base;
1765 if (flags & G_DISCARD) {
1772 Zero(PL_op, 1, UNOP);
1773 EXTEND(PL_stack_sp, 1);
1774 *++PL_stack_sp = sv;
1775 oldscope = PL_scopestack_ix;
1777 if (!(flags & G_NOARGS))
1778 myop.op_flags = OPf_STACKED;
1779 myop.op_next = Nullop;
1780 myop.op_type = OP_ENTEREVAL;
1781 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1782 (flags & G_ARRAY) ? OPf_WANT_LIST :
1784 if (flags & G_KEEPERR)
1785 myop.op_flags |= OPf_SPECIAL;
1787 #ifdef PERL_FLEXIBLE_EXCEPTIONS
1789 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_body),
1796 #ifndef PERL_FLEXIBLE_EXCEPTIONS
1798 call_body((OP*)&myop,TRUE);
1800 retval = PL_stack_sp - (PL_stack_base + oldmark);
1801 if (!(flags & G_KEEPERR))
1808 /* my_exit() was called */
1809 PL_curstash = PL_defstash;
1812 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
1813 Perl_croak(aTHX_ "Callback called exit");
1818 PL_op = PL_restartop;
1822 PL_stack_sp = PL_stack_base + oldmark;
1823 if (flags & G_ARRAY)
1827 *++PL_stack_sp = &PL_sv_undef;
1833 if (flags & G_DISCARD) {
1834 PL_stack_sp = PL_stack_base + oldmark;
1844 =for apidoc p||eval_pv
1846 Tells Perl to C<eval> the given string and return an SV* result.
1852 Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
1855 SV* sv = newSVpv(p, 0);
1858 eval_sv(sv, G_SCALAR);
1865 if (croak_on_error && SvTRUE(ERRSV)) {
1867 Perl_croak(aTHX_ SvPVx(ERRSV, n_a));
1873 /* Require a module. */
1876 =for apidoc p||require_pv
1878 Tells Perl to C<require> a module.
1884 Perl_require_pv(pTHX_ const char *pv)
1888 PUSHSTACKi(PERLSI_REQUIRE);
1890 sv = sv_newmortal();
1891 sv_setpv(sv, "require '");
1894 eval_sv(sv, G_DISCARD);
1900 Perl_magicname(pTHX_ char *sym, char *name, I32 namlen)
1904 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1905 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1909 S_usage(pTHX_ char *name) /* XXX move this out into a module ? */
1911 /* This message really ought to be max 23 lines.
1912 * Removed -h because the user already knows that opton. Others? */
1914 static char *usage_msg[] = {
1915 "-0[octal] specify record separator (\\0, if no argument)",
1916 "-a autosplit mode with -n or -p (splits $_ into @F)",
1917 "-C enable native wide character system interfaces",
1918 "-c check syntax only (runs BEGIN and END blocks)",
1919 "-d[:debugger] run program under debugger",
1920 "-D[number/list] set debugging flags (argument is a bit mask or alphabets)",
1921 "-e 'command' one line of program (several -e's allowed, omit programfile)",
1922 "-F/pattern/ split() pattern for -a switch (//'s are optional)",
1923 "-i[extension] edit <> files in place (makes backup if extension supplied)",
1924 "-Idirectory specify @INC/#include directory (several -I's allowed)",
1925 "-l[octal] enable line ending processing, specifies line terminator",
1926 "-[mM][-]module execute `use/no module...' before executing program",
1927 "-n assume 'while (<>) { ... }' loop around program",
1928 "-p assume loop like -n but print line also, like sed",
1929 "-P run program through C preprocessor before compilation",
1930 "-s enable rudimentary parsing for switches after programfile",
1931 "-S look for programfile using PATH environment variable",
1932 "-T enable tainting checks",
1933 "-u dump core after parsing program",
1934 "-U allow unsafe operations",
1935 "-v print version, subversion (includes VERY IMPORTANT perl info)",
1936 "-V[:variable] print configuration summary (or a single Config.pm variable)",
1937 "-w enable many useful warnings (RECOMMENDED)",
1938 "-W enable all warnings",
1939 "-X disable all warnings",
1940 "-x[directory] strip off text before #!perl line and perhaps cd to directory",
1944 char **p = usage_msg;
1946 printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1948 printf("\n %s", *p++);
1951 /* This routine handles any switches that can be given during run */
1954 Perl_moreswitches(pTHX_ char *s)
1963 rschar = (U32)scan_oct(s, 4, &numlen);
1964 SvREFCNT_dec(PL_nrs);
1965 if (rschar & ~((U8)~0))
1966 PL_nrs = &PL_sv_undef;
1967 else if (!rschar && numlen >= 2)
1968 PL_nrs = newSVpvn("", 0);
1971 PL_nrs = newSVpvn(&ch, 1);
1976 PL_widesyscalls = TRUE;
1981 PL_splitstr = savepv(s + 1);
1995 if (*s == ':' || *s == '=') {
1996 my_setenv("PERL5DB", Perl_form(aTHX_ "use Devel::%s;", ++s));
2000 PL_perldb = PERLDB_ALL;
2008 if (isALPHA(s[1])) {
2009 static char debopts[] = "psltocPmfrxuLHXDS";
2012 for (s++; *s && (d = strchr(debopts,*s)); s++)
2013 PL_debug |= 1 << (d - debopts);
2016 PL_debug = atoi(s+1);
2017 for (s++; isDIGIT(*s); s++) ;
2019 PL_debug |= 0x80000000;
2022 if (ckWARN_d(WARN_DEBUGGING))
2023 Perl_warner(aTHX_ WARN_DEBUGGING,
2024 "Recompile perl with -DDEBUGGING to use -D switch\n");
2025 for (s++; isALNUM(*s); s++) ;
2031 usage(PL_origargv[0]);
2035 Safefree(PL_inplace);
2036 PL_inplace = savepv(s+1);
2038 for (s = PL_inplace; *s && !isSPACE(*s); s++) ;
2041 if (*s == '-') /* Additional switches on #! line. */
2045 case 'I': /* -I handled both here and in parse_perl() */
2048 while (*s && isSPACE(*s))
2053 /* ignore trailing spaces (possibly followed by other switches) */
2055 for (e = p; *e && !isSPACE(*e); e++) ;
2059 } while (*p && *p != '-');
2060 e = savepvn(s, e-s);
2068 Perl_croak(aTHX_ "No directory specified for -I");
2076 PL_ors = savepv("\n");
2078 *PL_ors = (char)scan_oct(s, 3 + (*s == '0'), &numlen);
2083 if (RsPARA(PL_nrs)) {
2088 PL_ors = SvPV(PL_nrs, PL_orslen);
2089 PL_ors = savepvn(PL_ors, PL_orslen);
2093 forbid_setid("-M"); /* XXX ? */
2096 forbid_setid("-m"); /* XXX ? */
2101 /* -M-foo == 'no foo' */
2102 if (*s == '-') { use = "no "; ++s; }
2103 sv = newSVpv(use,0);
2105 /* We allow -M'Module qw(Foo Bar)' */
2106 while(isALNUM(*s) || *s==':') ++s;
2108 sv_catpv(sv, start);
2109 if (*(start-1) == 'm') {
2111 Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
2112 sv_catpv( sv, " ()");
2115 sv_catpvn(sv, start, s-start);
2116 sv_catpv(sv, " split(/,/,q{");
2122 PL_preambleav = newAV();
2123 av_push(PL_preambleav, sv);
2126 Perl_croak(aTHX_ "No space allowed after -%c", *(s-1));
2138 PL_doswitches = TRUE;
2143 Perl_croak(aTHX_ "Too late for \"-T\" option");
2147 PL_do_undump = TRUE;
2155 printf(Perl_form(aTHX_ "\nThis is perl, v%vd built for %s",
2156 PL_patchlevel, ARCHNAME));
2157 #if defined(LOCAL_PATCH_COUNT)
2158 if (LOCAL_PATCH_COUNT > 0)
2159 printf("\n(with %d registered patch%s, see perl -V for more detail)",
2160 (int)LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : "");
2163 printf("\n\nCopyright 1987-2000, Larry Wall\n");
2165 printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
2168 printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
2169 printf("djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
2172 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
2173 "Version 5 port Copyright (c) 1994-1999, Andreas Kaiser, Ilya Zakharevich\n");
2176 printf("atariST series port, ++jrb bammi@cadence.com\n");
2179 printf("BeOS port Copyright Tom Spindler, 1997-1999\n");
2182 printf("MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-1999\n");
2185 printf("MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
2188 printf("Stratus VOS port by Paul_Green@stratus.com, 1997-1999\n");
2191 printf("VM/ESA port by Neale Ferguson, 1998-1999\n");
2194 printf("BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
2197 printf("MiNT port by Guido Flohr, 1997-1999\n");
2200 printf("EPOC port by Olaf Flebbe, 1999-2000\n");
2202 #ifdef BINARY_BUILD_NOTICE
2203 BINARY_BUILD_NOTICE;
2206 Perl may be copied only under the terms of either the Artistic License or the\n\
2207 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n\
2208 Complete documentation for Perl, including FAQ lists, should be found on\n\
2209 this system using `man perl' or `perldoc perl'. If you have access to the\n\
2210 Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
2213 if (! (PL_dowarn & G_WARN_ALL_MASK))
2214 PL_dowarn |= G_WARN_ON;
2218 PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
2219 PL_compiling.cop_warnings = WARN_ALL ;
2223 PL_dowarn = G_WARN_ALL_OFF;
2224 PL_compiling.cop_warnings = WARN_NONE ;
2229 if (s[1] == '-') /* Additional switches on #! line. */
2234 #if defined(WIN32) || !defined(PERL_STRICT_CR)
2240 #ifdef ALTERNATE_SHEBANG
2241 case 'S': /* OS/2 needs -S on "extproc" line. */
2249 Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
2254 /* compliments of Tom Christiansen */
2256 /* unexec() can be found in the Gnu emacs distribution */
2257 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
2260 Perl_my_unexec(pTHX)
2268 prog = newSVpv(BIN_EXP, 0);
2269 sv_catpv(prog, "/perl");
2270 file = newSVpv(PL_origfilename, 0);
2271 sv_catpv(file, ".perldump");
2273 unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
2274 /* unexec prints msg to stderr in case of failure */
2275 PerlProc_exit(status);
2278 # include <lib$routines.h>
2279 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
2281 ABORT(); /* for use with undump */
2286 /* initialize curinterp */
2291 #ifdef PERL_OBJECT /* XXX kludge */
2294 PL_chopset = " \n-"; \
2295 PL_copline = NOLINE; \
2296 PL_curcop = &PL_compiling;\
2297 PL_curcopdb = NULL; \
2299 PL_dumpindent = 4; \
2300 PL_laststatval = -1; \
2301 PL_laststype = OP_STAT; \
2302 PL_maxscream = -1; \
2303 PL_maxsysfd = MAXSYSFD; \
2304 PL_statname = Nullsv; \
2305 PL_tmps_floor = -1; \
2307 PL_op_mask = NULL; \
2308 PL_laststatval = -1; \
2309 PL_laststype = OP_STAT; \
2310 PL_mess_sv = Nullsv; \
2311 PL_splitstr = " "; \
2312 PL_generation = 100; \
2313 PL_exitlist = NULL; \
2314 PL_exitlistlen = 0; \
2316 PL_in_clean_objs = FALSE; \
2317 PL_in_clean_all = FALSE; \
2318 PL_profiledata = NULL; \
2320 PL_rsfp_filters = Nullav; \
2325 # ifdef MULTIPLICITY
2326 # define PERLVAR(var,type)
2327 # define PERLVARA(var,n,type)
2328 # if defined(PERL_IMPLICIT_CONTEXT)
2329 # if defined(USE_THREADS)
2330 # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
2331 # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
2332 # else /* !USE_THREADS */
2333 # define PERLVARI(var,type,init) aTHX->var = init;
2334 # define PERLVARIC(var,type,init) aTHX->var = init;
2335 # endif /* USE_THREADS */
2337 # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
2338 # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
2340 # include "intrpvar.h"
2341 # ifndef USE_THREADS
2342 # include "thrdvar.h"
2349 # define PERLVAR(var,type)
2350 # define PERLVARA(var,n,type)
2351 # define PERLVARI(var,type,init) PL_##var = init;
2352 # define PERLVARIC(var,type,init) PL_##var = init;
2353 # include "intrpvar.h"
2354 # ifndef USE_THREADS
2355 # include "thrdvar.h"
2367 S_init_main_stash(pTHX)
2372 /* Note that strtab is a rather special HV. Assumptions are made
2373 about not iterating on it, and not adding tie magic to it.
2374 It is properly deallocated in perl_destruct() */
2375 PL_strtab = newHV();
2377 MUTEX_INIT(&PL_strtab_mutex);
2379 HvSHAREKEYS_off(PL_strtab); /* mandatory */
2380 hv_ksplit(PL_strtab, 512);
2382 PL_curstash = PL_defstash = newHV();
2383 PL_curstname = newSVpvn("main",4);
2384 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
2385 SvREFCNT_dec(GvHV(gv));
2386 GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
2388 HvNAME(PL_defstash) = savepv("main");
2389 PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
2390 GvMULTI_on(PL_incgv);
2391 PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
2392 GvMULTI_on(PL_hintgv);
2393 PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
2394 PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
2395 GvMULTI_on(PL_errgv);
2396 PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
2397 GvMULTI_on(PL_replgv);
2398 (void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */
2399 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
2400 sv_setpvn(ERRSV, "", 0);
2401 PL_curstash = PL_defstash;
2402 CopSTASH_set(&PL_compiling, PL_defstash);
2403 PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
2404 PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
2405 /* We must init $/ before switches are processed. */
2406 sv_setpvn(get_sv("/", TRUE), "\n", 1);
2410 S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
2418 PL_origfilename = savepv("-e");
2421 /* if find_script() returns, it returns a malloc()-ed value */
2422 PL_origfilename = scriptname = find_script(scriptname, dosearch, NULL, 1);
2424 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
2425 char *s = scriptname + 8;
2426 *fdscript = atoi(s);
2430 scriptname = savepv(s + 1);
2431 Safefree(PL_origfilename);
2432 PL_origfilename = scriptname;
2437 CopFILE_set(PL_curcop, PL_origfilename);
2438 if (strEQ(PL_origfilename,"-"))
2440 if (*fdscript >= 0) {
2441 PL_rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE);
2442 #if defined(HAS_FCNTL) && defined(F_SETFD)
2444 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); /* ensure close-on-exec */
2447 else if (PL_preprocess) {
2448 char *cpp_cfg = CPPSTDIN;
2449 SV *cpp = newSVpvn("",0);
2450 SV *cmd = NEWSV(0,0);
2452 if (strEQ(cpp_cfg, "cppstdin"))
2453 Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
2454 sv_catpv(cpp, cpp_cfg);
2456 sv_catpvn(sv, "-I", 2);
2457 sv_catpv(sv,PRIVLIB_EXP);
2460 Perl_sv_setpvf(aTHX_ cmd, "\
2461 sed %s -e \"/^[^#]/b\" \
2462 -e \"/^#[ ]*include[ ]/b\" \
2463 -e \"/^#[ ]*define[ ]/b\" \
2464 -e \"/^#[ ]*if[ ]/b\" \
2465 -e \"/^#[ ]*ifdef[ ]/b\" \
2466 -e \"/^#[ ]*ifndef[ ]/b\" \
2467 -e \"/^#[ ]*else/b\" \
2468 -e \"/^#[ ]*elif[ ]/b\" \
2469 -e \"/^#[ ]*undef[ ]/b\" \
2470 -e \"/^#[ ]*endif/b\" \
2472 %s | %"SVf" -C %"SVf" %s",
2473 (PL_doextract ? "-e \"1,/^#/d\n\"" : ""),
2476 Perl_sv_setpvf(aTHX_ cmd, "\
2477 %s %s -e '/^[^#]/b' \
2478 -e '/^#[ ]*include[ ]/b' \
2479 -e '/^#[ ]*define[ ]/b' \
2480 -e '/^#[ ]*if[ ]/b' \
2481 -e '/^#[ ]*ifdef[ ]/b' \
2482 -e '/^#[ ]*ifndef[ ]/b' \
2483 -e '/^#[ ]*else/b' \
2484 -e '/^#[ ]*elif[ ]/b' \
2485 -e '/^#[ ]*undef[ ]/b' \
2486 -e '/^#[ ]*endif/b' \
2488 %s | %"SVf" %"SVf" %s",
2490 Perl_sv_setpvf(aTHX_ cmd, "\
2491 %s %s -e '/^[^#]/b' \
2492 -e '/^#[ ]*include[ ]/b' \
2493 -e '/^#[ ]*define[ ]/b' \
2494 -e '/^#[ ]*if[ ]/b' \
2495 -e '/^#[ ]*ifdef[ ]/b' \
2496 -e '/^#[ ]*ifndef[ ]/b' \
2497 -e '/^#[ ]*else/b' \
2498 -e '/^#[ ]*elif[ ]/b' \
2499 -e '/^#[ ]*undef[ ]/b' \
2500 -e '/^#[ ]*endif/b' \
2502 %s | %"SVf" -C %"SVf" %s",
2509 (PL_doextract ? "-e '1,/^#/d\n'" : ""),
2511 scriptname, cpp, sv, CPPMINUS);
2512 PL_doextract = FALSE;
2513 #ifdef IAMSUID /* actually, this is caught earlier */
2514 if (PL_euid != PL_uid && !PL_euid) { /* if running suidperl */
2516 (void)seteuid(PL_uid); /* musn't stay setuid root */
2519 (void)setreuid((Uid_t)-1, PL_uid);
2521 #ifdef HAS_SETRESUID
2522 (void)setresuid((Uid_t)-1, PL_uid, (Uid_t)-1);
2524 PerlProc_setuid(PL_uid);
2528 if (PerlProc_geteuid() != PL_uid)
2529 Perl_croak(aTHX_ "Can't do seteuid!\n");
2531 #endif /* IAMSUID */
2532 PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
2536 else if (!*scriptname) {
2537 forbid_setid("program input from stdin");
2538 PL_rsfp = PerlIO_stdin();
2541 PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
2542 #if defined(HAS_FCNTL) && defined(F_SETFD)
2544 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); /* ensure close-on-exec */
2549 #ifndef IAMSUID /* in case script is not readable before setuid */
2551 PerlLIO_stat(CopFILE(PL_curcop),&PL_statbuf) >= 0 &&
2552 PL_statbuf.st_mode & (S_ISUID|S_ISGID))
2555 PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
2556 (int)PERL_REVISION, (int)PERL_VERSION,
2557 (int)PERL_SUBVERSION), PL_origargv);
2558 Perl_croak(aTHX_ "Can't do setuid\n");
2562 Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
2563 CopFILE(PL_curcop), Strerror(errno));
2568 * I_SYSSTATVFS HAS_FSTATVFS
2570 * I_STATFS HAS_FSTATFS HAS_GETFSSTAT
2571 * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT
2572 * here so that metaconfig picks them up. */
2576 S_fd_on_nosuid_fs(pTHX_ int fd)
2578 int check_okay = 0; /* able to do all the required sys/libcalls */
2579 int on_nosuid = 0; /* the fd is on a nosuid fs */
2581 * Preferred order: fstatvfs(), fstatfs(), ustat()+getmnt(), getmntent().
2582 * fstatvfs() is UNIX98.
2583 * fstatfs() is 4.3 BSD.
2584 * ustat()+getmnt() is pre-4.3 BSD.
2585 * getmntent() is O(number-of-mounted-filesystems) and can hang on
2586 * an irrelevant filesystem while trying to reach the right one.
2589 # ifdef HAS_FSTATVFS
2590 struct statvfs stfs;
2591 check_okay = fstatvfs(fd, &stfs) == 0;
2592 on_nosuid = check_okay && (stfs.f_flag & ST_NOSUID);
2594 # ifdef PERL_MOUNT_NOSUID
2595 # if defined(HAS_FSTATFS) && \
2596 defined(HAS_STRUCT_STATFS) && \
2597 defined(HAS_STRUCT_STATFS_F_FLAGS)
2599 check_okay = fstatfs(fd, &stfs) == 0;
2600 on_nosuid = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
2602 # if defined(HAS_FSTAT) && \
2603 defined(HAS_USTAT) && \
2604 defined(HAS_GETMNT) && \
2605 defined(HAS_STRUCT_FS_DATA) && \
2608 if (fstat(fd, &fdst) == 0) {
2610 if (ustat(fdst.st_dev, &us) == 0) {
2612 /* NOSTAT_ONE here because we're not examining fields which
2613 * vary between that case and STAT_ONE. */
2614 if (getmnt((int*)0, &fsd, (int)0, NOSTAT_ONE, us.f_fname) == 0) {
2615 size_t cmplen = sizeof(us.f_fname);
2616 if (sizeof(fsd.fd_req.path) < cmplen)
2617 cmplen = sizeof(fsd.fd_req.path);
2618 if (strnEQ(fsd.fd_req.path, us.f_fname, cmplen) &&
2619 fdst.st_dev == fsd.fd_req.dev) {
2621 on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID;
2627 # endif /* fstat+ustat+getmnt */
2628 # endif /* fstatfs */
2630 # if defined(HAS_GETMNTENT) && \
2631 defined(HAS_HASMNTOPT) && \
2632 defined(MNTOPT_NOSUID)
2633 FILE *mtab = fopen("/etc/mtab", "r");
2634 struct mntent *entry;
2635 struct stat stb, fsb;
2637 if (mtab && (fstat(fd, &stb) == 0)) {
2638 while (entry = getmntent(mtab)) {
2639 if (stat(entry->mnt_dir, &fsb) == 0
2640 && fsb.st_dev == stb.st_dev)
2642 /* found the filesystem */
2644 if (hasmntopt(entry, MNTOPT_NOSUID))
2647 } /* A single fs may well fail its stat(). */
2652 # endif /* getmntent+hasmntopt */
2653 # endif /* PERL_MOUNT_NOSUID: fstatfs or fstat+ustat+statfs */
2654 # endif /* statvfs */
2657 Perl_croak(aTHX_ "Can't check filesystem of script \"%s\" for nosuid", PL_origfilename);
2660 #endif /* IAMSUID */
2663 S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript)
2667 /* do we need to emulate setuid on scripts? */
2669 /* This code is for those BSD systems that have setuid #! scripts disabled
2670 * in the kernel because of a security problem. Merely defining DOSUID
2671 * in perl will not fix that problem, but if you have disabled setuid
2672 * scripts in the kernel, this will attempt to emulate setuid and setgid
2673 * on scripts that have those now-otherwise-useless bits set. The setuid
2674 * root version must be called suidperl or sperlN.NNN. If regular perl
2675 * discovers that it has opened a setuid script, it calls suidperl with
2676 * the same argv that it had. If suidperl finds that the script it has
2677 * just opened is NOT setuid root, it sets the effective uid back to the
2678 * uid. We don't just make perl setuid root because that loses the
2679 * effective uid we had before invoking perl, if it was different from the
2682 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
2683 * be defined in suidperl only. suidperl must be setuid root. The
2684 * Configure script will set this up for you if you want it.
2691 if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */
2692 Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
2693 if (fdscript < 0 && PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
2698 #ifndef HAS_SETREUID
2699 /* On this access check to make sure the directories are readable,
2700 * there is actually a small window that the user could use to make
2701 * filename point to an accessible directory. So there is a faint
2702 * chance that someone could execute a setuid script down in a
2703 * non-accessible directory. I don't know what to do about that.
2704 * But I don't think it's too important. The manual lies when
2705 * it says access() is useful in setuid programs.
2707 if (PerlLIO_access(CopFILE(PL_curcop),1)) /*double check*/
2708 Perl_croak(aTHX_ "Permission denied");
2710 /* If we can swap euid and uid, then we can determine access rights
2711 * with a simple stat of the file, and then compare device and
2712 * inode to make sure we did stat() on the same file we opened.
2713 * Then we just have to make sure he or she can execute it.
2716 struct stat tmpstatbuf;
2720 setreuid(PL_euid,PL_uid) < 0
2723 setresuid(PL_euid,PL_uid,(Uid_t)-1) < 0
2726 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
2727 Perl_croak(aTHX_ "Can't swap uid and euid"); /* really paranoid */
2728 if (PerlLIO_stat(CopFILE(PL_curcop),&tmpstatbuf) < 0)
2729 Perl_croak(aTHX_ "Permission denied"); /* testing full pathname here */
2730 #if defined(IAMSUID) && !defined(NO_NOSUID_CHECK)
2731 if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp)))
2732 Perl_croak(aTHX_ "Permission denied");
2734 if (tmpstatbuf.st_dev != PL_statbuf.st_dev ||
2735 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
2736 (void)PerlIO_close(PL_rsfp);
2737 if (PL_rsfp = PerlProc_popen("/bin/mail root","w")) { /* heh, heh */
2738 PerlIO_printf(PL_rsfp,
2739 "User %"Uid_t_f" tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2740 (Filename of set-id script was %s, uid %"Uid_t_f" gid %"Gid_t_f".)\n\nSincerely,\nperl\n",
2741 PL_uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
2742 (long)PL_statbuf.st_dev, (long)PL_statbuf.st_ino,
2744 PL_statbuf.st_uid, PL_statbuf.st_gid);
2745 (void)PerlProc_pclose(PL_rsfp);
2747 Perl_croak(aTHX_ "Permission denied\n");
2751 setreuid(PL_uid,PL_euid) < 0
2753 # if defined(HAS_SETRESUID)
2754 setresuid(PL_uid,PL_euid,(Uid_t)-1) < 0
2757 || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
2758 Perl_croak(aTHX_ "Can't reswap uid and euid");
2759 if (!cando(S_IXUSR,FALSE,&PL_statbuf)) /* can real uid exec? */
2760 Perl_croak(aTHX_ "Permission denied\n");
2762 #endif /* HAS_SETREUID */
2763 #endif /* IAMSUID */
2765 if (!S_ISREG(PL_statbuf.st_mode))
2766 Perl_croak(aTHX_ "Permission denied");
2767 if (PL_statbuf.st_mode & S_IWOTH)
2768 Perl_croak(aTHX_ "Setuid/gid script is writable by world");
2769 PL_doswitches = FALSE; /* -s is insecure in suid */
2770 CopLINE_inc(PL_curcop);
2771 if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
2772 strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */
2773 Perl_croak(aTHX_ "No #! line");
2774 s = SvPV(PL_linestr,n_a)+2;
2776 while (!isSPACE(*s)) s++;
2777 for (s2 = s; (s2 > SvPV(PL_linestr,n_a)+2 &&
2778 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
2779 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
2780 Perl_croak(aTHX_ "Not a perl script");
2781 while (*s == ' ' || *s == '\t') s++;
2783 * #! arg must be what we saw above. They can invoke it by
2784 * mentioning suidperl explicitly, but they may not add any strange
2785 * arguments beyond what #! says if they do invoke suidperl that way.
2787 len = strlen(validarg);
2788 if (strEQ(validarg," PHOOEY ") ||
2789 strnNE(s,validarg,len) || !isSPACE(s[len]))
2790 Perl_croak(aTHX_ "Args must match #! line");
2793 if (PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
2794 PL_euid == PL_statbuf.st_uid)
2796 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2797 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2798 #endif /* IAMSUID */
2800 if (PL_euid) { /* oops, we're not the setuid root perl */
2801 (void)PerlIO_close(PL_rsfp);
2804 PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
2805 (int)PERL_REVISION, (int)PERL_VERSION,
2806 (int)PERL_SUBVERSION), PL_origargv);
2808 Perl_croak(aTHX_ "Can't do setuid\n");
2811 if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
2813 (void)setegid(PL_statbuf.st_gid);
2816 (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
2818 #ifdef HAS_SETRESGID
2819 (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
2821 PerlProc_setgid(PL_statbuf.st_gid);
2825 if (PerlProc_getegid() != PL_statbuf.st_gid)
2826 Perl_croak(aTHX_ "Can't do setegid!\n");
2828 if (PL_statbuf.st_mode & S_ISUID) {
2829 if (PL_statbuf.st_uid != PL_euid)
2831 (void)seteuid(PL_statbuf.st_uid); /* all that for this */
2834 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
2836 #ifdef HAS_SETRESUID
2837 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
2839 PerlProc_setuid(PL_statbuf.st_uid);
2843 if (PerlProc_geteuid() != PL_statbuf.st_uid)
2844 Perl_croak(aTHX_ "Can't do seteuid!\n");
2846 else if (PL_uid) { /* oops, mustn't run as root */
2848 (void)seteuid((Uid_t)PL_uid);
2851 (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
2853 #ifdef HAS_SETRESUID
2854 (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
2856 PerlProc_setuid((Uid_t)PL_uid);
2860 if (PerlProc_geteuid() != PL_uid)
2861 Perl_croak(aTHX_ "Can't do seteuid!\n");
2864 if (!cando(S_IXUSR,TRUE,&PL_statbuf))
2865 Perl_croak(aTHX_ "Permission denied\n"); /* they can't do this */
2868 else if (PL_preprocess)
2869 Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
2870 else if (fdscript >= 0)
2871 Perl_croak(aTHX_ "fd script not allowed in suidperl\n");
2873 Perl_croak(aTHX_ "Script is not setuid/setgid in suidperl\n");
2875 /* We absolutely must clear out any saved ids here, so we */
2876 /* exec the real perl, substituting fd script for scriptname. */
2877 /* (We pass script name as "subdir" of fd, which perl will grok.) */
2878 PerlIO_rewind(PL_rsfp);
2879 PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0); /* just in case rewind didn't */
2880 for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
2881 if (!PL_origargv[which])
2882 Perl_croak(aTHX_ "Permission denied");
2883 PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
2884 PerlIO_fileno(PL_rsfp), PL_origargv[which]));
2885 #if defined(HAS_FCNTL) && defined(F_SETFD)
2886 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */
2888 PerlProc_execv(Perl_form(aTHX_ "%s/perl"PERL_FS_VER_FMT, BIN_EXP,
2889 (int)PERL_REVISION, (int)PERL_VERSION,
2890 (int)PERL_SUBVERSION), PL_origargv);/* try again */
2891 Perl_croak(aTHX_ "Can't do setuid\n");
2892 #endif /* IAMSUID */
2894 if (PL_euid != PL_uid || PL_egid != PL_gid) { /* (suidperl doesn't exist, in fact) */
2895 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2897 PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf); /* may be either wrapped or real suid */
2898 if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
2900 (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
2903 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2904 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2905 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2906 /* not set-id, must be wrapped */
2912 S_find_beginning(pTHX)
2914 register char *s, *s2;
2916 /* skip forward in input to the real script? */
2919 while (PL_doextract) {
2920 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
2921 Perl_croak(aTHX_ "No Perl script found in input\n");
2922 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2923 PerlIO_ungetc(PL_rsfp, '\n'); /* to keep line count right */
2924 PL_doextract = FALSE;
2925 while (*s && !(isSPACE (*s) || *s == '#')) s++;
2927 while (*s == ' ' || *s == '\t') s++;
2929 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2930 if (strnEQ(s2-4,"perl",4))
2932 while (s = moreswitches(s)) ;
2942 PL_uid = PerlProc_getuid();
2943 PL_euid = PerlProc_geteuid();
2944 PL_gid = PerlProc_getgid();
2945 PL_egid = PerlProc_getegid();
2947 PL_uid |= PL_gid << 16;
2948 PL_euid |= PL_egid << 16;
2950 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2954 S_forbid_setid(pTHX_ char *s)
2956 if (PL_euid != PL_uid)
2957 Perl_croak(aTHX_ "No %s allowed while running setuid", s);
2958 if (PL_egid != PL_gid)
2959 Perl_croak(aTHX_ "No %s allowed while running setgid", s);
2963 Perl_init_debugger(pTHX)
2966 HV *ostash = PL_curstash;
2968 PL_curstash = PL_debstash;
2969 PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2970 AvREAL_off(PL_dbargs);
2971 PL_DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2972 PL_DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2973 PL_DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2974 sv_upgrade(GvSV(PL_DBsub), SVt_IV); /* IVX accessed if PERLDB_SUB_NN */
2975 PL_DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2976 sv_setiv(PL_DBsingle, 0);
2977 PL_DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2978 sv_setiv(PL_DBtrace, 0);
2979 PL_DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2980 sv_setiv(PL_DBsignal, 0);
2981 PL_curstash = ostash;
2984 #ifndef STRESS_REALLOC
2985 #define REASONABLE(size) (size)
2987 #define REASONABLE(size) (1) /* unreasonable */
2991 Perl_init_stacks(pTHX)
2993 /* start with 128-item stack and 8K cxstack */
2994 PL_curstackinfo = new_stackinfo(REASONABLE(128),
2995 REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
2996 PL_curstackinfo->si_type = PERLSI_MAIN;
2997 PL_curstack = PL_curstackinfo->si_stack;
2998 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
3000 PL_stack_base = AvARRAY(PL_curstack);
3001 PL_stack_sp = PL_stack_base;
3002 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
3004 New(50,PL_tmps_stack,REASONABLE(128),SV*);
3007 PL_tmps_max = REASONABLE(128);
3009 New(54,PL_markstack,REASONABLE(32),I32);
3010 PL_markstack_ptr = PL_markstack;
3011 PL_markstack_max = PL_markstack + REASONABLE(32);
3015 New(54,PL_scopestack,REASONABLE(32),I32);
3016 PL_scopestack_ix = 0;
3017 PL_scopestack_max = REASONABLE(32);
3019 New(54,PL_savestack,REASONABLE(128),ANY);
3020 PL_savestack_ix = 0;
3021 PL_savestack_max = REASONABLE(128);
3023 New(54,PL_retstack,REASONABLE(16),OP*);
3025 PL_retstack_max = REASONABLE(16);
3034 while (PL_curstackinfo->si_next)
3035 PL_curstackinfo = PL_curstackinfo->si_next;
3036 while (PL_curstackinfo) {
3037 PERL_SI *p = PL_curstackinfo->si_prev;
3038 /* curstackinfo->si_stack got nuked by sv_free_arenas() */
3039 Safefree(PL_curstackinfo->si_cxstack);
3040 Safefree(PL_curstackinfo);
3041 PL_curstackinfo = p;
3043 Safefree(PL_tmps_stack);
3044 Safefree(PL_markstack);
3045 Safefree(PL_scopestack);
3046 Safefree(PL_savestack);
3047 Safefree(PL_retstack);
3051 static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
3062 lex_start(PL_linestr);
3064 PL_subname = newSVpvn("main",4);
3068 S_init_predump_symbols(pTHX)
3075 sv_setpvn(get_sv("\"", TRUE), " ", 1);
3076 PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
3077 GvMULTI_on(PL_stdingv);
3078 io = GvIOp(PL_stdingv);
3079 IoIFP(io) = PerlIO_stdin();
3080 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
3082 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
3084 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
3087 IoOFP(io) = IoIFP(io) = PerlIO_stdout();
3089 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
3091 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
3093 PL_stderrgv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
3094 GvMULTI_on(PL_stderrgv);
3095 io = GvIOp(PL_stderrgv);
3096 IoOFP(io) = IoIFP(io) = PerlIO_stderr();
3097 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
3099 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
3101 PL_statname = NEWSV(66,0); /* last filename we did stat on */
3104 PL_osname = savepv(OSNAME);
3108 S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
3115 argc--,argv++; /* skip name of script */
3116 if (PL_doswitches) {
3117 for (; argc > 0 && **argv == '-'; argc--,argv++) {
3120 if (argv[0][1] == '-' && !argv[0][2]) {
3124 if (s = strchr(argv[0], '=')) {
3126 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
3129 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
3132 PL_toptarget = NEWSV(0,0);
3133 sv_upgrade(PL_toptarget, SVt_PVFM);
3134 sv_setpvn(PL_toptarget, "", 0);
3135 PL_bodytarget = NEWSV(0,0);
3136 sv_upgrade(PL_bodytarget, SVt_PVFM);
3137 sv_setpvn(PL_bodytarget, "", 0);
3138 PL_formtarget = PL_bodytarget;
3141 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
3142 sv_setpv(GvSV(tmpgv),PL_origfilename);
3143 magicname("0", "0", 1);
3145 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
3147 sv_setpv(GvSV(tmpgv), os2_execname());
3149 sv_setpv(GvSV(tmpgv),PL_origargv[0]);
3151 if (PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
3152 GvMULTI_on(PL_argvgv);
3153 (void)gv_AVadd(PL_argvgv);
3154 av_clear(GvAVn(PL_argvgv));
3155 for (; argc > 0; argc--,argv++) {
3156 av_push(GvAVn(PL_argvgv),newSVpv(argv[0],0));
3159 if (PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
3161 GvMULTI_on(PL_envgv);
3162 hv = GvHVn(PL_envgv);
3163 hv_magic(hv, PL_envgv, 'E');
3164 #if !defined( VMS) && !defined(EPOC) /* VMS doesn't have environ array */
3165 /* Note that if the supplied env parameter is actually a copy
3166 of the global environ then it may now point to free'd memory
3167 if the environment has been modified since. To avoid this
3168 problem we treat env==NULL as meaning 'use the default'
3173 environ[0] = Nullch;
3174 for (; *env; env++) {
3175 if (!(s = strchr(*env,'=')))
3181 sv = newSVpv(s--,0);
3182 (void)hv_store(hv, *env, s - *env, sv, 0);
3184 #if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
3185 /* Sins of the RTL. See note in my_setenv(). */
3186 (void)PerlEnv_putenv(savepv(*env));
3190 #ifdef DYNAMIC_ENV_FETCH
3191 HvNAME(hv) = savepv(ENV_HV_NAME);
3195 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
3196 sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
3200 S_init_perllib(pTHX)
3205 s = PerlEnv_getenv("PERL5LIB");
3209 incpush(PerlEnv_getenv("PERLLIB"), FALSE);
3211 /* Treat PERL5?LIB as a possible search list logical name -- the
3212 * "natural" VMS idiom for a Unix path string. We allow each
3213 * element to be a set of |-separated directories for compatibility.
3217 if (my_trnlnm("PERL5LIB",buf,0))
3218 do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
3220 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
3224 /* Use the ~-expanded versions of APPLLIB (undocumented),
3225 ARCHLIB PRIVLIB SITEARCH and SITELIB
3228 incpush(APPLLIB_EXP, TRUE);
3232 incpush(ARCHLIB_EXP, FALSE);
3235 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
3238 incpush(PRIVLIB_EXP, TRUE);
3240 incpush(PRIVLIB_EXP, FALSE);
3244 incpush(SITELIB_EXP, TRUE); /* XXX Win32 needs inc_version_list support */
3248 char *path = SITELIB_EXP;
3253 if (strrchr(buf,'/')) /* XXX Hack, Configure var needed */
3254 *strrchr(buf,'/') = '\0';
3260 #if defined(PERL_VENDORLIB_EXP)
3262 incpush(PERL_VENDORLIB_EXP, TRUE);
3264 incpush(PERL_VENDORLIB_EXP, FALSE);
3268 incpush(".", FALSE);
3272 # define PERLLIB_SEP ';'
3275 # define PERLLIB_SEP '|'
3277 # define PERLLIB_SEP ':'
3280 #ifndef PERLLIB_MANGLE
3281 # define PERLLIB_MANGLE(s,n) (s)
3285 S_incpush(pTHX_ char *p, int addsubdirs)
3287 SV *subdir = Nullsv;
3293 subdir = sv_newmortal();
3296 /* Break at all separators */
3298 SV *libdir = NEWSV(55,0);
3301 /* skip any consecutive separators */
3302 while ( *p == PERLLIB_SEP ) {
3303 /* Uncomment the next line for PATH semantics */
3304 /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */
3308 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
3309 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
3314 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
3315 p = Nullch; /* break out */
3319 * BEFORE pushing libdir onto @INC we may first push version- and
3320 * archname-specific sub-directories.
3323 #ifdef PERL_INC_VERSION_LIST
3324 /* Configure terminates PERL_INC_VERSION_LIST with a NULL */
3325 const char *incverlist[] = { PERL_INC_VERSION_LIST };
3326 const char **incver;
3328 struct stat tmpstatbuf;
3333 if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) {
3335 while (unix[len-1] == '/') len--; /* Cosmetic */
3336 sv_usepvn(libdir,unix,len);
3339 PerlIO_printf(Perl_error_log,
3340 "Failed to unixify @INC element \"%s\"\n",
3343 /* .../version/archname if -d .../version/archname */
3344 Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/"PERL_FS_VER_FMT"/%s", libdir,
3345 (int)PERL_REVISION, (int)PERL_VERSION,
3346 (int)PERL_SUBVERSION, ARCHNAME);
3347 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3348 S_ISDIR(tmpstatbuf.st_mode))
3349 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3351 /* .../version if -d .../version */
3352 Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/"PERL_FS_VER_FMT, libdir,
3353 (int)PERL_REVISION, (int)PERL_VERSION,
3354 (int)PERL_SUBVERSION);
3355 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3356 S_ISDIR(tmpstatbuf.st_mode))
3357 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3359 /* .../archname if -d .../archname */
3360 Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/%s", libdir, ARCHNAME);
3361 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3362 S_ISDIR(tmpstatbuf.st_mode))
3363 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3365 #ifdef PERL_INC_VERSION_LIST
3366 for (incver = incverlist; *incver; incver++) {
3367 /* .../xxx if -d .../xxx */
3368 Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/%s", libdir, *incver);
3369 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3370 S_ISDIR(tmpstatbuf.st_mode))
3371 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3376 /* finally push this lib directory on the end of @INC */
3377 av_push(GvAVn(PL_incgv), libdir);
3382 STATIC struct perl_thread *
3383 S_init_main_thread(pTHX)
3385 #if !defined(PERL_IMPLICIT_CONTEXT)
3386 struct perl_thread *thr;
3390 Newz(53, thr, 1, struct perl_thread);
3391 PL_curcop = &PL_compiling;
3392 thr->interp = PERL_GET_INTERP;
3393 thr->cvcache = newHV();
3394 thr->threadsv = newAV();
3395 /* thr->threadsvp is set when find_threadsv is called */
3396 thr->specific = newAV();
3397 thr->flags = THRf_R_JOINABLE;
3398 MUTEX_INIT(&thr->mutex);
3399 /* Handcraft thrsv similarly to mess_sv */
3400 New(53, PL_thrsv, 1, SV);
3401 Newz(53, xpv, 1, XPV);
3402 SvFLAGS(PL_thrsv) = SVt_PV;
3403 SvANY(PL_thrsv) = (void*)xpv;
3404 SvREFCNT(PL_thrsv) = 1 << 30; /* practically infinite */
3405 SvPVX(PL_thrsv) = (char*)thr;
3406 SvCUR_set(PL_thrsv, sizeof(thr));
3407 SvLEN_set(PL_thrsv, sizeof(thr));
3408 *SvEND(PL_thrsv) = '\0'; /* in the trailing_nul field */
3409 thr->oursv = PL_thrsv;
3410 PL_chopset = " \n-";
3413 MUTEX_LOCK(&PL_threads_mutex);
3418 MUTEX_UNLOCK(&PL_threads_mutex);
3420 #ifdef HAVE_THREAD_INTERN
3421 Perl_init_thread_intern(thr);
3424 #ifdef SET_THREAD_SELF
3425 SET_THREAD_SELF(thr);
3427 thr->self = pthread_self();
3428 #endif /* SET_THREAD_SELF */
3432 * These must come after the SET_THR because sv_setpvn does
3433 * SvTAINT and the taint fields require dTHR.
3435 PL_toptarget = NEWSV(0,0);
3436 sv_upgrade(PL_toptarget, SVt_PVFM);
3437 sv_setpvn(PL_toptarget, "", 0);
3438 PL_bodytarget = NEWSV(0,0);
3439 sv_upgrade(PL_bodytarget, SVt_PVFM);
3440 sv_setpvn(PL_bodytarget, "", 0);
3441 PL_formtarget = PL_bodytarget;
3442 thr->errsv = newSVpvn("", 0);
3443 (void) find_threadsv("@"); /* Ensure $@ is initialised early */
3446 PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
3447 PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
3448 PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
3449 PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
3450 PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
3452 PL_reginterp_cnt = 0;
3456 #endif /* USE_THREADS */
3459 Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
3463 line_t oldline = CopLINE(PL_curcop);
3469 while (AvFILL(paramList) >= 0) {
3470 cv = (CV*)av_shift(paramList);
3472 #ifdef PERL_FLEXIBLE_EXCEPTIONS
3473 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_list_body), cv);
3479 #ifndef PERL_FLEXIBLE_EXCEPTIONS
3483 (void)SvPV(atsv, len);
3486 PL_curcop = &PL_compiling;
3487 CopLINE_set(PL_curcop, oldline);
3488 if (paramList == PL_beginav)
3489 sv_catpv(atsv, "BEGIN failed--compilation aborted");
3491 Perl_sv_catpvf(aTHX_ atsv,
3492 "%s failed--call queue aborted",
3493 paramList == PL_checkav ? "CHECK"
3494 : paramList == PL_initav ? "INIT"
3496 while (PL_scopestack_ix > oldscope)
3499 Perl_croak(aTHX_ "%s", SvPVx(atsv, n_a));
3506 /* my_exit() was called */
3507 while (PL_scopestack_ix > oldscope)
3510 PL_curstash = PL_defstash;
3511 PL_curcop = &PL_compiling;
3512 CopLINE_set(PL_curcop, oldline);
3514 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) {
3515 if (paramList == PL_beginav)
3516 Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
3518 Perl_croak(aTHX_ "%s failed--call queue aborted",
3519 paramList == PL_checkav ? "CHECK"
3520 : paramList == PL_initav ? "INIT"
3527 PL_curcop = &PL_compiling;
3528 CopLINE_set(PL_curcop, oldline);
3531 PerlIO_printf(Perl_error_log, "panic: restartop\n");
3539 #ifdef PERL_FLEXIBLE_EXCEPTIONS
3541 S_vcall_list_body(pTHX_ va_list args)
3543 CV *cv = va_arg(args, CV*);
3544 return call_list_body(cv);
3549 S_call_list_body(pTHX_ CV *cv)
3551 PUSHMARK(PL_stack_sp);
3552 call_sv((SV*)cv, G_EVAL|G_DISCARD);
3557 Perl_my_exit(pTHX_ U32 status)
3561 DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
3562 thr, (unsigned long) status));
3571 STATUS_NATIVE_SET(status);
3578 Perl_my_failure_exit(pTHX)
3581 if (vaxc$errno & 1) {
3582 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
3583 STATUS_NATIVE_SET(44);
3586 if (!vaxc$errno && errno) /* unlikely */
3587 STATUS_NATIVE_SET(44);
3589 STATUS_NATIVE_SET(vaxc$errno);
3594 STATUS_POSIX_SET(errno);
3596 exitstatus = STATUS_POSIX >> 8;
3597 if (exitstatus & 255)
3598 STATUS_POSIX_SET(exitstatus);
3600 STATUS_POSIX_SET(255);
3607 S_my_exit_jump(pTHX)
3610 register PERL_CONTEXT *cx;
3615 SvREFCNT_dec(PL_e_script);
3616 PL_e_script = Nullsv;
3619 POPSTACK_TO(PL_mainstack);
3620 if (cxstack_ix >= 0) {
3623 POPBLOCK(cx,PL_curpm);
3635 read_e_script(pTHXo_ int idx, SV *buf_sv, int maxlen)
3638 p = SvPVX(PL_e_script);
3639 nl = strchr(p, '\n');
3640 nl = (nl) ? nl+1 : SvEND(PL_e_script);
3642 filter_del(read_e_script);
3645 sv_catpvn(buf_sv, p, nl-p);
3646 sv_chop(PL_e_script, nl);