3 * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * "A ship then new they built for him/of mithril and of elven glass" --Bilbo
16 #define PERL_IN_PERL_C
18 #include "patchlevel.h" /* for local_patches */
22 char *nw_get_sitelib(const char *pl);
25 /* XXX If this causes problems, set i_unistd=undef in the hint file. */
42 #if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE) && !defined(PERL_MICRO)
43 char *getenv (char *); /* Usually in <stdlib.h> */
46 static I32 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen);
54 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
60 #if defined(USE_ITHREADS)
61 # define INIT_TLS_AND_INTERP \
63 if (!PL_curinterp) { \
64 PERL_SET_INTERP(my_perl); \
67 PERL_SET_THX(my_perl); \
69 MUTEX_INIT(&PL_dollarzero_mutex); \
72 PERL_SET_THX(my_perl); \
76 # define INIT_TLS_AND_INTERP \
78 if (!PL_curinterp) { \
79 PERL_SET_INTERP(my_perl); \
81 PERL_SET_THX(my_perl); \
85 #ifdef PERL_IMPLICIT_SYS
87 perl_alloc_using(struct IPerlMem* ipM, struct IPerlMem* ipMS,
88 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
89 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
90 struct IPerlDir* ipD, struct IPerlSock* ipS,
91 struct IPerlProc* ipP)
93 PerlInterpreter *my_perl;
94 /* New() needs interpreter, so call malloc() instead */
95 my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
97 Zero(my_perl, 1, PerlInterpreter);
113 =head1 Embedding Functions
115 =for apidoc perl_alloc
117 Allocates a new Perl interpreter. See L<perlembed>.
125 PerlInterpreter *my_perl;
126 #ifdef USE_5005THREADS
130 /* New() needs interpreter, so call malloc() instead */
131 my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
134 Zero(my_perl, 1, PerlInterpreter);
137 #endif /* PERL_IMPLICIT_SYS */
140 =for apidoc perl_construct
142 Initializes a new Perl interpreter. See L<perlembed>.
148 perl_construct(pTHXx)
152 PL_perl_destruct_level = 1;
154 if (PL_perl_destruct_level > 0)
157 /* Init the real globals (and main thread)? */
159 #ifdef PERL_FLEXIBLE_EXCEPTIONS
160 PL_protect = MEMBER_TO_FPTR(Perl_default_protect); /* for exceptions */
163 PL_curcop = &PL_compiling; /* needed by ckWARN, right away */
165 PL_linestr = NEWSV(65,79);
166 sv_upgrade(PL_linestr,SVt_PVIV);
168 if (!SvREADONLY(&PL_sv_undef)) {
169 /* set read-only and try to insure than we wont see REFCNT==0
172 SvREADONLY_on(&PL_sv_undef);
173 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
175 sv_setpv(&PL_sv_no,PL_No);
177 SvREADONLY_on(&PL_sv_no);
178 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
180 sv_setpv(&PL_sv_yes,PL_Yes);
182 SvREADONLY_on(&PL_sv_yes);
183 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
185 SvREADONLY_on(&PL_sv_placeholder);
186 SvREFCNT(&PL_sv_placeholder) = (~(U32)0)/2;
189 PL_sighandlerp = Perl_sighandler;
190 PL_pidstatus = newHV();
193 PL_rs = newSVpvn("\n", 1);
198 PL_lex_state = LEX_NOTPARSING;
204 SET_NUMERIC_STANDARD();
208 PL_patchlevel = NEWSV(0,4);
209 (void)SvUPGRADE(PL_patchlevel, SVt_PVNV);
210 if (PERL_REVISION > 127 || PERL_VERSION > 127 || PERL_SUBVERSION > 127)
211 SvGROW(PL_patchlevel, UTF8_MAXLEN*3+1);
212 s = (U8*)SvPVX(PL_patchlevel);
213 /* Build version strings using "native" characters */
214 s = uvchr_to_utf8(s, (UV)PERL_REVISION);
215 s = uvchr_to_utf8(s, (UV)PERL_VERSION);
216 s = uvchr_to_utf8(s, (UV)PERL_SUBVERSION);
218 SvCUR_set(PL_patchlevel, s - (U8*)SvPVX(PL_patchlevel));
219 SvPOK_on(PL_patchlevel);
220 SvNVX(PL_patchlevel) = (NV)PERL_REVISION +
221 ((NV)PERL_VERSION / (NV)1000) +
222 ((NV)PERL_SUBVERSION / (NV)1000000);
223 SvNOK_on(PL_patchlevel); /* dual valued */
224 SvUTF8_on(PL_patchlevel);
225 SvREADONLY_on(PL_patchlevel);
228 #if defined(LOCAL_PATCH_COUNT)
229 PL_localpatches = local_patches; /* For possible -v */
232 #ifdef HAVE_INTERP_INTERN
236 PerlIO_init(aTHX); /* Hook to IO system */
238 PL_fdpid = newAV(); /* for remembering popen pids by fd */
239 PL_modglobal = newHV(); /* pointers to per-interpreter module globals */
240 PL_errors = newSVpvn("",0);
241 sv_setpvn(PERL_DEBUG_PAD(0), "", 0); /* For regex debugging. */
242 sv_setpvn(PERL_DEBUG_PAD(1), "", 0); /* ext/re needs these */
243 sv_setpvn(PERL_DEBUG_PAD(2), "", 0); /* even without DEBUGGING. */
245 PL_regex_padav = newAV();
246 av_push(PL_regex_padav,(SV*)newAV()); /* First entry is an array of empty elements */
247 PL_regex_pad = AvARRAY(PL_regex_padav);
249 #ifdef USE_REENTRANT_API
250 Perl_reentrant_init(aTHX);
253 /* Note that strtab is a rather special HV. Assumptions are made
254 about not iterating on it, and not adding tie magic to it.
255 It is properly deallocated in perl_destruct() */
258 HvSHAREKEYS_off(PL_strtab); /* mandatory */
259 hv_ksplit(PL_strtab, 512);
261 #if defined(__DYNAMIC__) && (defined(NeXT) || defined(__NeXT__))
262 _dyld_lookup_and_bind
263 ("__environ", (unsigned long *) &environ_pointer, NULL);
266 #ifdef USE_ENVIRON_ARRAY
267 PL_origenviron = environ;
270 /* Use sysconf(_SC_CLK_TCK) if available, if not
271 * available or if the sysconf() fails, use the HZ. */
272 #if defined(HAS_SYSCONF) && defined(_SC_CLK_TCK)
273 PL_clocktick = sysconf(_SC_CLK_TCK);
274 if (PL_clocktick <= 0)
278 PL_stashcache = newHV();
284 =for apidoc nothreadhook
286 Stub that provides thread hook for perl_destruct when there are
293 Perl_nothreadhook(pTHX)
299 =for apidoc perl_destruct
301 Shuts down a Perl interpreter. See L<perlembed>.
309 volatile int destruct_level; /* 0=none, 1=full, 2=full with checks */
311 #ifdef USE_5005THREADS
313 #endif /* USE_5005THREADS */
315 /* wait for all pseudo-forked children to finish */
316 PERL_WAIT_FOR_CHILDREN;
318 destruct_level = PL_perl_destruct_level;
322 if ((s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL"))) {
324 if (destruct_level < i)
331 if(PL_exit_flags & PERL_EXIT_DESTRUCT_END) {
336 if (PL_endav && !PL_minus_c)
337 call_list(PL_scopestack_ix, PL_endav);
343 /* Need to flush since END blocks can produce output */
346 if (CALL_FPTR(PL_threadhook)(aTHX)) {
347 /* Threads hook has vetoed further cleanup */
348 return STATUS_NATIVE_EXPORT;
351 /* We must account for everything. */
353 /* Destroy the main CV and syntax tree */
355 op_free(PL_main_root);
356 PL_main_root = Nullop;
358 PL_curcop = &PL_compiling;
359 PL_main_start = Nullop;
360 SvREFCNT_dec(PL_main_cv);
364 /* Tell PerlIO we are about to tear things apart in case
365 we have layers which are using resources that should
369 PerlIO_destruct(aTHX);
371 if (PL_sv_objcount) {
373 * Try to destruct global references. We do this first so that the
374 * destructors and destructees still exist. Some sv's might remain.
375 * Non-referenced objects are on their own.
380 /* unhook hooks which will soon be, or use, destroyed data */
381 SvREFCNT_dec(PL_warnhook);
382 PL_warnhook = Nullsv;
383 SvREFCNT_dec(PL_diehook);
386 /* call exit list functions */
387 while (PL_exitlistlen-- > 0)
388 PL_exitlist[PL_exitlistlen].fn(aTHX_ PL_exitlist[PL_exitlistlen].ptr);
390 Safefree(PL_exitlist);
395 if (destruct_level == 0){
397 DEBUG_P(debprofdump());
399 #if defined(PERLIO_LAYERS)
400 /* No more IO - including error messages ! */
401 PerlIO_cleanup(aTHX);
404 /* The exit() function will do everything that needs doing. */
405 return STATUS_NATIVE_EXPORT;
408 /* jettison our possibly duplicated environment */
409 /* if PERL_USE_SAFE_PUTENV is defined environ will not have been copied
410 * so we certainly shouldn't free it here
412 #if defined(USE_ENVIRON_ARRAY) && !defined(PERL_USE_SAFE_PUTENV)
413 if (environ != PL_origenviron
415 /* only main thread can free environ[0] contents */
416 && PL_curinterp == aTHX
422 for (i = 0; environ[i]; i++)
423 safesysfree(environ[i]);
425 /* Must use safesysfree() when working with environ. */
426 safesysfree(environ);
428 environ = PL_origenviron;
433 /* the syntax tree is shared between clones
434 * so op_free(PL_main_root) only ReREFCNT_dec's
435 * REGEXPs in the parent interpreter
436 * we need to manually ReREFCNT_dec for the clones
439 I32 i = AvFILLp(PL_regex_padav) + 1;
440 SV **ary = AvARRAY(PL_regex_padav);
444 REGEXP *re = INT2PTR(REGEXP *,SvIVX(resv));
446 if (SvFLAGS(resv) & SVf_BREAK) {
447 /* this is PL_reg_curpm, already freed
448 * flag is set in regexec.c:S_regtry
450 SvFLAGS(resv) &= ~SVf_BREAK;
452 else if(SvREPADTMP(resv)) {
453 SvREPADTMP_off(resv);
460 SvREFCNT_dec(PL_regex_padav);
461 PL_regex_padav = Nullav;
465 SvREFCNT_dec((SV*) PL_stashcache);
466 PL_stashcache = NULL;
468 /* loosen bonds of global variables */
471 (void)PerlIO_close(PL_rsfp);
475 /* Filters for program text */
476 SvREFCNT_dec(PL_rsfp_filters);
477 PL_rsfp_filters = Nullav;
480 PL_preprocess = FALSE;
486 PL_doswitches = FALSE;
487 PL_dowarn = G_WARN_OFF;
488 PL_doextract = FALSE;
489 PL_sawampersand = FALSE; /* must save all match strings */
492 Safefree(PL_inplace);
494 SvREFCNT_dec(PL_patchlevel);
497 SvREFCNT_dec(PL_e_script);
498 PL_e_script = Nullsv;
501 /* magical thingies */
503 SvREFCNT_dec(PL_ofs_sv); /* $, */
506 SvREFCNT_dec(PL_ors_sv); /* $\ */
509 SvREFCNT_dec(PL_rs); /* $/ */
512 PL_multiline = 0; /* $* */
513 Safefree(PL_osname); /* $^O */
516 SvREFCNT_dec(PL_statname);
517 PL_statname = Nullsv;
520 /* defgv, aka *_ should be taken care of elsewhere */
522 /* clean up after study() */
523 SvREFCNT_dec(PL_lastscream);
524 PL_lastscream = Nullsv;
525 Safefree(PL_screamfirst);
527 Safefree(PL_screamnext);
531 Safefree(PL_efloatbuf);
532 PL_efloatbuf = Nullch;
535 /* startup and shutdown function lists */
536 SvREFCNT_dec(PL_beginav);
537 SvREFCNT_dec(PL_beginav_save);
538 SvREFCNT_dec(PL_endav);
539 SvREFCNT_dec(PL_checkav);
540 SvREFCNT_dec(PL_checkav_save);
541 SvREFCNT_dec(PL_initav);
543 PL_beginav_save = Nullav;
546 PL_checkav_save = Nullav;
549 /* shortcuts just get cleared */
555 PL_argvoutgv = Nullgv;
557 PL_stderrgv = Nullgv;
558 PL_last_in_gv = Nullgv;
560 PL_debstash = Nullhv;
562 /* reset so print() ends up where we expect */
565 SvREFCNT_dec(PL_argvout_stack);
566 PL_argvout_stack = Nullav;
568 SvREFCNT_dec(PL_modglobal);
569 PL_modglobal = Nullhv;
570 SvREFCNT_dec(PL_preambleav);
571 PL_preambleav = Nullav;
572 SvREFCNT_dec(PL_subname);
574 SvREFCNT_dec(PL_linestr);
576 SvREFCNT_dec(PL_pidstatus);
577 PL_pidstatus = Nullhv;
578 SvREFCNT_dec(PL_toptarget);
579 PL_toptarget = Nullsv;
580 SvREFCNT_dec(PL_bodytarget);
581 PL_bodytarget = Nullsv;
582 PL_formtarget = Nullsv;
584 /* free locale stuff */
585 #ifdef USE_LOCALE_COLLATE
586 Safefree(PL_collation_name);
587 PL_collation_name = Nullch;
590 #ifdef USE_LOCALE_NUMERIC
591 Safefree(PL_numeric_name);
592 PL_numeric_name = Nullch;
593 SvREFCNT_dec(PL_numeric_radix_sv);
596 /* clear utf8 character classes */
597 SvREFCNT_dec(PL_utf8_alnum);
598 SvREFCNT_dec(PL_utf8_alnumc);
599 SvREFCNT_dec(PL_utf8_ascii);
600 SvREFCNT_dec(PL_utf8_alpha);
601 SvREFCNT_dec(PL_utf8_space);
602 SvREFCNT_dec(PL_utf8_cntrl);
603 SvREFCNT_dec(PL_utf8_graph);
604 SvREFCNT_dec(PL_utf8_digit);
605 SvREFCNT_dec(PL_utf8_upper);
606 SvREFCNT_dec(PL_utf8_lower);
607 SvREFCNT_dec(PL_utf8_print);
608 SvREFCNT_dec(PL_utf8_punct);
609 SvREFCNT_dec(PL_utf8_xdigit);
610 SvREFCNT_dec(PL_utf8_mark);
611 SvREFCNT_dec(PL_utf8_toupper);
612 SvREFCNT_dec(PL_utf8_totitle);
613 SvREFCNT_dec(PL_utf8_tolower);
614 SvREFCNT_dec(PL_utf8_tofold);
615 SvREFCNT_dec(PL_utf8_idstart);
616 SvREFCNT_dec(PL_utf8_idcont);
617 PL_utf8_alnum = Nullsv;
618 PL_utf8_alnumc = Nullsv;
619 PL_utf8_ascii = Nullsv;
620 PL_utf8_alpha = Nullsv;
621 PL_utf8_space = Nullsv;
622 PL_utf8_cntrl = Nullsv;
623 PL_utf8_graph = Nullsv;
624 PL_utf8_digit = Nullsv;
625 PL_utf8_upper = Nullsv;
626 PL_utf8_lower = Nullsv;
627 PL_utf8_print = Nullsv;
628 PL_utf8_punct = Nullsv;
629 PL_utf8_xdigit = Nullsv;
630 PL_utf8_mark = Nullsv;
631 PL_utf8_toupper = Nullsv;
632 PL_utf8_totitle = Nullsv;
633 PL_utf8_tolower = Nullsv;
634 PL_utf8_tofold = Nullsv;
635 PL_utf8_idstart = Nullsv;
636 PL_utf8_idcont = Nullsv;
638 if (!specialWARN(PL_compiling.cop_warnings))
639 SvREFCNT_dec(PL_compiling.cop_warnings);
640 PL_compiling.cop_warnings = Nullsv;
641 if (!specialCopIO(PL_compiling.cop_io))
642 SvREFCNT_dec(PL_compiling.cop_io);
643 PL_compiling.cop_io = Nullsv;
644 CopFILE_free(&PL_compiling);
645 CopSTASH_free(&PL_compiling);
647 /* Prepare to destruct main symbol table. */
652 SvREFCNT_dec(PL_curstname);
653 PL_curstname = Nullsv;
655 /* clear queued errors */
656 SvREFCNT_dec(PL_errors);
660 if (destruct_level >= 2 && ckWARN_d(WARN_INTERNAL)) {
661 if (PL_scopestack_ix != 0)
662 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
663 "Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
664 (long)PL_scopestack_ix);
665 if (PL_savestack_ix != 0)
666 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
667 "Unbalanced saves: %ld more saves than restores\n",
668 (long)PL_savestack_ix);
669 if (PL_tmps_floor != -1)
670 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced tmps: %ld more allocs than frees\n",
671 (long)PL_tmps_floor + 1);
672 if (cxstack_ix != -1)
673 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced context: %ld more PUSHes than POPs\n",
674 (long)cxstack_ix + 1);
677 /* Now absolutely destruct everything, somehow or other, loops or no. */
678 SvFLAGS(PL_fdpid) |= SVTYPEMASK; /* don't clean out pid table now */
679 SvFLAGS(PL_strtab) |= SVTYPEMASK; /* don't clean out strtab now */
681 /* the 2 is for PL_fdpid and PL_strtab */
682 while (PL_sv_count > 2 && sv_clean_all())
685 SvFLAGS(PL_fdpid) &= ~SVTYPEMASK;
686 SvFLAGS(PL_fdpid) |= SVt_PVAV;
687 SvFLAGS(PL_strtab) &= ~SVTYPEMASK;
688 SvFLAGS(PL_strtab) |= SVt_PVHV;
690 AvREAL_off(PL_fdpid); /* no surviving entries */
691 SvREFCNT_dec(PL_fdpid); /* needed in io_close() */
694 #ifdef HAVE_INTERP_INTERN
698 /* Destruct the global string table. */
700 /* Yell and reset the HeVAL() slots that are still holding refcounts,
701 * so that sv_free() won't fail on them.
709 max = HvMAX(PL_strtab);
710 array = HvARRAY(PL_strtab);
713 if (hent && ckWARN_d(WARN_INTERNAL)) {
714 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
715 "Unbalanced string table refcount: (%d) for \"%s\"",
716 HeVAL(hent) - Nullsv, HeKEY(hent));
717 HeVAL(hent) = Nullsv;
727 SvREFCNT_dec(PL_strtab);
730 /* free the pointer table used for cloning */
731 ptr_table_free(PL_ptr_table);
734 /* free special SVs */
736 SvREFCNT(&PL_sv_yes) = 0;
737 sv_clear(&PL_sv_yes);
738 SvANY(&PL_sv_yes) = NULL;
739 SvFLAGS(&PL_sv_yes) = 0;
741 SvREFCNT(&PL_sv_no) = 0;
743 SvANY(&PL_sv_no) = NULL;
744 SvFLAGS(&PL_sv_no) = 0;
748 for (i=0; i<=2; i++) {
749 SvREFCNT(PERL_DEBUG_PAD(i)) = 0;
750 sv_clear(PERL_DEBUG_PAD(i));
751 SvANY(PERL_DEBUG_PAD(i)) = NULL;
752 SvFLAGS(PERL_DEBUG_PAD(i)) = 0;
756 if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL))
757 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Scalars leaked: %ld\n", (long)PL_sv_count);
759 #ifdef DEBUG_LEAKING_SCALARS
760 if (PL_sv_count != 0) {
765 for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
766 svend = &sva[SvREFCNT(sva)];
767 for (sv = sva + 1; sv < svend; ++sv) {
768 if (SvTYPE(sv) != SVTYPEMASK) {
769 PerlIO_printf(Perl_debug_log, "leaked: 0x%p\n", sv);
777 #if defined(PERLIO_LAYERS)
778 /* No more IO - including error messages ! */
779 PerlIO_cleanup(aTHX);
782 /* sv_undef needs to stay immortal until after PerlIO_cleanup
783 as currently layers use it rather than Nullsv as a marker
784 for no arg - and will try and SvREFCNT_dec it.
786 SvREFCNT(&PL_sv_undef) = 0;
787 SvREADONLY_off(&PL_sv_undef);
789 SvREFCNT(&PL_sv_placeholder) = 0;
790 SvREADONLY_off(&PL_sv_placeholder);
792 Safefree(PL_origfilename);
793 Safefree(PL_reg_start_tmp);
795 Safefree(PL_reg_curpm);
796 Safefree(PL_reg_poscache);
798 Safefree(PL_op_mask);
799 Safefree(PL_psig_ptr);
800 Safefree(PL_psig_name);
801 Safefree(PL_bitcount);
802 Safefree(PL_psig_pend);
804 PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */
806 DEBUG_P(debprofdump());
808 #ifdef USE_REENTRANT_API
809 Perl_reentrant_free(aTHX);
814 /* As the absolutely last thing, free the non-arena SV for mess() */
817 /* it could have accumulated taint magic */
818 if (SvTYPE(PL_mess_sv) >= SVt_PVMG) {
821 for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) {
822 moremagic = mg->mg_moremagic;
823 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global
825 Safefree(mg->mg_ptr);
829 /* we know that type >= SVt_PV */
830 (void)SvOOK_off(PL_mess_sv);
831 Safefree(SvPVX(PL_mess_sv));
832 Safefree(SvANY(PL_mess_sv));
833 Safefree(PL_mess_sv);
836 return STATUS_NATIVE_EXPORT;
840 =for apidoc perl_free
842 Releases a Perl interpreter. See L<perlembed>.
850 #if defined(WIN32) || defined(NETWARE)
851 # if defined(PERL_IMPLICIT_SYS)
853 void *host = nw_internal_host;
855 void *host = w32_internal_host;
859 nw_delete_internal_host(host);
861 win32_delete_internal_host(host);
872 Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
874 Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry);
875 PL_exitlist[PL_exitlistlen].fn = fn;
876 PL_exitlist[PL_exitlistlen].ptr = ptr;
881 =for apidoc perl_parse
883 Tells a Perl interpreter to parse a Perl script. See L<perlembed>.
889 perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
894 #ifdef USE_5005THREADS
898 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
901 Perl_croak(aTHX_ "suidperl is no longer needed since the kernel can now execute\n\
902 setuid perl scripts securely.\n");
906 #if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT)
907 /* [perl #22371] Algorimic Complexity Attack on Perl 5.6.1, 5.8.0
908 * This MUST be done before any hash stores or fetches take place.
909 * If you set PL_hash_seed (and assumedly also PL_hash_seed_set) yourself,
910 * it is your responsibility to provide a good random seed!
911 * You can also define PERL_HASH_SEED in compile time, see hv.h. */
912 if (!PL_hash_seed_set)
913 PL_hash_seed = get_hash_seed();
915 char *s = PerlEnv_getenv("PERL_HASH_SEED_DEBUG");
921 PerlIO_printf(Perl_debug_log, "HASH_SEED = %"UVuf"\n",
925 #endif /* #if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT) */
931 /* Set PL_origalen be the sum of the contiguous argv[]
932 * elements plus the size of the env in case that it is
933 * contiguous with the argv[]. This is used in mg.c:mg_set()
934 * as the maximum modifiable length of $0. In the worst case
935 * the area we are able to modify is limited to the size of
936 * the original argv[0]. (See below for 'contiguous', though.)
941 ~(UV)(PTRSIZE == 4 ? 3 : PTRSIZE == 8 ? 7 : PTRSIZE == 16 ? 15 : 0);
942 /* Do the mask check only if the args seem like aligned. */
944 (mask < ~(UV)0) && ((PTR2UV(argv[0]) & mask) == PTR2UV(argv[0]));
946 /* See if all the arguments are contiguous in memory. Note
947 * that 'contiguous' is a loose term because some platforms
948 * align the argv[] and the envp[]. If the arguments look
949 * like non-aligned, assume that they are 'strictly' or
950 * 'traditionally' contiguous. If the arguments look like
951 * aligned, we just check that they are within aligned
952 * PTRSIZE bytes. As long as no system has something bizarre
953 * like the argv[] interleaved with some other data, we are
954 * fine. (Did I just evoke Murphy's Law?) --jhi */
955 if (PL_origargv && PL_origargc >= 1 && (s = PL_origargv[0])) {
957 for (i = 1; i < PL_origargc; i++) {
958 if ((PL_origargv[i] == s + 1
960 || PL_origargv[i] == s + 2
965 (PL_origargv[i] > s &&
967 INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
977 /* Can we grab env area too to be used as the area for $0? */
978 if (PL_origenviron) {
979 if ((PL_origenviron[0] == s + 1
981 || (PL_origenviron[0] == s + 9 && (s += 8))
986 (PL_origenviron[0] > s &&
988 INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
992 s = PL_origenviron[0];
995 my_setenv("NoNe SuCh", Nullch);
996 /* Force copy of environment. */
997 for (i = 1; PL_origenviron[i]; i++) {
998 if (PL_origenviron[i] == s + 1
1001 (PL_origenviron[i] > s &&
1002 PL_origenviron[i] <=
1003 INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
1006 s = PL_origenviron[i];
1014 PL_origalen = s - PL_origargv[0];
1019 /* Come here if running an undumped a.out. */
1021 PL_origfilename = savepv(argv[0]);
1022 PL_do_undump = FALSE;
1023 cxstack_ix = -1; /* start label stack again */
1025 init_postdump_symbols(argc,argv,env);
1030 op_free(PL_main_root);
1031 PL_main_root = Nullop;
1033 PL_main_start = Nullop;
1034 SvREFCNT_dec(PL_main_cv);
1035 PL_main_cv = Nullcv;
1038 oldscope = PL_scopestack_ix;
1039 PL_dowarn = G_WARN_OFF;
1041 #ifdef PERL_FLEXIBLE_EXCEPTIONS
1042 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vparse_body), env, xsinit);
1048 #ifndef PERL_FLEXIBLE_EXCEPTIONS
1049 parse_body(env,xsinit);
1052 call_list(oldscope, PL_checkav);
1059 /* my_exit() was called */
1060 while (PL_scopestack_ix > oldscope)
1063 PL_curstash = PL_defstash;
1065 call_list(oldscope, PL_checkav);
1066 ret = STATUS_NATIVE_EXPORT;
1069 PerlIO_printf(Perl_error_log, "panic: top_env\n");
1077 #ifdef PERL_FLEXIBLE_EXCEPTIONS
1079 S_vparse_body(pTHX_ va_list args)
1081 char **env = va_arg(args, char**);
1082 XSINIT_t xsinit = va_arg(args, XSINIT_t);
1084 return parse_body(env, xsinit);
1089 S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
1091 int argc = PL_origargc;
1092 char **argv = PL_origargv;
1093 char *scriptname = NULL;
1095 VOL bool dosearch = FALSE;
1096 char *validarg = "";
1099 char *cddir = Nullch;
1101 sv_setpvn(PL_linestr,"",0);
1102 sv = newSVpvn("",0); /* first used for -I flags */
1106 for (argc--,argv++; argc > 0; argc--,argv++) {
1107 if (argv[0][0] != '-' || !argv[0][1])
1111 validarg = " PHOOEY ";
1119 #ifndef PERL_STRICT_CR
1144 if ((s = moreswitches(s)))
1149 CHECK_MALLOC_TOO_LATE_FOR('t');
1150 if( !PL_tainting ) {
1151 PL_taint_warn = TRUE;
1157 CHECK_MALLOC_TOO_LATE_FOR('T');
1159 PL_taint_warn = FALSE;
1164 #ifdef MACOS_TRADITIONAL
1165 /* ignore -e for Dev:Pseudo argument */
1166 if (argv[1] && !strcmp(argv[1], "Dev:Pseudo"))
1169 if (PL_euid != PL_uid || PL_egid != PL_gid)
1170 Perl_croak(aTHX_ "No -e allowed in setuid scripts");
1172 PL_e_script = newSVpvn("",0);
1173 filter_add(read_e_script, NULL);
1176 sv_catpv(PL_e_script, s);
1178 sv_catpv(PL_e_script, argv[1]);
1182 Perl_croak(aTHX_ "No code specified for -e");
1183 sv_catpv(PL_e_script, "\n");
1186 case 'I': /* -I handled both here and in moreswitches() */
1188 if (!*++s && (s=argv[1]) != Nullch) {
1193 STRLEN len = strlen(s);
1194 p = savepvn(s, len);
1195 incpush(p, TRUE, TRUE, FALSE);
1196 sv_catpvn(sv, "-I", 2);
1197 sv_catpvn(sv, p, len);
1198 sv_catpvn(sv, " ", 1);
1202 Perl_croak(aTHX_ "No directory specified for -I");
1206 PL_preprocess = TRUE;
1216 PL_preambleav = newAV();
1217 av_push(PL_preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
1219 PL_Sv = newSVpv("print myconfig();",0);
1221 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
1223 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
1225 sv_catpv(PL_Sv,"\" Compile-time options:");
1227 sv_catpv(PL_Sv," DEBUGGING");
1229 # ifdef MULTIPLICITY
1230 sv_catpv(PL_Sv," MULTIPLICITY");
1232 # ifdef USE_5005THREADS
1233 sv_catpv(PL_Sv," USE_5005THREADS");
1235 # ifdef USE_ITHREADS
1236 sv_catpv(PL_Sv," USE_ITHREADS");
1238 # ifdef USE_64_BIT_INT
1239 sv_catpv(PL_Sv," USE_64_BIT_INT");
1241 # ifdef USE_64_BIT_ALL
1242 sv_catpv(PL_Sv," USE_64_BIT_ALL");
1244 # ifdef USE_LONG_DOUBLE
1245 sv_catpv(PL_Sv," USE_LONG_DOUBLE");
1247 # ifdef USE_LARGE_FILES
1248 sv_catpv(PL_Sv," USE_LARGE_FILES");
1251 sv_catpv(PL_Sv," USE_SOCKS");
1253 # ifdef PERL_IMPLICIT_CONTEXT
1254 sv_catpv(PL_Sv," PERL_IMPLICIT_CONTEXT");
1256 # ifdef PERL_IMPLICIT_SYS
1257 sv_catpv(PL_Sv," PERL_IMPLICIT_SYS");
1259 sv_catpv(PL_Sv,"\\n\",");
1261 #if defined(LOCAL_PATCH_COUNT)
1262 if (LOCAL_PATCH_COUNT > 0) {
1264 sv_catpv(PL_Sv,"\" Locally applied patches:\\n\",");
1265 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
1266 if (PL_localpatches[i])
1267 Perl_sv_catpvf(aTHX_ PL_Sv,"q\" \t%s\n\",",PL_localpatches[i]);
1271 Perl_sv_catpvf(aTHX_ PL_Sv,"\" Built under %s\\n\"",OSNAME);
1274 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
1276 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled on %s\\n\"",__DATE__);
1279 sv_catpv(PL_Sv, "; \
1281 @env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; ");
1284 push @env, \"CYGWIN=\\\"$ENV{CYGWIN}\\\"\";");
1287 print \" \\%ENV:\\n @env\\n\" if @env; \
1288 print \" \\@INC:\\n @INC\\n\";");
1291 PL_Sv = newSVpv("config_vars(qw(",0);
1292 sv_catpv(PL_Sv, ++s);
1293 sv_catpv(PL_Sv, "))");
1296 av_push(PL_preambleav, PL_Sv);
1297 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
1300 PL_doextract = TRUE;
1308 if (!*++s || isSPACE(*s)) {
1312 /* catch use of gnu style long options */
1313 if (strEQ(s, "version")) {
1317 if (strEQ(s, "help")) {
1324 Perl_croak(aTHX_ "Unrecognized switch: -%s (-h will show valid options)",s);
1328 sv_setsv(get_sv("/", TRUE), PL_rs);
1331 #ifndef SECURE_INTERNAL_GETENV
1334 (s = PerlEnv_getenv("PERL5OPT")))
1339 if (*s == '-' && *(s+1) == 'T') {
1340 CHECK_MALLOC_TOO_LATE_FOR('T');
1342 PL_taint_warn = FALSE;
1345 char *popt_copy = Nullch;
1358 if (!strchr("DIMUdmtwA", *s))
1359 Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
1363 popt_copy = SvPVX(sv_2mortal(newSVpv(popt,0)));
1364 s = popt_copy + (s - popt);
1365 d = popt_copy + (d - popt);
1372 if( !PL_tainting ) {
1373 PL_taint_warn = TRUE;
1383 if (PL_taint_warn && PL_dowarn != G_WARN_ALL_OFF) {
1384 PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
1388 scriptname = argv[0];
1391 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
1393 else if (scriptname == Nullch) {
1395 if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
1403 open_script(scriptname,dosearch,sv,&fdscript);
1405 validate_suid(validarg, scriptname,fdscript);
1408 #if defined(SIGCHLD) || defined(SIGCLD)
1411 # define SIGCHLD SIGCLD
1413 Sighandler_t sigstate = rsignal_state(SIGCHLD);
1414 if (sigstate == SIG_IGN) {
1415 if (ckWARN(WARN_SIGNAL))
1416 Perl_warner(aTHX_ packWARN(WARN_SIGNAL),
1417 "Can't ignore signal CHLD, forcing to default");
1418 (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL);
1424 #ifdef MACOS_TRADITIONAL
1425 if (PL_doextract || gMacPerl_AlwaysExtract) {
1430 if (cddir && PerlDir_chdir(cddir) < 0)
1431 Perl_croak(aTHX_ "Can't chdir to %s",cddir);
1435 PL_main_cv = PL_compcv = (CV*)NEWSV(1104,0);
1436 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
1437 CvUNIQUE_on(PL_compcv);
1439 CvPADLIST(PL_compcv) = pad_new(0);
1440 #ifdef USE_5005THREADS
1441 CvOWNER(PL_compcv) = 0;
1442 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
1443 MUTEX_INIT(CvMUTEXP(PL_compcv));
1444 #endif /* USE_5005THREADS */
1447 boot_core_UNIVERSAL();
1449 boot_core_xsutils();
1453 (*xsinit)(aTHX); /* in case linked C routines want magical variables */
1455 #if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__) || defined(EPOC)
1461 # ifdef HAS_SOCKS5_INIT
1462 socks5_init(argv[0]);
1468 init_predump_symbols();
1469 /* init_postdump_symbols not currently designed to be called */
1470 /* more than once (ENV isn't cleared first, for example) */
1471 /* But running with -u leaves %ENV & @ARGV undefined! XXX */
1473 init_postdump_symbols(argc,argv,env);
1475 /* PL_unicode is turned on by -C or by $ENV{PERL_UNICODE}.
1476 * PL_utf8locale is conditionally turned on by
1477 * locale.c:Perl_init_i18nl10n() if the environment
1478 * look like the user wants to use UTF-8. */
1480 /* Requires init_predump_symbols(). */
1481 if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
1486 /* Turn on UTF-8-ness on STDIN, STDOUT, STDERR
1487 * and the default open disciplines. */
1488 if ((PL_unicode & PERL_UNICODE_STDIN_FLAG) &&
1489 PL_stdingv && (io = GvIO(PL_stdingv)) &&
1491 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
1492 if ((PL_unicode & PERL_UNICODE_STDOUT_FLAG) &&
1493 PL_defoutgv && (io = GvIO(PL_defoutgv)) &&
1495 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
1496 if ((PL_unicode & PERL_UNICODE_STDERR_FLAG) &&
1497 PL_stderrgv && (io = GvIO(PL_stderrgv)) &&
1499 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
1500 if ((PL_unicode & PERL_UNICODE_INOUT_FLAG) &&
1501 (sv = GvSV(gv_fetchpv("\017PEN", TRUE, SVt_PV)))) {
1502 U32 in = PL_unicode & PERL_UNICODE_IN_FLAG;
1503 U32 out = PL_unicode & PERL_UNICODE_OUT_FLAG;
1506 sv_setpvn(sv, ":utf8\0:utf8", 11);
1508 sv_setpvn(sv, ":utf8\0", 6);
1511 sv_setpvn(sv, "\0:utf8", 6);
1517 if ((s = PerlEnv_getenv("PERL_SIGNALS"))) {
1518 if (strEQ(s, "unsafe"))
1519 PL_signals |= PERL_SIGNALS_UNSAFE_FLAG;
1520 else if (strEQ(s, "safe"))
1521 PL_signals &= ~PERL_SIGNALS_UNSAFE_FLAG;
1523 Perl_croak(aTHX_ "PERL_SIGNALS illegal: \"%s\"", s);
1528 /* now parse the script */
1530 SETERRNO(0,SS_NORMAL);
1532 #ifdef MACOS_TRADITIONAL
1533 if (gMacPerl_SyntaxError = (yyparse() || PL_error_count)) {
1535 Perl_croak(aTHX_ "%s had compilation errors.\n", MacPerl_MPWFileName(PL_origfilename));
1537 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
1538 MacPerl_MPWFileName(PL_origfilename));
1542 if (yyparse() || PL_error_count) {
1544 Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
1546 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
1551 CopLINE_set(PL_curcop, 0);
1552 PL_curstash = PL_defstash;
1553 PL_preprocess = FALSE;
1555 SvREFCNT_dec(PL_e_script);
1556 PL_e_script = Nullsv;
1563 SAVECOPFILE(PL_curcop);
1564 SAVECOPLINE(PL_curcop);
1565 gv_check(PL_defstash);
1572 if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
1573 dump_mstats("after compilation:");
1582 =for apidoc perl_run
1584 Tells a Perl interpreter to run. See L<perlembed>.
1595 #ifdef USE_5005THREADS
1599 oldscope = PL_scopestack_ix;
1604 #ifdef PERL_FLEXIBLE_EXCEPTIONS
1606 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vrun_body), oldscope);
1612 cxstack_ix = -1; /* start context stack again */
1614 case 0: /* normal completion */
1615 #ifndef PERL_FLEXIBLE_EXCEPTIONS
1620 case 2: /* my_exit() */
1621 while (PL_scopestack_ix > oldscope)
1624 PL_curstash = PL_defstash;
1625 if (!(PL_exit_flags & PERL_EXIT_DESTRUCT_END) &&
1626 PL_endav && !PL_minus_c)
1627 call_list(oldscope, PL_endav);
1629 if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
1630 dump_mstats("after execution: ");
1632 ret = STATUS_NATIVE_EXPORT;
1636 POPSTACK_TO(PL_mainstack);
1639 PerlIO_printf(Perl_error_log, "panic: restartop\n");
1649 #ifdef PERL_FLEXIBLE_EXCEPTIONS
1651 S_vrun_body(pTHX_ va_list args)
1653 I32 oldscope = va_arg(args, I32);
1655 return run_body(oldscope);
1661 S_run_body(pTHX_ I32 oldscope)
1663 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
1664 PL_sawampersand ? "Enabling" : "Omitting"));
1666 if (!PL_restartop) {
1667 DEBUG_x(dump_all());
1668 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
1669 DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%"UVxf"\n",
1673 #ifdef MACOS_TRADITIONAL
1674 PerlIO_printf(Perl_error_log, "%s%s syntax OK\n",
1675 (gMacPerl_ErrorFormat ? "# " : ""),
1676 MacPerl_MPWFileName(PL_origfilename));
1678 PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
1682 if (PERLDB_SINGLE && PL_DBsingle)
1683 sv_setiv(PL_DBsingle, 1);
1685 call_list(oldscope, PL_initav);
1691 PL_op = PL_restartop;
1695 else if (PL_main_start) {
1696 CvDEPTH(PL_main_cv) = 1;
1697 PL_op = PL_main_start;
1707 =head1 SV Manipulation Functions
1709 =for apidoc p||get_sv
1711 Returns the SV of the specified Perl scalar. If C<create> is set and the
1712 Perl variable does not exist then it will be created. If C<create> is not
1713 set and the variable does not exist then NULL is returned.
1719 Perl_get_sv(pTHX_ const char *name, I32 create)
1722 #ifdef USE_5005THREADS
1723 if (name[1] == '\0' && !isALPHA(name[0])) {
1724 PADOFFSET tmp = find_threadsv(name);
1725 if (tmp != NOT_IN_PAD)
1726 return THREADSV(tmp);
1728 #endif /* USE_5005THREADS */
1729 gv = gv_fetchpv(name, create, SVt_PV);
1736 =head1 Array Manipulation Functions
1738 =for apidoc p||get_av
1740 Returns the AV of the specified Perl array. If C<create> is set and the
1741 Perl variable does not exist then it will be created. If C<create> is not
1742 set and the variable does not exist then NULL is returned.
1748 Perl_get_av(pTHX_ const char *name, I32 create)
1750 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1759 =head1 Hash Manipulation Functions
1761 =for apidoc p||get_hv
1763 Returns the HV of the specified Perl hash. If C<create> is set and the
1764 Perl variable does not exist then it will be created. If C<create> is not
1765 set and the variable does not exist then NULL is returned.
1771 Perl_get_hv(pTHX_ const char *name, I32 create)
1773 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1782 =head1 CV Manipulation Functions
1784 =for apidoc p||get_cv
1786 Returns the CV of the specified Perl subroutine. If C<create> is set and
1787 the Perl subroutine does not exist then it will be declared (which has the
1788 same effect as saying C<sub name;>). If C<create> is not set and the
1789 subroutine does not exist then NULL is returned.
1795 Perl_get_cv(pTHX_ const char *name, I32 create)
1797 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
1798 /* XXX unsafe for threads if eval_owner isn't held */
1799 /* XXX this is probably not what they think they're getting.
1800 * It has the same effect as "sub name;", i.e. just a forward
1802 if (create && !GvCVu(gv))
1803 return newSUB(start_subparse(FALSE, 0),
1804 newSVOP(OP_CONST, 0, newSVpv(name,0)),
1812 /* Be sure to refetch the stack pointer after calling these routines. */
1816 =head1 Callback Functions
1818 =for apidoc p||call_argv
1820 Performs a callback to the specified Perl sub. See L<perlcall>.
1826 Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv)
1828 /* See G_* flags in cop.h */
1829 /* null terminated arg list */
1836 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
1841 return call_pv(sub_name, flags);
1845 =for apidoc p||call_pv
1847 Performs a callback to the specified Perl sub. See L<perlcall>.
1853 Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
1854 /* name of the subroutine */
1855 /* See G_* flags in cop.h */
1857 return call_sv((SV*)get_cv(sub_name, TRUE), flags);
1861 =for apidoc p||call_method
1863 Performs a callback to the specified Perl method. The blessed object must
1864 be on the stack. See L<perlcall>.
1870 Perl_call_method(pTHX_ const char *methname, I32 flags)
1871 /* name of the subroutine */
1872 /* See G_* flags in cop.h */
1874 return call_sv(sv_2mortal(newSVpv(methname,0)), flags | G_METHOD);
1877 /* May be called with any of a CV, a GV, or an SV containing the name. */
1879 =for apidoc p||call_sv
1881 Performs a callback to the Perl sub whose name is in the SV. See
1888 Perl_call_sv(pTHX_ SV *sv, I32 flags)
1889 /* See G_* flags in cop.h */
1892 LOGOP myop; /* fake syntax tree node */
1895 volatile I32 retval = 0;
1897 bool oldcatch = CATCH_GET;
1902 if (flags & G_DISCARD) {
1907 Zero(&myop, 1, LOGOP);
1908 myop.op_next = Nullop;
1909 if (!(flags & G_NOARGS))
1910 myop.op_flags |= OPf_STACKED;
1911 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1912 (flags & G_ARRAY) ? OPf_WANT_LIST :
1917 EXTEND(PL_stack_sp, 1);
1918 *++PL_stack_sp = sv;
1920 oldscope = PL_scopestack_ix;
1922 if (PERLDB_SUB && PL_curstash != PL_debstash
1923 /* Handle first BEGIN of -d. */
1924 && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
1925 /* Try harder, since this may have been a sighandler, thus
1926 * curstash may be meaningless. */
1927 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != PL_debstash)
1928 && !(flags & G_NODEBUG))
1929 PL_op->op_private |= OPpENTERSUB_DB;
1931 if (flags & G_METHOD) {
1932 Zero(&method_op, 1, UNOP);
1933 method_op.op_next = PL_op;
1934 method_op.op_ppaddr = PL_ppaddr[OP_METHOD];
1935 myop.op_ppaddr = PL_ppaddr[OP_ENTERSUB];
1936 PL_op = (OP*)&method_op;
1939 if (!(flags & G_EVAL)) {
1941 call_body((OP*)&myop, FALSE);
1942 retval = PL_stack_sp - (PL_stack_base + oldmark);
1943 CATCH_SET(oldcatch);
1946 myop.op_other = (OP*)&myop;
1948 /* we're trying to emulate pp_entertry() here */
1950 register PERL_CONTEXT *cx;
1951 I32 gimme = GIMME_V;
1956 push_return(Nullop);
1957 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
1959 PL_eval_root = PL_op; /* Only needed so that goto works right. */
1961 PL_in_eval = EVAL_INEVAL;
1962 if (flags & G_KEEPERR)
1963 PL_in_eval |= EVAL_KEEPERR;
1969 #ifdef PERL_FLEXIBLE_EXCEPTIONS
1971 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_body),
1978 #ifndef PERL_FLEXIBLE_EXCEPTIONS
1980 call_body((OP*)&myop, FALSE);
1982 retval = PL_stack_sp - (PL_stack_base + oldmark);
1983 if (!(flags & G_KEEPERR))
1990 /* my_exit() was called */
1991 PL_curstash = PL_defstash;
1994 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
1995 Perl_croak(aTHX_ "Callback called exit");
2000 PL_op = PL_restartop;
2004 PL_stack_sp = PL_stack_base + oldmark;
2005 if (flags & G_ARRAY)
2009 *++PL_stack_sp = &PL_sv_undef;
2014 if (PL_scopestack_ix > oldscope) {
2018 register PERL_CONTEXT *cx;
2030 if (flags & G_DISCARD) {
2031 PL_stack_sp = PL_stack_base + oldmark;
2040 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2042 S_vcall_body(pTHX_ va_list args)
2044 OP *myop = va_arg(args, OP*);
2045 int is_eval = va_arg(args, int);
2047 call_body(myop, is_eval);
2053 S_call_body(pTHX_ OP *myop, int is_eval)
2055 if (PL_op == myop) {
2057 PL_op = Perl_pp_entereval(aTHX); /* this doesn't do a POPMARK */
2059 PL_op = Perl_pp_entersub(aTHX); /* this does */
2065 /* Eval a string. The G_EVAL flag is always assumed. */
2068 =for apidoc p||eval_sv
2070 Tells Perl to C<eval> the string in the SV.
2076 Perl_eval_sv(pTHX_ SV *sv, I32 flags)
2078 /* See G_* flags in cop.h */
2081 UNOP myop; /* fake syntax tree node */
2082 volatile I32 oldmark = SP - PL_stack_base;
2083 volatile I32 retval = 0;
2089 if (flags & G_DISCARD) {
2096 Zero(PL_op, 1, UNOP);
2097 EXTEND(PL_stack_sp, 1);
2098 *++PL_stack_sp = sv;
2099 oldscope = PL_scopestack_ix;
2101 if (!(flags & G_NOARGS))
2102 myop.op_flags = OPf_STACKED;
2103 myop.op_next = Nullop;
2104 myop.op_type = OP_ENTEREVAL;
2105 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
2106 (flags & G_ARRAY) ? OPf_WANT_LIST :
2108 if (flags & G_KEEPERR)
2109 myop.op_flags |= OPf_SPECIAL;
2111 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2113 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_body),
2120 #ifndef PERL_FLEXIBLE_EXCEPTIONS
2122 call_body((OP*)&myop,TRUE);
2124 retval = PL_stack_sp - (PL_stack_base + oldmark);
2125 if (!(flags & G_KEEPERR))
2132 /* my_exit() was called */
2133 PL_curstash = PL_defstash;
2136 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
2137 Perl_croak(aTHX_ "Callback called exit");
2142 PL_op = PL_restartop;
2146 PL_stack_sp = PL_stack_base + oldmark;
2147 if (flags & G_ARRAY)
2151 *++PL_stack_sp = &PL_sv_undef;
2157 if (flags & G_DISCARD) {
2158 PL_stack_sp = PL_stack_base + oldmark;
2168 =for apidoc p||eval_pv
2170 Tells Perl to C<eval> the given string and return an SV* result.
2176 Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
2179 SV* sv = newSVpv(p, 0);
2181 eval_sv(sv, G_SCALAR);
2188 if (croak_on_error && SvTRUE(ERRSV)) {
2190 Perl_croak(aTHX_ SvPVx(ERRSV, n_a));
2196 /* Require a module. */
2199 =head1 Embedding Functions
2201 =for apidoc p||require_pv
2203 Tells Perl to C<require> the file named by the string argument. It is
2204 analogous to the Perl code C<eval "require '$file'">. It's even
2205 implemented that way; consider using load_module instead.
2210 Perl_require_pv(pTHX_ const char *pv)
2214 PUSHSTACKi(PERLSI_REQUIRE);
2216 sv = sv_newmortal();
2217 sv_setpv(sv, "require '");
2220 eval_sv(sv, G_DISCARD);
2226 Perl_magicname(pTHX_ char *sym, char *name, I32 namlen)
2230 if ((gv = gv_fetchpv(sym,TRUE, SVt_PV)))
2231 sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, namlen);
2235 S_usage(pTHX_ char *name) /* XXX move this out into a module ? */
2237 /* This message really ought to be max 23 lines.
2238 * Removed -h because the user already knows that option. Others? */
2240 static char *usage_msg[] = {
2241 "-0[octal] specify record separator (\\0, if no argument)",
2242 "-a autosplit mode with -n or -p (splits $_ into @F)",
2243 "-C enable native wide character system interfaces",
2244 "-c check syntax only (runs BEGIN and CHECK blocks)",
2245 "-d[:debugger] run program under debugger",
2246 "-D[number/list] set debugging flags (argument is a bit mask or alphabets)",
2247 "-e 'command' one line of program (several -e's allowed, omit programfile)",
2248 "-F/pattern/ split() pattern for -a switch (//'s are optional)",
2249 "-i[extension] edit <> files in place (makes backup if extension supplied)",
2250 "-Idirectory specify @INC/#include directory (several -I's allowed)",
2251 "-l[octal] enable line ending processing, specifies line terminator",
2252 "-[mM][-]module execute `use/no module...' before executing program",
2253 "-n assume 'while (<>) { ... }' loop around program",
2254 "-p assume loop like -n but print line also, like sed",
2255 "-P run program through C preprocessor before compilation",
2256 "-s enable rudimentary parsing for switches after programfile",
2257 "-S look for programfile using PATH environment variable",
2258 "-T enable tainting checks",
2259 "-t enable tainting warnings",
2260 "-u dump core after parsing program",
2261 "-U allow unsafe operations",
2262 "-v print version, subversion (includes VERY IMPORTANT perl info)",
2263 "-V[:variable] print configuration summary (or a single Config.pm variable)",
2264 "-w enable many useful warnings (RECOMMENDED)",
2265 "-W enable all warnings",
2266 "-X disable all warnings",
2267 "-x[directory] strip off text before #!perl line and perhaps cd to directory",
2271 char **p = usage_msg;
2273 PerlIO_printf(PerlIO_stdout(),
2274 "\nUsage: %s [switches] [--] [programfile] [arguments]",
2277 PerlIO_printf(PerlIO_stdout(), "\n %s", *p++);
2280 /* convert a string of -D options (or digits) into an int.
2281 * sets *s to point to the char after the options */
2285 Perl_get_debug_opts(pTHX_ char **s)
2289 /* if adding extra options, remember to update DEBUG_MASK */
2290 static char debopts[] = "psltocPmfrxu HXDSTRJvC";
2292 for (; isALNUM(**s); (*s)++) {
2293 char *d = strchr(debopts,**s);
2295 i |= 1 << (d - debopts);
2296 else if (ckWARN_d(WARN_DEBUGGING))
2297 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
2298 "invalid option -D%c\n", **s);
2303 for (; isALNUM(**s); (*s)++) ;
2306 if ((i & DEBUG_p_FLAG) && ckWARN_d(WARN_DEBUGGING))
2307 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
2308 "-Dp not implemented on this platform\n");
2314 /* This routine handles any switches that can be given during run */
2317 Perl_moreswitches(pTHX_ char *s)
2327 SvREFCNT_dec(PL_rs);
2328 if (s[1] == 'x' && s[2]) {
2332 for (s += 2, e = s; *e; e++);
2334 flags = PERL_SCAN_SILENT_ILLDIGIT;
2335 rschar = (U32)grok_hex(s, &numlen, &flags, NULL);
2336 if (s + numlen < e) {
2337 rschar = 0; /* Grandfather -0xFOO as -0 -xFOO. */
2341 PL_rs = newSVpvn("", 0);
2342 SvGROW(PL_rs, (STRLEN)(UNISKIP(rschar) + 1));
2343 tmps = (U8*)SvPVX(PL_rs);
2344 uvchr_to_utf8(tmps, rschar);
2345 SvCUR_set(PL_rs, UNISKIP(rschar));
2350 rschar = (U32)grok_oct(s, &numlen, &flags, NULL);
2351 if (rschar & ~((U8)~0))
2352 PL_rs = &PL_sv_undef;
2353 else if (!rschar && numlen >= 2)
2354 PL_rs = newSVpvn("", 0);
2356 char ch = (char)rschar;
2357 PL_rs = newSVpvn(&ch, 1);
2364 PL_unicode = parse_unicode_opts(&s);
2369 while (*s && !isSPACE(*s)) ++s;
2371 PL_splitstr = savepv(PL_splitstr);
2384 /* The following permits -d:Mod to accepts arguments following an =
2385 in the fashion that -MSome::Mod does. */
2386 if (*s == ':' || *s == '=') {
2389 sv = newSVpv("use Devel::", 0);
2391 /* We now allow -d:Module=Foo,Bar */
2392 while(isALNUM(*s) || *s==':') ++s;
2394 sv_catpv(sv, start);
2396 sv_catpvn(sv, start, s-start);
2397 sv_catpv(sv, " split(/,/,q{");
2402 my_setenv("PERL5DB", SvPV(sv, PL_na));
2405 PL_perldb = PERLDB_ALL;
2414 PL_debug = get_debug_opts(&s) | DEBUG_TOP_FLAG;
2415 #else /* !DEBUGGING */
2416 if (ckWARN_d(WARN_DEBUGGING))
2417 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
2418 "Recompile perl with -DDEBUGGING to use -D switch\n");
2419 for (s++; isALNUM(*s); s++) ;
2425 usage(PL_origargv[0]);
2429 Safefree(PL_inplace);
2430 #if defined(__CYGWIN__) /* do backup extension automagically */
2431 if (*(s+1) == '\0') {
2432 PL_inplace = savepv(".bak");
2435 #endif /* __CYGWIN__ */
2436 PL_inplace = savepv(s+1);
2438 for (s = PL_inplace; *s && !isSPACE(*s); s++) ;
2441 if (*s == '-') /* Additional switches on #! line. */
2445 case 'I': /* -I handled both here and in parse_body() */
2448 while (*s && isSPACE(*s))
2453 /* ignore trailing spaces (possibly followed by other switches) */
2455 for (e = p; *e && !isSPACE(*e); e++) ;
2459 } while (*p && *p != '-');
2460 e = savepvn(s, e-s);
2461 incpush(e, TRUE, TRUE, FALSE);
2468 Perl_croak(aTHX_ "No directory specified for -I");
2474 SvREFCNT_dec(PL_ors_sv);
2479 PL_ors_sv = newSVpvn("\n",1);
2480 numlen = 3 + (*s == '0');
2481 *SvPVX(PL_ors_sv) = (char)grok_oct(s, &numlen, &flags, NULL);
2485 if (RsPARA(PL_rs)) {
2486 PL_ors_sv = newSVpvn("\n\n",2);
2489 PL_ors_sv = newSVsv(PL_rs);
2496 PL_preambleav = newAV();
2498 SV *sv = newSVpvn("use assertions::activate split(/,/,q{",37);
2502 av_push(PL_preambleav, sv);
2505 av_push(PL_preambleav, newSVpvn("use assertions::activate",24));
2508 forbid_setid("-M"); /* XXX ? */
2511 forbid_setid("-m"); /* XXX ? */
2516 /* -M-foo == 'no foo' */
2517 if (*s == '-') { use = "no "; ++s; }
2518 sv = newSVpv(use,0);
2520 /* We allow -M'Module qw(Foo Bar)' */
2521 while(isALNUM(*s) || *s==':') ++s;
2523 sv_catpv(sv, start);
2524 if (*(start-1) == 'm') {
2526 Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
2527 sv_catpv( sv, " ()");
2531 Perl_croak(aTHX_ "Module name required with -%c option",
2533 sv_catpvn(sv, start, s-start);
2534 sv_catpv(sv, " split(/,/,q{");
2540 PL_preambleav = newAV();
2541 av_push(PL_preambleav, sv);
2544 Perl_croak(aTHX_ "No space allowed after -%c", *(s-1));
2556 PL_doswitches = TRUE;
2570 #ifdef MACOS_TRADITIONAL
2571 Perl_croak(aTHX_ "Believe me, you don't want to use \"-u\" on a Macintosh");
2573 PL_do_undump = TRUE;
2582 PerlIO_printf(PerlIO_stdout(),
2583 Perl_form(aTHX_ "\nThis is perl, v%"VDf" built for %s",
2584 PL_patchlevel, ARCHNAME));
2586 /* Adjust verbose output as in the perl that ships with the DG/UX OS from EMC */
2587 PerlIO_printf(PerlIO_stdout(),
2588 Perl_form(aTHX_ "\nThis is perl, version %vd\n", PL_patchlevel));
2589 PerlIO_printf(PerlIO_stdout(),
2590 Perl_form(aTHX_ " built under %s at %s %s\n",
2591 OSNAME, __DATE__, __TIME__));
2592 PerlIO_printf(PerlIO_stdout(),
2593 Perl_form(aTHX_ " OS Specific Release: %s\n",
2597 #if defined(LOCAL_PATCH_COUNT)
2598 if (LOCAL_PATCH_COUNT > 0)
2599 PerlIO_printf(PerlIO_stdout(),
2600 "\n(with %d registered patch%s, "
2601 "see perl -V for more detail)",
2602 (int)LOCAL_PATCH_COUNT,
2603 (LOCAL_PATCH_COUNT!=1) ? "es" : "");
2606 PerlIO_printf(PerlIO_stdout(),
2607 "\n\nCopyright 1987-2003, Larry Wall\n");
2608 #ifdef MACOS_TRADITIONAL
2609 PerlIO_printf(PerlIO_stdout(),
2610 "\nMac OS port Copyright 1991-2002, Matthias Neeracher;\n"
2611 "maintained by Chris Nandor\n");
2614 PerlIO_printf(PerlIO_stdout(),
2615 "\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
2618 PerlIO_printf(PerlIO_stdout(),
2619 "djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n"
2620 "djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
2623 PerlIO_printf(PerlIO_stdout(),
2624 "\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
2625 "Version 5 port Copyright (c) 1994-2002, Andreas Kaiser, Ilya Zakharevich\n");
2628 PerlIO_printf(PerlIO_stdout(),
2629 "atariST series port, ++jrb bammi@cadence.com\n");
2632 PerlIO_printf(PerlIO_stdout(),
2633 "BeOS port Copyright Tom Spindler, 1997-1999\n");
2636 PerlIO_printf(PerlIO_stdout(),
2637 "MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-2003\n");
2640 PerlIO_printf(PerlIO_stdout(),
2641 "MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
2644 PerlIO_printf(PerlIO_stdout(),
2645 "Stratus VOS port by Paul.Green@stratus.com, 1997-2002\n");
2648 PerlIO_printf(PerlIO_stdout(),
2649 "VM/ESA port by Neale Ferguson, 1998-1999\n");
2652 PerlIO_printf(PerlIO_stdout(),
2653 "BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
2656 PerlIO_printf(PerlIO_stdout(),
2657 "MiNT port by Guido Flohr, 1997-1999\n");
2660 PerlIO_printf(PerlIO_stdout(),
2661 "EPOC port by Olaf Flebbe, 1999-2002\n");
2664 PerlIO_printf(PerlIO_stdout(),"WINCE port by Rainer Keuchel, 2001-2002\n");
2665 PerlIO_printf(PerlIO_stdout(),"Built on " __DATE__ " " __TIME__ "\n\n");
2668 #ifdef BINARY_BUILD_NOTICE
2669 BINARY_BUILD_NOTICE;
2671 PerlIO_printf(PerlIO_stdout(),
2673 Perl may be copied only under the terms of either the Artistic License or the\n\
2674 GNU General Public License, which may be found in the Perl 5 source kit.\n\n\
2675 Complete documentation for Perl, including FAQ lists, should be found on\n\
2676 this system using `man perl' or `perldoc perl'. If you have access to the\n\
2677 Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
2680 if (! (PL_dowarn & G_WARN_ALL_MASK))
2681 PL_dowarn |= G_WARN_ON;
2685 PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
2686 if (!specialWARN(PL_compiling.cop_warnings))
2687 SvREFCNT_dec(PL_compiling.cop_warnings);
2688 PL_compiling.cop_warnings = pWARN_ALL ;
2692 PL_dowarn = G_WARN_ALL_OFF;
2693 if (!specialWARN(PL_compiling.cop_warnings))
2694 SvREFCNT_dec(PL_compiling.cop_warnings);
2695 PL_compiling.cop_warnings = pWARN_NONE ;
2700 if (s[1] == '-') /* Additional switches on #! line. */
2705 #if defined(WIN32) || !defined(PERL_STRICT_CR)
2711 #ifdef ALTERNATE_SHEBANG
2712 case 'S': /* OS/2 needs -S on "extproc" line. */
2720 Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
2725 /* compliments of Tom Christiansen */
2727 /* unexec() can be found in the Gnu emacs distribution */
2728 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
2731 Perl_my_unexec(pTHX)
2739 prog = newSVpv(BIN_EXP, 0);
2740 sv_catpv(prog, "/perl");
2741 file = newSVpv(PL_origfilename, 0);
2742 sv_catpv(file, ".perldump");
2744 unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
2745 /* unexec prints msg to stderr in case of failure */
2746 PerlProc_exit(status);
2749 # include <lib$routines.h>
2750 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
2752 ABORT(); /* for use with undump */
2757 /* initialize curinterp */
2763 # define PERLVAR(var,type)
2764 # define PERLVARA(var,n,type)
2765 # if defined(PERL_IMPLICIT_CONTEXT)
2766 # if defined(USE_5005THREADS)
2767 # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
2768 # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
2769 # else /* !USE_5005THREADS */
2770 # define PERLVARI(var,type,init) aTHX->var = init;
2771 # define PERLVARIC(var,type,init) aTHX->var = init;
2772 # endif /* USE_5005THREADS */
2774 # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
2775 # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
2777 # include "intrpvar.h"
2778 # ifndef USE_5005THREADS
2779 # include "thrdvar.h"
2786 # define PERLVAR(var,type)
2787 # define PERLVARA(var,n,type)
2788 # define PERLVARI(var,type,init) PL_##var = init;
2789 # define PERLVARIC(var,type,init) PL_##var = init;
2790 # include "intrpvar.h"
2791 # ifndef USE_5005THREADS
2792 # include "thrdvar.h"
2803 S_init_main_stash(pTHX)
2807 PL_curstash = PL_defstash = newHV();
2808 PL_curstname = newSVpvn("main",4);
2809 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
2810 SvREFCNT_dec(GvHV(gv));
2811 GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
2813 HvNAME(PL_defstash) = savepv("main");
2814 PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
2815 GvMULTI_on(PL_incgv);
2816 PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
2817 GvMULTI_on(PL_hintgv);
2818 PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
2819 PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
2820 GvMULTI_on(PL_errgv);
2821 PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
2822 GvMULTI_on(PL_replgv);
2823 (void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */
2824 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
2825 sv_setpvn(ERRSV, "", 0);
2826 PL_curstash = PL_defstash;
2827 CopSTASH_set(&PL_compiling, PL_defstash);
2828 PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
2829 PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
2830 /* We must init $/ before switches are processed. */
2831 sv_setpvn(get_sv("/", TRUE), "\n", 1);
2835 S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
2839 char *cpp_discard_flag;
2845 PL_origfilename = savepv("-e");
2848 /* if find_script() returns, it returns a malloc()-ed value */
2849 PL_origfilename = scriptname = find_script(scriptname, dosearch, NULL, 1);
2851 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
2852 char *s = scriptname + 8;
2853 *fdscript = atoi(s);
2857 scriptname = savepv(s + 1);
2858 Safefree(PL_origfilename);
2859 PL_origfilename = scriptname;
2864 CopFILE_free(PL_curcop);
2865 CopFILE_set(PL_curcop, PL_origfilename);
2866 if (strEQ(PL_origfilename,"-"))
2868 if (*fdscript >= 0) {
2869 PL_rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE);
2870 # if defined(HAS_FCNTL) && defined(F_SETFD)
2872 /* ensure close-on-exec */
2873 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
2876 else if (PL_preprocess) {
2877 char *cpp_cfg = CPPSTDIN;
2878 SV *cpp = newSVpvn("",0);
2879 SV *cmd = NEWSV(0,0);
2881 if (strEQ(cpp_cfg, "cppstdin"))
2882 Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
2883 sv_catpv(cpp, cpp_cfg);
2886 sv_catpvn(sv, "-I", 2);
2887 sv_catpv(sv,PRIVLIB_EXP);
2890 DEBUG_P(PerlIO_printf(Perl_debug_log,
2891 "PL_preprocess: scriptname=\"%s\", cpp=\"%s\", sv=\"%s\", CPPMINUS=\"%s\"\n",
2892 scriptname, SvPVX (cpp), SvPVX (sv), CPPMINUS));
2894 # if defined(MSDOS) || defined(WIN32) || defined(VMS)
2901 cpp_discard_flag = "";
2903 cpp_discard_flag = "-C";
2907 perl = os2_execname(aTHX);
2909 perl = PL_origargv[0];
2913 /* This strips off Perl comments which might interfere with
2914 the C pre-processor, including #!. #line directives are
2915 deliberately stripped to avoid confusion with Perl's version
2916 of #line. FWP played some golf with it so it will fit
2917 into VMS's 255 character buffer.
2920 code = "(1../^#!.*perl/i)|/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print";
2922 code = "/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print";
2924 Perl_sv_setpvf(aTHX_ cmd, "\
2925 %s -ne%s%s%s %s | %"SVf" %s %"SVf" %s",
2926 perl, quote, code, quote, scriptname, cpp,
2927 cpp_discard_flag, sv, CPPMINUS);
2929 PL_doextract = FALSE;
2930 # ifdef IAMSUID /* actually, this is caught earlier */
2931 if (PL_euid != PL_uid && !PL_euid) { /* if running suidperl */
2933 (void)seteuid(PL_uid); /* musn't stay setuid root */
2935 # ifdef HAS_SETREUID
2936 (void)setreuid((Uid_t)-1, PL_uid);
2938 # ifdef HAS_SETRESUID
2939 (void)setresuid((Uid_t)-1, PL_uid, (Uid_t)-1);
2941 PerlProc_setuid(PL_uid);
2945 if (PerlProc_geteuid() != PL_uid)
2946 Perl_croak(aTHX_ "Can't do seteuid!\n");
2948 # endif /* IAMSUID */
2950 DEBUG_P(PerlIO_printf(Perl_debug_log,
2951 "PL_preprocess: cmd=\"%s\"\n",
2954 PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
2958 else if (!*scriptname) {
2959 forbid_setid("program input from stdin");
2960 PL_rsfp = PerlIO_stdin();
2963 PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
2964 # if defined(HAS_FCNTL) && defined(F_SETFD)
2966 /* ensure close-on-exec */
2967 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
2972 # ifndef IAMSUID /* in case script is not readable before setuid */
2974 PerlLIO_stat(CopFILE(PL_curcop),&PL_statbuf) >= 0 &&
2975 PL_statbuf.st_mode & (S_ISUID|S_ISGID))
2979 PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT,
2980 BIN_EXP, (int)PERL_REVISION,
2982 (int)PERL_SUBVERSION), PL_origargv);
2984 Perl_croak(aTHX_ "Can't do setuid\n");
2990 Perl_croak(aTHX_ "Can't open perl script: %s\n",
2993 Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
2994 CopFILE(PL_curcop), Strerror(errno));
3000 * I_SYSSTATVFS HAS_FSTATVFS
3002 * I_STATFS HAS_FSTATFS HAS_GETFSSTAT
3003 * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT
3004 * here so that metaconfig picks them up. */
3008 S_fd_on_nosuid_fs(pTHX_ int fd)
3010 int check_okay = 0; /* able to do all the required sys/libcalls */
3011 int on_nosuid = 0; /* the fd is on a nosuid fs */
3013 * Preferred order: fstatvfs(), fstatfs(), ustat()+getmnt(), getmntent().
3014 * fstatvfs() is UNIX98.
3015 * fstatfs() is 4.3 BSD.
3016 * ustat()+getmnt() is pre-4.3 BSD.
3017 * getmntent() is O(number-of-mounted-filesystems) and can hang on
3018 * an irrelevant filesystem while trying to reach the right one.
3021 #undef FD_ON_NOSUID_CHECK_OKAY /* found the syscalls to do the check? */
3023 # if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3024 defined(HAS_FSTATVFS)
3025 # define FD_ON_NOSUID_CHECK_OKAY
3026 struct statvfs stfs;
3028 check_okay = fstatvfs(fd, &stfs) == 0;
3029 on_nosuid = check_okay && (stfs.f_flag & ST_NOSUID);
3030 # endif /* fstatvfs */
3032 # if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3033 defined(PERL_MOUNT_NOSUID) && \
3034 defined(HAS_FSTATFS) && \
3035 defined(HAS_STRUCT_STATFS) && \
3036 defined(HAS_STRUCT_STATFS_F_FLAGS)
3037 # define FD_ON_NOSUID_CHECK_OKAY
3040 check_okay = fstatfs(fd, &stfs) == 0;
3041 on_nosuid = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
3042 # endif /* fstatfs */
3044 # if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3045 defined(PERL_MOUNT_NOSUID) && \
3046 defined(HAS_FSTAT) && \
3047 defined(HAS_USTAT) && \
3048 defined(HAS_GETMNT) && \
3049 defined(HAS_STRUCT_FS_DATA) && \
3051 # define FD_ON_NOSUID_CHECK_OKAY
3054 if (fstat(fd, &fdst) == 0) {
3056 if (ustat(fdst.st_dev, &us) == 0) {
3058 /* NOSTAT_ONE here because we're not examining fields which
3059 * vary between that case and STAT_ONE. */
3060 if (getmnt((int*)0, &fsd, (int)0, NOSTAT_ONE, us.f_fname) == 0) {
3061 size_t cmplen = sizeof(us.f_fname);
3062 if (sizeof(fsd.fd_req.path) < cmplen)
3063 cmplen = sizeof(fsd.fd_req.path);
3064 if (strnEQ(fsd.fd_req.path, us.f_fname, cmplen) &&
3065 fdst.st_dev == fsd.fd_req.dev) {
3067 on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID;
3073 # endif /* fstat+ustat+getmnt */
3075 # if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3076 defined(HAS_GETMNTENT) && \
3077 defined(HAS_HASMNTOPT) && \
3078 defined(MNTOPT_NOSUID)
3079 # define FD_ON_NOSUID_CHECK_OKAY
3080 FILE *mtab = fopen("/etc/mtab", "r");
3081 struct mntent *entry;
3084 if (mtab && (fstat(fd, &stb) == 0)) {
3085 while (entry = getmntent(mtab)) {
3086 if (stat(entry->mnt_dir, &fsb) == 0
3087 && fsb.st_dev == stb.st_dev)
3089 /* found the filesystem */
3091 if (hasmntopt(entry, MNTOPT_NOSUID))
3094 } /* A single fs may well fail its stat(). */
3099 # endif /* getmntent+hasmntopt */
3102 Perl_croak(aTHX_ "Can't check filesystem of script \"%s\" for nosuid", PL_origfilename);
3105 #endif /* IAMSUID */
3108 S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript)
3114 /* do we need to emulate setuid on scripts? */
3116 /* This code is for those BSD systems that have setuid #! scripts disabled
3117 * in the kernel because of a security problem. Merely defining DOSUID
3118 * in perl will not fix that problem, but if you have disabled setuid
3119 * scripts in the kernel, this will attempt to emulate setuid and setgid
3120 * on scripts that have those now-otherwise-useless bits set. The setuid
3121 * root version must be called suidperl or sperlN.NNN. If regular perl
3122 * discovers that it has opened a setuid script, it calls suidperl with
3123 * the same argv that it had. If suidperl finds that the script it has
3124 * just opened is NOT setuid root, it sets the effective uid back to the
3125 * uid. We don't just make perl setuid root because that loses the
3126 * effective uid we had before invoking perl, if it was different from the
3129 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
3130 * be defined in suidperl only. suidperl must be setuid root. The
3131 * Configure script will set this up for you if you want it.
3137 if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */
3138 Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
3139 if (fdscript < 0 && PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
3144 #ifndef HAS_SETREUID
3145 /* On this access check to make sure the directories are readable,
3146 * there is actually a small window that the user could use to make
3147 * filename point to an accessible directory. So there is a faint
3148 * chance that someone could execute a setuid script down in a
3149 * non-accessible directory. I don't know what to do about that.
3150 * But I don't think it's too important. The manual lies when
3151 * it says access() is useful in setuid programs.
3153 if (PerlLIO_access(CopFILE(PL_curcop),1)) /*double check*/
3154 Perl_croak(aTHX_ "Permission denied");
3156 /* If we can swap euid and uid, then we can determine access rights
3157 * with a simple stat of the file, and then compare device and
3158 * inode to make sure we did stat() on the same file we opened.
3159 * Then we just have to make sure he or she can execute it.
3166 setreuid(PL_euid,PL_uid) < 0
3169 setresuid(PL_euid,PL_uid,(Uid_t)-1) < 0
3172 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
3173 Perl_croak(aTHX_ "Can't swap uid and euid"); /* really paranoid */
3174 if (PerlLIO_stat(CopFILE(PL_curcop),&tmpstatbuf) < 0)
3175 Perl_croak(aTHX_ "Permission denied"); /* testing full pathname here */
3176 #if defined(IAMSUID) && !defined(NO_NOSUID_CHECK)
3177 if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp)))
3178 Perl_croak(aTHX_ "Permission denied");
3180 if (tmpstatbuf.st_dev != PL_statbuf.st_dev ||
3181 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
3182 (void)PerlIO_close(PL_rsfp);
3183 Perl_croak(aTHX_ "Permission denied\n");
3187 setreuid(PL_uid,PL_euid) < 0
3189 # if defined(HAS_SETRESUID)
3190 setresuid(PL_uid,PL_euid,(Uid_t)-1) < 0
3193 || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
3194 Perl_croak(aTHX_ "Can't reswap uid and euid");
3195 if (!cando(S_IXUSR,FALSE,&PL_statbuf)) /* can real uid exec? */
3196 Perl_croak(aTHX_ "Permission denied\n");
3198 #endif /* HAS_SETREUID */
3199 #endif /* IAMSUID */
3201 if (!S_ISREG(PL_statbuf.st_mode))
3202 Perl_croak(aTHX_ "Permission denied");
3203 if (PL_statbuf.st_mode & S_IWOTH)
3204 Perl_croak(aTHX_ "Setuid/gid script is writable by world");
3205 PL_doswitches = FALSE; /* -s is insecure in suid */
3206 CopLINE_inc(PL_curcop);
3207 if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
3208 strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */
3209 Perl_croak(aTHX_ "No #! line");
3210 s = SvPV(PL_linestr,n_a)+2;
3212 while (!isSPACE(*s)) s++;
3213 for (s2 = s; (s2 > SvPV(PL_linestr,n_a)+2 &&
3214 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
3215 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
3216 Perl_croak(aTHX_ "Not a perl script");
3217 while (*s == ' ' || *s == '\t') s++;
3219 * #! arg must be what we saw above. They can invoke it by
3220 * mentioning suidperl explicitly, but they may not add any strange
3221 * arguments beyond what #! says if they do invoke suidperl that way.
3223 len = strlen(validarg);
3224 if (strEQ(validarg," PHOOEY ") ||
3225 strnNE(s,validarg,len) || !isSPACE(s[len]))
3226 Perl_croak(aTHX_ "Args must match #! line");
3229 if (PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
3230 PL_euid == PL_statbuf.st_uid)
3232 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
3233 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
3234 #endif /* IAMSUID */
3236 if (PL_euid) { /* oops, we're not the setuid root perl */
3237 (void)PerlIO_close(PL_rsfp);
3241 PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
3242 (int)PERL_REVISION, (int)PERL_VERSION,
3243 (int)PERL_SUBVERSION), PL_origargv);
3246 Perl_croak(aTHX_ "Can't do setuid\n");
3249 if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
3251 (void)setegid(PL_statbuf.st_gid);
3254 (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
3256 #ifdef HAS_SETRESGID
3257 (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
3259 PerlProc_setgid(PL_statbuf.st_gid);
3263 if (PerlProc_getegid() != PL_statbuf.st_gid)
3264 Perl_croak(aTHX_ "Can't do setegid!\n");
3266 if (PL_statbuf.st_mode & S_ISUID) {
3267 if (PL_statbuf.st_uid != PL_euid)
3269 (void)seteuid(PL_statbuf.st_uid); /* all that for this */
3272 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
3274 #ifdef HAS_SETRESUID
3275 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
3277 PerlProc_setuid(PL_statbuf.st_uid);
3281 if (PerlProc_geteuid() != PL_statbuf.st_uid)
3282 Perl_croak(aTHX_ "Can't do seteuid!\n");
3284 else if (PL_uid) { /* oops, mustn't run as root */
3286 (void)seteuid((Uid_t)PL_uid);
3289 (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
3291 #ifdef HAS_SETRESUID
3292 (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
3294 PerlProc_setuid((Uid_t)PL_uid);
3298 if (PerlProc_geteuid() != PL_uid)
3299 Perl_croak(aTHX_ "Can't do seteuid!\n");
3302 if (!cando(S_IXUSR,TRUE,&PL_statbuf))
3303 Perl_croak(aTHX_ "Permission denied\n"); /* they can't do this */
3306 else if (PL_preprocess)
3307 Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
3308 else if (fdscript >= 0)
3309 Perl_croak(aTHX_ "fd script not allowed in suidperl\n");
3311 Perl_croak(aTHX_ "Script is not setuid/setgid in suidperl\n");
3313 /* We absolutely must clear out any saved ids here, so we */
3314 /* exec the real perl, substituting fd script for scriptname. */
3315 /* (We pass script name as "subdir" of fd, which perl will grok.) */
3316 PerlIO_rewind(PL_rsfp);
3317 PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0); /* just in case rewind didn't */
3318 for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
3319 if (!PL_origargv[which])
3320 Perl_croak(aTHX_ "Permission denied");
3321 PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
3322 PerlIO_fileno(PL_rsfp), PL_origargv[which]));
3323 #if defined(HAS_FCNTL) && defined(F_SETFD)
3324 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */
3327 PerlProc_execv(Perl_form(aTHX_ "%s/perl"PERL_FS_VER_FMT, BIN_EXP,
3328 (int)PERL_REVISION, (int)PERL_VERSION,
3329 (int)PERL_SUBVERSION), PL_origargv);/* try again */
3331 Perl_croak(aTHX_ "Can't do setuid\n");
3332 #endif /* IAMSUID */
3334 if (PL_euid != PL_uid || PL_egid != PL_gid) { /* (suidperl doesn't exist, in fact) */
3335 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
3336 PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf); /* may be either wrapped or real suid */
3337 if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
3339 (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
3342 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
3343 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
3344 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
3345 /* not set-id, must be wrapped */
3351 S_find_beginning(pTHX)
3353 register char *s, *s2;
3354 #ifdef MACOS_TRADITIONAL
3358 /* skip forward in input to the real script? */
3361 #ifdef MACOS_TRADITIONAL
3362 /* Since the Mac OS does not honor #! arguments for us, we do it ourselves */
3364 while (PL_doextract || gMacPerl_AlwaysExtract) {
3365 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
3366 if (!gMacPerl_AlwaysExtract)
3367 Perl_croak(aTHX_ "No Perl script found in input\n");
3369 if (PL_doextract) /* require explicit override ? */
3370 if (!OverrideExtract(PL_origfilename))
3371 Perl_croak(aTHX_ "User aborted script\n");
3373 PL_doextract = FALSE;
3375 /* Pater peccavi, file does not have #! */
3376 PerlIO_rewind(PL_rsfp);
3381 while (PL_doextract) {
3382 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
3383 Perl_croak(aTHX_ "No Perl script found in input\n");
3386 if (*s == '#' && s[1] == '!' && ((s = instr(s,"perl")) || (s = instr(s2,"PERL")))) {
3387 PerlIO_ungetc(PL_rsfp, '\n'); /* to keep line count right */
3388 PL_doextract = FALSE;
3389 while (*s && !(isSPACE (*s) || *s == '#')) s++;
3391 while (*s == ' ' || *s == '\t') s++;
3393 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
3394 if (strnEQ(s2-4,"perl",4))
3396 while ((s = moreswitches(s)))
3399 #ifdef MACOS_TRADITIONAL
3400 /* We are always searching for the #!perl line in MacPerl,
3401 * so if we find it, still keep the line count correct
3402 * by counting lines we already skipped over
3404 for (; maclines > 0 ; maclines--)
3405 PerlIO_ungetc(PL_rsfp, '\n');
3409 /* gMacPerl_AlwaysExtract is false in MPW tool */
3410 } else if (gMacPerl_AlwaysExtract) {
3421 PL_uid = PerlProc_getuid();
3422 PL_euid = PerlProc_geteuid();
3423 PL_gid = PerlProc_getgid();
3424 PL_egid = PerlProc_getegid();
3426 PL_uid |= PL_gid << 16;
3427 PL_euid |= PL_egid << 16;
3429 /* Should not happen: */
3430 CHECK_MALLOC_TAINT(PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
3431 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
3434 /* This is used very early in the lifetime of the program,
3435 * before even the options are parsed, so PL_tainting has
3436 * not been initialized properly. */
3438 Perl_doing_taint(int argc, char *argv[], char *envp[])
3440 #ifndef PERL_IMPLICIT_SYS
3441 /* If we have PERL_IMPLICIT_SYS we can't call getuid() et alia
3442 * before we have an interpreter-- and the whole point of this
3443 * function is to be called at such an early stage. If you are on
3444 * a system with PERL_IMPLICIT_SYS but you do have a concept of
3445 * "tainted because running with altered effective ids', you'll
3446 * have to add your own checks somewhere in here. The two most
3447 * known samples of 'implicitness' are Win32 and NetWare, neither
3448 * of which has much of concept of 'uids'. */
3449 int uid = PerlProc_getuid();
3450 int euid = PerlProc_geteuid();
3451 int gid = PerlProc_getgid();
3452 int egid = PerlProc_getegid();
3458 if (uid && (euid != uid || egid != gid))
3460 #endif /* !PERL_IMPLICIT_SYS */
3461 /* This is a really primitive check; environment gets ignored only
3462 * if -T are the first chars together; otherwise one gets
3463 * "Too late" message. */
3464 if ( argc > 1 && argv[1][0] == '-'
3465 && (argv[1][1] == 't' || argv[1][1] == 'T') )
3471 S_forbid_setid(pTHX_ char *s)
3473 if (PL_euid != PL_uid)
3474 Perl_croak(aTHX_ "No %s allowed while running setuid", s);
3475 if (PL_egid != PL_gid)
3476 Perl_croak(aTHX_ "No %s allowed while running setgid", s);
3480 Perl_init_debugger(pTHX)
3482 HV *ostash = PL_curstash;
3484 PL_curstash = PL_debstash;
3485 PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("DB::args", GV_ADDMULTI, SVt_PVAV))));
3486 AvREAL_off(PL_dbargs);
3487 PL_DBgv = gv_fetchpv("DB::DB", GV_ADDMULTI, SVt_PVGV);
3488 PL_DBline = gv_fetchpv("DB::dbline", GV_ADDMULTI, SVt_PVAV);
3489 PL_DBsub = gv_HVadd(gv_fetchpv("DB::sub", GV_ADDMULTI, SVt_PVHV));
3490 sv_upgrade(GvSV(PL_DBsub), SVt_IV); /* IVX accessed if PERLDB_SUB_NN */
3491 PL_DBsingle = GvSV((gv_fetchpv("DB::single", GV_ADDMULTI, SVt_PV)));
3492 sv_setiv(PL_DBsingle, 0);
3493 PL_DBtrace = GvSV((gv_fetchpv("DB::trace", GV_ADDMULTI, SVt_PV)));
3494 sv_setiv(PL_DBtrace, 0);
3495 PL_DBsignal = GvSV((gv_fetchpv("DB::signal", GV_ADDMULTI, SVt_PV)));
3496 sv_setiv(PL_DBsignal, 0);
3497 PL_DBassertion = GvSV((gv_fetchpv("assertion", GV_ADDMULTI, SVt_PV)));
3498 sv_setiv(PL_DBassertion, 0);
3499 PL_curstash = ostash;
3502 #ifndef STRESS_REALLOC
3503 #define REASONABLE(size) (size)
3505 #define REASONABLE(size) (1) /* unreasonable */
3509 Perl_init_stacks(pTHX)
3511 /* start with 128-item stack and 8K cxstack */
3512 PL_curstackinfo = new_stackinfo(REASONABLE(128),
3513 REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
3514 PL_curstackinfo->si_type = PERLSI_MAIN;
3515 PL_curstack = PL_curstackinfo->si_stack;
3516 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
3518 PL_stack_base = AvARRAY(PL_curstack);
3519 PL_stack_sp = PL_stack_base;
3520 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
3522 New(50,PL_tmps_stack,REASONABLE(128),SV*);
3525 PL_tmps_max = REASONABLE(128);
3527 New(54,PL_markstack,REASONABLE(32),I32);
3528 PL_markstack_ptr = PL_markstack;
3529 PL_markstack_max = PL_markstack + REASONABLE(32);
3533 New(54,PL_scopestack,REASONABLE(32),I32);
3534 PL_scopestack_ix = 0;
3535 PL_scopestack_max = REASONABLE(32);
3537 New(54,PL_savestack,REASONABLE(128),ANY);
3538 PL_savestack_ix = 0;
3539 PL_savestack_max = REASONABLE(128);
3541 New(54,PL_retstack,REASONABLE(16),OP*);
3543 PL_retstack_max = REASONABLE(16);
3551 while (PL_curstackinfo->si_next)
3552 PL_curstackinfo = PL_curstackinfo->si_next;
3553 while (PL_curstackinfo) {
3554 PERL_SI *p = PL_curstackinfo->si_prev;
3555 /* curstackinfo->si_stack got nuked by sv_free_arenas() */
3556 Safefree(PL_curstackinfo->si_cxstack);
3557 Safefree(PL_curstackinfo);
3558 PL_curstackinfo = p;
3560 Safefree(PL_tmps_stack);
3561 Safefree(PL_markstack);
3562 Safefree(PL_scopestack);
3563 Safefree(PL_savestack);
3564 Safefree(PL_retstack);
3573 lex_start(PL_linestr);
3575 PL_subname = newSVpvn("main",4);
3579 S_init_predump_symbols(pTHX)
3584 sv_setpvn(get_sv("\"", TRUE), " ", 1);
3585 PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
3586 GvMULTI_on(PL_stdingv);
3587 io = GvIOp(PL_stdingv);
3588 IoTYPE(io) = IoTYPE_RDONLY;
3589 IoIFP(io) = PerlIO_stdin();
3590 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
3592 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
3594 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
3597 IoTYPE(io) = IoTYPE_WRONLY;
3598 IoOFP(io) = IoIFP(io) = PerlIO_stdout();
3600 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
3602 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
3604 PL_stderrgv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
3605 GvMULTI_on(PL_stderrgv);
3606 io = GvIOp(PL_stderrgv);
3607 IoTYPE(io) = IoTYPE_WRONLY;
3608 IoOFP(io) = IoIFP(io) = PerlIO_stderr();
3609 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
3611 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
3613 PL_statname = NEWSV(66,0); /* last filename we did stat on */
3616 Safefree(PL_osname);
3617 PL_osname = savepv(OSNAME);
3621 Perl_init_argv_symbols(pTHX_ register int argc, register char **argv)
3624 argc--,argv++; /* skip name of script */
3625 if (PL_doswitches) {
3626 for (; argc > 0 && **argv == '-'; argc--,argv++) {
3629 if (argv[0][1] == '-' && !argv[0][2]) {
3633 if ((s = strchr(argv[0], '='))) {
3635 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
3638 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
3641 if ((PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV))) {
3642 GvMULTI_on(PL_argvgv);
3643 (void)gv_AVadd(PL_argvgv);
3644 av_clear(GvAVn(PL_argvgv));
3645 for (; argc > 0; argc--,argv++) {
3646 SV *sv = newSVpv(argv[0],0);
3647 av_push(GvAVn(PL_argvgv),sv);
3648 if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
3649 if (PL_unicode & PERL_UNICODE_ARGV_FLAG)
3652 if (PL_unicode & PERL_UNICODE_WIDESYSCALLS_FLAG) /* Sarathy? */
3653 (void)sv_utf8_decode(sv);
3658 #ifdef HAS_PROCSELFEXE
3659 /* This is a function so that we don't hold on to MAXPATHLEN
3660 bytes of stack longer than necessary
3663 S_procself_val(pTHX_ SV *sv, char *arg0)
3665 char buf[MAXPATHLEN];
3666 int len = readlink(PROCSELFEXE_PATH, buf, sizeof(buf) - 1);
3668 /* On Playstation2 Linux V1.0 (kernel 2.2.1) readlink(/proc/self/exe)
3669 includes a spurious NUL which will cause $^X to fail in system
3670 or backticks (this will prevent extensions from being built and
3671 many tests from working). readlink is not meant to add a NUL.
3672 Normal readlink works fine.
3674 if (len > 0 && buf[len-1] == '\0') {
3678 /* FreeBSD's implementation is acknowledged to be imperfect, sometimes
3679 returning the text "unknown" from the readlink rather than the path
3680 to the executable (or returning an error from the readlink). Any valid
3681 path has a '/' in it somewhere, so use that to validate the result.
3682 See http://www.freebsd.org/cgi/query-pr.cgi?pr=35703
3684 if (len > 0 && memchr(buf, '/', len)) {
3685 sv_setpvn(sv,buf,len);
3691 #endif /* HAS_PROCSELFEXE */
3694 S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
3700 PL_toptarget = NEWSV(0,0);
3701 sv_upgrade(PL_toptarget, SVt_PVFM);
3702 sv_setpvn(PL_toptarget, "", 0);
3703 PL_bodytarget = NEWSV(0,0);
3704 sv_upgrade(PL_bodytarget, SVt_PVFM);
3705 sv_setpvn(PL_bodytarget, "", 0);
3706 PL_formtarget = PL_bodytarget;
3710 init_argv_symbols(argc,argv);
3712 if ((tmpgv = gv_fetchpv("0",TRUE, SVt_PV))) {
3713 #ifdef MACOS_TRADITIONAL
3714 /* $0 is not majick on a Mac */
3715 sv_setpv(GvSV(tmpgv),MacPerl_MPWFileName(PL_origfilename));
3717 sv_setpv(GvSV(tmpgv),PL_origfilename);
3718 magicname("0", "0", 1);
3721 if ((tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))) {/* $^X */
3722 #ifdef HAS_PROCSELFEXE
3723 S_procself_val(aTHX_ GvSV(tmpgv), PL_origargv[0]);
3726 sv_setpv(GvSV(tmpgv), os2_execname(aTHX));
3728 sv_setpv(GvSV(tmpgv),PL_origargv[0]);
3732 if ((PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV))) {
3734 GvMULTI_on(PL_envgv);
3735 hv = GvHVn(PL_envgv);
3736 hv_magic(hv, Nullgv, PERL_MAGIC_env);
3737 #ifdef USE_ENVIRON_ARRAY
3738 /* Note that if the supplied env parameter is actually a copy
3739 of the global environ then it may now point to free'd memory
3740 if the environment has been modified since. To avoid this
3741 problem we treat env==NULL as meaning 'use the default'
3746 # ifdef USE_ITHREADS
3747 && PL_curinterp == aTHX
3751 environ[0] = Nullch;
3754 for (; *env; env++) {
3755 if (!(s = strchr(*env,'=')))
3762 sv = newSVpv(s+1, 0);
3763 (void)hv_store(hv, *env, s - *env, sv, 0);
3767 #endif /* USE_ENVIRON_ARRAY */
3770 if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV))) {
3771 SvREADONLY_off(GvSV(tmpgv));
3772 sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
3773 SvREADONLY_on(GvSV(tmpgv));
3775 #ifdef THREADS_HAVE_PIDS
3776 PL_ppid = (IV)getppid();
3779 /* touch @F array to prevent spurious warnings 20020415 MJD */
3781 (void) get_av("main::F", TRUE | GV_ADDMULTI);
3783 /* touch @- and @+ arrays to prevent spurious warnings 20020415 MJD */
3784 (void) get_av("main::-", TRUE | GV_ADDMULTI);
3785 (void) get_av("main::+", TRUE | GV_ADDMULTI);
3789 S_init_perllib(pTHX)
3794 s = PerlEnv_getenv("PERL5LIB");
3796 incpush(s, TRUE, TRUE, TRUE);
3798 incpush(PerlEnv_getenv("PERLLIB"), FALSE, FALSE, TRUE);
3800 /* Treat PERL5?LIB as a possible search list logical name -- the
3801 * "natural" VMS idiom for a Unix path string. We allow each
3802 * element to be a set of |-separated directories for compatibility.
3806 if (my_trnlnm("PERL5LIB",buf,0))
3807 do { incpush(buf,TRUE,TRUE,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
3809 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE,FALSE,TRUE);
3813 /* Use the ~-expanded versions of APPLLIB (undocumented),
3814 ARCHLIB PRIVLIB SITEARCH SITELIB VENDORARCH and VENDORLIB
3817 incpush(APPLLIB_EXP, TRUE, TRUE, TRUE);
3821 incpush(ARCHLIB_EXP, FALSE, FALSE, TRUE);
3823 #ifdef MACOS_TRADITIONAL
3826 SV * privdir = NEWSV(55, 0);
3827 char * macperl = PerlEnv_getenv("MACPERL");
3832 Perl_sv_setpvf(aTHX_ privdir, "%slib:", macperl);
3833 if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
3834 incpush(SvPVX(privdir), TRUE, FALSE, TRUE);
3835 Perl_sv_setpvf(aTHX_ privdir, "%ssite_perl:", macperl);
3836 if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
3837 incpush(SvPVX(privdir), TRUE, FALSE, TRUE);
3839 SvREFCNT_dec(privdir);
3842 incpush(":", FALSE, FALSE, TRUE);
3845 # define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
3848 incpush(PRIVLIB_EXP, TRUE, FALSE, TRUE);
3850 incpush(PRIVLIB_EXP, FALSE, FALSE, TRUE);
3854 /* sitearch is always relative to sitelib on Windows for
3855 * DLL-based path intuition to work correctly */
3856 # if !defined(WIN32)
3857 incpush(SITEARCH_EXP, FALSE, FALSE, TRUE);
3863 /* this picks up sitearch as well */
3864 incpush(SITELIB_EXP, TRUE, FALSE, TRUE);
3866 incpush(SITELIB_EXP, FALSE, FALSE, TRUE);
3870 #ifdef SITELIB_STEM /* Search for version-specific dirs below here */
3871 incpush(SITELIB_STEM, FALSE, TRUE, TRUE);
3874 #ifdef PERL_VENDORARCH_EXP
3875 /* vendorarch is always relative to vendorlib on Windows for
3876 * DLL-based path intuition to work correctly */
3877 # if !defined(WIN32)
3878 incpush(PERL_VENDORARCH_EXP, FALSE, FALSE, TRUE);
3882 #ifdef PERL_VENDORLIB_EXP
3884 incpush(PERL_VENDORLIB_EXP, TRUE, FALSE, TRUE); /* this picks up vendorarch as well */
3886 incpush(PERL_VENDORLIB_EXP, FALSE, FALSE, TRUE);
3890 #ifdef PERL_VENDORLIB_STEM /* Search for version-specific dirs below here */
3891 incpush(PERL_VENDORLIB_STEM, FALSE, TRUE, TRUE);
3894 #ifdef PERL_OTHERLIBDIRS
3895 incpush(PERL_OTHERLIBDIRS, TRUE, TRUE, TRUE);
3899 incpush(".", FALSE, FALSE, TRUE);
3900 #endif /* MACOS_TRADITIONAL */
3903 #if defined(DOSISH) || defined(EPOC)
3904 # define PERLLIB_SEP ';'
3907 # define PERLLIB_SEP '|'
3909 # if defined(MACOS_TRADITIONAL)
3910 # define PERLLIB_SEP ','
3912 # define PERLLIB_SEP ':'
3916 #ifndef PERLLIB_MANGLE
3917 # define PERLLIB_MANGLE(s,n) (s)
3921 S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers, int usesep)
3923 SV *subdir = Nullsv;
3928 if (addsubdirs || addoldvers) {
3929 subdir = sv_newmortal();
3932 /* Break at all separators */
3934 SV *libdir = NEWSV(55,0);
3937 /* skip any consecutive separators */
3939 while ( *p == PERLLIB_SEP ) {
3940 /* Uncomment the next line for PATH semantics */
3941 /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */
3946 if ( usesep && (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
3947 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
3952 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
3953 p = Nullch; /* break out */
3955 #ifdef MACOS_TRADITIONAL
3956 if (!strchr(SvPVX(libdir), ':')) {
3959 sv_setpv(libdir, MacPerl_CanonDir(SvPVX(libdir), buf, 0));
3961 if (SvPVX(libdir)[SvCUR(libdir)-1] != ':')
3962 sv_catpv(libdir, ":");
3966 * BEFORE pushing libdir onto @INC we may first push version- and
3967 * archname-specific sub-directories.
3969 if (addsubdirs || addoldvers) {
3970 #ifdef PERL_INC_VERSION_LIST
3971 /* Configure terminates PERL_INC_VERSION_LIST with a NULL */
3972 const char *incverlist[] = { PERL_INC_VERSION_LIST };
3973 const char **incver;
3980 if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) {
3982 while (unix[len-1] == '/') len--; /* Cosmetic */
3983 sv_usepvn(libdir,unix,len);
3986 PerlIO_printf(Perl_error_log,
3987 "Failed to unixify @INC element \"%s\"\n",
3991 #ifdef MACOS_TRADITIONAL
3992 #define PERL_AV_SUFFIX_FMT ""
3993 #define PERL_ARCH_FMT "%s:"
3994 #define PERL_ARCH_FMT_PATH PERL_FS_VER_FMT PERL_AV_SUFFIX_FMT
3996 #define PERL_AV_SUFFIX_FMT "/"
3997 #define PERL_ARCH_FMT "/%s"
3998 #define PERL_ARCH_FMT_PATH PERL_AV_SUFFIX_FMT PERL_FS_VER_FMT
4000 /* .../version/archname if -d .../version/archname */
4001 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH PERL_ARCH_FMT,
4003 (int)PERL_REVISION, (int)PERL_VERSION,
4004 (int)PERL_SUBVERSION, ARCHNAME);
4005 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
4006 S_ISDIR(tmpstatbuf.st_mode))
4007 av_push(GvAVn(PL_incgv), newSVsv(subdir));
4009 /* .../version if -d .../version */
4010 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH, libdir,
4011 (int)PERL_REVISION, (int)PERL_VERSION,
4012 (int)PERL_SUBVERSION);
4013 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
4014 S_ISDIR(tmpstatbuf.st_mode))
4015 av_push(GvAVn(PL_incgv), newSVsv(subdir));
4017 /* .../archname if -d .../archname */
4018 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, ARCHNAME);
4019 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
4020 S_ISDIR(tmpstatbuf.st_mode))
4021 av_push(GvAVn(PL_incgv), newSVsv(subdir));
4024 #ifdef PERL_INC_VERSION_LIST
4026 for (incver = incverlist; *incver; incver++) {
4027 /* .../xxx if -d .../xxx */
4028 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, *incver);
4029 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
4030 S_ISDIR(tmpstatbuf.st_mode))
4031 av_push(GvAVn(PL_incgv), newSVsv(subdir));
4037 /* finally push this lib directory on the end of @INC */
4038 av_push(GvAVn(PL_incgv), libdir);
4042 #ifdef USE_5005THREADS
4043 STATIC struct perl_thread *
4044 S_init_main_thread(pTHX)
4046 #if !defined(PERL_IMPLICIT_CONTEXT)
4047 struct perl_thread *thr;
4051 Newz(53, thr, 1, struct perl_thread);
4052 PL_curcop = &PL_compiling;
4053 thr->interp = PERL_GET_INTERP;
4054 thr->cvcache = newHV();
4055 thr->threadsv = newAV();
4056 /* thr->threadsvp is set when find_threadsv is called */
4057 thr->specific = newAV();
4058 thr->flags = THRf_R_JOINABLE;
4059 MUTEX_INIT(&thr->mutex);
4060 /* Handcraft thrsv similarly to mess_sv */
4061 New(53, PL_thrsv, 1, SV);
4062 Newz(53, xpv, 1, XPV);
4063 SvFLAGS(PL_thrsv) = SVt_PV;
4064 SvANY(PL_thrsv) = (void*)xpv;
4065 SvREFCNT(PL_thrsv) = 1 << 30; /* practically infinite */
4066 SvPVX(PL_thrsv) = (char*)thr;
4067 SvCUR_set(PL_thrsv, sizeof(thr));
4068 SvLEN_set(PL_thrsv, sizeof(thr));
4069 *SvEND(PL_thrsv) = '\0'; /* in the trailing_nul field */
4070 thr->oursv = PL_thrsv;
4071 PL_chopset = " \n-";
4074 MUTEX_LOCK(&PL_threads_mutex);
4080 MUTEX_UNLOCK(&PL_threads_mutex);
4082 #ifdef HAVE_THREAD_INTERN
4083 Perl_init_thread_intern(thr);
4086 #ifdef SET_THREAD_SELF
4087 SET_THREAD_SELF(thr);
4089 thr->self = pthread_self();
4090 #endif /* SET_THREAD_SELF */
4094 * These must come after the thread self setting
4095 * because sv_setpvn does SvTAINT and the taint
4096 * fields thread selfness being set.
4098 PL_toptarget = NEWSV(0,0);
4099 sv_upgrade(PL_toptarget, SVt_PVFM);
4100 sv_setpvn(PL_toptarget, "", 0);
4101 PL_bodytarget = NEWSV(0,0);
4102 sv_upgrade(PL_bodytarget, SVt_PVFM);
4103 sv_setpvn(PL_bodytarget, "", 0);
4104 PL_formtarget = PL_bodytarget;
4105 thr->errsv = newSVpvn("", 0);
4106 (void) find_threadsv("@"); /* Ensure $@ is initialised early */
4109 PL_peepp = MEMBER_TO_FPTR(Perl_peep);
4110 PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
4111 PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
4112 PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
4113 PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
4114 PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
4116 PL_reginterp_cnt = 0;
4120 #endif /* USE_5005THREADS */
4123 Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
4126 line_t oldline = CopLINE(PL_curcop);
4132 while (AvFILL(paramList) >= 0) {
4133 cv = (CV*)av_shift(paramList);
4135 if (paramList == PL_beginav) {
4136 /* save PL_beginav for compiler */
4137 if (! PL_beginav_save)
4138 PL_beginav_save = newAV();
4139 av_push(PL_beginav_save, (SV*)cv);
4141 else if (paramList == PL_checkav) {
4142 /* save PL_checkav for compiler */
4143 if (! PL_checkav_save)
4144 PL_checkav_save = newAV();
4145 av_push(PL_checkav_save, (SV*)cv);
4150 #ifdef PERL_FLEXIBLE_EXCEPTIONS
4151 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_list_body), cv);
4157 #ifndef PERL_FLEXIBLE_EXCEPTIONS
4161 (void)SvPV(atsv, len);
4163 PL_curcop = &PL_compiling;
4164 CopLINE_set(PL_curcop, oldline);
4165 if (paramList == PL_beginav)
4166 sv_catpv(atsv, "BEGIN failed--compilation aborted");
4168 Perl_sv_catpvf(aTHX_ atsv,
4169 "%s failed--call queue aborted",
4170 paramList == PL_checkav ? "CHECK"
4171 : paramList == PL_initav ? "INIT"
4173 while (PL_scopestack_ix > oldscope)
4176 Perl_croak(aTHX_ "%"SVf"", atsv);
4183 /* my_exit() was called */
4184 while (PL_scopestack_ix > oldscope)
4187 PL_curstash = PL_defstash;
4188 PL_curcop = &PL_compiling;
4189 CopLINE_set(PL_curcop, oldline);
4191 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) {
4192 if (paramList == PL_beginav)
4193 Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
4195 Perl_croak(aTHX_ "%s failed--call queue aborted",
4196 paramList == PL_checkav ? "CHECK"
4197 : paramList == PL_initav ? "INIT"
4204 PL_curcop = &PL_compiling;
4205 CopLINE_set(PL_curcop, oldline);
4208 PerlIO_printf(Perl_error_log, "panic: restartop\n");
4216 #ifdef PERL_FLEXIBLE_EXCEPTIONS
4218 S_vcall_list_body(pTHX_ va_list args)
4220 CV *cv = va_arg(args, CV*);
4221 return call_list_body(cv);
4226 S_call_list_body(pTHX_ CV *cv)
4228 PUSHMARK(PL_stack_sp);
4229 call_sv((SV*)cv, G_EVAL|G_DISCARD);
4234 Perl_my_exit(pTHX_ U32 status)
4236 DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
4237 thr, (unsigned long) status));
4246 STATUS_NATIVE_SET(status);
4253 Perl_my_failure_exit(pTHX)
4256 if (vaxc$errno & 1) {
4257 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
4258 STATUS_NATIVE_SET(44);
4261 if (!vaxc$errno && errno) /* unlikely */
4262 STATUS_NATIVE_SET(44);
4264 STATUS_NATIVE_SET(vaxc$errno);
4269 STATUS_POSIX_SET(errno);
4271 exitstatus = STATUS_POSIX >> 8;
4272 if (exitstatus & 255)
4273 STATUS_POSIX_SET(exitstatus);
4275 STATUS_POSIX_SET(255);
4282 S_my_exit_jump(pTHX)
4284 register PERL_CONTEXT *cx;
4289 SvREFCNT_dec(PL_e_script);
4290 PL_e_script = Nullsv;
4293 POPSTACK_TO(PL_mainstack);
4294 if (cxstack_ix >= 0) {
4297 POPBLOCK(cx,PL_curpm);
4305 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen)
4308 p = SvPVX(PL_e_script);
4309 nl = strchr(p, '\n');
4310 nl = (nl) ? nl+1 : SvEND(PL_e_script);
4312 filter_del(read_e_script);
4315 sv_catpvn(buf_sv, p, nl-p);
4316 sv_chop(PL_e_script, nl);