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;
186 PL_sighandlerp = Perl_sighandler;
187 PL_pidstatus = newHV();
190 PL_rs = newSVpvn("\n", 1);
195 PL_lex_state = LEX_NOTPARSING;
201 SET_NUMERIC_STANDARD();
205 PL_patchlevel = NEWSV(0,4);
206 (void)SvUPGRADE(PL_patchlevel, SVt_PVNV);
207 if (PERL_REVISION > 127 || PERL_VERSION > 127 || PERL_SUBVERSION > 127)
208 SvGROW(PL_patchlevel, UTF8_MAXLEN*3+1);
209 s = (U8*)SvPVX(PL_patchlevel);
210 /* Build version strings using "native" characters */
211 s = uvchr_to_utf8(s, (UV)PERL_REVISION);
212 s = uvchr_to_utf8(s, (UV)PERL_VERSION);
213 s = uvchr_to_utf8(s, (UV)PERL_SUBVERSION);
215 SvCUR_set(PL_patchlevel, s - (U8*)SvPVX(PL_patchlevel));
216 SvPOK_on(PL_patchlevel);
217 SvNVX(PL_patchlevel) = (NV)PERL_REVISION +
218 ((NV)PERL_VERSION / (NV)1000) +
219 ((NV)PERL_SUBVERSION / (NV)1000000);
220 SvNOK_on(PL_patchlevel); /* dual valued */
221 SvUTF8_on(PL_patchlevel);
222 SvREADONLY_on(PL_patchlevel);
225 #if defined(LOCAL_PATCH_COUNT)
226 PL_localpatches = local_patches; /* For possible -v */
229 #ifdef HAVE_INTERP_INTERN
233 PerlIO_init(aTHX); /* Hook to IO system */
235 PL_fdpid = newAV(); /* for remembering popen pids by fd */
236 PL_modglobal = newHV(); /* pointers to per-interpreter module globals */
237 PL_errors = newSVpvn("",0);
238 sv_setpvn(PERL_DEBUG_PAD(0), "", 0); /* For regex debugging. */
239 sv_setpvn(PERL_DEBUG_PAD(1), "", 0); /* ext/re needs these */
240 sv_setpvn(PERL_DEBUG_PAD(2), "", 0); /* even without DEBUGGING. */
242 PL_regex_padav = newAV();
243 av_push(PL_regex_padav,(SV*)newAV()); /* First entry is an array of empty elements */
244 PL_regex_pad = AvARRAY(PL_regex_padav);
246 #ifdef USE_REENTRANT_API
247 Perl_reentrant_init(aTHX);
250 /* Note that strtab is a rather special HV. Assumptions are made
251 about not iterating on it, and not adding tie magic to it.
252 It is properly deallocated in perl_destruct() */
255 HvSHAREKEYS_off(PL_strtab); /* mandatory */
256 hv_ksplit(PL_strtab, 512);
258 #if defined(__DYNAMIC__) && (defined(NeXT) || defined(__NeXT__))
259 _dyld_lookup_and_bind
260 ("__environ", (unsigned long *) &environ_pointer, NULL);
263 #ifdef USE_ENVIRON_ARRAY
264 PL_origenviron = environ;
267 /* Use sysconf(_SC_CLK_TCK) if available, if not
268 * available or if the sysconf() fails, use the HZ. */
269 #if defined(HAS_SYSCONF) && defined(_SC_CLK_TCK)
270 PL_clocktick = sysconf(_SC_CLK_TCK);
271 if (PL_clocktick <= 0)
275 PL_stashcache = newHV();
277 #if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT)
278 /* [perl #22371] Algorimic Complexity Attack on Perl 5.6.1, 5.8.0 */
283 s = PerlEnv_getenv("PERL_HASH_SEED");
285 while (isSPACE(*s)) s++;
286 if (s && isDIGIT(*s))
287 PL_hash_seed = (UV)atoi(s);
288 #ifndef USE_HASH_SEED_EXPLICIT
290 /* Compute a random seed */
291 (void)seedDrand01((Rand_seed_t)seed());
292 PL_srand_called = TRUE;
293 PL_hash_seed = (UV)(Drand01() * (NV)UV_MAX);
294 #if RANDBITS < (UVSIZE * 8)
296 int skip = (UVSIZE * 8) - RANDBITS;
297 PL_hash_seed >>= skip;
298 /* The low bits might need extra help. */
299 PL_hash_seed += (UV)(Drand01() * ((1 << skip) - 1));
301 #endif /* RANDBITS < (UVSIZE * 8) */
303 #endif /* USE_HASH_SEED_EXPLICIT */
304 if (!PL_earlytaint && (s = PerlEnv_getenv("PERL_HASH_SEED_DEBUG")))
305 PerlIO_printf(Perl_debug_log, "HASH_SEED = %"UVuf"\n",
308 #endif /* #if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT) */
314 =for apidoc nothreadhook
316 Stub that provides thread hook for perl_destruct when there are
323 Perl_nothreadhook(pTHX)
329 =for apidoc perl_destruct
331 Shuts down a Perl interpreter. See L<perlembed>.
339 volatile int destruct_level; /* 0=none, 1=full, 2=full with checks */
341 #ifdef USE_5005THREADS
343 #endif /* USE_5005THREADS */
345 /* wait for all pseudo-forked children to finish */
346 PERL_WAIT_FOR_CHILDREN;
348 destruct_level = PL_perl_destruct_level;
352 if ((s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL"))) {
354 if (destruct_level < i)
361 if(PL_exit_flags & PERL_EXIT_DESTRUCT_END) {
366 if (PL_endav && !PL_minus_c)
367 call_list(PL_scopestack_ix, PL_endav);
373 /* Need to flush since END blocks can produce output */
376 if (CALL_FPTR(PL_threadhook)(aTHX)) {
377 /* Threads hook has vetoed further cleanup */
378 return STATUS_NATIVE_EXPORT;
381 /* We must account for everything. */
383 /* Destroy the main CV and syntax tree */
385 op_free(PL_main_root);
386 PL_main_root = Nullop;
388 PL_curcop = &PL_compiling;
389 PL_main_start = Nullop;
390 SvREFCNT_dec(PL_main_cv);
394 /* Tell PerlIO we are about to tear things apart in case
395 we have layers which are using resources that should
399 PerlIO_destruct(aTHX);
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(aTHX_ PL_exitlist[PL_exitlistlen].ptr);
420 Safefree(PL_exitlist);
425 if (destruct_level == 0){
427 DEBUG_P(debprofdump());
429 #if defined(PERLIO_LAYERS)
430 /* No more IO - including error messages ! */
431 PerlIO_cleanup(aTHX);
434 /* The exit() function will do everything that needs doing. */
435 return STATUS_NATIVE_EXPORT;
438 /* jettison our possibly duplicated environment */
439 /* if PERL_USE_SAFE_PUTENV is defined environ will not have been copied
440 * so we certainly shouldn't free it here
442 #if defined(USE_ENVIRON_ARRAY) && !defined(PERL_USE_SAFE_PUTENV)
443 if (environ != PL_origenviron
445 /* only main thread can free environ[0] contents */
446 && PL_curinterp == aTHX
452 for (i = 0; environ[i]; i++)
453 safesysfree(environ[i]);
455 /* Must use safesysfree() when working with environ. */
456 safesysfree(environ);
458 environ = PL_origenviron;
463 /* the syntax tree is shared between clones
464 * so op_free(PL_main_root) only ReREFCNT_dec's
465 * REGEXPs in the parent interpreter
466 * we need to manually ReREFCNT_dec for the clones
469 I32 i = AvFILLp(PL_regex_padav) + 1;
470 SV **ary = AvARRAY(PL_regex_padav);
474 REGEXP *re = INT2PTR(REGEXP *,SvIVX(resv));
476 if (SvFLAGS(resv) & SVf_BREAK) {
477 /* this is PL_reg_curpm, already freed
478 * flag is set in regexec.c:S_regtry
480 SvFLAGS(resv) &= ~SVf_BREAK;
482 else if(SvREPADTMP(resv)) {
483 SvREPADTMP_off(resv);
490 SvREFCNT_dec(PL_regex_padav);
491 PL_regex_padav = Nullav;
495 SvREFCNT_dec((SV*) PL_stashcache);
496 PL_stashcache = NULL;
498 /* loosen bonds of global variables */
501 (void)PerlIO_close(PL_rsfp);
505 /* Filters for program text */
506 SvREFCNT_dec(PL_rsfp_filters);
507 PL_rsfp_filters = Nullav;
510 PL_preprocess = FALSE;
516 PL_doswitches = FALSE;
517 PL_dowarn = G_WARN_OFF;
518 PL_doextract = FALSE;
519 PL_sawampersand = FALSE; /* must save all match strings */
522 Safefree(PL_inplace);
524 SvREFCNT_dec(PL_patchlevel);
527 SvREFCNT_dec(PL_e_script);
528 PL_e_script = Nullsv;
531 /* magical thingies */
533 SvREFCNT_dec(PL_ofs_sv); /* $, */
536 SvREFCNT_dec(PL_ors_sv); /* $\ */
539 SvREFCNT_dec(PL_rs); /* $/ */
542 PL_multiline = 0; /* $* */
543 Safefree(PL_osname); /* $^O */
546 SvREFCNT_dec(PL_statname);
547 PL_statname = Nullsv;
550 /* defgv, aka *_ should be taken care of elsewhere */
552 /* clean up after study() */
553 SvREFCNT_dec(PL_lastscream);
554 PL_lastscream = Nullsv;
555 Safefree(PL_screamfirst);
557 Safefree(PL_screamnext);
561 Safefree(PL_efloatbuf);
562 PL_efloatbuf = Nullch;
565 /* startup and shutdown function lists */
566 SvREFCNT_dec(PL_beginav);
567 SvREFCNT_dec(PL_beginav_save);
568 SvREFCNT_dec(PL_endav);
569 SvREFCNT_dec(PL_checkav);
570 SvREFCNT_dec(PL_checkav_save);
571 SvREFCNT_dec(PL_initav);
573 PL_beginav_save = Nullav;
576 PL_checkav_save = Nullav;
579 /* shortcuts just get cleared */
585 PL_argvoutgv = Nullgv;
587 PL_stderrgv = Nullgv;
588 PL_last_in_gv = Nullgv;
590 PL_debstash = Nullhv;
592 /* reset so print() ends up where we expect */
595 SvREFCNT_dec(PL_argvout_stack);
596 PL_argvout_stack = Nullav;
598 SvREFCNT_dec(PL_modglobal);
599 PL_modglobal = Nullhv;
600 SvREFCNT_dec(PL_preambleav);
601 PL_preambleav = Nullav;
602 SvREFCNT_dec(PL_subname);
604 SvREFCNT_dec(PL_linestr);
606 SvREFCNT_dec(PL_pidstatus);
607 PL_pidstatus = Nullhv;
608 SvREFCNT_dec(PL_toptarget);
609 PL_toptarget = Nullsv;
610 SvREFCNT_dec(PL_bodytarget);
611 PL_bodytarget = Nullsv;
612 PL_formtarget = Nullsv;
614 /* free locale stuff */
615 #ifdef USE_LOCALE_COLLATE
616 Safefree(PL_collation_name);
617 PL_collation_name = Nullch;
620 #ifdef USE_LOCALE_NUMERIC
621 Safefree(PL_numeric_name);
622 PL_numeric_name = Nullch;
623 SvREFCNT_dec(PL_numeric_radix_sv);
626 /* clear utf8 character classes */
627 SvREFCNT_dec(PL_utf8_alnum);
628 SvREFCNT_dec(PL_utf8_alnumc);
629 SvREFCNT_dec(PL_utf8_ascii);
630 SvREFCNT_dec(PL_utf8_alpha);
631 SvREFCNT_dec(PL_utf8_space);
632 SvREFCNT_dec(PL_utf8_cntrl);
633 SvREFCNT_dec(PL_utf8_graph);
634 SvREFCNT_dec(PL_utf8_digit);
635 SvREFCNT_dec(PL_utf8_upper);
636 SvREFCNT_dec(PL_utf8_lower);
637 SvREFCNT_dec(PL_utf8_print);
638 SvREFCNT_dec(PL_utf8_punct);
639 SvREFCNT_dec(PL_utf8_xdigit);
640 SvREFCNT_dec(PL_utf8_mark);
641 SvREFCNT_dec(PL_utf8_toupper);
642 SvREFCNT_dec(PL_utf8_totitle);
643 SvREFCNT_dec(PL_utf8_tolower);
644 SvREFCNT_dec(PL_utf8_tofold);
645 SvREFCNT_dec(PL_utf8_idstart);
646 SvREFCNT_dec(PL_utf8_idcont);
647 PL_utf8_alnum = Nullsv;
648 PL_utf8_alnumc = Nullsv;
649 PL_utf8_ascii = Nullsv;
650 PL_utf8_alpha = Nullsv;
651 PL_utf8_space = Nullsv;
652 PL_utf8_cntrl = Nullsv;
653 PL_utf8_graph = Nullsv;
654 PL_utf8_digit = Nullsv;
655 PL_utf8_upper = Nullsv;
656 PL_utf8_lower = Nullsv;
657 PL_utf8_print = Nullsv;
658 PL_utf8_punct = Nullsv;
659 PL_utf8_xdigit = Nullsv;
660 PL_utf8_mark = Nullsv;
661 PL_utf8_toupper = Nullsv;
662 PL_utf8_totitle = Nullsv;
663 PL_utf8_tolower = Nullsv;
664 PL_utf8_tofold = Nullsv;
665 PL_utf8_idstart = Nullsv;
666 PL_utf8_idcont = Nullsv;
668 if (!specialWARN(PL_compiling.cop_warnings))
669 SvREFCNT_dec(PL_compiling.cop_warnings);
670 PL_compiling.cop_warnings = Nullsv;
671 if (!specialCopIO(PL_compiling.cop_io))
672 SvREFCNT_dec(PL_compiling.cop_io);
673 PL_compiling.cop_io = Nullsv;
674 CopFILE_free(&PL_compiling);
675 CopSTASH_free(&PL_compiling);
677 /* Prepare to destruct main symbol table. */
682 SvREFCNT_dec(PL_curstname);
683 PL_curstname = Nullsv;
685 /* clear queued errors */
686 SvREFCNT_dec(PL_errors);
690 if (destruct_level >= 2 && ckWARN_d(WARN_INTERNAL)) {
691 if (PL_scopestack_ix != 0)
692 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
693 "Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
694 (long)PL_scopestack_ix);
695 if (PL_savestack_ix != 0)
696 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
697 "Unbalanced saves: %ld more saves than restores\n",
698 (long)PL_savestack_ix);
699 if (PL_tmps_floor != -1)
700 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced tmps: %ld more allocs than frees\n",
701 (long)PL_tmps_floor + 1);
702 if (cxstack_ix != -1)
703 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced context: %ld more PUSHes than POPs\n",
704 (long)cxstack_ix + 1);
707 /* Now absolutely destruct everything, somehow or other, loops or no. */
708 SvFLAGS(PL_fdpid) |= SVTYPEMASK; /* don't clean out pid table now */
709 SvFLAGS(PL_strtab) |= SVTYPEMASK; /* don't clean out strtab now */
711 /* the 2 is for PL_fdpid and PL_strtab */
712 while (PL_sv_count > 2 && sv_clean_all())
715 SvFLAGS(PL_fdpid) &= ~SVTYPEMASK;
716 SvFLAGS(PL_fdpid) |= SVt_PVAV;
717 SvFLAGS(PL_strtab) &= ~SVTYPEMASK;
718 SvFLAGS(PL_strtab) |= SVt_PVHV;
720 AvREAL_off(PL_fdpid); /* no surviving entries */
721 SvREFCNT_dec(PL_fdpid); /* needed in io_close() */
724 #ifdef HAVE_INTERP_INTERN
728 /* Destruct the global string table. */
730 /* Yell and reset the HeVAL() slots that are still holding refcounts,
731 * so that sv_free() won't fail on them.
739 max = HvMAX(PL_strtab);
740 array = HvARRAY(PL_strtab);
743 if (hent && ckWARN_d(WARN_INTERNAL)) {
744 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
745 "Unbalanced string table refcount: (%d) for \"%s\"",
746 HeVAL(hent) - Nullsv, HeKEY(hent));
747 HeVAL(hent) = Nullsv;
757 SvREFCNT_dec(PL_strtab);
760 /* free the pointer table used for cloning */
761 ptr_table_free(PL_ptr_table);
764 /* free special SVs */
766 SvREFCNT(&PL_sv_yes) = 0;
767 sv_clear(&PL_sv_yes);
768 SvANY(&PL_sv_yes) = NULL;
769 SvFLAGS(&PL_sv_yes) = 0;
771 SvREFCNT(&PL_sv_no) = 0;
773 SvANY(&PL_sv_no) = NULL;
774 SvFLAGS(&PL_sv_no) = 0;
778 for (i=0; i<=2; i++) {
779 SvREFCNT(PERL_DEBUG_PAD(i)) = 0;
780 sv_clear(PERL_DEBUG_PAD(i));
781 SvANY(PERL_DEBUG_PAD(i)) = NULL;
782 SvFLAGS(PERL_DEBUG_PAD(i)) = 0;
786 if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL))
787 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Scalars leaked: %ld\n", (long)PL_sv_count);
789 #ifdef DEBUG_LEAKING_SCALARS
790 if (PL_sv_count != 0) {
795 for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
796 svend = &sva[SvREFCNT(sva)];
797 for (sv = sva + 1; sv < svend; ++sv) {
798 if (SvTYPE(sv) != SVTYPEMASK) {
799 PerlIO_printf(Perl_debug_log, "leaked: 0x%p\n", sv);
807 #if defined(PERLIO_LAYERS)
808 /* No more IO - including error messages ! */
809 PerlIO_cleanup(aTHX);
812 /* sv_undef needs to stay immortal until after PerlIO_cleanup
813 as currently layers use it rather than Nullsv as a marker
814 for no arg - and will try and SvREFCNT_dec it.
816 SvREFCNT(&PL_sv_undef) = 0;
817 SvREADONLY_off(&PL_sv_undef);
819 Safefree(PL_origfilename);
820 Safefree(PL_reg_start_tmp);
822 Safefree(PL_reg_curpm);
823 Safefree(PL_reg_poscache);
825 Safefree(PL_op_mask);
826 Safefree(PL_psig_ptr);
827 Safefree(PL_psig_name);
828 Safefree(PL_bitcount);
829 Safefree(PL_psig_pend);
831 PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */
833 DEBUG_P(debprofdump());
835 #ifdef USE_REENTRANT_API
836 Perl_reentrant_free(aTHX);
841 /* As the absolutely last thing, free the non-arena SV for mess() */
844 /* it could have accumulated taint magic */
845 if (SvTYPE(PL_mess_sv) >= SVt_PVMG) {
848 for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) {
849 moremagic = mg->mg_moremagic;
850 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global
852 Safefree(mg->mg_ptr);
856 /* we know that type >= SVt_PV */
857 (void)SvOOK_off(PL_mess_sv);
858 Safefree(SvPVX(PL_mess_sv));
859 Safefree(SvANY(PL_mess_sv));
860 Safefree(PL_mess_sv);
863 return STATUS_NATIVE_EXPORT;
867 =for apidoc perl_free
869 Releases a Perl interpreter. See L<perlembed>.
877 #if defined(WIN32) || defined(NETWARE)
878 # if defined(PERL_IMPLICIT_SYS)
880 void *host = nw_internal_host;
882 void *host = w32_internal_host;
886 nw_delete_internal_host(host);
888 win32_delete_internal_host(host);
899 Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
901 Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry);
902 PL_exitlist[PL_exitlistlen].fn = fn;
903 PL_exitlist[PL_exitlistlen].ptr = ptr;
908 =for apidoc perl_parse
910 Tells a Perl interpreter to parse a Perl script. See L<perlembed>.
916 perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
921 #ifdef USE_5005THREADS
925 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
928 Perl_croak(aTHX_ "suidperl is no longer needed since the kernel can now execute\n\
929 setuid perl scripts securely.\n");
938 /* Come here if running an undumped a.out. */
940 PL_origfilename = savepv(argv[0]);
941 PL_do_undump = FALSE;
942 cxstack_ix = -1; /* start label stack again */
944 init_postdump_symbols(argc,argv,env);
949 op_free(PL_main_root);
950 PL_main_root = Nullop;
952 PL_main_start = Nullop;
953 SvREFCNT_dec(PL_main_cv);
957 oldscope = PL_scopestack_ix;
958 PL_dowarn = G_WARN_OFF;
960 #ifdef PERL_FLEXIBLE_EXCEPTIONS
961 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vparse_body), env, xsinit);
967 #ifndef PERL_FLEXIBLE_EXCEPTIONS
968 parse_body(env,xsinit);
971 call_list(oldscope, PL_checkav);
978 /* my_exit() was called */
979 while (PL_scopestack_ix > oldscope)
982 PL_curstash = PL_defstash;
984 call_list(oldscope, PL_checkav);
985 ret = STATUS_NATIVE_EXPORT;
988 PerlIO_printf(Perl_error_log, "panic: top_env\n");
996 #ifdef PERL_FLEXIBLE_EXCEPTIONS
998 S_vparse_body(pTHX_ va_list args)
1000 char **env = va_arg(args, char**);
1001 XSINIT_t xsinit = va_arg(args, XSINIT_t);
1003 return parse_body(env, xsinit);
1008 S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
1010 int argc = PL_origargc;
1011 char **argv = PL_origargv;
1012 char *scriptname = NULL;
1014 VOL bool dosearch = FALSE;
1015 char *validarg = "";
1018 char *cddir = Nullch;
1020 sv_setpvn(PL_linestr,"",0);
1021 sv = newSVpvn("",0); /* first used for -I flags */
1025 for (argc--,argv++; argc > 0; argc--,argv++) {
1026 if (argv[0][0] != '-' || !argv[0][1])
1030 validarg = " PHOOEY ";
1038 #ifndef PERL_STRICT_CR
1063 if ((s = moreswitches(s)))
1068 CHECK_MALLOC_TOO_LATE_FOR('t');
1069 if( !PL_tainting ) {
1070 PL_taint_warn = TRUE;
1076 CHECK_MALLOC_TOO_LATE_FOR('T');
1078 PL_taint_warn = FALSE;
1083 #ifdef MACOS_TRADITIONAL
1084 /* ignore -e for Dev:Pseudo argument */
1085 if (argv[1] && !strcmp(argv[1], "Dev:Pseudo"))
1088 if (PL_euid != PL_uid || PL_egid != PL_gid)
1089 Perl_croak(aTHX_ "No -e allowed in setuid scripts");
1091 PL_e_script = newSVpvn("",0);
1092 filter_add(read_e_script, NULL);
1095 sv_catpv(PL_e_script, s);
1097 sv_catpv(PL_e_script, argv[1]);
1101 Perl_croak(aTHX_ "No code specified for -e");
1102 sv_catpv(PL_e_script, "\n");
1105 case 'I': /* -I handled both here and in moreswitches() */
1107 if (!*++s && (s=argv[1]) != Nullch) {
1112 STRLEN len = strlen(s);
1113 p = savepvn(s, len);
1114 incpush(p, TRUE, TRUE, FALSE);
1115 sv_catpvn(sv, "-I", 2);
1116 sv_catpvn(sv, p, len);
1117 sv_catpvn(sv, " ", 1);
1121 Perl_croak(aTHX_ "No directory specified for -I");
1125 PL_preprocess = TRUE;
1135 PL_preambleav = newAV();
1136 av_push(PL_preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
1138 PL_Sv = newSVpv("print myconfig();",0);
1140 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
1142 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
1144 sv_catpv(PL_Sv,"\" Compile-time options:");
1146 sv_catpv(PL_Sv," DEBUGGING");
1148 # ifdef MULTIPLICITY
1149 sv_catpv(PL_Sv," MULTIPLICITY");
1151 # ifdef USE_5005THREADS
1152 sv_catpv(PL_Sv," USE_5005THREADS");
1154 # ifdef USE_ITHREADS
1155 sv_catpv(PL_Sv," USE_ITHREADS");
1157 # ifdef USE_64_BIT_INT
1158 sv_catpv(PL_Sv," USE_64_BIT_INT");
1160 # ifdef USE_64_BIT_ALL
1161 sv_catpv(PL_Sv," USE_64_BIT_ALL");
1163 # ifdef USE_LONG_DOUBLE
1164 sv_catpv(PL_Sv," USE_LONG_DOUBLE");
1166 # ifdef USE_LARGE_FILES
1167 sv_catpv(PL_Sv," USE_LARGE_FILES");
1170 sv_catpv(PL_Sv," USE_SOCKS");
1172 # ifdef PERL_IMPLICIT_CONTEXT
1173 sv_catpv(PL_Sv," PERL_IMPLICIT_CONTEXT");
1175 # ifdef PERL_IMPLICIT_SYS
1176 sv_catpv(PL_Sv," PERL_IMPLICIT_SYS");
1178 sv_catpv(PL_Sv,"\\n\",");
1180 #if defined(LOCAL_PATCH_COUNT)
1181 if (LOCAL_PATCH_COUNT > 0) {
1183 sv_catpv(PL_Sv,"\" Locally applied patches:\\n\",");
1184 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
1185 if (PL_localpatches[i])
1186 Perl_sv_catpvf(aTHX_ PL_Sv,"q\" \t%s\n\",",PL_localpatches[i]);
1190 Perl_sv_catpvf(aTHX_ PL_Sv,"\" Built under %s\\n\"",OSNAME);
1193 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
1195 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled on %s\\n\"",__DATE__);
1198 sv_catpv(PL_Sv, "; \
1200 @env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; ");
1203 push @env, \"CYGWIN=\\\"$ENV{CYGWIN}\\\"\";");
1206 print \" \\%ENV:\\n @env\\n\" if @env; \
1207 print \" \\@INC:\\n @INC\\n\";");
1210 PL_Sv = newSVpv("config_vars(qw(",0);
1211 sv_catpv(PL_Sv, ++s);
1212 sv_catpv(PL_Sv, "))");
1215 av_push(PL_preambleav, PL_Sv);
1216 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
1219 PL_doextract = TRUE;
1227 if (!*++s || isSPACE(*s)) {
1231 /* catch use of gnu style long options */
1232 if (strEQ(s, "version")) {
1236 if (strEQ(s, "help")) {
1243 Perl_croak(aTHX_ "Unrecognized switch: -%s (-h will show valid options)",s);
1247 sv_setsv(get_sv("/", TRUE), PL_rs);
1250 #ifndef SECURE_INTERNAL_GETENV
1253 (s = PerlEnv_getenv("PERL5OPT")))
1258 if (*s == '-' && *(s+1) == 'T') {
1259 CHECK_MALLOC_TOO_LATE_FOR('T');
1261 PL_taint_warn = FALSE;
1264 char *popt_copy = Nullch;
1277 if (!strchr("DIMUdmtwA", *s))
1278 Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
1282 popt_copy = SvPVX(sv_2mortal(newSVpv(popt,0)));
1283 s = popt_copy + (s - popt);
1284 d = popt_copy + (d - popt);
1291 if( !PL_tainting ) {
1292 PL_taint_warn = TRUE;
1302 if (PL_taint_warn && PL_dowarn != G_WARN_ALL_OFF) {
1303 PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
1307 scriptname = argv[0];
1310 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
1312 else if (scriptname == Nullch) {
1314 if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
1322 open_script(scriptname,dosearch,sv,&fdscript);
1324 validate_suid(validarg, scriptname,fdscript);
1327 #if defined(SIGCHLD) || defined(SIGCLD)
1330 # define SIGCHLD SIGCLD
1332 Sighandler_t sigstate = rsignal_state(SIGCHLD);
1333 if (sigstate == SIG_IGN) {
1334 if (ckWARN(WARN_SIGNAL))
1335 Perl_warner(aTHX_ packWARN(WARN_SIGNAL),
1336 "Can't ignore signal CHLD, forcing to default");
1337 (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL);
1343 #ifdef MACOS_TRADITIONAL
1344 if (PL_doextract || gMacPerl_AlwaysExtract) {
1349 if (cddir && PerlDir_chdir(cddir) < 0)
1350 Perl_croak(aTHX_ "Can't chdir to %s",cddir);
1354 PL_main_cv = PL_compcv = (CV*)NEWSV(1104,0);
1355 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
1356 CvUNIQUE_on(PL_compcv);
1358 CvPADLIST(PL_compcv) = pad_new(0);
1359 #ifdef USE_5005THREADS
1360 CvOWNER(PL_compcv) = 0;
1361 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
1362 MUTEX_INIT(CvMUTEXP(PL_compcv));
1363 #endif /* USE_5005THREADS */
1366 boot_core_UNIVERSAL();
1368 boot_core_xsutils();
1372 (*xsinit)(aTHX); /* in case linked C routines want magical variables */
1374 #if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__) || defined(EPOC)
1380 # ifdef HAS_SOCKS5_INIT
1381 socks5_init(argv[0]);
1387 init_predump_symbols();
1388 /* init_postdump_symbols not currently designed to be called */
1389 /* more than once (ENV isn't cleared first, for example) */
1390 /* But running with -u leaves %ENV & @ARGV undefined! XXX */
1392 init_postdump_symbols(argc,argv,env);
1394 /* PL_unicode is turned on by -C or by $ENV{PERL_UNICODE}.
1395 * PL_utf8locale is conditionally turned on by
1396 * locale.c:Perl_init_i18nl10n() if the environment
1397 * look like the user wants to use UTF-8. */
1399 /* Requires init_predump_symbols(). */
1400 if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
1405 /* Turn on UTF-8-ness on STDIN, STDOUT, STDERR
1406 * and the default open disciplines. */
1407 if ((PL_unicode & PERL_UNICODE_STDIN_FLAG) &&
1408 PL_stdingv && (io = GvIO(PL_stdingv)) &&
1410 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
1411 if ((PL_unicode & PERL_UNICODE_STDOUT_FLAG) &&
1412 PL_defoutgv && (io = GvIO(PL_defoutgv)) &&
1414 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
1415 if ((PL_unicode & PERL_UNICODE_STDERR_FLAG) &&
1416 PL_stderrgv && (io = GvIO(PL_stderrgv)) &&
1418 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
1419 if ((PL_unicode & PERL_UNICODE_INOUT_FLAG) &&
1420 (sv = GvSV(gv_fetchpv("\017PEN", TRUE, SVt_PV)))) {
1421 U32 in = PL_unicode & PERL_UNICODE_IN_FLAG;
1422 U32 out = PL_unicode & PERL_UNICODE_OUT_FLAG;
1425 sv_setpvn(sv, ":utf8\0:utf8", 11);
1427 sv_setpvn(sv, ":utf8\0", 6);
1430 sv_setpvn(sv, "\0:utf8", 6);
1436 if ((s = PerlEnv_getenv("PERL_SIGNALS"))) {
1437 if (strEQ(s, "unsafe"))
1438 PL_signals |= PERL_SIGNALS_UNSAFE_FLAG;
1439 else if (strEQ(s, "safe"))
1440 PL_signals &= ~PERL_SIGNALS_UNSAFE_FLAG;
1442 Perl_croak(aTHX_ "PERL_SIGNALS illegal: \"%s\"", s);
1447 /* now parse the script */
1449 SETERRNO(0,SS_NORMAL);
1451 #ifdef MACOS_TRADITIONAL
1452 if (gMacPerl_SyntaxError = (yyparse() || PL_error_count)) {
1454 Perl_croak(aTHX_ "%s had compilation errors.\n", MacPerl_MPWFileName(PL_origfilename));
1456 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
1457 MacPerl_MPWFileName(PL_origfilename));
1461 if (yyparse() || PL_error_count) {
1463 Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
1465 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
1470 CopLINE_set(PL_curcop, 0);
1471 PL_curstash = PL_defstash;
1472 PL_preprocess = FALSE;
1474 SvREFCNT_dec(PL_e_script);
1475 PL_e_script = Nullsv;
1482 SAVECOPFILE(PL_curcop);
1483 SAVECOPLINE(PL_curcop);
1484 gv_check(PL_defstash);
1491 if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
1492 dump_mstats("after compilation:");
1501 =for apidoc perl_run
1503 Tells a Perl interpreter to run. See L<perlembed>.
1514 #ifdef USE_5005THREADS
1518 oldscope = PL_scopestack_ix;
1523 #ifdef PERL_FLEXIBLE_EXCEPTIONS
1525 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vrun_body), oldscope);
1531 cxstack_ix = -1; /* start context stack again */
1533 case 0: /* normal completion */
1534 #ifndef PERL_FLEXIBLE_EXCEPTIONS
1539 case 2: /* my_exit() */
1540 while (PL_scopestack_ix > oldscope)
1543 PL_curstash = PL_defstash;
1544 if (!(PL_exit_flags & PERL_EXIT_DESTRUCT_END) &&
1545 PL_endav && !PL_minus_c)
1546 call_list(oldscope, PL_endav);
1548 if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
1549 dump_mstats("after execution: ");
1551 ret = STATUS_NATIVE_EXPORT;
1555 POPSTACK_TO(PL_mainstack);
1558 PerlIO_printf(Perl_error_log, "panic: restartop\n");
1568 #ifdef PERL_FLEXIBLE_EXCEPTIONS
1570 S_vrun_body(pTHX_ va_list args)
1572 I32 oldscope = va_arg(args, I32);
1574 return run_body(oldscope);
1580 S_run_body(pTHX_ I32 oldscope)
1582 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
1583 PL_sawampersand ? "Enabling" : "Omitting"));
1585 if (!PL_restartop) {
1586 DEBUG_x(dump_all());
1587 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
1588 DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%"UVxf"\n",
1592 #ifdef MACOS_TRADITIONAL
1593 PerlIO_printf(Perl_error_log, "%s%s syntax OK\n",
1594 (gMacPerl_ErrorFormat ? "# " : ""),
1595 MacPerl_MPWFileName(PL_origfilename));
1597 PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
1601 if (PERLDB_SINGLE && PL_DBsingle)
1602 sv_setiv(PL_DBsingle, 1);
1604 call_list(oldscope, PL_initav);
1610 PL_op = PL_restartop;
1614 else if (PL_main_start) {
1615 CvDEPTH(PL_main_cv) = 1;
1616 PL_op = PL_main_start;
1626 =head1 SV Manipulation Functions
1628 =for apidoc p||get_sv
1630 Returns the SV of the specified Perl scalar. If C<create> is set and the
1631 Perl variable does not exist then it will be created. If C<create> is not
1632 set and the variable does not exist then NULL is returned.
1638 Perl_get_sv(pTHX_ const char *name, I32 create)
1641 #ifdef USE_5005THREADS
1642 if (name[1] == '\0' && !isALPHA(name[0])) {
1643 PADOFFSET tmp = find_threadsv(name);
1644 if (tmp != NOT_IN_PAD)
1645 return THREADSV(tmp);
1647 #endif /* USE_5005THREADS */
1648 gv = gv_fetchpv(name, create, SVt_PV);
1655 =head1 Array Manipulation Functions
1657 =for apidoc p||get_av
1659 Returns the AV of the specified Perl array. If C<create> is set and the
1660 Perl variable does not exist then it will be created. If C<create> is not
1661 set and the variable does not exist then NULL is returned.
1667 Perl_get_av(pTHX_ const char *name, I32 create)
1669 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1678 =head1 Hash Manipulation Functions
1680 =for apidoc p||get_hv
1682 Returns the HV of the specified Perl hash. If C<create> is set and the
1683 Perl variable does not exist then it will be created. If C<create> is not
1684 set and the variable does not exist then NULL is returned.
1690 Perl_get_hv(pTHX_ const char *name, I32 create)
1692 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1701 =head1 CV Manipulation Functions
1703 =for apidoc p||get_cv
1705 Returns the CV of the specified Perl subroutine. If C<create> is set and
1706 the Perl subroutine does not exist then it will be declared (which has the
1707 same effect as saying C<sub name;>). If C<create> is not set and the
1708 subroutine does not exist then NULL is returned.
1714 Perl_get_cv(pTHX_ const char *name, I32 create)
1716 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
1717 /* XXX unsafe for threads if eval_owner isn't held */
1718 /* XXX this is probably not what they think they're getting.
1719 * It has the same effect as "sub name;", i.e. just a forward
1721 if (create && !GvCVu(gv))
1722 return newSUB(start_subparse(FALSE, 0),
1723 newSVOP(OP_CONST, 0, newSVpv(name,0)),
1731 /* Be sure to refetch the stack pointer after calling these routines. */
1735 =head1 Callback Functions
1737 =for apidoc p||call_argv
1739 Performs a callback to the specified Perl sub. See L<perlcall>.
1745 Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv)
1747 /* See G_* flags in cop.h */
1748 /* null terminated arg list */
1755 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
1760 return call_pv(sub_name, flags);
1764 =for apidoc p||call_pv
1766 Performs a callback to the specified Perl sub. See L<perlcall>.
1772 Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
1773 /* name of the subroutine */
1774 /* See G_* flags in cop.h */
1776 return call_sv((SV*)get_cv(sub_name, TRUE), flags);
1780 =for apidoc p||call_method
1782 Performs a callback to the specified Perl method. The blessed object must
1783 be on the stack. See L<perlcall>.
1789 Perl_call_method(pTHX_ const char *methname, I32 flags)
1790 /* name of the subroutine */
1791 /* See G_* flags in cop.h */
1793 return call_sv(sv_2mortal(newSVpv(methname,0)), flags | G_METHOD);
1796 /* May be called with any of a CV, a GV, or an SV containing the name. */
1798 =for apidoc p||call_sv
1800 Performs a callback to the Perl sub whose name is in the SV. See
1807 Perl_call_sv(pTHX_ SV *sv, I32 flags)
1808 /* See G_* flags in cop.h */
1811 LOGOP myop; /* fake syntax tree node */
1814 volatile I32 retval = 0;
1816 bool oldcatch = CATCH_GET;
1821 if (flags & G_DISCARD) {
1826 Zero(&myop, 1, LOGOP);
1827 myop.op_next = Nullop;
1828 if (!(flags & G_NOARGS))
1829 myop.op_flags |= OPf_STACKED;
1830 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1831 (flags & G_ARRAY) ? OPf_WANT_LIST :
1836 EXTEND(PL_stack_sp, 1);
1837 *++PL_stack_sp = sv;
1839 oldscope = PL_scopestack_ix;
1841 if (PERLDB_SUB && PL_curstash != PL_debstash
1842 /* Handle first BEGIN of -d. */
1843 && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
1844 /* Try harder, since this may have been a sighandler, thus
1845 * curstash may be meaningless. */
1846 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != PL_debstash)
1847 && !(flags & G_NODEBUG))
1848 PL_op->op_private |= OPpENTERSUB_DB;
1850 if (flags & G_METHOD) {
1851 Zero(&method_op, 1, UNOP);
1852 method_op.op_next = PL_op;
1853 method_op.op_ppaddr = PL_ppaddr[OP_METHOD];
1854 myop.op_ppaddr = PL_ppaddr[OP_ENTERSUB];
1855 PL_op = (OP*)&method_op;
1858 if (!(flags & G_EVAL)) {
1860 call_body((OP*)&myop, FALSE);
1861 retval = PL_stack_sp - (PL_stack_base + oldmark);
1862 CATCH_SET(oldcatch);
1865 myop.op_other = (OP*)&myop;
1867 /* we're trying to emulate pp_entertry() here */
1869 register PERL_CONTEXT *cx;
1870 I32 gimme = GIMME_V;
1875 push_return(Nullop);
1876 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
1878 PL_eval_root = PL_op; /* Only needed so that goto works right. */
1880 PL_in_eval = EVAL_INEVAL;
1881 if (flags & G_KEEPERR)
1882 PL_in_eval |= EVAL_KEEPERR;
1888 #ifdef PERL_FLEXIBLE_EXCEPTIONS
1890 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_body),
1897 #ifndef PERL_FLEXIBLE_EXCEPTIONS
1899 call_body((OP*)&myop, FALSE);
1901 retval = PL_stack_sp - (PL_stack_base + oldmark);
1902 if (!(flags & G_KEEPERR))
1909 /* my_exit() was called */
1910 PL_curstash = PL_defstash;
1913 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
1914 Perl_croak(aTHX_ "Callback called exit");
1919 PL_op = PL_restartop;
1923 PL_stack_sp = PL_stack_base + oldmark;
1924 if (flags & G_ARRAY)
1928 *++PL_stack_sp = &PL_sv_undef;
1933 if (PL_scopestack_ix > oldscope) {
1937 register PERL_CONTEXT *cx;
1949 if (flags & G_DISCARD) {
1950 PL_stack_sp = PL_stack_base + oldmark;
1959 #ifdef PERL_FLEXIBLE_EXCEPTIONS
1961 S_vcall_body(pTHX_ va_list args)
1963 OP *myop = va_arg(args, OP*);
1964 int is_eval = va_arg(args, int);
1966 call_body(myop, is_eval);
1972 S_call_body(pTHX_ OP *myop, int is_eval)
1974 if (PL_op == myop) {
1976 PL_op = Perl_pp_entereval(aTHX); /* this doesn't do a POPMARK */
1978 PL_op = Perl_pp_entersub(aTHX); /* this does */
1984 /* Eval a string. The G_EVAL flag is always assumed. */
1987 =for apidoc p||eval_sv
1989 Tells Perl to C<eval> the string in the SV.
1995 Perl_eval_sv(pTHX_ SV *sv, I32 flags)
1997 /* See G_* flags in cop.h */
2000 UNOP myop; /* fake syntax tree node */
2001 volatile I32 oldmark = SP - PL_stack_base;
2002 volatile I32 retval = 0;
2008 if (flags & G_DISCARD) {
2015 Zero(PL_op, 1, UNOP);
2016 EXTEND(PL_stack_sp, 1);
2017 *++PL_stack_sp = sv;
2018 oldscope = PL_scopestack_ix;
2020 if (!(flags & G_NOARGS))
2021 myop.op_flags = OPf_STACKED;
2022 myop.op_next = Nullop;
2023 myop.op_type = OP_ENTEREVAL;
2024 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
2025 (flags & G_ARRAY) ? OPf_WANT_LIST :
2027 if (flags & G_KEEPERR)
2028 myop.op_flags |= OPf_SPECIAL;
2030 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2032 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_body),
2039 #ifndef PERL_FLEXIBLE_EXCEPTIONS
2041 call_body((OP*)&myop,TRUE);
2043 retval = PL_stack_sp - (PL_stack_base + oldmark);
2044 if (!(flags & G_KEEPERR))
2051 /* my_exit() was called */
2052 PL_curstash = PL_defstash;
2055 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
2056 Perl_croak(aTHX_ "Callback called exit");
2061 PL_op = PL_restartop;
2065 PL_stack_sp = PL_stack_base + oldmark;
2066 if (flags & G_ARRAY)
2070 *++PL_stack_sp = &PL_sv_undef;
2076 if (flags & G_DISCARD) {
2077 PL_stack_sp = PL_stack_base + oldmark;
2087 =for apidoc p||eval_pv
2089 Tells Perl to C<eval> the given string and return an SV* result.
2095 Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
2098 SV* sv = newSVpv(p, 0);
2100 eval_sv(sv, G_SCALAR);
2107 if (croak_on_error && SvTRUE(ERRSV)) {
2109 Perl_croak(aTHX_ SvPVx(ERRSV, n_a));
2115 /* Require a module. */
2118 =head1 Embedding Functions
2120 =for apidoc p||require_pv
2122 Tells Perl to C<require> the file named by the string argument. It is
2123 analogous to the Perl code C<eval "require '$file'">. It's even
2124 implemented that way; consider using load_module instead.
2129 Perl_require_pv(pTHX_ const char *pv)
2133 PUSHSTACKi(PERLSI_REQUIRE);
2135 sv = sv_newmortal();
2136 sv_setpv(sv, "require '");
2139 eval_sv(sv, G_DISCARD);
2145 Perl_magicname(pTHX_ char *sym, char *name, I32 namlen)
2149 if ((gv = gv_fetchpv(sym,TRUE, SVt_PV)))
2150 sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, namlen);
2154 S_usage(pTHX_ char *name) /* XXX move this out into a module ? */
2156 /* This message really ought to be max 23 lines.
2157 * Removed -h because the user already knows that option. Others? */
2159 static char *usage_msg[] = {
2160 "-0[octal] specify record separator (\\0, if no argument)",
2161 "-a autosplit mode with -n or -p (splits $_ into @F)",
2162 "-C enable native wide character system interfaces",
2163 "-c check syntax only (runs BEGIN and CHECK blocks)",
2164 "-d[:debugger] run program under debugger",
2165 "-D[number/list] set debugging flags (argument is a bit mask or alphabets)",
2166 "-e 'command' one line of program (several -e's allowed, omit programfile)",
2167 "-F/pattern/ split() pattern for -a switch (//'s are optional)",
2168 "-i[extension] edit <> files in place (makes backup if extension supplied)",
2169 "-Idirectory specify @INC/#include directory (several -I's allowed)",
2170 "-l[octal] enable line ending processing, specifies line terminator",
2171 "-[mM][-]module execute `use/no module...' before executing program",
2172 "-n assume 'while (<>) { ... }' loop around program",
2173 "-p assume loop like -n but print line also, like sed",
2174 "-P run program through C preprocessor before compilation",
2175 "-s enable rudimentary parsing for switches after programfile",
2176 "-S look for programfile using PATH environment variable",
2177 "-T enable tainting checks",
2178 "-t enable tainting warnings",
2179 "-u dump core after parsing program",
2180 "-U allow unsafe operations",
2181 "-v print version, subversion (includes VERY IMPORTANT perl info)",
2182 "-V[:variable] print configuration summary (or a single Config.pm variable)",
2183 "-w enable many useful warnings (RECOMMENDED)",
2184 "-W enable all warnings",
2185 "-X disable all warnings",
2186 "-x[directory] strip off text before #!perl line and perhaps cd to directory",
2190 char **p = usage_msg;
2192 PerlIO_printf(PerlIO_stdout(),
2193 "\nUsage: %s [switches] [--] [programfile] [arguments]",
2196 PerlIO_printf(PerlIO_stdout(), "\n %s", *p++);
2199 /* This routine handles any switches that can be given during run */
2202 Perl_moreswitches(pTHX_ char *s)
2212 SvREFCNT_dec(PL_rs);
2213 if (s[1] == 'x' && s[2]) {
2217 for (s += 2, e = s; *e; e++);
2219 flags = PERL_SCAN_SILENT_ILLDIGIT;
2220 rschar = (U32)grok_hex(s, &numlen, &flags, NULL);
2221 if (s + numlen < e) {
2222 rschar = 0; /* Grandfather -0xFOO as -0 -xFOO. */
2226 PL_rs = newSVpvn("", 0);
2227 SvGROW(PL_rs, (STRLEN)(UNISKIP(rschar) + 1));
2228 tmps = (U8*)SvPVX(PL_rs);
2229 uvchr_to_utf8(tmps, rschar);
2230 SvCUR_set(PL_rs, UNISKIP(rschar));
2235 rschar = (U32)grok_oct(s, &numlen, &flags, NULL);
2236 if (rschar & ~((U8)~0))
2237 PL_rs = &PL_sv_undef;
2238 else if (!rschar && numlen >= 2)
2239 PL_rs = newSVpvn("", 0);
2241 char ch = (char)rschar;
2242 PL_rs = newSVpvn(&ch, 1);
2249 PL_unicode = parse_unicode_opts(&s);
2254 while (*s && !isSPACE(*s)) ++s;
2256 PL_splitstr = savepv(PL_splitstr);
2269 /* The following permits -d:Mod to accepts arguments following an =
2270 in the fashion that -MSome::Mod does. */
2271 if (*s == ':' || *s == '=') {
2274 sv = newSVpv("use Devel::", 0);
2276 /* We now allow -d:Module=Foo,Bar */
2277 while(isALNUM(*s) || *s==':') ++s;
2279 sv_catpv(sv, start);
2281 sv_catpvn(sv, start, s-start);
2282 sv_catpv(sv, " split(/,/,q{");
2287 my_setenv("PERL5DB", SvPV(sv, PL_na));
2290 PL_perldb = PERLDB_ALL;
2298 if (isALPHA(s[1])) {
2299 /* if adding extra options, remember to update DEBUG_MASK */
2300 static char debopts[] = "psltocPmfrxu HXDSTRJvC";
2303 for (s++; *s && (d = strchr(debopts,*s)); s++)
2304 PL_debug |= 1 << (d - debopts);
2307 PL_debug = atoi(s+1);
2308 for (s++; isDIGIT(*s); s++) ;
2311 if (DEBUG_p_TEST_ && ckWARN_d(WARN_DEBUGGING))
2312 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
2313 "-Dp not implemented on this platform\n");
2315 PL_debug |= DEBUG_TOP_FLAG;
2316 #else /* !DEBUGGING */
2317 if (ckWARN_d(WARN_DEBUGGING))
2318 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
2319 "Recompile perl with -DDEBUGGING to use -D switch\n");
2320 for (s++; isALNUM(*s); s++) ;
2326 usage(PL_origargv[0]);
2330 Safefree(PL_inplace);
2331 #if defined(__CYGWIN__) /* do backup extension automagically */
2332 if (*(s+1) == '\0') {
2333 PL_inplace = savepv(".bak");
2336 #endif /* __CYGWIN__ */
2337 PL_inplace = savepv(s+1);
2339 for (s = PL_inplace; *s && !isSPACE(*s); s++) ;
2342 if (*s == '-') /* Additional switches on #! line. */
2346 case 'I': /* -I handled both here and in parse_body() */
2349 while (*s && isSPACE(*s))
2354 /* ignore trailing spaces (possibly followed by other switches) */
2356 for (e = p; *e && !isSPACE(*e); e++) ;
2360 } while (*p && *p != '-');
2361 e = savepvn(s, e-s);
2362 incpush(e, TRUE, TRUE, FALSE);
2369 Perl_croak(aTHX_ "No directory specified for -I");
2375 SvREFCNT_dec(PL_ors_sv);
2380 PL_ors_sv = newSVpvn("\n",1);
2381 numlen = 3 + (*s == '0');
2382 *SvPVX(PL_ors_sv) = (char)grok_oct(s, &numlen, &flags, NULL);
2386 if (RsPARA(PL_rs)) {
2387 PL_ors_sv = newSVpvn("\n\n",2);
2390 PL_ors_sv = newSVsv(PL_rs);
2397 PL_preambleav = newAV();
2399 SV *sv = newSVpvn("use assertions::activate split(/,/,q{",37);
2403 av_push(PL_preambleav, sv);
2406 av_push(PL_preambleav, newSVpvn("use assertions::activate",24));
2409 forbid_setid("-M"); /* XXX ? */
2412 forbid_setid("-m"); /* XXX ? */
2417 /* -M-foo == 'no foo' */
2418 if (*s == '-') { use = "no "; ++s; }
2419 sv = newSVpv(use,0);
2421 /* We allow -M'Module qw(Foo Bar)' */
2422 while(isALNUM(*s) || *s==':') ++s;
2424 sv_catpv(sv, start);
2425 if (*(start-1) == 'm') {
2427 Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
2428 sv_catpv( sv, " ()");
2432 Perl_croak(aTHX_ "Module name required with -%c option",
2434 sv_catpvn(sv, start, s-start);
2435 sv_catpv(sv, " split(/,/,q{");
2441 PL_preambleav = newAV();
2442 av_push(PL_preambleav, sv);
2445 Perl_croak(aTHX_ "No space allowed after -%c", *(s-1));
2457 PL_doswitches = TRUE;
2471 #ifdef MACOS_TRADITIONAL
2472 Perl_croak(aTHX_ "Believe me, you don't want to use \"-u\" on a Macintosh");
2474 PL_do_undump = TRUE;
2483 PerlIO_printf(PerlIO_stdout(),
2484 Perl_form(aTHX_ "\nThis is perl, v%"VDf" built for %s",
2485 PL_patchlevel, ARCHNAME));
2487 /* Adjust verbose output as in the perl that ships with the DG/UX OS from EMC */
2488 PerlIO_printf(PerlIO_stdout(),
2489 Perl_form(aTHX_ "\nThis is perl, version %vd\n", PL_patchlevel));
2490 PerlIO_printf(PerlIO_stdout(),
2491 Perl_form(aTHX_ " built under %s at %s %s\n",
2492 OSNAME, __DATE__, __TIME__));
2493 PerlIO_printf(PerlIO_stdout(),
2494 Perl_form(aTHX_ " OS Specific Release: %s\n",
2498 #if defined(LOCAL_PATCH_COUNT)
2499 if (LOCAL_PATCH_COUNT > 0)
2500 PerlIO_printf(PerlIO_stdout(),
2501 "\n(with %d registered patch%s, "
2502 "see perl -V for more detail)",
2503 (int)LOCAL_PATCH_COUNT,
2504 (LOCAL_PATCH_COUNT!=1) ? "es" : "");
2507 PerlIO_printf(PerlIO_stdout(),
2508 "\n\nCopyright 1987-2003, Larry Wall\n");
2509 #ifdef MACOS_TRADITIONAL
2510 PerlIO_printf(PerlIO_stdout(),
2511 "\nMac OS port Copyright 1991-2002, Matthias Neeracher;\n"
2512 "maintained by Chris Nandor\n");
2515 PerlIO_printf(PerlIO_stdout(),
2516 "\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
2519 PerlIO_printf(PerlIO_stdout(),
2520 "djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n"
2521 "djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
2524 PerlIO_printf(PerlIO_stdout(),
2525 "\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
2526 "Version 5 port Copyright (c) 1994-2002, Andreas Kaiser, Ilya Zakharevich\n");
2529 PerlIO_printf(PerlIO_stdout(),
2530 "atariST series port, ++jrb bammi@cadence.com\n");
2533 PerlIO_printf(PerlIO_stdout(),
2534 "BeOS port Copyright Tom Spindler, 1997-1999\n");
2537 PerlIO_printf(PerlIO_stdout(),
2538 "MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-2002\n");
2541 PerlIO_printf(PerlIO_stdout(),
2542 "MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
2545 PerlIO_printf(PerlIO_stdout(),
2546 "Stratus VOS port by Paul.Green@stratus.com, 1997-2002\n");
2549 PerlIO_printf(PerlIO_stdout(),
2550 "VM/ESA port by Neale Ferguson, 1998-1999\n");
2553 PerlIO_printf(PerlIO_stdout(),
2554 "BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
2557 PerlIO_printf(PerlIO_stdout(),
2558 "MiNT port by Guido Flohr, 1997-1999\n");
2561 PerlIO_printf(PerlIO_stdout(),
2562 "EPOC port by Olaf Flebbe, 1999-2002\n");
2565 PerlIO_printf(PerlIO_stdout(),"WINCE port by Rainer Keuchel, 2001-2002\n");
2566 PerlIO_printf(PerlIO_stdout(),"Built on " __DATE__ " " __TIME__ "\n\n");
2569 #ifdef BINARY_BUILD_NOTICE
2570 BINARY_BUILD_NOTICE;
2572 PerlIO_printf(PerlIO_stdout(),
2574 Perl may be copied only under the terms of either the Artistic License or the\n\
2575 GNU General Public License, which may be found in the Perl 5 source kit.\n\n\
2576 Complete documentation for Perl, including FAQ lists, should be found on\n\
2577 this system using `man perl' or `perldoc perl'. If you have access to the\n\
2578 Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
2581 if (! (PL_dowarn & G_WARN_ALL_MASK))
2582 PL_dowarn |= G_WARN_ON;
2586 PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
2587 if (!specialWARN(PL_compiling.cop_warnings))
2588 SvREFCNT_dec(PL_compiling.cop_warnings);
2589 PL_compiling.cop_warnings = pWARN_ALL ;
2593 PL_dowarn = G_WARN_ALL_OFF;
2594 if (!specialWARN(PL_compiling.cop_warnings))
2595 SvREFCNT_dec(PL_compiling.cop_warnings);
2596 PL_compiling.cop_warnings = pWARN_NONE ;
2601 if (s[1] == '-') /* Additional switches on #! line. */
2606 #if defined(WIN32) || !defined(PERL_STRICT_CR)
2612 #ifdef ALTERNATE_SHEBANG
2613 case 'S': /* OS/2 needs -S on "extproc" line. */
2621 Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
2626 /* compliments of Tom Christiansen */
2628 /* unexec() can be found in the Gnu emacs distribution */
2629 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
2632 Perl_my_unexec(pTHX)
2640 prog = newSVpv(BIN_EXP, 0);
2641 sv_catpv(prog, "/perl");
2642 file = newSVpv(PL_origfilename, 0);
2643 sv_catpv(file, ".perldump");
2645 unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
2646 /* unexec prints msg to stderr in case of failure */
2647 PerlProc_exit(status);
2650 # include <lib$routines.h>
2651 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
2653 ABORT(); /* for use with undump */
2658 /* initialize curinterp */
2664 # define PERLVAR(var,type)
2665 # define PERLVARA(var,n,type)
2666 # if defined(PERL_IMPLICIT_CONTEXT)
2667 # if defined(USE_5005THREADS)
2668 # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
2669 # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
2670 # else /* !USE_5005THREADS */
2671 # define PERLVARI(var,type,init) aTHX->var = init;
2672 # define PERLVARIC(var,type,init) aTHX->var = init;
2673 # endif /* USE_5005THREADS */
2675 # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
2676 # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
2678 # include "intrpvar.h"
2679 # ifndef USE_5005THREADS
2680 # include "thrdvar.h"
2687 # define PERLVAR(var,type)
2688 # define PERLVARA(var,n,type)
2689 # define PERLVARI(var,type,init) PL_##var = init;
2690 # define PERLVARIC(var,type,init) PL_##var = init;
2691 # include "intrpvar.h"
2692 # ifndef USE_5005THREADS
2693 # include "thrdvar.h"
2704 S_init_main_stash(pTHX)
2708 PL_curstash = PL_defstash = newHV();
2709 PL_curstname = newSVpvn("main",4);
2710 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
2711 SvREFCNT_dec(GvHV(gv));
2712 GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
2714 HvNAME(PL_defstash) = savepv("main");
2715 PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
2716 GvMULTI_on(PL_incgv);
2717 PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
2718 GvMULTI_on(PL_hintgv);
2719 PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
2720 PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
2721 GvMULTI_on(PL_errgv);
2722 PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
2723 GvMULTI_on(PL_replgv);
2724 (void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */
2725 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
2726 sv_setpvn(ERRSV, "", 0);
2727 PL_curstash = PL_defstash;
2728 CopSTASH_set(&PL_compiling, PL_defstash);
2729 PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
2730 PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
2731 /* We must init $/ before switches are processed. */
2732 sv_setpvn(get_sv("/", TRUE), "\n", 1);
2736 S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
2740 char *cpp_discard_flag;
2746 PL_origfilename = savepv("-e");
2749 /* if find_script() returns, it returns a malloc()-ed value */
2750 PL_origfilename = scriptname = find_script(scriptname, dosearch, NULL, 1);
2752 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
2753 char *s = scriptname + 8;
2754 *fdscript = atoi(s);
2758 scriptname = savepv(s + 1);
2759 Safefree(PL_origfilename);
2760 PL_origfilename = scriptname;
2765 CopFILE_free(PL_curcop);
2766 CopFILE_set(PL_curcop, PL_origfilename);
2767 if (strEQ(PL_origfilename,"-"))
2769 if (*fdscript >= 0) {
2770 PL_rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE);
2771 # if defined(HAS_FCNTL) && defined(F_SETFD)
2773 /* ensure close-on-exec */
2774 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
2777 else if (PL_preprocess) {
2778 char *cpp_cfg = CPPSTDIN;
2779 SV *cpp = newSVpvn("",0);
2780 SV *cmd = NEWSV(0,0);
2782 if (strEQ(cpp_cfg, "cppstdin"))
2783 Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
2784 sv_catpv(cpp, cpp_cfg);
2787 sv_catpvn(sv, "-I", 2);
2788 sv_catpv(sv,PRIVLIB_EXP);
2791 DEBUG_P(PerlIO_printf(Perl_debug_log,
2792 "PL_preprocess: scriptname=\"%s\", cpp=\"%s\", sv=\"%s\", CPPMINUS=\"%s\"\n",
2793 scriptname, SvPVX (cpp), SvPVX (sv), CPPMINUS));
2795 # if defined(MSDOS) || defined(WIN32) || defined(VMS)
2802 cpp_discard_flag = "";
2804 cpp_discard_flag = "-C";
2808 perl = os2_execname(aTHX);
2810 perl = PL_origargv[0];
2814 /* This strips off Perl comments which might interfere with
2815 the C pre-processor, including #!. #line directives are
2816 deliberately stripped to avoid confusion with Perl's version
2817 of #line. FWP played some golf with it so it will fit
2818 into VMS's 255 character buffer.
2821 code = "(1../^#!.*perl/i)|/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print";
2823 code = "/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print";
2825 Perl_sv_setpvf(aTHX_ cmd, "\
2826 %s -ne%s%s%s %s | %"SVf" %s %"SVf" %s",
2827 perl, quote, code, quote, scriptname, cpp,
2828 cpp_discard_flag, sv, CPPMINUS);
2830 PL_doextract = FALSE;
2831 # ifdef IAMSUID /* actually, this is caught earlier */
2832 if (PL_euid != PL_uid && !PL_euid) { /* if running suidperl */
2834 (void)seteuid(PL_uid); /* musn't stay setuid root */
2836 # ifdef HAS_SETREUID
2837 (void)setreuid((Uid_t)-1, PL_uid);
2839 # ifdef HAS_SETRESUID
2840 (void)setresuid((Uid_t)-1, PL_uid, (Uid_t)-1);
2842 PerlProc_setuid(PL_uid);
2846 if (PerlProc_geteuid() != PL_uid)
2847 Perl_croak(aTHX_ "Can't do seteuid!\n");
2849 # endif /* IAMSUID */
2851 DEBUG_P(PerlIO_printf(Perl_debug_log,
2852 "PL_preprocess: cmd=\"%s\"\n",
2855 PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
2859 else if (!*scriptname) {
2860 forbid_setid("program input from stdin");
2861 PL_rsfp = PerlIO_stdin();
2864 PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
2865 # if defined(HAS_FCNTL) && defined(F_SETFD)
2867 /* ensure close-on-exec */
2868 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
2873 # ifndef IAMSUID /* in case script is not readable before setuid */
2875 PerlLIO_stat(CopFILE(PL_curcop),&PL_statbuf) >= 0 &&
2876 PL_statbuf.st_mode & (S_ISUID|S_ISGID))
2879 PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT,
2880 BIN_EXP, (int)PERL_REVISION,
2882 (int)PERL_SUBVERSION), PL_origargv);
2883 Perl_croak(aTHX_ "Can't do setuid\n");
2889 Perl_croak(aTHX_ "Can't open perl script: %s\n",
2892 Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
2893 CopFILE(PL_curcop), Strerror(errno));
2899 * I_SYSSTATVFS HAS_FSTATVFS
2901 * I_STATFS HAS_FSTATFS HAS_GETFSSTAT
2902 * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT
2903 * here so that metaconfig picks them up. */
2907 S_fd_on_nosuid_fs(pTHX_ int fd)
2909 int check_okay = 0; /* able to do all the required sys/libcalls */
2910 int on_nosuid = 0; /* the fd is on a nosuid fs */
2912 * Preferred order: fstatvfs(), fstatfs(), ustat()+getmnt(), getmntent().
2913 * fstatvfs() is UNIX98.
2914 * fstatfs() is 4.3 BSD.
2915 * ustat()+getmnt() is pre-4.3 BSD.
2916 * getmntent() is O(number-of-mounted-filesystems) and can hang on
2917 * an irrelevant filesystem while trying to reach the right one.
2920 #undef FD_ON_NOSUID_CHECK_OKAY /* found the syscalls to do the check? */
2922 # if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
2923 defined(HAS_FSTATVFS)
2924 # define FD_ON_NOSUID_CHECK_OKAY
2925 struct statvfs stfs;
2927 check_okay = fstatvfs(fd, &stfs) == 0;
2928 on_nosuid = check_okay && (stfs.f_flag & ST_NOSUID);
2929 # endif /* fstatvfs */
2931 # if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
2932 defined(PERL_MOUNT_NOSUID) && \
2933 defined(HAS_FSTATFS) && \
2934 defined(HAS_STRUCT_STATFS) && \
2935 defined(HAS_STRUCT_STATFS_F_FLAGS)
2936 # define FD_ON_NOSUID_CHECK_OKAY
2939 check_okay = fstatfs(fd, &stfs) == 0;
2940 on_nosuid = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
2941 # endif /* fstatfs */
2943 # if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
2944 defined(PERL_MOUNT_NOSUID) && \
2945 defined(HAS_FSTAT) && \
2946 defined(HAS_USTAT) && \
2947 defined(HAS_GETMNT) && \
2948 defined(HAS_STRUCT_FS_DATA) && \
2950 # define FD_ON_NOSUID_CHECK_OKAY
2953 if (fstat(fd, &fdst) == 0) {
2955 if (ustat(fdst.st_dev, &us) == 0) {
2957 /* NOSTAT_ONE here because we're not examining fields which
2958 * vary between that case and STAT_ONE. */
2959 if (getmnt((int*)0, &fsd, (int)0, NOSTAT_ONE, us.f_fname) == 0) {
2960 size_t cmplen = sizeof(us.f_fname);
2961 if (sizeof(fsd.fd_req.path) < cmplen)
2962 cmplen = sizeof(fsd.fd_req.path);
2963 if (strnEQ(fsd.fd_req.path, us.f_fname, cmplen) &&
2964 fdst.st_dev == fsd.fd_req.dev) {
2966 on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID;
2972 # endif /* fstat+ustat+getmnt */
2974 # if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
2975 defined(HAS_GETMNTENT) && \
2976 defined(HAS_HASMNTOPT) && \
2977 defined(MNTOPT_NOSUID)
2978 # define FD_ON_NOSUID_CHECK_OKAY
2979 FILE *mtab = fopen("/etc/mtab", "r");
2980 struct mntent *entry;
2983 if (mtab && (fstat(fd, &stb) == 0)) {
2984 while (entry = getmntent(mtab)) {
2985 if (stat(entry->mnt_dir, &fsb) == 0
2986 && fsb.st_dev == stb.st_dev)
2988 /* found the filesystem */
2990 if (hasmntopt(entry, MNTOPT_NOSUID))
2993 } /* A single fs may well fail its stat(). */
2998 # endif /* getmntent+hasmntopt */
3001 Perl_croak(aTHX_ "Can't check filesystem of script \"%s\" for nosuid", PL_origfilename);
3004 #endif /* IAMSUID */
3007 S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript)
3013 /* do we need to emulate setuid on scripts? */
3015 /* This code is for those BSD systems that have setuid #! scripts disabled
3016 * in the kernel because of a security problem. Merely defining DOSUID
3017 * in perl will not fix that problem, but if you have disabled setuid
3018 * scripts in the kernel, this will attempt to emulate setuid and setgid
3019 * on scripts that have those now-otherwise-useless bits set. The setuid
3020 * root version must be called suidperl or sperlN.NNN. If regular perl
3021 * discovers that it has opened a setuid script, it calls suidperl with
3022 * the same argv that it had. If suidperl finds that the script it has
3023 * just opened is NOT setuid root, it sets the effective uid back to the
3024 * uid. We don't just make perl setuid root because that loses the
3025 * effective uid we had before invoking perl, if it was different from the
3028 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
3029 * be defined in suidperl only. suidperl must be setuid root. The
3030 * Configure script will set this up for you if you want it.
3036 if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */
3037 Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
3038 if (fdscript < 0 && PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
3043 #ifndef HAS_SETREUID
3044 /* On this access check to make sure the directories are readable,
3045 * there is actually a small window that the user could use to make
3046 * filename point to an accessible directory. So there is a faint
3047 * chance that someone could execute a setuid script down in a
3048 * non-accessible directory. I don't know what to do about that.
3049 * But I don't think it's too important. The manual lies when
3050 * it says access() is useful in setuid programs.
3052 if (PerlLIO_access(CopFILE(PL_curcop),1)) /*double check*/
3053 Perl_croak(aTHX_ "Permission denied");
3055 /* If we can swap euid and uid, then we can determine access rights
3056 * with a simple stat of the file, and then compare device and
3057 * inode to make sure we did stat() on the same file we opened.
3058 * Then we just have to make sure he or she can execute it.
3065 setreuid(PL_euid,PL_uid) < 0
3068 setresuid(PL_euid,PL_uid,(Uid_t)-1) < 0
3071 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
3072 Perl_croak(aTHX_ "Can't swap uid and euid"); /* really paranoid */
3073 if (PerlLIO_stat(CopFILE(PL_curcop),&tmpstatbuf) < 0)
3074 Perl_croak(aTHX_ "Permission denied"); /* testing full pathname here */
3075 #if defined(IAMSUID) && !defined(NO_NOSUID_CHECK)
3076 if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp)))
3077 Perl_croak(aTHX_ "Permission denied");
3079 if (tmpstatbuf.st_dev != PL_statbuf.st_dev ||
3080 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
3081 (void)PerlIO_close(PL_rsfp);
3082 Perl_croak(aTHX_ "Permission denied\n");
3086 setreuid(PL_uid,PL_euid) < 0
3088 # if defined(HAS_SETRESUID)
3089 setresuid(PL_uid,PL_euid,(Uid_t)-1) < 0
3092 || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
3093 Perl_croak(aTHX_ "Can't reswap uid and euid");
3094 if (!cando(S_IXUSR,FALSE,&PL_statbuf)) /* can real uid exec? */
3095 Perl_croak(aTHX_ "Permission denied\n");
3097 #endif /* HAS_SETREUID */
3098 #endif /* IAMSUID */
3100 if (!S_ISREG(PL_statbuf.st_mode))
3101 Perl_croak(aTHX_ "Permission denied");
3102 if (PL_statbuf.st_mode & S_IWOTH)
3103 Perl_croak(aTHX_ "Setuid/gid script is writable by world");
3104 PL_doswitches = FALSE; /* -s is insecure in suid */
3105 CopLINE_inc(PL_curcop);
3106 if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
3107 strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */
3108 Perl_croak(aTHX_ "No #! line");
3109 s = SvPV(PL_linestr,n_a)+2;
3111 while (!isSPACE(*s)) s++;
3112 for (s2 = s; (s2 > SvPV(PL_linestr,n_a)+2 &&
3113 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
3114 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
3115 Perl_croak(aTHX_ "Not a perl script");
3116 while (*s == ' ' || *s == '\t') s++;
3118 * #! arg must be what we saw above. They can invoke it by
3119 * mentioning suidperl explicitly, but they may not add any strange
3120 * arguments beyond what #! says if they do invoke suidperl that way.
3122 len = strlen(validarg);
3123 if (strEQ(validarg," PHOOEY ") ||
3124 strnNE(s,validarg,len) || !isSPACE(s[len]))
3125 Perl_croak(aTHX_ "Args must match #! line");
3128 if (PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
3129 PL_euid == PL_statbuf.st_uid)
3131 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
3132 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
3133 #endif /* IAMSUID */
3135 if (PL_euid) { /* oops, we're not the setuid root perl */
3136 (void)PerlIO_close(PL_rsfp);
3139 PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
3140 (int)PERL_REVISION, (int)PERL_VERSION,
3141 (int)PERL_SUBVERSION), PL_origargv);
3143 Perl_croak(aTHX_ "Can't do setuid\n");
3146 if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
3148 (void)setegid(PL_statbuf.st_gid);
3151 (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
3153 #ifdef HAS_SETRESGID
3154 (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
3156 PerlProc_setgid(PL_statbuf.st_gid);
3160 if (PerlProc_getegid() != PL_statbuf.st_gid)
3161 Perl_croak(aTHX_ "Can't do setegid!\n");
3163 if (PL_statbuf.st_mode & S_ISUID) {
3164 if (PL_statbuf.st_uid != PL_euid)
3166 (void)seteuid(PL_statbuf.st_uid); /* all that for this */
3169 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
3171 #ifdef HAS_SETRESUID
3172 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
3174 PerlProc_setuid(PL_statbuf.st_uid);
3178 if (PerlProc_geteuid() != PL_statbuf.st_uid)
3179 Perl_croak(aTHX_ "Can't do seteuid!\n");
3181 else if (PL_uid) { /* oops, mustn't run as root */
3183 (void)seteuid((Uid_t)PL_uid);
3186 (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
3188 #ifdef HAS_SETRESUID
3189 (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
3191 PerlProc_setuid((Uid_t)PL_uid);
3195 if (PerlProc_geteuid() != PL_uid)
3196 Perl_croak(aTHX_ "Can't do seteuid!\n");
3199 if (!cando(S_IXUSR,TRUE,&PL_statbuf))
3200 Perl_croak(aTHX_ "Permission denied\n"); /* they can't do this */
3203 else if (PL_preprocess)
3204 Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
3205 else if (fdscript >= 0)
3206 Perl_croak(aTHX_ "fd script not allowed in suidperl\n");
3208 Perl_croak(aTHX_ "Script is not setuid/setgid in suidperl\n");
3210 /* We absolutely must clear out any saved ids here, so we */
3211 /* exec the real perl, substituting fd script for scriptname. */
3212 /* (We pass script name as "subdir" of fd, which perl will grok.) */
3213 PerlIO_rewind(PL_rsfp);
3214 PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0); /* just in case rewind didn't */
3215 for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
3216 if (!PL_origargv[which])
3217 Perl_croak(aTHX_ "Permission denied");
3218 PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
3219 PerlIO_fileno(PL_rsfp), PL_origargv[which]));
3220 #if defined(HAS_FCNTL) && defined(F_SETFD)
3221 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */
3223 PerlProc_execv(Perl_form(aTHX_ "%s/perl"PERL_FS_VER_FMT, BIN_EXP,
3224 (int)PERL_REVISION, (int)PERL_VERSION,
3225 (int)PERL_SUBVERSION), PL_origargv);/* try again */
3226 Perl_croak(aTHX_ "Can't do setuid\n");
3227 #endif /* IAMSUID */
3229 if (PL_euid != PL_uid || PL_egid != PL_gid) { /* (suidperl doesn't exist, in fact) */
3230 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
3231 PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf); /* may be either wrapped or real suid */
3232 if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
3234 (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
3237 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
3238 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
3239 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
3240 /* not set-id, must be wrapped */
3246 S_find_beginning(pTHX)
3248 register char *s, *s2;
3249 #ifdef MACOS_TRADITIONAL
3253 /* skip forward in input to the real script? */
3256 #ifdef MACOS_TRADITIONAL
3257 /* Since the Mac OS does not honor #! arguments for us, we do it ourselves */
3259 while (PL_doextract || gMacPerl_AlwaysExtract) {
3260 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
3261 if (!gMacPerl_AlwaysExtract)
3262 Perl_croak(aTHX_ "No Perl script found in input\n");
3264 if (PL_doextract) /* require explicit override ? */
3265 if (!OverrideExtract(PL_origfilename))
3266 Perl_croak(aTHX_ "User aborted script\n");
3268 PL_doextract = FALSE;
3270 /* Pater peccavi, file does not have #! */
3271 PerlIO_rewind(PL_rsfp);
3276 while (PL_doextract) {
3277 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
3278 Perl_croak(aTHX_ "No Perl script found in input\n");
3281 if (*s == '#' && s[1] == '!' && ((s = instr(s,"perl")) || (s = instr(s2,"PERL")))) {
3282 PerlIO_ungetc(PL_rsfp, '\n'); /* to keep line count right */
3283 PL_doextract = FALSE;
3284 while (*s && !(isSPACE (*s) || *s == '#')) s++;
3286 while (*s == ' ' || *s == '\t') s++;
3288 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
3289 if (strnEQ(s2-4,"perl",4))
3291 while ((s = moreswitches(s)))
3294 #ifdef MACOS_TRADITIONAL
3295 /* We are always searching for the #!perl line in MacPerl,
3296 * so if we find it, still keep the line count correct
3297 * by counting lines we already skipped over
3299 for (; maclines > 0 ; maclines--)
3300 PerlIO_ungetc(PL_rsfp, '\n');
3304 /* gMacPerl_AlwaysExtract is false in MPW tool */
3305 } else if (gMacPerl_AlwaysExtract) {
3316 PL_uid = PerlProc_getuid();
3317 PL_euid = PerlProc_geteuid();
3318 PL_gid = PerlProc_getgid();
3319 PL_egid = PerlProc_getegid();
3321 PL_uid |= PL_gid << 16;
3322 PL_euid |= PL_egid << 16;
3324 /* Should not happen: */
3325 CHECK_MALLOC_TAINT(PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
3326 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
3329 /* This is used very early in the lifetime of the program,
3330 * before even the options are parsed, so PL_tainting has
3331 * not been initialized properly. The variable PL_earlytaint
3332 * is set early in main() to the result of this function. */
3334 Perl_doing_taint(int argc, char *argv[], char *envp[])
3336 int uid = PerlProc_getuid();
3337 int euid = PerlProc_geteuid();
3338 int gid = PerlProc_getgid();
3339 int egid = PerlProc_getegid();
3345 if (uid && (euid != uid || egid != gid))
3347 /* This is a really primitive check; environment gets ignored only
3348 * if -T are the first chars together; otherwise one gets
3349 * "Too late" message. */
3350 if ( argc > 1 && argv[1][0] == '-'
3351 && (argv[1][1] == 't' || argv[1][1] == 'T') )
3357 S_forbid_setid(pTHX_ char *s)
3359 if (PL_euid != PL_uid)
3360 Perl_croak(aTHX_ "No %s allowed while running setuid", s);
3361 if (PL_egid != PL_gid)
3362 Perl_croak(aTHX_ "No %s allowed while running setgid", s);
3366 Perl_init_debugger(pTHX)
3368 HV *ostash = PL_curstash;
3370 PL_curstash = PL_debstash;
3371 PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
3372 AvREAL_off(PL_dbargs);
3373 PL_DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
3374 PL_DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
3375 PL_DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
3376 sv_upgrade(GvSV(PL_DBsub), SVt_IV); /* IVX accessed if PERLDB_SUB_NN */
3377 PL_DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
3378 sv_setiv(PL_DBsingle, 0);
3379 PL_DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
3380 sv_setiv(PL_DBtrace, 0);
3381 PL_DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
3382 sv_setiv(PL_DBsignal, 0);
3383 PL_DBassertion = GvSV((gv_fetchpv("assertion", GV_ADDMULTI, SVt_PV)));
3384 sv_setiv(PL_DBassertion, 0);
3385 PL_curstash = ostash;
3388 #ifndef STRESS_REALLOC
3389 #define REASONABLE(size) (size)
3391 #define REASONABLE(size) (1) /* unreasonable */
3395 Perl_init_stacks(pTHX)
3397 /* start with 128-item stack and 8K cxstack */
3398 PL_curstackinfo = new_stackinfo(REASONABLE(128),
3399 REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
3400 PL_curstackinfo->si_type = PERLSI_MAIN;
3401 PL_curstack = PL_curstackinfo->si_stack;
3402 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
3404 PL_stack_base = AvARRAY(PL_curstack);
3405 PL_stack_sp = PL_stack_base;
3406 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
3408 New(50,PL_tmps_stack,REASONABLE(128),SV*);
3411 PL_tmps_max = REASONABLE(128);
3413 New(54,PL_markstack,REASONABLE(32),I32);
3414 PL_markstack_ptr = PL_markstack;
3415 PL_markstack_max = PL_markstack + REASONABLE(32);
3419 New(54,PL_scopestack,REASONABLE(32),I32);
3420 PL_scopestack_ix = 0;
3421 PL_scopestack_max = REASONABLE(32);
3423 New(54,PL_savestack,REASONABLE(128),ANY);
3424 PL_savestack_ix = 0;
3425 PL_savestack_max = REASONABLE(128);
3427 New(54,PL_retstack,REASONABLE(16),OP*);
3429 PL_retstack_max = REASONABLE(16);
3437 while (PL_curstackinfo->si_next)
3438 PL_curstackinfo = PL_curstackinfo->si_next;
3439 while (PL_curstackinfo) {
3440 PERL_SI *p = PL_curstackinfo->si_prev;
3441 /* curstackinfo->si_stack got nuked by sv_free_arenas() */
3442 Safefree(PL_curstackinfo->si_cxstack);
3443 Safefree(PL_curstackinfo);
3444 PL_curstackinfo = p;
3446 Safefree(PL_tmps_stack);
3447 Safefree(PL_markstack);
3448 Safefree(PL_scopestack);
3449 Safefree(PL_savestack);
3450 Safefree(PL_retstack);
3459 lex_start(PL_linestr);
3461 PL_subname = newSVpvn("main",4);
3465 S_init_predump_symbols(pTHX)
3470 sv_setpvn(get_sv("\"", TRUE), " ", 1);
3471 PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
3472 GvMULTI_on(PL_stdingv);
3473 io = GvIOp(PL_stdingv);
3474 IoTYPE(io) = IoTYPE_RDONLY;
3475 IoIFP(io) = PerlIO_stdin();
3476 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
3478 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
3480 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
3483 IoTYPE(io) = IoTYPE_WRONLY;
3484 IoOFP(io) = IoIFP(io) = PerlIO_stdout();
3486 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
3488 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
3490 PL_stderrgv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
3491 GvMULTI_on(PL_stderrgv);
3492 io = GvIOp(PL_stderrgv);
3493 IoTYPE(io) = IoTYPE_WRONLY;
3494 IoOFP(io) = IoIFP(io) = PerlIO_stderr();
3495 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
3497 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
3499 PL_statname = NEWSV(66,0); /* last filename we did stat on */
3502 Safefree(PL_osname);
3503 PL_osname = savepv(OSNAME);
3507 Perl_init_argv_symbols(pTHX_ register int argc, register char **argv)
3510 argc--,argv++; /* skip name of script */
3511 if (PL_doswitches) {
3512 for (; argc > 0 && **argv == '-'; argc--,argv++) {
3515 if (argv[0][1] == '-' && !argv[0][2]) {
3519 if ((s = strchr(argv[0], '='))) {
3521 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
3524 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
3527 if ((PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV))) {
3528 GvMULTI_on(PL_argvgv);
3529 (void)gv_AVadd(PL_argvgv);
3530 av_clear(GvAVn(PL_argvgv));
3531 for (; argc > 0; argc--,argv++) {
3532 SV *sv = newSVpv(argv[0],0);
3533 av_push(GvAVn(PL_argvgv),sv);
3534 if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
3535 if (PL_unicode & PERL_UNICODE_ARGV_FLAG)
3538 if (PL_unicode & PERL_UNICODE_WIDESYSCALLS_FLAG) /* Sarathy? */
3539 (void)sv_utf8_decode(sv);
3544 #ifdef HAS_PROCSELFEXE
3545 /* This is a function so that we don't hold on to MAXPATHLEN
3546 bytes of stack longer than necessary
3549 S_procself_val(pTHX_ SV *sv, char *arg0)
3551 char buf[MAXPATHLEN];
3552 int len = readlink(PROCSELFEXE_PATH, buf, sizeof(buf) - 1);
3554 /* On Playstation2 Linux V1.0 (kernel 2.2.1) readlink(/proc/self/exe)
3555 includes a spurious NUL which will cause $^X to fail in system
3556 or backticks (this will prevent extensions from being built and
3557 many tests from working). readlink is not meant to add a NUL.
3558 Normal readlink works fine.
3560 if (len > 0 && buf[len-1] == '\0') {
3564 /* FreeBSD's implementation is acknowledged to be imperfect, sometimes
3565 returning the text "unknown" from the readlink rather than the path
3566 to the executable (or returning an error from the readlink). Any valid
3567 path has a '/' in it somewhere, so use that to validate the result.
3568 See http://www.freebsd.org/cgi/query-pr.cgi?pr=35703
3570 if (len > 0 && memchr(buf, '/', len)) {
3571 sv_setpvn(sv,buf,len);
3577 #endif /* HAS_PROCSELFEXE */
3580 S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
3586 PL_toptarget = NEWSV(0,0);
3587 sv_upgrade(PL_toptarget, SVt_PVFM);
3588 sv_setpvn(PL_toptarget, "", 0);
3589 PL_bodytarget = NEWSV(0,0);
3590 sv_upgrade(PL_bodytarget, SVt_PVFM);
3591 sv_setpvn(PL_bodytarget, "", 0);
3592 PL_formtarget = PL_bodytarget;
3596 init_argv_symbols(argc,argv);
3598 if ((tmpgv = gv_fetchpv("0",TRUE, SVt_PV))) {
3599 #ifdef MACOS_TRADITIONAL
3600 /* $0 is not majick on a Mac */
3601 sv_setpv(GvSV(tmpgv),MacPerl_MPWFileName(PL_origfilename));
3603 sv_setpv(GvSV(tmpgv),PL_origfilename);
3604 magicname("0", "0", 1);
3607 if ((tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))) {/* $^X */
3608 #ifdef HAS_PROCSELFEXE
3609 S_procself_val(aTHX_ GvSV(tmpgv), PL_origargv[0]);
3612 sv_setpv(GvSV(tmpgv), os2_execname(aTHX));
3614 sv_setpv(GvSV(tmpgv),PL_origargv[0]);
3618 if ((PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV))) {
3620 GvMULTI_on(PL_envgv);
3621 hv = GvHVn(PL_envgv);
3622 hv_magic(hv, Nullgv, PERL_MAGIC_env);
3623 #ifdef USE_ENVIRON_ARRAY
3624 /* Note that if the supplied env parameter is actually a copy
3625 of the global environ then it may now point to free'd memory
3626 if the environment has been modified since. To avoid this
3627 problem we treat env==NULL as meaning 'use the default'
3632 # ifdef USE_ITHREADS
3633 && PL_curinterp == aTHX
3637 environ[0] = Nullch;
3640 for (; *env; env++) {
3641 if (!(s = strchr(*env,'=')))
3648 sv = newSVpv(s+1, 0);
3649 (void)hv_store(hv, *env, s - *env, sv, 0);
3653 #endif /* USE_ENVIRON_ARRAY */
3656 if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV))) {
3657 SvREADONLY_off(GvSV(tmpgv));
3658 sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
3659 SvREADONLY_on(GvSV(tmpgv));
3661 #ifdef THREADS_HAVE_PIDS
3662 PL_ppid = (IV)getppid();
3665 /* touch @F array to prevent spurious warnings 20020415 MJD */
3667 (void) get_av("main::F", TRUE | GV_ADDMULTI);
3669 /* touch @- and @+ arrays to prevent spurious warnings 20020415 MJD */
3670 (void) get_av("main::-", TRUE | GV_ADDMULTI);
3671 (void) get_av("main::+", TRUE | GV_ADDMULTI);
3675 S_init_perllib(pTHX)
3680 s = PerlEnv_getenv("PERL5LIB");
3682 incpush(s, TRUE, TRUE, TRUE);
3684 incpush(PerlEnv_getenv("PERLLIB"), FALSE, FALSE, TRUE);
3686 /* Treat PERL5?LIB as a possible search list logical name -- the
3687 * "natural" VMS idiom for a Unix path string. We allow each
3688 * element to be a set of |-separated directories for compatibility.
3692 if (my_trnlnm("PERL5LIB",buf,0))
3693 do { incpush(buf,TRUE,TRUE,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
3695 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE,FALSE,TRUE);
3699 /* Use the ~-expanded versions of APPLLIB (undocumented),
3700 ARCHLIB PRIVLIB SITEARCH SITELIB VENDORARCH and VENDORLIB
3703 incpush(APPLLIB_EXP, TRUE, TRUE, TRUE);
3707 incpush(ARCHLIB_EXP, FALSE, FALSE, TRUE);
3709 #ifdef MACOS_TRADITIONAL
3712 SV * privdir = NEWSV(55, 0);
3713 char * macperl = PerlEnv_getenv("MACPERL");
3718 Perl_sv_setpvf(aTHX_ privdir, "%slib:", macperl);
3719 if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
3720 incpush(SvPVX(privdir), TRUE, FALSE, TRUE);
3721 Perl_sv_setpvf(aTHX_ privdir, "%ssite_perl:", macperl);
3722 if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
3723 incpush(SvPVX(privdir), TRUE, FALSE, TRUE);
3725 SvREFCNT_dec(privdir);
3728 incpush(":", FALSE, FALSE, TRUE);
3731 # define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
3734 incpush(PRIVLIB_EXP, TRUE, FALSE, TRUE);
3736 incpush(PRIVLIB_EXP, FALSE, FALSE, TRUE);
3740 /* sitearch is always relative to sitelib on Windows for
3741 * DLL-based path intuition to work correctly */
3742 # if !defined(WIN32)
3743 incpush(SITEARCH_EXP, FALSE, FALSE, TRUE);
3749 /* this picks up sitearch as well */
3750 incpush(SITELIB_EXP, TRUE, FALSE, TRUE);
3752 incpush(SITELIB_EXP, FALSE, FALSE, TRUE);
3756 #ifdef SITELIB_STEM /* Search for version-specific dirs below here */
3757 incpush(SITELIB_STEM, FALSE, TRUE, TRUE);
3760 #ifdef PERL_VENDORARCH_EXP
3761 /* vendorarch is always relative to vendorlib on Windows for
3762 * DLL-based path intuition to work correctly */
3763 # if !defined(WIN32)
3764 incpush(PERL_VENDORARCH_EXP, FALSE, FALSE, TRUE);
3768 #ifdef PERL_VENDORLIB_EXP
3770 incpush(PERL_VENDORLIB_EXP, TRUE, FALSE, TRUE); /* this picks up vendorarch as well */
3772 incpush(PERL_VENDORLIB_EXP, FALSE, FALSE, TRUE);
3776 #ifdef PERL_VENDORLIB_STEM /* Search for version-specific dirs below here */
3777 incpush(PERL_VENDORLIB_STEM, FALSE, TRUE, TRUE);
3780 #ifdef PERL_OTHERLIBDIRS
3781 incpush(PERL_OTHERLIBDIRS, TRUE, TRUE, TRUE);
3785 incpush(".", FALSE, FALSE, TRUE);
3786 #endif /* MACOS_TRADITIONAL */
3789 #if defined(DOSISH) || defined(EPOC)
3790 # define PERLLIB_SEP ';'
3793 # define PERLLIB_SEP '|'
3795 # if defined(MACOS_TRADITIONAL)
3796 # define PERLLIB_SEP ','
3798 # define PERLLIB_SEP ':'
3802 #ifndef PERLLIB_MANGLE
3803 # define PERLLIB_MANGLE(s,n) (s)
3807 S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers, int usesep)
3809 SV *subdir = Nullsv;
3814 if (addsubdirs || addoldvers) {
3815 subdir = sv_newmortal();
3818 /* Break at all separators */
3820 SV *libdir = NEWSV(55,0);
3823 /* skip any consecutive separators */
3825 while ( *p == PERLLIB_SEP ) {
3826 /* Uncomment the next line for PATH semantics */
3827 /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */
3832 if ( usesep && (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
3833 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
3838 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
3839 p = Nullch; /* break out */
3841 #ifdef MACOS_TRADITIONAL
3842 if (!strchr(SvPVX(libdir), ':')) {
3845 sv_setpv(libdir, MacPerl_CanonDir(SvPVX(libdir), buf, 0));
3847 if (SvPVX(libdir)[SvCUR(libdir)-1] != ':')
3848 sv_catpv(libdir, ":");
3852 * BEFORE pushing libdir onto @INC we may first push version- and
3853 * archname-specific sub-directories.
3855 if (addsubdirs || addoldvers) {
3856 #ifdef PERL_INC_VERSION_LIST
3857 /* Configure terminates PERL_INC_VERSION_LIST with a NULL */
3858 const char *incverlist[] = { PERL_INC_VERSION_LIST };
3859 const char **incver;
3866 if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) {
3868 while (unix[len-1] == '/') len--; /* Cosmetic */
3869 sv_usepvn(libdir,unix,len);
3872 PerlIO_printf(Perl_error_log,
3873 "Failed to unixify @INC element \"%s\"\n",
3877 #ifdef MACOS_TRADITIONAL
3878 #define PERL_AV_SUFFIX_FMT ""
3879 #define PERL_ARCH_FMT "%s:"
3880 #define PERL_ARCH_FMT_PATH PERL_FS_VER_FMT PERL_AV_SUFFIX_FMT
3882 #define PERL_AV_SUFFIX_FMT "/"
3883 #define PERL_ARCH_FMT "/%s"
3884 #define PERL_ARCH_FMT_PATH PERL_AV_SUFFIX_FMT PERL_FS_VER_FMT
3886 /* .../version/archname if -d .../version/archname */
3887 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH PERL_ARCH_FMT,
3889 (int)PERL_REVISION, (int)PERL_VERSION,
3890 (int)PERL_SUBVERSION, ARCHNAME);
3891 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3892 S_ISDIR(tmpstatbuf.st_mode))
3893 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3895 /* .../version if -d .../version */
3896 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH, libdir,
3897 (int)PERL_REVISION, (int)PERL_VERSION,
3898 (int)PERL_SUBVERSION);
3899 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3900 S_ISDIR(tmpstatbuf.st_mode))
3901 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3903 /* .../archname if -d .../archname */
3904 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, ARCHNAME);
3905 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3906 S_ISDIR(tmpstatbuf.st_mode))
3907 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3910 #ifdef PERL_INC_VERSION_LIST
3912 for (incver = incverlist; *incver; incver++) {
3913 /* .../xxx if -d .../xxx */
3914 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, *incver);
3915 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3916 S_ISDIR(tmpstatbuf.st_mode))
3917 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3923 /* finally push this lib directory on the end of @INC */
3924 av_push(GvAVn(PL_incgv), libdir);
3928 #ifdef USE_5005THREADS
3929 STATIC struct perl_thread *
3930 S_init_main_thread(pTHX)
3932 #if !defined(PERL_IMPLICIT_CONTEXT)
3933 struct perl_thread *thr;
3937 Newz(53, thr, 1, struct perl_thread);
3938 PL_curcop = &PL_compiling;
3939 thr->interp = PERL_GET_INTERP;
3940 thr->cvcache = newHV();
3941 thr->threadsv = newAV();
3942 /* thr->threadsvp is set when find_threadsv is called */
3943 thr->specific = newAV();
3944 thr->flags = THRf_R_JOINABLE;
3945 MUTEX_INIT(&thr->mutex);
3946 /* Handcraft thrsv similarly to mess_sv */
3947 New(53, PL_thrsv, 1, SV);
3948 Newz(53, xpv, 1, XPV);
3949 SvFLAGS(PL_thrsv) = SVt_PV;
3950 SvANY(PL_thrsv) = (void*)xpv;
3951 SvREFCNT(PL_thrsv) = 1 << 30; /* practically infinite */
3952 SvPVX(PL_thrsv) = (char*)thr;
3953 SvCUR_set(PL_thrsv, sizeof(thr));
3954 SvLEN_set(PL_thrsv, sizeof(thr));
3955 *SvEND(PL_thrsv) = '\0'; /* in the trailing_nul field */
3956 thr->oursv = PL_thrsv;
3957 PL_chopset = " \n-";
3960 MUTEX_LOCK(&PL_threads_mutex);
3966 MUTEX_UNLOCK(&PL_threads_mutex);
3968 #ifdef HAVE_THREAD_INTERN
3969 Perl_init_thread_intern(thr);
3972 #ifdef SET_THREAD_SELF
3973 SET_THREAD_SELF(thr);
3975 thr->self = pthread_self();
3976 #endif /* SET_THREAD_SELF */
3980 * These must come after the thread self setting
3981 * because sv_setpvn does SvTAINT and the taint
3982 * fields thread selfness being set.
3984 PL_toptarget = NEWSV(0,0);
3985 sv_upgrade(PL_toptarget, SVt_PVFM);
3986 sv_setpvn(PL_toptarget, "", 0);
3987 PL_bodytarget = NEWSV(0,0);
3988 sv_upgrade(PL_bodytarget, SVt_PVFM);
3989 sv_setpvn(PL_bodytarget, "", 0);
3990 PL_formtarget = PL_bodytarget;
3991 thr->errsv = newSVpvn("", 0);
3992 (void) find_threadsv("@"); /* Ensure $@ is initialised early */
3995 PL_peepp = MEMBER_TO_FPTR(Perl_peep);
3996 PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
3997 PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
3998 PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
3999 PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
4000 PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
4002 PL_reginterp_cnt = 0;
4006 #endif /* USE_5005THREADS */
4009 Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
4012 line_t oldline = CopLINE(PL_curcop);
4018 while (AvFILL(paramList) >= 0) {
4019 cv = (CV*)av_shift(paramList);
4021 if (paramList == PL_beginav) {
4022 /* save PL_beginav for compiler */
4023 if (! PL_beginav_save)
4024 PL_beginav_save = newAV();
4025 av_push(PL_beginav_save, (SV*)cv);
4027 else if (paramList == PL_checkav) {
4028 /* save PL_checkav for compiler */
4029 if (! PL_checkav_save)
4030 PL_checkav_save = newAV();
4031 av_push(PL_checkav_save, (SV*)cv);
4036 #ifdef PERL_FLEXIBLE_EXCEPTIONS
4037 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_list_body), cv);
4043 #ifndef PERL_FLEXIBLE_EXCEPTIONS
4047 (void)SvPV(atsv, len);
4049 PL_curcop = &PL_compiling;
4050 CopLINE_set(PL_curcop, oldline);
4051 if (paramList == PL_beginav)
4052 sv_catpv(atsv, "BEGIN failed--compilation aborted");
4054 Perl_sv_catpvf(aTHX_ atsv,
4055 "%s failed--call queue aborted",
4056 paramList == PL_checkav ? "CHECK"
4057 : paramList == PL_initav ? "INIT"
4059 while (PL_scopestack_ix > oldscope)
4062 Perl_croak(aTHX_ "%"SVf"", atsv);
4069 /* my_exit() was called */
4070 while (PL_scopestack_ix > oldscope)
4073 PL_curstash = PL_defstash;
4074 PL_curcop = &PL_compiling;
4075 CopLINE_set(PL_curcop, oldline);
4077 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) {
4078 if (paramList == PL_beginav)
4079 Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
4081 Perl_croak(aTHX_ "%s failed--call queue aborted",
4082 paramList == PL_checkav ? "CHECK"
4083 : paramList == PL_initav ? "INIT"
4090 PL_curcop = &PL_compiling;
4091 CopLINE_set(PL_curcop, oldline);
4094 PerlIO_printf(Perl_error_log, "panic: restartop\n");
4102 #ifdef PERL_FLEXIBLE_EXCEPTIONS
4104 S_vcall_list_body(pTHX_ va_list args)
4106 CV *cv = va_arg(args, CV*);
4107 return call_list_body(cv);
4112 S_call_list_body(pTHX_ CV *cv)
4114 PUSHMARK(PL_stack_sp);
4115 call_sv((SV*)cv, G_EVAL|G_DISCARD);
4120 Perl_my_exit(pTHX_ U32 status)
4122 DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
4123 thr, (unsigned long) status));
4132 STATUS_NATIVE_SET(status);
4139 Perl_my_failure_exit(pTHX)
4142 if (vaxc$errno & 1) {
4143 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
4144 STATUS_NATIVE_SET(44);
4147 if (!vaxc$errno && errno) /* unlikely */
4148 STATUS_NATIVE_SET(44);
4150 STATUS_NATIVE_SET(vaxc$errno);
4155 STATUS_POSIX_SET(errno);
4157 exitstatus = STATUS_POSIX >> 8;
4158 if (exitstatus & 255)
4159 STATUS_POSIX_SET(exitstatus);
4161 STATUS_POSIX_SET(255);
4168 S_my_exit_jump(pTHX)
4170 register PERL_CONTEXT *cx;
4175 SvREFCNT_dec(PL_e_script);
4176 PL_e_script = Nullsv;
4179 POPSTACK_TO(PL_mainstack);
4180 if (cxstack_ix >= 0) {
4183 POPBLOCK(cx,PL_curpm);
4191 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen)
4194 p = SvPVX(PL_e_script);
4195 nl = strchr(p, '\n');
4196 nl = (nl) ? nl+1 : SvEND(PL_e_script);
4198 filter_del(read_e_script);
4201 sv_catpvn(buf_sv, p, nl-p);
4202 sv_chop(PL_e_script, nl);