3 * Copyright (c) 1987-2002 Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * "A ship then new they built for him/of mithril and of elven glass" --Bilbo
15 #define PERL_IN_PERL_C
17 #include "patchlevel.h" /* for local_patches */
21 char *nw_get_sitelib(const char *pl);
24 /* XXX If this causes problems, set i_unistd=undef in the hint file. */
41 #if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE) && !defined(PERL_MICRO)
42 char *getenv (char *); /* Usually in <stdlib.h> */
45 static I32 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen);
53 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
59 #if defined(USE_ITHREADS)
60 # define INIT_TLS_AND_INTERP \
62 if (!PL_curinterp) { \
63 PERL_SET_INTERP(my_perl); \
66 PERL_SET_THX(my_perl); \
70 PERL_SET_THX(my_perl); \
74 # define INIT_TLS_AND_INTERP \
76 if (!PL_curinterp) { \
77 PERL_SET_INTERP(my_perl); \
79 PERL_SET_THX(my_perl); \
83 #ifdef PERL_IMPLICIT_SYS
85 perl_alloc_using(struct IPerlMem* ipM, struct IPerlMem* ipMS,
86 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
87 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
88 struct IPerlDir* ipD, struct IPerlSock* ipS,
89 struct IPerlProc* ipP)
91 PerlInterpreter *my_perl;
92 /* New() needs interpreter, so call malloc() instead */
93 my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
95 Zero(my_perl, 1, PerlInterpreter);
111 =head1 Embedding Functions
113 =for apidoc perl_alloc
115 Allocates a new Perl interpreter. See L<perlembed>.
123 PerlInterpreter *my_perl;
124 #ifdef USE_5005THREADS
128 /* New() needs interpreter, so call malloc() instead */
129 my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
132 Zero(my_perl, 1, PerlInterpreter);
135 #endif /* PERL_IMPLICIT_SYS */
138 =for apidoc perl_construct
140 Initializes a new Perl interpreter. See L<perlembed>.
146 perl_construct(pTHXx)
150 PL_perl_destruct_level = 1;
152 if (PL_perl_destruct_level > 0)
156 /* Init the real globals (and main thread)? */
159 MUTEX_INIT(&PL_dollarzero_mutex); /* for $0 modifying */
161 #ifdef PERL_FLEXIBLE_EXCEPTIONS
162 PL_protect = MEMBER_TO_FPTR(Perl_default_protect); /* for exceptions */
165 PL_curcop = &PL_compiling; /* needed by ckWARN, right away */
167 PL_linestr = NEWSV(65,79);
168 sv_upgrade(PL_linestr,SVt_PVIV);
170 if (!SvREADONLY(&PL_sv_undef)) {
171 /* set read-only and try to insure than we wont see REFCNT==0
174 SvREADONLY_on(&PL_sv_undef);
175 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
177 sv_setpv(&PL_sv_no,PL_No);
179 SvREADONLY_on(&PL_sv_no);
180 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
182 sv_setpv(&PL_sv_yes,PL_Yes);
184 SvREADONLY_on(&PL_sv_yes);
185 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
188 PL_sighandlerp = Perl_sighandler;
189 PL_pidstatus = newHV();
192 PL_rs = newSVpvn("\n", 1);
197 PL_lex_state = LEX_NOTPARSING;
203 SET_NUMERIC_STANDARD();
207 PL_patchlevel = NEWSV(0,4);
208 (void)SvUPGRADE(PL_patchlevel, SVt_PVNV);
209 if (PERL_REVISION > 127 || PERL_VERSION > 127 || PERL_SUBVERSION > 127)
210 SvGROW(PL_patchlevel, UTF8_MAXLEN*3+1);
211 s = (U8*)SvPVX(PL_patchlevel);
212 /* Build version strings using "native" characters */
213 s = uvchr_to_utf8(s, (UV)PERL_REVISION);
214 s = uvchr_to_utf8(s, (UV)PERL_VERSION);
215 s = uvchr_to_utf8(s, (UV)PERL_SUBVERSION);
217 SvCUR_set(PL_patchlevel, s - (U8*)SvPVX(PL_patchlevel));
218 SvPOK_on(PL_patchlevel);
219 SvNVX(PL_patchlevel) = (NV)PERL_REVISION
220 + ((NV)PERL_VERSION / (NV)1000)
221 #if defined(PERL_SUBVERSION) && PERL_SUBVERSION > 0
222 + ((NV)PERL_SUBVERSION / (NV)1000000)
225 SvNOK_on(PL_patchlevel); /* dual valued */
226 SvUTF8_on(PL_patchlevel);
227 SvREADONLY_on(PL_patchlevel);
230 #if defined(LOCAL_PATCH_COUNT)
231 PL_localpatches = local_patches; /* For possible -v */
234 #ifdef HAVE_INTERP_INTERN
238 PerlIO_init(aTHX); /* Hook to IO system */
240 PL_fdpid = newAV(); /* for remembering popen pids by fd */
241 PL_modglobal = newHV(); /* pointers to per-interpreter module globals */
242 PL_errors = newSVpvn("",0);
243 sv_setpvn(PERL_DEBUG_PAD(0), "", 0); /* For regex debugging. */
244 sv_setpvn(PERL_DEBUG_PAD(1), "", 0); /* ext/re needs these */
245 sv_setpvn(PERL_DEBUG_PAD(2), "", 0); /* even without DEBUGGING. */
247 PL_regex_padav = newAV();
248 av_push(PL_regex_padav,(SV*)newAV()); /* First entry is an array of empty elements */
249 PL_regex_pad = AvARRAY(PL_regex_padav);
251 #ifdef USE_REENTRANT_API
252 Perl_reentrant_init(aTHX);
255 /* Note that strtab is a rather special HV. Assumptions are made
256 about not iterating on it, and not adding tie magic to it.
257 It is properly deallocated in perl_destruct() */
260 HvSHAREKEYS_off(PL_strtab); /* mandatory */
261 hv_ksplit(PL_strtab, 512);
263 #if defined(__DYNAMIC__) && (defined(NeXT) || defined(__NeXT__))
264 _dyld_lookup_and_bind
265 ("__environ", (unsigned long *) &environ_pointer, NULL);
268 #ifdef USE_ENVIRON_ARRAY
269 PL_origenviron = environ;
272 /* Use sysconf(_SC_CLK_TCK) if available, if not
273 * available or if the sysconf() fails, use the HZ. */
274 #if defined(HAS_SYSCONF) && defined(_SC_CLK_TCK)
275 PL_clocktick = sysconf(_SC_CLK_TCK);
276 if (PL_clocktick <= 0)
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);
392 if (destruct_level == 0){
394 DEBUG_P(debprofdump());
396 #if defined(PERLIO_LAYERS)
397 /* No more IO - including error messages ! */
398 PerlIO_cleanup(aTHX);
401 /* The exit() function will do everything that needs doing. */
402 return STATUS_NATIVE_EXPORT;
405 /* jettison our possibly duplicated environment */
406 /* if PERL_USE_SAFE_PUTENV is defined environ will not have been copied
407 * so we certainly shouldn't free it here
409 #if defined(USE_ENVIRON_ARRAY) && !defined(PERL_USE_SAFE_PUTENV)
410 if (environ != PL_origenviron
412 /* only main thread can free environ[0] contents */
413 && PL_curinterp == aTHX
419 for (i = 0; environ[i]; i++)
420 safesysfree(environ[i]);
422 /* Must use safesysfree() when working with environ. */
423 safesysfree(environ);
425 environ = PL_origenviron;
430 /* the syntax tree is shared between clones
431 * so op_free(PL_main_root) only ReREFCNT_dec's
432 * REGEXPs in the parent interpreter
433 * we need to manually ReREFCNT_dec for the clones
436 I32 i = AvFILLp(PL_regex_padav) + 1;
437 SV **ary = AvARRAY(PL_regex_padav);
441 REGEXP *re = INT2PTR(REGEXP *,SvIVX(resv));
443 if (SvFLAGS(resv) & SVf_BREAK) {
444 /* this is PL_reg_curpm, already freed
445 * flag is set in regexec.c:S_regtry
447 SvFLAGS(resv) &= ~SVf_BREAK;
449 else if(SvREPADTMP(resv)) {
450 SvREPADTMP_off(resv);
457 SvREFCNT_dec(PL_regex_padav);
458 PL_regex_padav = Nullav;
462 /* loosen bonds of global variables */
465 (void)PerlIO_close(PL_rsfp);
469 /* Filters for program text */
470 SvREFCNT_dec(PL_rsfp_filters);
471 PL_rsfp_filters = Nullav;
474 PL_preprocess = FALSE;
480 PL_doswitches = FALSE;
481 PL_dowarn = G_WARN_OFF;
482 PL_doextract = FALSE;
483 PL_sawampersand = FALSE; /* must save all match strings */
486 Safefree(PL_inplace);
488 SvREFCNT_dec(PL_patchlevel);
491 SvREFCNT_dec(PL_e_script);
492 PL_e_script = Nullsv;
495 /* magical thingies */
497 SvREFCNT_dec(PL_ofs_sv); /* $, */
500 SvREFCNT_dec(PL_ors_sv); /* $\ */
503 SvREFCNT_dec(PL_rs); /* $/ */
506 PL_multiline = 0; /* $* */
507 Safefree(PL_osname); /* $^O */
510 SvREFCNT_dec(PL_statname);
511 PL_statname = Nullsv;
514 /* defgv, aka *_ should be taken care of elsewhere */
516 /* clean up after study() */
517 SvREFCNT_dec(PL_lastscream);
518 PL_lastscream = Nullsv;
519 Safefree(PL_screamfirst);
521 Safefree(PL_screamnext);
525 Safefree(PL_efloatbuf);
526 PL_efloatbuf = Nullch;
529 /* startup and shutdown function lists */
530 SvREFCNT_dec(PL_beginav);
531 SvREFCNT_dec(PL_beginav_save);
532 SvREFCNT_dec(PL_endav);
533 SvREFCNT_dec(PL_checkav);
534 SvREFCNT_dec(PL_checkav_save);
535 SvREFCNT_dec(PL_initav);
537 PL_beginav_save = Nullav;
540 PL_checkav_save = Nullav;
543 /* shortcuts just get cleared */
549 PL_argvoutgv = Nullgv;
551 PL_stderrgv = Nullgv;
552 PL_last_in_gv = Nullgv;
554 PL_debstash = Nullhv;
556 /* reset so print() ends up where we expect */
559 SvREFCNT_dec(PL_argvout_stack);
560 PL_argvout_stack = Nullav;
562 SvREFCNT_dec(PL_modglobal);
563 PL_modglobal = Nullhv;
564 SvREFCNT_dec(PL_preambleav);
565 PL_preambleav = Nullav;
566 SvREFCNT_dec(PL_subname);
568 SvREFCNT_dec(PL_linestr);
570 SvREFCNT_dec(PL_pidstatus);
571 PL_pidstatus = Nullhv;
572 SvREFCNT_dec(PL_toptarget);
573 PL_toptarget = Nullsv;
574 SvREFCNT_dec(PL_bodytarget);
575 PL_bodytarget = Nullsv;
576 PL_formtarget = Nullsv;
578 /* free locale stuff */
579 #ifdef USE_LOCALE_COLLATE
580 Safefree(PL_collation_name);
581 PL_collation_name = Nullch;
584 #ifdef USE_LOCALE_NUMERIC
585 Safefree(PL_numeric_name);
586 PL_numeric_name = Nullch;
587 SvREFCNT_dec(PL_numeric_radix_sv);
590 /* clear utf8 character classes */
591 SvREFCNT_dec(PL_utf8_alnum);
592 SvREFCNT_dec(PL_utf8_alnumc);
593 SvREFCNT_dec(PL_utf8_ascii);
594 SvREFCNT_dec(PL_utf8_alpha);
595 SvREFCNT_dec(PL_utf8_space);
596 SvREFCNT_dec(PL_utf8_cntrl);
597 SvREFCNT_dec(PL_utf8_graph);
598 SvREFCNT_dec(PL_utf8_digit);
599 SvREFCNT_dec(PL_utf8_upper);
600 SvREFCNT_dec(PL_utf8_lower);
601 SvREFCNT_dec(PL_utf8_print);
602 SvREFCNT_dec(PL_utf8_punct);
603 SvREFCNT_dec(PL_utf8_xdigit);
604 SvREFCNT_dec(PL_utf8_mark);
605 SvREFCNT_dec(PL_utf8_toupper);
606 SvREFCNT_dec(PL_utf8_totitle);
607 SvREFCNT_dec(PL_utf8_tolower);
608 SvREFCNT_dec(PL_utf8_tofold);
609 SvREFCNT_dec(PL_utf8_idstart);
610 SvREFCNT_dec(PL_utf8_idcont);
611 PL_utf8_alnum = Nullsv;
612 PL_utf8_alnumc = Nullsv;
613 PL_utf8_ascii = Nullsv;
614 PL_utf8_alpha = Nullsv;
615 PL_utf8_space = Nullsv;
616 PL_utf8_cntrl = Nullsv;
617 PL_utf8_graph = Nullsv;
618 PL_utf8_digit = Nullsv;
619 PL_utf8_upper = Nullsv;
620 PL_utf8_lower = Nullsv;
621 PL_utf8_print = Nullsv;
622 PL_utf8_punct = Nullsv;
623 PL_utf8_xdigit = Nullsv;
624 PL_utf8_mark = Nullsv;
625 PL_utf8_toupper = Nullsv;
626 PL_utf8_totitle = Nullsv;
627 PL_utf8_tolower = Nullsv;
628 PL_utf8_tofold = Nullsv;
629 PL_utf8_idstart = Nullsv;
630 PL_utf8_idcont = Nullsv;
632 if (!specialWARN(PL_compiling.cop_warnings))
633 SvREFCNT_dec(PL_compiling.cop_warnings);
634 PL_compiling.cop_warnings = Nullsv;
635 if (!specialCopIO(PL_compiling.cop_io))
636 SvREFCNT_dec(PL_compiling.cop_io);
637 PL_compiling.cop_io = Nullsv;
638 CopFILE_free(&PL_compiling);
639 CopSTASH_free(&PL_compiling);
641 /* Prepare to destruct main symbol table. */
646 SvREFCNT_dec(PL_curstname);
647 PL_curstname = Nullsv;
649 /* clear queued errors */
650 SvREFCNT_dec(PL_errors);
654 if (destruct_level >= 2 && ckWARN_d(WARN_INTERNAL)) {
655 if (PL_scopestack_ix != 0)
656 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
657 "Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
658 (long)PL_scopestack_ix);
659 if (PL_savestack_ix != 0)
660 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
661 "Unbalanced saves: %ld more saves than restores\n",
662 (long)PL_savestack_ix);
663 if (PL_tmps_floor != -1)
664 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced tmps: %ld more allocs than frees\n",
665 (long)PL_tmps_floor + 1);
666 if (cxstack_ix != -1)
667 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced context: %ld more PUSHes than POPs\n",
668 (long)cxstack_ix + 1);
671 /* Now absolutely destruct everything, somehow or other, loops or no. */
672 SvFLAGS(PL_fdpid) |= SVTYPEMASK; /* don't clean out pid table now */
673 SvFLAGS(PL_strtab) |= SVTYPEMASK; /* don't clean out strtab now */
675 /* the 2 is for PL_fdpid and PL_strtab */
676 while (PL_sv_count > 2 && sv_clean_all())
679 SvFLAGS(PL_fdpid) &= ~SVTYPEMASK;
680 SvFLAGS(PL_fdpid) |= SVt_PVAV;
681 SvFLAGS(PL_strtab) &= ~SVTYPEMASK;
682 SvFLAGS(PL_strtab) |= SVt_PVHV;
684 AvREAL_off(PL_fdpid); /* no surviving entries */
685 SvREFCNT_dec(PL_fdpid); /* needed in io_close() */
688 #ifdef HAVE_INTERP_INTERN
692 /* Destruct the global string table. */
694 /* Yell and reset the HeVAL() slots that are still holding refcounts,
695 * so that sv_free() won't fail on them.
703 max = HvMAX(PL_strtab);
704 array = HvARRAY(PL_strtab);
707 if (hent && ckWARN_d(WARN_INTERNAL)) {
708 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
709 "Unbalanced string table refcount: (%d) for \"%s\"",
710 HeVAL(hent) - Nullsv, HeKEY(hent));
711 HeVAL(hent) = Nullsv;
721 SvREFCNT_dec(PL_strtab);
724 /* free the pointer table used for cloning */
725 ptr_table_free(PL_ptr_table);
728 /* free special SVs */
730 SvREFCNT(&PL_sv_yes) = 0;
731 sv_clear(&PL_sv_yes);
732 SvANY(&PL_sv_yes) = NULL;
733 SvFLAGS(&PL_sv_yes) = 0;
735 SvREFCNT(&PL_sv_no) = 0;
737 SvANY(&PL_sv_no) = NULL;
738 SvFLAGS(&PL_sv_no) = 0;
742 for (i=0; i<=2; i++) {
743 SvREFCNT(PERL_DEBUG_PAD(i)) = 0;
744 sv_clear(PERL_DEBUG_PAD(i));
745 SvANY(PERL_DEBUG_PAD(i)) = NULL;
746 SvFLAGS(PERL_DEBUG_PAD(i)) = 0;
750 if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL))
751 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Scalars leaked: %ld\n", (long)PL_sv_count);
753 #ifdef DEBUG_LEAKING_SCALARS
754 if (PL_sv_count != 0) {
759 for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
760 svend = &sva[SvREFCNT(sva)];
761 for (sv = sva + 1; sv < svend; ++sv) {
762 if (SvTYPE(sv) != SVTYPEMASK) {
763 PerlIO_printf(Perl_debug_log, "leaked: 0x%p\n", sv);
771 #if defined(PERLIO_LAYERS)
772 /* No more IO - including error messages ! */
773 PerlIO_cleanup(aTHX);
776 /* sv_undef needs to stay immortal until after PerlIO_cleanup
777 as currently layers use it rather than Nullsv as a marker
778 for no arg - and will try and SvREFCNT_dec it.
780 SvREFCNT(&PL_sv_undef) = 0;
781 SvREADONLY_off(&PL_sv_undef);
783 Safefree(PL_origfilename);
784 Safefree(PL_reg_start_tmp);
786 Safefree(PL_reg_curpm);
787 Safefree(PL_reg_poscache);
788 Safefree(HeKEY_hek(&PL_hv_fetch_ent_mh));
789 Safefree(PL_op_mask);
790 Safefree(PL_psig_ptr);
791 Safefree(PL_psig_name);
792 Safefree(PL_bitcount);
793 Safefree(PL_psig_pend);
795 PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */
797 DEBUG_P(debprofdump());
799 #ifdef USE_REENTRANT_API
800 Perl_reentrant_free(aTHX);
805 /* As the absolutely last thing, free the non-arena SV for mess() */
808 /* it could have accumulated taint magic */
809 if (SvTYPE(PL_mess_sv) >= SVt_PVMG) {
812 for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) {
813 moremagic = mg->mg_moremagic;
814 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global
816 Safefree(mg->mg_ptr);
820 /* we know that type >= SVt_PV */
821 (void)SvOOK_off(PL_mess_sv);
822 Safefree(SvPVX(PL_mess_sv));
823 Safefree(SvANY(PL_mess_sv));
824 Safefree(PL_mess_sv);
827 return STATUS_NATIVE_EXPORT;
831 =for apidoc perl_free
833 Releases a Perl interpreter. See L<perlembed>.
841 #if defined(WIN32) || defined(NETWARE)
842 # if defined(PERL_IMPLICIT_SYS)
844 void *host = nw_internal_host;
846 void *host = w32_internal_host;
850 nw_delete_internal_host(host);
852 win32_delete_internal_host(host);
863 Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
865 Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry);
866 PL_exitlist[PL_exitlistlen].fn = fn;
867 PL_exitlist[PL_exitlistlen].ptr = ptr;
872 =for apidoc perl_parse
874 Tells a Perl interpreter to parse a Perl script. See L<perlembed>.
880 perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
885 #ifdef USE_5005THREADS
889 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
892 Perl_croak(aTHX_ "suidperl is no longer needed since the kernel can now execute\n\
893 setuid perl scripts securely.\n");
902 /* Come here if running an undumped a.out. */
904 PL_origfilename = savepv(argv[0]);
905 PL_do_undump = FALSE;
906 cxstack_ix = -1; /* start label stack again */
908 init_postdump_symbols(argc,argv,env);
913 op_free(PL_main_root);
914 PL_main_root = Nullop;
916 PL_main_start = Nullop;
917 SvREFCNT_dec(PL_main_cv);
921 oldscope = PL_scopestack_ix;
922 PL_dowarn = G_WARN_OFF;
924 #ifdef PERL_FLEXIBLE_EXCEPTIONS
925 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vparse_body), env, xsinit);
931 #ifndef PERL_FLEXIBLE_EXCEPTIONS
932 parse_body(env,xsinit);
935 call_list(oldscope, PL_checkav);
942 /* my_exit() was called */
943 while (PL_scopestack_ix > oldscope)
946 PL_curstash = PL_defstash;
948 call_list(oldscope, PL_checkav);
949 ret = STATUS_NATIVE_EXPORT;
952 PerlIO_printf(Perl_error_log, "panic: top_env\n");
960 #ifdef PERL_FLEXIBLE_EXCEPTIONS
962 S_vparse_body(pTHX_ va_list args)
964 char **env = va_arg(args, char**);
965 XSINIT_t xsinit = va_arg(args, XSINIT_t);
967 return parse_body(env, xsinit);
972 S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
974 int argc = PL_origargc;
975 char **argv = PL_origargv;
976 char *scriptname = NULL;
978 VOL bool dosearch = FALSE;
982 char *cddir = Nullch;
984 sv_setpvn(PL_linestr,"",0);
985 sv = newSVpvn("",0); /* first used for -I flags */
989 for (argc--,argv++; argc > 0; argc--,argv++) {
990 if (argv[0][0] != '-' || !argv[0][1])
994 validarg = " PHOOEY ";
1003 win32_argv2utf8(argc-1, argv+1);
1006 #ifndef PERL_STRICT_CR
1030 if ((s = moreswitches(s)))
1035 if( !PL_tainting ) {
1036 PL_taint_warn = TRUE;
1043 PL_taint_warn = FALSE;
1048 #ifdef MACOS_TRADITIONAL
1049 /* ignore -e for Dev:Pseudo argument */
1050 if (argv[1] && !strcmp(argv[1], "Dev:Pseudo"))
1053 if (PL_euid != PL_uid || PL_egid != PL_gid)
1054 Perl_croak(aTHX_ "No -e allowed in setuid scripts");
1056 PL_e_script = newSVpvn("",0);
1057 filter_add(read_e_script, NULL);
1060 sv_catpv(PL_e_script, s);
1062 sv_catpv(PL_e_script, argv[1]);
1066 Perl_croak(aTHX_ "No code specified for -e");
1067 sv_catpv(PL_e_script, "\n");
1070 case 'I': /* -I handled both here and in moreswitches() */
1072 if (!*++s && (s=argv[1]) != Nullch) {
1077 STRLEN len = strlen(s);
1078 p = savepvn(s, len);
1079 incpush(p, TRUE, TRUE, FALSE);
1080 sv_catpvn(sv, "-I", 2);
1081 sv_catpvn(sv, p, len);
1082 sv_catpvn(sv, " ", 1);
1086 Perl_croak(aTHX_ "No directory specified for -I");
1090 PL_preprocess = TRUE;
1100 PL_preambleav = newAV();
1101 av_push(PL_preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
1103 PL_Sv = newSVpv("print myconfig();",0);
1105 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
1107 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
1109 sv_catpv(PL_Sv,"\" Compile-time options:");
1111 sv_catpv(PL_Sv," DEBUGGING");
1113 # ifdef MULTIPLICITY
1114 sv_catpv(PL_Sv," MULTIPLICITY");
1116 # ifdef USE_5005THREADS
1117 sv_catpv(PL_Sv," USE_5005THREADS");
1119 # ifdef USE_ITHREADS
1120 sv_catpv(PL_Sv," USE_ITHREADS");
1122 # ifdef USE_64_BIT_INT
1123 sv_catpv(PL_Sv," USE_64_BIT_INT");
1125 # ifdef USE_64_BIT_ALL
1126 sv_catpv(PL_Sv," USE_64_BIT_ALL");
1128 # ifdef USE_LONG_DOUBLE
1129 sv_catpv(PL_Sv," USE_LONG_DOUBLE");
1131 # ifdef USE_LARGE_FILES
1132 sv_catpv(PL_Sv," USE_LARGE_FILES");
1135 sv_catpv(PL_Sv," USE_SOCKS");
1137 # ifdef PERL_IMPLICIT_CONTEXT
1138 sv_catpv(PL_Sv," PERL_IMPLICIT_CONTEXT");
1140 # ifdef PERL_IMPLICIT_SYS
1141 sv_catpv(PL_Sv," PERL_IMPLICIT_SYS");
1143 sv_catpv(PL_Sv,"\\n\",");
1145 #if defined(LOCAL_PATCH_COUNT)
1146 if (LOCAL_PATCH_COUNT > 0) {
1148 sv_catpv(PL_Sv,"\" Locally applied patches:\\n\",");
1149 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
1150 if (PL_localpatches[i])
1151 Perl_sv_catpvf(aTHX_ PL_Sv,"q\" \t%s\n\",",PL_localpatches[i]);
1155 Perl_sv_catpvf(aTHX_ PL_Sv,"\" Built under %s\\n\"",OSNAME);
1158 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
1160 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled on %s\\n\"",__DATE__);
1163 sv_catpv(PL_Sv, "; \
1165 @env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; ");
1168 push @env, \"CYGWIN=\\\"$ENV{CYGWIN}\\\"\";");
1171 print \" \\%ENV:\\n @env\\n\" if @env; \
1172 print \" \\@INC:\\n @INC\\n\";");
1175 PL_Sv = newSVpv("config_vars(qw(",0);
1176 sv_catpv(PL_Sv, ++s);
1177 sv_catpv(PL_Sv, "))");
1180 av_push(PL_preambleav, PL_Sv);
1181 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
1184 PL_doextract = TRUE;
1192 if (!*++s || isSPACE(*s)) {
1196 /* catch use of gnu style long options */
1197 if (strEQ(s, "version")) {
1201 if (strEQ(s, "help")) {
1208 Perl_croak(aTHX_ "Unrecognized switch: -%s (-h will show valid options)",s);
1212 sv_setsv(get_sv("/", TRUE), PL_rs);
1215 #ifndef SECURE_INTERNAL_GETENV
1218 (s = PerlEnv_getenv("PERL5OPT")))
1223 if (*s == '-' && *(s+1) == 'T') {
1225 PL_taint_warn = FALSE;
1228 char *popt_copy = Nullch;
1241 if (!strchr("DIMUdmtw", *s))
1242 Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
1246 popt_copy = SvPVX(sv_2mortal(newSVpv(popt,0)));
1247 s = popt_copy + (s - popt);
1248 d = popt_copy + (d - popt);
1255 if( !PL_tainting ) {
1256 PL_taint_warn = TRUE;
1266 if (PL_taint_warn && PL_dowarn != G_WARN_ALL_OFF) {
1267 PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
1271 scriptname = argv[0];
1274 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
1276 else if (scriptname == Nullch) {
1278 if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
1286 open_script(scriptname,dosearch,sv,&fdscript);
1288 validate_suid(validarg, scriptname,fdscript);
1291 #if defined(SIGCHLD) || defined(SIGCLD)
1294 # define SIGCHLD SIGCLD
1296 Sighandler_t sigstate = rsignal_state(SIGCHLD);
1297 if (sigstate == SIG_IGN) {
1298 if (ckWARN(WARN_SIGNAL))
1299 Perl_warner(aTHX_ packWARN(WARN_SIGNAL),
1300 "Can't ignore signal CHLD, forcing to default");
1301 (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL);
1307 #ifdef MACOS_TRADITIONAL
1308 if (PL_doextract || gMacPerl_AlwaysExtract) {
1313 if (cddir && PerlDir_chdir(cddir) < 0)
1314 Perl_croak(aTHX_ "Can't chdir to %s",cddir);
1318 PL_main_cv = PL_compcv = (CV*)NEWSV(1104,0);
1319 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
1320 CvUNIQUE_on(PL_compcv);
1322 CvPADLIST(PL_compcv) = pad_new(0);
1323 #ifdef USE_5005THREADS
1324 CvOWNER(PL_compcv) = 0;
1325 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
1326 MUTEX_INIT(CvMUTEXP(PL_compcv));
1327 #endif /* USE_5005THREADS */
1330 boot_core_UNIVERSAL();
1332 boot_core_xsutils();
1336 (*xsinit)(aTHX); /* in case linked C routines want magical variables */
1338 #if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__) || defined(EPOC)
1344 # ifdef HAS_SOCKS5_INIT
1345 socks5_init(argv[0]);
1351 init_predump_symbols();
1352 /* init_postdump_symbols not currently designed to be called */
1353 /* more than once (ENV isn't cleared first, for example) */
1354 /* But running with -u leaves %ENV & @ARGV undefined! XXX */
1356 init_postdump_symbols(argc,argv,env);
1358 /* PL_utf8locale is conditionally turned on by
1359 * locale.c:Perl_init_i18nl10n() if the environment
1360 * look like the user wants to use UTF-8.
1361 * PL_wantutf8 is turned on by -C or by $ENV{PERL_UTF8_LOCALE}. */
1362 if (PL_utf8locale && PL_wantutf8) { /* Requires init_predump_symbols(). */
1366 /* Turn on UTF-8-ness on STDIN, STDOUT, STDERR
1367 * _and_ the default open discipline. */
1368 if (PL_stdingv && (io = GvIO(PL_stdingv)) && (fp = IoIFP(io)))
1369 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
1370 if (PL_defoutgv && (io = GvIO(PL_defoutgv)) && (fp = IoOFP(io)))
1371 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
1372 if (PL_stderrgv && (io = GvIO(PL_stderrgv)) && (fp = IoOFP(io)))
1373 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
1374 if ((sv = GvSV(gv_fetchpv("\017PEN", TRUE, SVt_PV)))) {
1375 sv_setpvn(sv, ":utf8\0:utf8", 11);
1382 /* now parse the script */
1384 SETERRNO(0,SS_NORMAL);
1386 #ifdef MACOS_TRADITIONAL
1387 if (gMacPerl_SyntaxError = (yyparse() || PL_error_count)) {
1389 Perl_croak(aTHX_ "%s had compilation errors.\n", MacPerl_MPWFileName(PL_origfilename));
1391 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
1392 MacPerl_MPWFileName(PL_origfilename));
1396 if (yyparse() || PL_error_count) {
1398 Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
1400 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
1405 CopLINE_set(PL_curcop, 0);
1406 PL_curstash = PL_defstash;
1407 PL_preprocess = FALSE;
1409 SvREFCNT_dec(PL_e_script);
1410 PL_e_script = Nullsv;
1417 SAVECOPFILE(PL_curcop);
1418 SAVECOPLINE(PL_curcop);
1419 gv_check(PL_defstash);
1426 if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
1427 dump_mstats("after compilation:");
1436 =for apidoc perl_run
1438 Tells a Perl interpreter to run. See L<perlembed>.
1449 #ifdef USE_5005THREADS
1453 oldscope = PL_scopestack_ix;
1458 #ifdef PERL_FLEXIBLE_EXCEPTIONS
1460 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vrun_body), oldscope);
1466 cxstack_ix = -1; /* start context stack again */
1468 case 0: /* normal completion */
1469 #ifndef PERL_FLEXIBLE_EXCEPTIONS
1474 case 2: /* my_exit() */
1475 while (PL_scopestack_ix > oldscope)
1478 PL_curstash = PL_defstash;
1479 if (!(PL_exit_flags & PERL_EXIT_DESTRUCT_END) &&
1480 PL_endav && !PL_minus_c)
1481 call_list(oldscope, PL_endav);
1483 if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
1484 dump_mstats("after execution: ");
1486 ret = STATUS_NATIVE_EXPORT;
1490 POPSTACK_TO(PL_mainstack);
1493 PerlIO_printf(Perl_error_log, "panic: restartop\n");
1503 #ifdef PERL_FLEXIBLE_EXCEPTIONS
1505 S_vrun_body(pTHX_ va_list args)
1507 I32 oldscope = va_arg(args, I32);
1509 return run_body(oldscope);
1515 S_run_body(pTHX_ I32 oldscope)
1517 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
1518 PL_sawampersand ? "Enabling" : "Omitting"));
1520 if (!PL_restartop) {
1521 DEBUG_x(dump_all());
1522 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
1523 DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%"UVxf"\n",
1527 #ifdef MACOS_TRADITIONAL
1528 PerlIO_printf(Perl_error_log, "%s%s syntax OK\n",
1529 (gMacPerl_ErrorFormat ? "# " : ""),
1530 MacPerl_MPWFileName(PL_origfilename));
1532 PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
1536 if (PERLDB_SINGLE && PL_DBsingle)
1537 sv_setiv(PL_DBsingle, 1);
1539 call_list(oldscope, PL_initav);
1545 PL_op = PL_restartop;
1549 else if (PL_main_start) {
1550 CvDEPTH(PL_main_cv) = 1;
1551 PL_op = PL_main_start;
1561 =head1 SV Manipulation Functions
1563 =for apidoc p||get_sv
1565 Returns the SV of the specified Perl scalar. If C<create> is set and the
1566 Perl variable does not exist then it will be created. If C<create> is not
1567 set and the variable does not exist then NULL is returned.
1573 Perl_get_sv(pTHX_ const char *name, I32 create)
1576 #ifdef USE_5005THREADS
1577 if (name[1] == '\0' && !isALPHA(name[0])) {
1578 PADOFFSET tmp = find_threadsv(name);
1579 if (tmp != NOT_IN_PAD)
1580 return THREADSV(tmp);
1582 #endif /* USE_5005THREADS */
1583 gv = gv_fetchpv(name, create, SVt_PV);
1590 =head1 Array Manipulation Functions
1592 =for apidoc p||get_av
1594 Returns the AV of the specified Perl array. If C<create> is set and the
1595 Perl variable does not exist then it will be created. If C<create> is not
1596 set and the variable does not exist then NULL is returned.
1602 Perl_get_av(pTHX_ const char *name, I32 create)
1604 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1613 =head1 Hash Manipulation Functions
1615 =for apidoc p||get_hv
1617 Returns the HV of the specified Perl hash. If C<create> is set and the
1618 Perl variable does not exist then it will be created. If C<create> is not
1619 set and the variable does not exist then NULL is returned.
1625 Perl_get_hv(pTHX_ const char *name, I32 create)
1627 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1636 =head1 CV Manipulation Functions
1638 =for apidoc p||get_cv
1640 Returns the CV of the specified Perl subroutine. If C<create> is set and
1641 the Perl subroutine does not exist then it will be declared (which has the
1642 same effect as saying C<sub name;>). If C<create> is not set and the
1643 subroutine does not exist then NULL is returned.
1649 Perl_get_cv(pTHX_ const char *name, I32 create)
1651 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
1652 /* XXX unsafe for threads if eval_owner isn't held */
1653 /* XXX this is probably not what they think they're getting.
1654 * It has the same effect as "sub name;", i.e. just a forward
1656 if (create && !GvCVu(gv))
1657 return newSUB(start_subparse(FALSE, 0),
1658 newSVOP(OP_CONST, 0, newSVpv(name,0)),
1666 /* Be sure to refetch the stack pointer after calling these routines. */
1670 =head1 Callback Functions
1672 =for apidoc p||call_argv
1674 Performs a callback to the specified Perl sub. See L<perlcall>.
1680 Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv)
1682 /* See G_* flags in cop.h */
1683 /* null terminated arg list */
1690 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
1695 return call_pv(sub_name, flags);
1699 =for apidoc p||call_pv
1701 Performs a callback to the specified Perl sub. See L<perlcall>.
1707 Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
1708 /* name of the subroutine */
1709 /* See G_* flags in cop.h */
1711 return call_sv((SV*)get_cv(sub_name, TRUE), flags);
1715 =for apidoc p||call_method
1717 Performs a callback to the specified Perl method. The blessed object must
1718 be on the stack. See L<perlcall>.
1724 Perl_call_method(pTHX_ const char *methname, I32 flags)
1725 /* name of the subroutine */
1726 /* See G_* flags in cop.h */
1728 return call_sv(sv_2mortal(newSVpv(methname,0)), flags | G_METHOD);
1731 /* May be called with any of a CV, a GV, or an SV containing the name. */
1733 =for apidoc p||call_sv
1735 Performs a callback to the Perl sub whose name is in the SV. See
1742 Perl_call_sv(pTHX_ SV *sv, I32 flags)
1743 /* See G_* flags in cop.h */
1746 LOGOP myop; /* fake syntax tree node */
1749 volatile I32 retval = 0;
1751 bool oldcatch = CATCH_GET;
1756 if (flags & G_DISCARD) {
1761 Zero(&myop, 1, LOGOP);
1762 myop.op_next = Nullop;
1763 if (!(flags & G_NOARGS))
1764 myop.op_flags |= OPf_STACKED;
1765 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1766 (flags & G_ARRAY) ? OPf_WANT_LIST :
1771 EXTEND(PL_stack_sp, 1);
1772 *++PL_stack_sp = sv;
1774 oldscope = PL_scopestack_ix;
1776 if (PERLDB_SUB && PL_curstash != PL_debstash
1777 /* Handle first BEGIN of -d. */
1778 && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
1779 /* Try harder, since this may have been a sighandler, thus
1780 * curstash may be meaningless. */
1781 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != PL_debstash)
1782 && !(flags & G_NODEBUG))
1783 PL_op->op_private |= OPpENTERSUB_DB;
1785 if (flags & G_METHOD) {
1786 Zero(&method_op, 1, UNOP);
1787 method_op.op_next = PL_op;
1788 method_op.op_ppaddr = PL_ppaddr[OP_METHOD];
1789 myop.op_ppaddr = PL_ppaddr[OP_ENTERSUB];
1790 PL_op = (OP*)&method_op;
1793 if (!(flags & G_EVAL)) {
1795 call_body((OP*)&myop, FALSE);
1796 retval = PL_stack_sp - (PL_stack_base + oldmark);
1797 CATCH_SET(oldcatch);
1800 myop.op_other = (OP*)&myop;
1802 /* we're trying to emulate pp_entertry() here */
1804 register PERL_CONTEXT *cx;
1805 I32 gimme = GIMME_V;
1810 push_return(Nullop);
1811 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
1813 PL_eval_root = PL_op; /* Only needed so that goto works right. */
1815 PL_in_eval = EVAL_INEVAL;
1816 if (flags & G_KEEPERR)
1817 PL_in_eval |= EVAL_KEEPERR;
1823 #ifdef PERL_FLEXIBLE_EXCEPTIONS
1825 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_body),
1832 #ifndef PERL_FLEXIBLE_EXCEPTIONS
1834 call_body((OP*)&myop, FALSE);
1836 retval = PL_stack_sp - (PL_stack_base + oldmark);
1837 if (!(flags & G_KEEPERR))
1844 /* my_exit() was called */
1845 PL_curstash = PL_defstash;
1848 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
1849 Perl_croak(aTHX_ "Callback called exit");
1854 PL_op = PL_restartop;
1858 PL_stack_sp = PL_stack_base + oldmark;
1859 if (flags & G_ARRAY)
1863 *++PL_stack_sp = &PL_sv_undef;
1868 if (PL_scopestack_ix > oldscope) {
1872 register PERL_CONTEXT *cx;
1884 if (flags & G_DISCARD) {
1885 PL_stack_sp = PL_stack_base + oldmark;
1894 #ifdef PERL_FLEXIBLE_EXCEPTIONS
1896 S_vcall_body(pTHX_ va_list args)
1898 OP *myop = va_arg(args, OP*);
1899 int is_eval = va_arg(args, int);
1901 call_body(myop, is_eval);
1907 S_call_body(pTHX_ OP *myop, int is_eval)
1909 if (PL_op == myop) {
1911 PL_op = Perl_pp_entereval(aTHX); /* this doesn't do a POPMARK */
1913 PL_op = Perl_pp_entersub(aTHX); /* this does */
1919 /* Eval a string. The G_EVAL flag is always assumed. */
1922 =for apidoc p||eval_sv
1924 Tells Perl to C<eval> the string in the SV.
1930 Perl_eval_sv(pTHX_ SV *sv, I32 flags)
1932 /* See G_* flags in cop.h */
1935 UNOP myop; /* fake syntax tree node */
1936 volatile I32 oldmark = SP - PL_stack_base;
1937 volatile I32 retval = 0;
1943 if (flags & G_DISCARD) {
1950 Zero(PL_op, 1, UNOP);
1951 EXTEND(PL_stack_sp, 1);
1952 *++PL_stack_sp = sv;
1953 oldscope = PL_scopestack_ix;
1955 if (!(flags & G_NOARGS))
1956 myop.op_flags = OPf_STACKED;
1957 myop.op_next = Nullop;
1958 myop.op_type = OP_ENTEREVAL;
1959 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1960 (flags & G_ARRAY) ? OPf_WANT_LIST :
1962 if (flags & G_KEEPERR)
1963 myop.op_flags |= OPf_SPECIAL;
1965 #ifdef PERL_FLEXIBLE_EXCEPTIONS
1967 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_body),
1974 #ifndef PERL_FLEXIBLE_EXCEPTIONS
1976 call_body((OP*)&myop,TRUE);
1978 retval = PL_stack_sp - (PL_stack_base + oldmark);
1979 if (!(flags & G_KEEPERR))
1986 /* my_exit() was called */
1987 PL_curstash = PL_defstash;
1990 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
1991 Perl_croak(aTHX_ "Callback called exit");
1996 PL_op = PL_restartop;
2000 PL_stack_sp = PL_stack_base + oldmark;
2001 if (flags & G_ARRAY)
2005 *++PL_stack_sp = &PL_sv_undef;
2011 if (flags & G_DISCARD) {
2012 PL_stack_sp = PL_stack_base + oldmark;
2022 =for apidoc p||eval_pv
2024 Tells Perl to C<eval> the given string and return an SV* result.
2030 Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
2033 SV* sv = newSVpv(p, 0);
2035 eval_sv(sv, G_SCALAR);
2042 if (croak_on_error && SvTRUE(ERRSV)) {
2044 Perl_croak(aTHX_ SvPVx(ERRSV, n_a));
2050 /* Require a module. */
2053 =head1 Embedding Functions
2055 =for apidoc p||require_pv
2057 Tells Perl to C<require> the file named by the string argument. It is
2058 analogous to the Perl code C<eval "require '$file'">. It's even
2059 implemented that way; consider using Perl_load_module instead.
2064 Perl_require_pv(pTHX_ const char *pv)
2068 PUSHSTACKi(PERLSI_REQUIRE);
2070 sv = sv_newmortal();
2071 sv_setpv(sv, "require '");
2074 eval_sv(sv, G_DISCARD);
2080 Perl_magicname(pTHX_ char *sym, char *name, I32 namlen)
2084 if ((gv = gv_fetchpv(sym,TRUE, SVt_PV)))
2085 sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, namlen);
2089 S_usage(pTHX_ char *name) /* XXX move this out into a module ? */
2091 /* This message really ought to be max 23 lines.
2092 * Removed -h because the user already knows that option. Others? */
2094 static char *usage_msg[] = {
2095 "-0[octal] specify record separator (\\0, if no argument)",
2096 "-a autosplit mode with -n or -p (splits $_ into @F)",
2097 "-C enable native wide character system interfaces",
2098 "-c check syntax only (runs BEGIN and CHECK blocks)",
2099 "-d[:debugger] run program under debugger",
2100 "-D[number/list] set debugging flags (argument is a bit mask or alphabets)",
2101 "-e 'command' one line of program (several -e's allowed, omit programfile)",
2102 "-F/pattern/ split() pattern for -a switch (//'s are optional)",
2103 "-i[extension] edit <> files in place (makes backup if extension supplied)",
2104 "-Idirectory specify @INC/#include directory (several -I's allowed)",
2105 "-l[octal] enable line ending processing, specifies line terminator",
2106 "-[mM][-]module execute `use/no module...' before executing program",
2107 "-n assume 'while (<>) { ... }' loop around program",
2108 "-p assume loop like -n but print line also, like sed",
2109 "-P run program through C preprocessor before compilation",
2110 "-s enable rudimentary parsing for switches after programfile",
2111 "-S look for programfile using PATH environment variable",
2112 "-T enable tainting checks",
2113 "-t enable tainting warnings",
2114 "-u dump core after parsing program",
2115 "-U allow unsafe operations",
2116 "-v print version, subversion (includes VERY IMPORTANT perl info)",
2117 "-V[:variable] print configuration summary (or a single Config.pm variable)",
2118 "-w enable many useful warnings (RECOMMENDED)",
2119 "-W enable all warnings",
2120 "-X disable all warnings",
2121 "-x[directory] strip off text before #!perl line and perhaps cd to directory",
2125 char **p = usage_msg;
2127 PerlIO_printf(PerlIO_stdout(),
2128 "\nUsage: %s [switches] [--] [programfile] [arguments]",
2131 PerlIO_printf(PerlIO_stdout(), "\n %s", *p++);
2134 /* This routine handles any switches that can be given during run */
2137 Perl_moreswitches(pTHX_ char *s)
2147 rschar = (U32)grok_oct(s, &numlen, &flags, NULL);
2148 SvREFCNT_dec(PL_rs);
2149 if (rschar & ~((U8)~0))
2150 PL_rs = &PL_sv_undef;
2151 else if (!rschar && numlen >= 2)
2152 PL_rs = newSVpvn("", 0);
2154 char ch = (char)rschar;
2155 PL_rs = newSVpvn(&ch, 1);
2160 PL_wantutf8 = TRUE; /* Can be set earlier by $ENV{PERL_UTF8_LOCALE}. */
2166 while (*s && !isSPACE(*s)) ++s;
2168 PL_splitstr = savepv(PL_splitstr);
2181 /* The following permits -d:Mod to accepts arguments following an =
2182 in the fashion that -MSome::Mod does. */
2183 if (*s == ':' || *s == '=') {
2186 sv = newSVpv("use Devel::", 0);
2188 /* We now allow -d:Module=Foo,Bar */
2189 while(isALNUM(*s) || *s==':') ++s;
2191 sv_catpv(sv, start);
2193 sv_catpvn(sv, start, s-start);
2194 sv_catpv(sv, " split(/,/,q{");
2199 my_setenv("PERL5DB", SvPV(sv, PL_na));
2202 PL_perldb = PERLDB_ALL;
2210 if (isALPHA(s[1])) {
2211 /* if adding extra options, remember to update DEBUG_MASK */
2212 static char debopts[] = "psltocPmfrxu HXDSTRJvC";
2215 for (s++; *s && (d = strchr(debopts,*s)); s++)
2216 PL_debug |= 1 << (d - debopts);
2219 PL_debug = atoi(s+1);
2220 for (s++; isDIGIT(*s); s++) ;
2223 if (DEBUG_p_TEST_ && ckWARN_d(WARN_DEBUGGING))
2224 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
2225 "-Dp not implemented on this platform\n");
2227 PL_debug |= DEBUG_TOP_FLAG;
2228 #else /* !DEBUGGING */
2229 if (ckWARN_d(WARN_DEBUGGING))
2230 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
2231 "Recompile perl with -DDEBUGGING to use -D switch\n");
2232 for (s++; isALNUM(*s); s++) ;
2238 usage(PL_origargv[0]);
2242 Safefree(PL_inplace);
2243 #if defined(__CYGWIN__) /* do backup extension automagically */
2244 if (*(s+1) == '\0') {
2245 PL_inplace = savepv(".bak");
2248 #endif /* __CYGWIN__ */
2249 PL_inplace = savepv(s+1);
2251 for (s = PL_inplace; *s && !isSPACE(*s); s++) ;
2254 if (*s == '-') /* Additional switches on #! line. */
2258 case 'I': /* -I handled both here and in parse_body() */
2261 while (*s && isSPACE(*s))
2266 /* ignore trailing spaces (possibly followed by other switches) */
2268 for (e = p; *e && !isSPACE(*e); e++) ;
2272 } while (*p && *p != '-');
2273 e = savepvn(s, e-s);
2274 incpush(e, TRUE, TRUE, FALSE);
2281 Perl_croak(aTHX_ "No directory specified for -I");
2287 SvREFCNT_dec(PL_ors_sv);
2292 PL_ors_sv = newSVpvn("\n",1);
2293 numlen = 3 + (*s == '0');
2294 *SvPVX(PL_ors_sv) = (char)grok_oct(s, &numlen, &flags, NULL);
2298 if (RsPARA(PL_rs)) {
2299 PL_ors_sv = newSVpvn("\n\n",2);
2302 PL_ors_sv = newSVsv(PL_rs);
2307 forbid_setid("-M"); /* XXX ? */
2310 forbid_setid("-m"); /* XXX ? */
2315 /* -M-foo == 'no foo' */
2316 if (*s == '-') { use = "no "; ++s; }
2317 sv = newSVpv(use,0);
2319 /* We allow -M'Module qw(Foo Bar)' */
2320 while(isALNUM(*s) || *s==':') ++s;
2322 sv_catpv(sv, start);
2323 if (*(start-1) == 'm') {
2325 Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
2326 sv_catpv( sv, " ()");
2330 Perl_croak(aTHX_ "Module name required with -%c option",
2332 sv_catpvn(sv, start, s-start);
2333 sv_catpv(sv, " split(/,/,q{");
2339 PL_preambleav = newAV();
2340 av_push(PL_preambleav, sv);
2343 Perl_croak(aTHX_ "No space allowed after -%c", *(s-1));
2355 PL_doswitches = TRUE;
2360 Perl_croak(aTHX_ "Too late for \"-t\" option");
2365 Perl_croak(aTHX_ "Too late for \"-T\" option");
2369 #ifdef MACOS_TRADITIONAL
2370 Perl_croak(aTHX_ "Believe me, you don't want to use \"-u\" on a Macintosh");
2372 PL_do_undump = TRUE;
2381 PerlIO_printf(PerlIO_stdout(),
2382 Perl_form(aTHX_ "\nThis is perl, v%"VDf" built for %s",
2383 PL_patchlevel, ARCHNAME));
2385 /* Adjust verbose output as in the perl that ships with the DG/UX OS from EMC */
2386 PerlIO_printf(PerlIO_stdout(),
2387 Perl_form(aTHX_ "\nThis is perl, version %vd\n", PL_patchlevel));
2388 PerlIO_printf(PerlIO_stdout(),
2389 Perl_form(aTHX_ " built under %s at %s %s\n",
2390 OSNAME, __DATE__, __TIME__));
2391 PerlIO_printf(PerlIO_stdout(),
2392 Perl_form(aTHX_ " OS Specific Release: %s\n",
2396 #if defined(LOCAL_PATCH_COUNT)
2397 if (LOCAL_PATCH_COUNT > 0)
2398 PerlIO_printf(PerlIO_stdout(),
2399 "\n(with %d registered patch%s, "
2400 "see perl -V for more detail)",
2401 (int)LOCAL_PATCH_COUNT,
2402 (LOCAL_PATCH_COUNT!=1) ? "es" : "");
2405 PerlIO_printf(PerlIO_stdout(),
2406 "\n\nCopyright 1987-2002, Larry Wall\n");
2407 #ifdef MACOS_TRADITIONAL
2408 PerlIO_printf(PerlIO_stdout(),
2409 "\nMac OS port Copyright 1991-2002, Matthias Neeracher;\n"
2410 "maintained by Chris Nandor\n");
2413 PerlIO_printf(PerlIO_stdout(),
2414 "\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
2417 PerlIO_printf(PerlIO_stdout(),
2418 "djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n"
2419 "djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
2422 PerlIO_printf(PerlIO_stdout(),
2423 "\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
2424 "Version 5 port Copyright (c) 1994-2002, Andreas Kaiser, Ilya Zakharevich\n");
2427 PerlIO_printf(PerlIO_stdout(),
2428 "atariST series port, ++jrb bammi@cadence.com\n");
2431 PerlIO_printf(PerlIO_stdout(),
2432 "BeOS port Copyright Tom Spindler, 1997-1999\n");
2435 PerlIO_printf(PerlIO_stdout(),
2436 "MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-2002\n");
2439 PerlIO_printf(PerlIO_stdout(),
2440 "MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
2443 PerlIO_printf(PerlIO_stdout(),
2444 "Stratus VOS port by Paul.Green@stratus.com, 1997-2002\n");
2447 PerlIO_printf(PerlIO_stdout(),
2448 "VM/ESA port by Neale Ferguson, 1998-1999\n");
2451 PerlIO_printf(PerlIO_stdout(),
2452 "BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
2455 PerlIO_printf(PerlIO_stdout(),
2456 "MiNT port by Guido Flohr, 1997-1999\n");
2459 PerlIO_printf(PerlIO_stdout(),
2460 "EPOC port by Olaf Flebbe, 1999-2002\n");
2463 printf("WINCE port by Rainer Keuchel, 2001-2002\n");
2464 printf("Built on " __DATE__ " " __TIME__ "\n\n");
2467 #ifdef BINARY_BUILD_NOTICE
2468 BINARY_BUILD_NOTICE;
2470 PerlIO_printf(PerlIO_stdout(),
2472 Perl may be copied only under the terms of either the Artistic License or the\n\
2473 GNU General Public License, which may be found in the Perl 5 source kit.\n\n\
2474 Complete documentation for Perl, including FAQ lists, should be found on\n\
2475 this system using `man perl' or `perldoc perl'. If you have access to the\n\
2476 Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
2479 if (! (PL_dowarn & G_WARN_ALL_MASK))
2480 PL_dowarn |= G_WARN_ON;
2484 PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
2485 if (!specialWARN(PL_compiling.cop_warnings))
2486 SvREFCNT_dec(PL_compiling.cop_warnings);
2487 PL_compiling.cop_warnings = pWARN_ALL ;
2491 PL_dowarn = G_WARN_ALL_OFF;
2492 if (!specialWARN(PL_compiling.cop_warnings))
2493 SvREFCNT_dec(PL_compiling.cop_warnings);
2494 PL_compiling.cop_warnings = pWARN_NONE ;
2499 if (s[1] == '-') /* Additional switches on #! line. */
2504 #if defined(WIN32) || !defined(PERL_STRICT_CR)
2510 #ifdef ALTERNATE_SHEBANG
2511 case 'S': /* OS/2 needs -S on "extproc" line. */
2519 Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
2524 /* compliments of Tom Christiansen */
2526 /* unexec() can be found in the Gnu emacs distribution */
2527 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
2530 Perl_my_unexec(pTHX)
2538 prog = newSVpv(BIN_EXP, 0);
2539 sv_catpv(prog, "/perl");
2540 file = newSVpv(PL_origfilename, 0);
2541 sv_catpv(file, ".perldump");
2543 unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
2544 /* unexec prints msg to stderr in case of failure */
2545 PerlProc_exit(status);
2548 # include <lib$routines.h>
2549 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
2551 ABORT(); /* for use with undump */
2556 /* initialize curinterp */
2562 # define PERLVAR(var,type)
2563 # define PERLVARA(var,n,type)
2564 # if defined(PERL_IMPLICIT_CONTEXT)
2565 # if defined(USE_5005THREADS)
2566 # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
2567 # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
2568 # else /* !USE_5005THREADS */
2569 # define PERLVARI(var,type,init) aTHX->var = init;
2570 # define PERLVARIC(var,type,init) aTHX->var = init;
2571 # endif /* USE_5005THREADS */
2573 # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
2574 # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
2576 # include "intrpvar.h"
2577 # ifndef USE_5005THREADS
2578 # include "thrdvar.h"
2585 # define PERLVAR(var,type)
2586 # define PERLVARA(var,n,type)
2587 # define PERLVARI(var,type,init) PL_##var = init;
2588 # define PERLVARIC(var,type,init) PL_##var = init;
2589 # include "intrpvar.h"
2590 # ifndef USE_5005THREADS
2591 # include "thrdvar.h"
2602 S_init_main_stash(pTHX)
2606 PL_curstash = PL_defstash = newHV();
2607 PL_curstname = newSVpvn("main",4);
2608 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
2609 SvREFCNT_dec(GvHV(gv));
2610 GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
2612 HvNAME(PL_defstash) = savepv("main");
2613 PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
2614 GvMULTI_on(PL_incgv);
2615 PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
2616 GvMULTI_on(PL_hintgv);
2617 PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
2618 PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
2619 GvMULTI_on(PL_errgv);
2620 PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
2621 GvMULTI_on(PL_replgv);
2622 (void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */
2623 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
2624 sv_setpvn(ERRSV, "", 0);
2625 PL_curstash = PL_defstash;
2626 CopSTASH_set(&PL_compiling, PL_defstash);
2627 PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
2628 PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
2629 /* We must init $/ before switches are processed. */
2630 sv_setpvn(get_sv("/", TRUE), "\n", 1);
2634 S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
2638 char *cpp_discard_flag;
2644 PL_origfilename = savepv("-e");
2647 /* if find_script() returns, it returns a malloc()-ed value */
2648 PL_origfilename = scriptname = find_script(scriptname, dosearch, NULL, 1);
2650 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
2651 char *s = scriptname + 8;
2652 *fdscript = atoi(s);
2656 scriptname = savepv(s + 1);
2657 Safefree(PL_origfilename);
2658 PL_origfilename = scriptname;
2663 CopFILE_free(PL_curcop);
2664 CopFILE_set(PL_curcop, PL_origfilename);
2665 if (strEQ(PL_origfilename,"-"))
2667 if (*fdscript >= 0) {
2668 PL_rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE);
2669 # if defined(HAS_FCNTL) && defined(F_SETFD)
2671 /* ensure close-on-exec */
2672 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
2675 else if (PL_preprocess) {
2676 char *cpp_cfg = CPPSTDIN;
2677 SV *cpp = newSVpvn("",0);
2678 SV *cmd = NEWSV(0,0);
2680 if (strEQ(cpp_cfg, "cppstdin"))
2681 Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
2682 sv_catpv(cpp, cpp_cfg);
2685 sv_catpvn(sv, "-I", 2);
2686 sv_catpv(sv,PRIVLIB_EXP);
2689 DEBUG_P(PerlIO_printf(Perl_debug_log,
2690 "PL_preprocess: scriptname=\"%s\", cpp=\"%s\", sv=\"%s\", CPPMINUS=\"%s\"\n",
2691 scriptname, SvPVX (cpp), SvPVX (sv), CPPMINUS));
2693 # if defined(MSDOS) || defined(WIN32) || defined(VMS)
2700 cpp_discard_flag = "";
2702 cpp_discard_flag = "-C";
2706 perl = os2_execname(aTHX);
2708 perl = PL_origargv[0];
2712 /* This strips off Perl comments which might interfere with
2713 the C pre-processor, including #!. #line directives are
2714 deliberately stripped to avoid confusion with Perl's version
2715 of #line. FWP played some golf with it so it will fit
2716 into VMS's 255 character buffer.
2719 code = "(1../^#!.*perl/i)|/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print";
2721 code = "/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print";
2723 Perl_sv_setpvf(aTHX_ cmd, "\
2724 %s -ne%s%s%s %s | %"SVf" %s %"SVf" %s",
2725 perl, quote, code, quote, scriptname, cpp,
2726 cpp_discard_flag, sv, CPPMINUS);
2728 PL_doextract = FALSE;
2729 # ifdef IAMSUID /* actually, this is caught earlier */
2730 if (PL_euid != PL_uid && !PL_euid) { /* if running suidperl */
2732 (void)seteuid(PL_uid); /* musn't stay setuid root */
2734 # ifdef HAS_SETREUID
2735 (void)setreuid((Uid_t)-1, PL_uid);
2737 # ifdef HAS_SETRESUID
2738 (void)setresuid((Uid_t)-1, PL_uid, (Uid_t)-1);
2740 PerlProc_setuid(PL_uid);
2744 if (PerlProc_geteuid() != PL_uid)
2745 Perl_croak(aTHX_ "Can't do seteuid!\n");
2747 # endif /* IAMSUID */
2749 DEBUG_P(PerlIO_printf(Perl_debug_log,
2750 "PL_preprocess: cmd=\"%s\"\n",
2753 PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
2757 else if (!*scriptname) {
2758 forbid_setid("program input from stdin");
2759 PL_rsfp = PerlIO_stdin();
2762 PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
2763 # if defined(HAS_FCNTL) && defined(F_SETFD)
2765 /* ensure close-on-exec */
2766 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
2771 # ifndef IAMSUID /* in case script is not readable before setuid */
2773 PerlLIO_stat(CopFILE(PL_curcop),&PL_statbuf) >= 0 &&
2774 PL_statbuf.st_mode & (S_ISUID|S_ISGID))
2777 PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT,
2778 BIN_EXP, (int)PERL_REVISION,
2780 (int)PERL_SUBVERSION), PL_origargv);
2781 Perl_croak(aTHX_ "Can't do setuid\n");
2787 Perl_croak(aTHX_ "Can't open perl script: %s\n",
2790 Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
2791 CopFILE(PL_curcop), Strerror(errno));
2797 * I_SYSSTATVFS HAS_FSTATVFS
2799 * I_STATFS HAS_FSTATFS HAS_GETFSSTAT
2800 * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT
2801 * here so that metaconfig picks them up. */
2805 S_fd_on_nosuid_fs(pTHX_ int fd)
2807 int check_okay = 0; /* able to do all the required sys/libcalls */
2808 int on_nosuid = 0; /* the fd is on a nosuid fs */
2810 * Preferred order: fstatvfs(), fstatfs(), ustat()+getmnt(), getmntent().
2811 * fstatvfs() is UNIX98.
2812 * fstatfs() is 4.3 BSD.
2813 * ustat()+getmnt() is pre-4.3 BSD.
2814 * getmntent() is O(number-of-mounted-filesystems) and can hang on
2815 * an irrelevant filesystem while trying to reach the right one.
2818 #undef FD_ON_NOSUID_CHECK_OKAY /* found the syscalls to do the check? */
2820 # if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
2821 defined(HAS_FSTATVFS)
2822 # define FD_ON_NOSUID_CHECK_OKAY
2823 struct statvfs stfs;
2825 check_okay = fstatvfs(fd, &stfs) == 0;
2826 on_nosuid = check_okay && (stfs.f_flag & ST_NOSUID);
2827 # endif /* fstatvfs */
2829 # if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
2830 defined(PERL_MOUNT_NOSUID) && \
2831 defined(HAS_FSTATFS) && \
2832 defined(HAS_STRUCT_STATFS) && \
2833 defined(HAS_STRUCT_STATFS_F_FLAGS)
2834 # define FD_ON_NOSUID_CHECK_OKAY
2837 check_okay = fstatfs(fd, &stfs) == 0;
2838 on_nosuid = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
2839 # endif /* fstatfs */
2841 # if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
2842 defined(PERL_MOUNT_NOSUID) && \
2843 defined(HAS_FSTAT) && \
2844 defined(HAS_USTAT) && \
2845 defined(HAS_GETMNT) && \
2846 defined(HAS_STRUCT_FS_DATA) && \
2848 # define FD_ON_NOSUID_CHECK_OKAY
2851 if (fstat(fd, &fdst) == 0) {
2853 if (ustat(fdst.st_dev, &us) == 0) {
2855 /* NOSTAT_ONE here because we're not examining fields which
2856 * vary between that case and STAT_ONE. */
2857 if (getmnt((int*)0, &fsd, (int)0, NOSTAT_ONE, us.f_fname) == 0) {
2858 size_t cmplen = sizeof(us.f_fname);
2859 if (sizeof(fsd.fd_req.path) < cmplen)
2860 cmplen = sizeof(fsd.fd_req.path);
2861 if (strnEQ(fsd.fd_req.path, us.f_fname, cmplen) &&
2862 fdst.st_dev == fsd.fd_req.dev) {
2864 on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID;
2870 # endif /* fstat+ustat+getmnt */
2872 # if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
2873 defined(HAS_GETMNTENT) && \
2874 defined(HAS_HASMNTOPT) && \
2875 defined(MNTOPT_NOSUID)
2876 # define FD_ON_NOSUID_CHECK_OKAY
2877 FILE *mtab = fopen("/etc/mtab", "r");
2878 struct mntent *entry;
2881 if (mtab && (fstat(fd, &stb) == 0)) {
2882 while (entry = getmntent(mtab)) {
2883 if (stat(entry->mnt_dir, &fsb) == 0
2884 && fsb.st_dev == stb.st_dev)
2886 /* found the filesystem */
2888 if (hasmntopt(entry, MNTOPT_NOSUID))
2891 } /* A single fs may well fail its stat(). */
2896 # endif /* getmntent+hasmntopt */
2899 Perl_croak(aTHX_ "Can't check filesystem of script \"%s\" for nosuid", PL_origfilename);
2902 #endif /* IAMSUID */
2905 S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript)
2911 /* do we need to emulate setuid on scripts? */
2913 /* This code is for those BSD systems that have setuid #! scripts disabled
2914 * in the kernel because of a security problem. Merely defining DOSUID
2915 * in perl will not fix that problem, but if you have disabled setuid
2916 * scripts in the kernel, this will attempt to emulate setuid and setgid
2917 * on scripts that have those now-otherwise-useless bits set. The setuid
2918 * root version must be called suidperl or sperlN.NNN. If regular perl
2919 * discovers that it has opened a setuid script, it calls suidperl with
2920 * the same argv that it had. If suidperl finds that the script it has
2921 * just opened is NOT setuid root, it sets the effective uid back to the
2922 * uid. We don't just make perl setuid root because that loses the
2923 * effective uid we had before invoking perl, if it was different from the
2926 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
2927 * be defined in suidperl only. suidperl must be setuid root. The
2928 * Configure script will set this up for you if you want it.
2934 if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */
2935 Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
2936 if (fdscript < 0 && PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
2941 #ifndef HAS_SETREUID
2942 /* On this access check to make sure the directories are readable,
2943 * there is actually a small window that the user could use to make
2944 * filename point to an accessible directory. So there is a faint
2945 * chance that someone could execute a setuid script down in a
2946 * non-accessible directory. I don't know what to do about that.
2947 * But I don't think it's too important. The manual lies when
2948 * it says access() is useful in setuid programs.
2950 if (PerlLIO_access(CopFILE(PL_curcop),1)) /*double check*/
2951 Perl_croak(aTHX_ "Permission denied");
2953 /* If we can swap euid and uid, then we can determine access rights
2954 * with a simple stat of the file, and then compare device and
2955 * inode to make sure we did stat() on the same file we opened.
2956 * Then we just have to make sure he or she can execute it.
2963 setreuid(PL_euid,PL_uid) < 0
2966 setresuid(PL_euid,PL_uid,(Uid_t)-1) < 0
2969 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
2970 Perl_croak(aTHX_ "Can't swap uid and euid"); /* really paranoid */
2971 if (PerlLIO_stat(CopFILE(PL_curcop),&tmpstatbuf) < 0)
2972 Perl_croak(aTHX_ "Permission denied"); /* testing full pathname here */
2973 #if defined(IAMSUID) && !defined(NO_NOSUID_CHECK)
2974 if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp)))
2975 Perl_croak(aTHX_ "Permission denied");
2977 if (tmpstatbuf.st_dev != PL_statbuf.st_dev ||
2978 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
2979 (void)PerlIO_close(PL_rsfp);
2980 Perl_croak(aTHX_ "Permission denied\n");
2984 setreuid(PL_uid,PL_euid) < 0
2986 # if defined(HAS_SETRESUID)
2987 setresuid(PL_uid,PL_euid,(Uid_t)-1) < 0
2990 || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
2991 Perl_croak(aTHX_ "Can't reswap uid and euid");
2992 if (!cando(S_IXUSR,FALSE,&PL_statbuf)) /* can real uid exec? */
2993 Perl_croak(aTHX_ "Permission denied\n");
2995 #endif /* HAS_SETREUID */
2996 #endif /* IAMSUID */
2998 if (!S_ISREG(PL_statbuf.st_mode))
2999 Perl_croak(aTHX_ "Permission denied");
3000 if (PL_statbuf.st_mode & S_IWOTH)
3001 Perl_croak(aTHX_ "Setuid/gid script is writable by world");
3002 PL_doswitches = FALSE; /* -s is insecure in suid */
3003 CopLINE_inc(PL_curcop);
3004 if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
3005 strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */
3006 Perl_croak(aTHX_ "No #! line");
3007 s = SvPV(PL_linestr,n_a)+2;
3009 while (!isSPACE(*s)) s++;
3010 for (s2 = s; (s2 > SvPV(PL_linestr,n_a)+2 &&
3011 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
3012 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
3013 Perl_croak(aTHX_ "Not a perl script");
3014 while (*s == ' ' || *s == '\t') s++;
3016 * #! arg must be what we saw above. They can invoke it by
3017 * mentioning suidperl explicitly, but they may not add any strange
3018 * arguments beyond what #! says if they do invoke suidperl that way.
3020 len = strlen(validarg);
3021 if (strEQ(validarg," PHOOEY ") ||
3022 strnNE(s,validarg,len) || !isSPACE(s[len]))
3023 Perl_croak(aTHX_ "Args must match #! line");
3026 if (PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
3027 PL_euid == PL_statbuf.st_uid)
3029 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
3030 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
3031 #endif /* IAMSUID */
3033 if (PL_euid) { /* oops, we're not the setuid root perl */
3034 (void)PerlIO_close(PL_rsfp);
3037 PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
3038 (int)PERL_REVISION, (int)PERL_VERSION,
3039 (int)PERL_SUBVERSION), PL_origargv);
3041 Perl_croak(aTHX_ "Can't do setuid\n");
3044 if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
3046 (void)setegid(PL_statbuf.st_gid);
3049 (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
3051 #ifdef HAS_SETRESGID
3052 (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
3054 PerlProc_setgid(PL_statbuf.st_gid);
3058 if (PerlProc_getegid() != PL_statbuf.st_gid)
3059 Perl_croak(aTHX_ "Can't do setegid!\n");
3061 if (PL_statbuf.st_mode & S_ISUID) {
3062 if (PL_statbuf.st_uid != PL_euid)
3064 (void)seteuid(PL_statbuf.st_uid); /* all that for this */
3067 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
3069 #ifdef HAS_SETRESUID
3070 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
3072 PerlProc_setuid(PL_statbuf.st_uid);
3076 if (PerlProc_geteuid() != PL_statbuf.st_uid)
3077 Perl_croak(aTHX_ "Can't do seteuid!\n");
3079 else if (PL_uid) { /* oops, mustn't run as root */
3081 (void)seteuid((Uid_t)PL_uid);
3084 (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
3086 #ifdef HAS_SETRESUID
3087 (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
3089 PerlProc_setuid((Uid_t)PL_uid);
3093 if (PerlProc_geteuid() != PL_uid)
3094 Perl_croak(aTHX_ "Can't do seteuid!\n");
3097 if (!cando(S_IXUSR,TRUE,&PL_statbuf))
3098 Perl_croak(aTHX_ "Permission denied\n"); /* they can't do this */
3101 else if (PL_preprocess)
3102 Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
3103 else if (fdscript >= 0)
3104 Perl_croak(aTHX_ "fd script not allowed in suidperl\n");
3106 Perl_croak(aTHX_ "Script is not setuid/setgid in suidperl\n");
3108 /* We absolutely must clear out any saved ids here, so we */
3109 /* exec the real perl, substituting fd script for scriptname. */
3110 /* (We pass script name as "subdir" of fd, which perl will grok.) */
3111 PerlIO_rewind(PL_rsfp);
3112 PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0); /* just in case rewind didn't */
3113 for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
3114 if (!PL_origargv[which])
3115 Perl_croak(aTHX_ "Permission denied");
3116 PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
3117 PerlIO_fileno(PL_rsfp), PL_origargv[which]));
3118 #if defined(HAS_FCNTL) && defined(F_SETFD)
3119 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */
3121 PerlProc_execv(Perl_form(aTHX_ "%s/perl"PERL_FS_VER_FMT, BIN_EXP,
3122 (int)PERL_REVISION, (int)PERL_VERSION,
3123 (int)PERL_SUBVERSION), PL_origargv);/* try again */
3124 Perl_croak(aTHX_ "Can't do setuid\n");
3125 #endif /* IAMSUID */
3127 if (PL_euid != PL_uid || PL_egid != PL_gid) { /* (suidperl doesn't exist, in fact) */
3128 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
3129 PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf); /* may be either wrapped or real suid */
3130 if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
3132 (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
3135 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
3136 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
3137 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
3138 /* not set-id, must be wrapped */
3144 S_find_beginning(pTHX)
3146 register char *s, *s2;
3147 #ifdef MACOS_TRADITIONAL
3151 /* skip forward in input to the real script? */
3154 #ifdef MACOS_TRADITIONAL
3155 /* Since the Mac OS does not honor #! arguments for us, we do it ourselves */
3157 while (PL_doextract || gMacPerl_AlwaysExtract) {
3158 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
3159 if (!gMacPerl_AlwaysExtract)
3160 Perl_croak(aTHX_ "No Perl script found in input\n");
3162 if (PL_doextract) /* require explicit override ? */
3163 if (!OverrideExtract(PL_origfilename))
3164 Perl_croak(aTHX_ "User aborted script\n");
3166 PL_doextract = FALSE;
3168 /* Pater peccavi, file does not have #! */
3169 PerlIO_rewind(PL_rsfp);
3174 while (PL_doextract) {
3175 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
3176 Perl_croak(aTHX_ "No Perl script found in input\n");
3179 if (*s == '#' && s[1] == '!' && ((s = instr(s,"perl")) || (s = instr(s2,"PERL")))) {
3180 PerlIO_ungetc(PL_rsfp, '\n'); /* to keep line count right */
3181 PL_doextract = FALSE;
3182 while (*s && !(isSPACE (*s) || *s == '#')) s++;
3184 while (*s == ' ' || *s == '\t') s++;
3186 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
3187 if (strnEQ(s2-4,"perl",4))
3189 while ((s = moreswitches(s)))
3192 #ifdef MACOS_TRADITIONAL
3193 /* We are always searching for the #!perl line in MacPerl,
3194 * so if we find it, still keep the line count correct
3195 * by counting lines we already skipped over
3197 for (; maclines > 0 ; maclines--)
3198 PerlIO_ungetc(PL_rsfp, '\n');
3202 /* gMacPerl_AlwaysExtract is false in MPW tool */
3203 } else if (gMacPerl_AlwaysExtract) {
3214 PL_uid = PerlProc_getuid();
3215 PL_euid = PerlProc_geteuid();
3216 PL_gid = PerlProc_getgid();
3217 PL_egid = PerlProc_getegid();
3219 PL_uid |= PL_gid << 16;
3220 PL_euid |= PL_egid << 16;
3222 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
3226 S_forbid_setid(pTHX_ char *s)
3228 if (PL_euid != PL_uid)
3229 Perl_croak(aTHX_ "No %s allowed while running setuid", s);
3230 if (PL_egid != PL_gid)
3231 Perl_croak(aTHX_ "No %s allowed while running setgid", s);
3235 Perl_init_debugger(pTHX)
3237 HV *ostash = PL_curstash;
3239 PL_curstash = PL_debstash;
3240 PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
3241 AvREAL_off(PL_dbargs);
3242 PL_DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
3243 PL_DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
3244 PL_DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
3245 sv_upgrade(GvSV(PL_DBsub), SVt_IV); /* IVX accessed if PERLDB_SUB_NN */
3246 PL_DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
3247 sv_setiv(PL_DBsingle, 0);
3248 PL_DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
3249 sv_setiv(PL_DBtrace, 0);
3250 PL_DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
3251 sv_setiv(PL_DBsignal, 0);
3252 PL_curstash = ostash;
3255 #ifndef STRESS_REALLOC
3256 #define REASONABLE(size) (size)
3258 #define REASONABLE(size) (1) /* unreasonable */
3262 Perl_init_stacks(pTHX)
3264 /* start with 128-item stack and 8K cxstack */
3265 PL_curstackinfo = new_stackinfo(REASONABLE(128),
3266 REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
3267 PL_curstackinfo->si_type = PERLSI_MAIN;
3268 PL_curstack = PL_curstackinfo->si_stack;
3269 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
3271 PL_stack_base = AvARRAY(PL_curstack);
3272 PL_stack_sp = PL_stack_base;
3273 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
3275 New(50,PL_tmps_stack,REASONABLE(128),SV*);
3278 PL_tmps_max = REASONABLE(128);
3280 New(54,PL_markstack,REASONABLE(32),I32);
3281 PL_markstack_ptr = PL_markstack;
3282 PL_markstack_max = PL_markstack + REASONABLE(32);
3286 New(54,PL_scopestack,REASONABLE(32),I32);
3287 PL_scopestack_ix = 0;
3288 PL_scopestack_max = REASONABLE(32);
3290 New(54,PL_savestack,REASONABLE(128),ANY);
3291 PL_savestack_ix = 0;
3292 PL_savestack_max = REASONABLE(128);
3294 New(54,PL_retstack,REASONABLE(16),OP*);
3296 PL_retstack_max = REASONABLE(16);
3304 while (PL_curstackinfo->si_next)
3305 PL_curstackinfo = PL_curstackinfo->si_next;
3306 while (PL_curstackinfo) {
3307 PERL_SI *p = PL_curstackinfo->si_prev;
3308 /* curstackinfo->si_stack got nuked by sv_free_arenas() */
3309 Safefree(PL_curstackinfo->si_cxstack);
3310 Safefree(PL_curstackinfo);
3311 PL_curstackinfo = p;
3313 Safefree(PL_tmps_stack);
3314 Safefree(PL_markstack);
3315 Safefree(PL_scopestack);
3316 Safefree(PL_savestack);
3317 Safefree(PL_retstack);
3326 lex_start(PL_linestr);
3328 PL_subname = newSVpvn("main",4);
3332 S_init_predump_symbols(pTHX)
3337 sv_setpvn(get_sv("\"", TRUE), " ", 1);
3338 PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
3339 GvMULTI_on(PL_stdingv);
3340 io = GvIOp(PL_stdingv);
3341 IoTYPE(io) = IoTYPE_RDONLY;
3342 IoIFP(io) = PerlIO_stdin();
3343 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
3345 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
3347 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
3350 IoTYPE(io) = IoTYPE_WRONLY;
3351 IoOFP(io) = IoIFP(io) = PerlIO_stdout();
3353 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
3355 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
3357 PL_stderrgv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
3358 GvMULTI_on(PL_stderrgv);
3359 io = GvIOp(PL_stderrgv);
3360 IoTYPE(io) = IoTYPE_WRONLY;
3361 IoOFP(io) = IoIFP(io) = PerlIO_stderr();
3362 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
3364 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
3366 PL_statname = NEWSV(66,0); /* last filename we did stat on */
3369 Safefree(PL_osname);
3370 PL_osname = savepv(OSNAME);
3374 Perl_init_argv_symbols(pTHX_ register int argc, register char **argv)
3377 argc--,argv++; /* skip name of script */
3378 if (PL_doswitches) {
3379 for (; argc > 0 && **argv == '-'; argc--,argv++) {
3382 if (argv[0][1] == '-' && !argv[0][2]) {
3386 if ((s = strchr(argv[0], '='))) {
3388 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
3391 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
3394 if ((PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV))) {
3395 GvMULTI_on(PL_argvgv);
3396 (void)gv_AVadd(PL_argvgv);
3397 av_clear(GvAVn(PL_argvgv));
3398 for (; argc > 0; argc--,argv++) {
3399 SV *sv = newSVpv(argv[0],0);
3400 av_push(GvAVn(PL_argvgv),sv);
3402 (void)sv_utf8_decode(sv);
3407 #ifdef HAS_PROCSELFEXE
3408 /* This is a function so that we don't hold on to MAXPATHLEN
3409 bytes of stack longer than necessary
3412 S_procself_val(pTHX_ SV *sv, char *arg0)
3414 char buf[MAXPATHLEN];
3415 int len = readlink(PROCSELFEXE_PATH, buf, sizeof(buf) - 1);
3417 /* On Playstation2 Linux V1.0 (kernel 2.2.1) readlink(/proc/self/exe)
3418 includes a spurious NUL which will cause $^X to fail in system
3419 or backticks (this will prevent extensions from being built and
3420 many tests from working). readlink is not meant to add a NUL.
3421 Normal readlink works fine.
3423 if (len > 0 && buf[len-1] == '\0') {
3427 /* FreeBSD's implementation is acknowledged to be imperfect, sometimes
3428 returning the text "unknown" from the readlink rather than the path
3429 to the executable (or returning an error from the readlink). Any valid
3430 path has a '/' in it somewhere, so use that to validate the result.
3431 See http://www.freebsd.org/cgi/query-pr.cgi?pr=35703
3433 if (len > 0 && memchr(buf, '/', len)) {
3434 sv_setpvn(sv,buf,len);
3440 #endif /* HAS_PROCSELFEXE */
3443 S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
3449 PL_toptarget = NEWSV(0,0);
3450 sv_upgrade(PL_toptarget, SVt_PVFM);
3451 sv_setpvn(PL_toptarget, "", 0);
3452 PL_bodytarget = NEWSV(0,0);
3453 sv_upgrade(PL_bodytarget, SVt_PVFM);
3454 sv_setpvn(PL_bodytarget, "", 0);
3455 PL_formtarget = PL_bodytarget;
3459 init_argv_symbols(argc,argv);
3461 if ((tmpgv = gv_fetchpv("0",TRUE, SVt_PV))) {
3462 #ifdef MACOS_TRADITIONAL
3463 /* $0 is not majick on a Mac */
3464 sv_setpv(GvSV(tmpgv),MacPerl_MPWFileName(PL_origfilename));
3466 sv_setpv(GvSV(tmpgv),PL_origfilename);
3467 magicname("0", "0", 1);
3470 if ((tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))) {/* $^X */
3471 #ifdef HAS_PROCSELFEXE
3472 S_procself_val(aTHX_ GvSV(tmpgv), PL_origargv[0]);
3475 sv_setpv(GvSV(tmpgv), os2_execname(aTHX));
3477 sv_setpv(GvSV(tmpgv),PL_origargv[0]);
3481 if ((PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV))) {
3483 GvMULTI_on(PL_envgv);
3484 hv = GvHVn(PL_envgv);
3485 hv_magic(hv, Nullgv, PERL_MAGIC_env);
3486 #ifdef USE_ENVIRON_ARRAY
3487 /* Note that if the supplied env parameter is actually a copy
3488 of the global environ then it may now point to free'd memory
3489 if the environment has been modified since. To avoid this
3490 problem we treat env==NULL as meaning 'use the default'
3495 # ifdef USE_ITHREADS
3496 && PL_curinterp == aTHX
3500 environ[0] = Nullch;
3503 for (; *env; env++) {
3504 if (!(s = strchr(*env,'=')))
3511 sv = newSVpv(s+1, 0);
3512 (void)hv_store(hv, *env, s - *env, sv, 0);
3516 #endif /* USE_ENVIRON_ARRAY */
3519 if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV))) {
3520 SvREADONLY_off(GvSV(tmpgv));
3521 sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
3522 SvREADONLY_on(GvSV(tmpgv));
3524 #ifdef THREADS_HAVE_PIDS
3525 PL_ppid = (IV)getppid();
3528 /* touch @F array to prevent spurious warnings 20020415 MJD */
3530 (void) get_av("main::F", TRUE | GV_ADDMULTI);
3532 /* touch @- and @+ arrays to prevent spurious warnings 20020415 MJD */
3533 (void) get_av("main::-", TRUE | GV_ADDMULTI);
3534 (void) get_av("main::+", TRUE | GV_ADDMULTI);
3538 S_init_perllib(pTHX)
3543 s = PerlEnv_getenv("PERL5LIB");
3545 incpush(s, TRUE, TRUE, TRUE);
3547 incpush(PerlEnv_getenv("PERLLIB"), FALSE, FALSE, TRUE);
3549 /* Treat PERL5?LIB as a possible search list logical name -- the
3550 * "natural" VMS idiom for a Unix path string. We allow each
3551 * element to be a set of |-separated directories for compatibility.
3555 if (my_trnlnm("PERL5LIB",buf,0))
3556 do { incpush(buf,TRUE,TRUE,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
3558 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE,FALSE,TRUE);
3562 /* Use the ~-expanded versions of APPLLIB (undocumented),
3563 ARCHLIB PRIVLIB SITEARCH SITELIB VENDORARCH and VENDORLIB
3566 incpush(APPLLIB_EXP, TRUE, TRUE, TRUE);
3570 incpush(ARCHLIB_EXP, FALSE, FALSE, TRUE);
3572 #ifdef MACOS_TRADITIONAL
3575 SV * privdir = NEWSV(55, 0);
3576 char * macperl = PerlEnv_getenv("MACPERL");
3581 Perl_sv_setpvf(aTHX_ privdir, "%slib:", macperl);
3582 if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
3583 incpush(SvPVX(privdir), TRUE, FALSE, TRUE);
3584 Perl_sv_setpvf(aTHX_ privdir, "%ssite_perl:", macperl);
3585 if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
3586 incpush(SvPVX(privdir), TRUE, FALSE, TRUE);
3588 SvREFCNT_dec(privdir);
3591 incpush(":", FALSE, FALSE, TRUE);
3594 # define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
3597 incpush(PRIVLIB_EXP, TRUE, FALSE, TRUE);
3599 incpush(PRIVLIB_EXP, FALSE, FALSE, TRUE);
3603 /* sitearch is always relative to sitelib on Windows for
3604 * DLL-based path intuition to work correctly */
3605 # if !defined(WIN32)
3606 incpush(SITEARCH_EXP, FALSE, FALSE, TRUE);
3612 /* this picks up sitearch as well */
3613 incpush(SITELIB_EXP, TRUE, FALSE, TRUE);
3615 incpush(SITELIB_EXP, FALSE, FALSE, TRUE);
3619 #ifdef SITELIB_STEM /* Search for version-specific dirs below here */
3620 incpush(SITELIB_STEM, FALSE, TRUE, TRUE);
3623 #ifdef PERL_VENDORARCH_EXP
3624 /* vendorarch is always relative to vendorlib on Windows for
3625 * DLL-based path intuition to work correctly */
3626 # if !defined(WIN32)
3627 incpush(PERL_VENDORARCH_EXP, FALSE, FALSE, TRUE);
3631 #ifdef PERL_VENDORLIB_EXP
3633 incpush(PERL_VENDORLIB_EXP, TRUE, FALSE, TRUE); /* this picks up vendorarch as well */
3635 incpush(PERL_VENDORLIB_EXP, FALSE, FALSE, TRUE);
3639 #ifdef PERL_VENDORLIB_STEM /* Search for version-specific dirs below here */
3640 incpush(PERL_VENDORLIB_STEM, FALSE, TRUE, TRUE);
3643 #ifdef PERL_OTHERLIBDIRS
3644 incpush(PERL_OTHERLIBDIRS, TRUE, TRUE, TRUE);
3648 incpush(".", FALSE, FALSE, TRUE);
3649 #endif /* MACOS_TRADITIONAL */
3652 #if defined(DOSISH) || defined(EPOC)
3653 # define PERLLIB_SEP ';'
3656 # define PERLLIB_SEP '|'
3658 # if defined(MACOS_TRADITIONAL)
3659 # define PERLLIB_SEP ','
3661 # define PERLLIB_SEP ':'
3665 #ifndef PERLLIB_MANGLE
3666 # define PERLLIB_MANGLE(s,n) (s)
3670 S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers, int usesep)
3672 SV *subdir = Nullsv;
3677 if (addsubdirs || addoldvers) {
3678 subdir = sv_newmortal();
3681 /* Break at all separators */
3683 SV *libdir = NEWSV(55,0);
3686 /* skip any consecutive separators */
3688 while ( *p == PERLLIB_SEP ) {
3689 /* Uncomment the next line for PATH semantics */
3690 /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */
3695 if ( usesep && (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
3696 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
3701 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
3702 p = Nullch; /* break out */
3704 #ifdef MACOS_TRADITIONAL
3705 if (!strchr(SvPVX(libdir), ':')) {
3708 sv_setpv(libdir, MacPerl_CanonDir(SvPVX(libdir), buf, 0));
3710 if (SvPVX(libdir)[SvCUR(libdir)-1] != ':')
3711 sv_catpv(libdir, ":");
3715 * BEFORE pushing libdir onto @INC we may first push version- and
3716 * archname-specific sub-directories.
3718 if (addsubdirs || addoldvers) {
3719 #ifdef PERL_INC_VERSION_LIST
3720 /* Configure terminates PERL_INC_VERSION_LIST with a NULL */
3721 const char *incverlist[] = { PERL_INC_VERSION_LIST };
3722 const char **incver;
3729 if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) {
3731 while (unix[len-1] == '/') len--; /* Cosmetic */
3732 sv_usepvn(libdir,unix,len);
3735 PerlIO_printf(Perl_error_log,
3736 "Failed to unixify @INC element \"%s\"\n",
3740 #ifdef MACOS_TRADITIONAL
3741 #define PERL_AV_SUFFIX_FMT ""
3742 #define PERL_ARCH_FMT "%s:"
3743 #define PERL_ARCH_FMT_PATH PERL_FS_VER_FMT PERL_AV_SUFFIX_FMT
3745 #define PERL_AV_SUFFIX_FMT "/"
3746 #define PERL_ARCH_FMT "/%s"
3747 #define PERL_ARCH_FMT_PATH PERL_AV_SUFFIX_FMT PERL_FS_VER_FMT
3749 /* .../version/archname if -d .../version/archname */
3750 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH PERL_ARCH_FMT,
3752 (int)PERL_REVISION, (int)PERL_VERSION,
3753 (int)PERL_SUBVERSION, ARCHNAME);
3754 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3755 S_ISDIR(tmpstatbuf.st_mode))
3756 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3758 /* .../version if -d .../version */
3759 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH, libdir,
3760 (int)PERL_REVISION, (int)PERL_VERSION,
3761 (int)PERL_SUBVERSION);
3762 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3763 S_ISDIR(tmpstatbuf.st_mode))
3764 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3766 /* .../archname if -d .../archname */
3767 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, ARCHNAME);
3768 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3769 S_ISDIR(tmpstatbuf.st_mode))
3770 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3773 #ifdef PERL_INC_VERSION_LIST
3775 for (incver = incverlist; *incver; incver++) {
3776 /* .../xxx if -d .../xxx */
3777 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, *incver);
3778 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3779 S_ISDIR(tmpstatbuf.st_mode))
3780 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3786 /* finally push this lib directory on the end of @INC */
3787 av_push(GvAVn(PL_incgv), libdir);
3791 #ifdef USE_5005THREADS
3792 STATIC struct perl_thread *
3793 S_init_main_thread(pTHX)
3795 #if !defined(PERL_IMPLICIT_CONTEXT)
3796 struct perl_thread *thr;
3800 Newz(53, thr, 1, struct perl_thread);
3801 PL_curcop = &PL_compiling;
3802 thr->interp = PERL_GET_INTERP;
3803 thr->cvcache = newHV();
3804 thr->threadsv = newAV();
3805 /* thr->threadsvp is set when find_threadsv is called */
3806 thr->specific = newAV();
3807 thr->flags = THRf_R_JOINABLE;
3808 MUTEX_INIT(&thr->mutex);
3809 /* Handcraft thrsv similarly to mess_sv */
3810 New(53, PL_thrsv, 1, SV);
3811 Newz(53, xpv, 1, XPV);
3812 SvFLAGS(PL_thrsv) = SVt_PV;
3813 SvANY(PL_thrsv) = (void*)xpv;
3814 SvREFCNT(PL_thrsv) = 1 << 30; /* practically infinite */
3815 SvPVX(PL_thrsv) = (char*)thr;
3816 SvCUR_set(PL_thrsv, sizeof(thr));
3817 SvLEN_set(PL_thrsv, sizeof(thr));
3818 *SvEND(PL_thrsv) = '\0'; /* in the trailing_nul field */
3819 thr->oursv = PL_thrsv;
3820 PL_chopset = " \n-";
3823 MUTEX_LOCK(&PL_threads_mutex);
3829 MUTEX_UNLOCK(&PL_threads_mutex);
3831 #ifdef HAVE_THREAD_INTERN
3832 Perl_init_thread_intern(thr);
3835 #ifdef SET_THREAD_SELF
3836 SET_THREAD_SELF(thr);
3838 thr->self = pthread_self();
3839 #endif /* SET_THREAD_SELF */
3843 * These must come after the thread self setting
3844 * because sv_setpvn does SvTAINT and the taint
3845 * fields thread selfness being set.
3847 PL_toptarget = NEWSV(0,0);
3848 sv_upgrade(PL_toptarget, SVt_PVFM);
3849 sv_setpvn(PL_toptarget, "", 0);
3850 PL_bodytarget = NEWSV(0,0);
3851 sv_upgrade(PL_bodytarget, SVt_PVFM);
3852 sv_setpvn(PL_bodytarget, "", 0);
3853 PL_formtarget = PL_bodytarget;
3854 thr->errsv = newSVpvn("", 0);
3855 (void) find_threadsv("@"); /* Ensure $@ is initialised early */
3858 PL_peepp = MEMBER_TO_FPTR(Perl_peep);
3859 PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
3860 PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
3861 PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
3862 PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
3863 PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
3865 PL_reginterp_cnt = 0;
3869 #endif /* USE_5005THREADS */
3872 Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
3875 line_t oldline = CopLINE(PL_curcop);
3881 while (AvFILL(paramList) >= 0) {
3882 cv = (CV*)av_shift(paramList);
3884 if (paramList == PL_beginav) {
3885 /* save PL_beginav for compiler */
3886 if (! PL_beginav_save)
3887 PL_beginav_save = newAV();
3888 av_push(PL_beginav_save, (SV*)cv);
3890 else if (paramList == PL_checkav) {
3891 /* save PL_checkav for compiler */
3892 if (! PL_checkav_save)
3893 PL_checkav_save = newAV();
3894 av_push(PL_checkav_save, (SV*)cv);
3899 #ifdef PERL_FLEXIBLE_EXCEPTIONS
3900 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_list_body), cv);
3906 #ifndef PERL_FLEXIBLE_EXCEPTIONS
3910 (void)SvPV(atsv, len);
3912 PL_curcop = &PL_compiling;
3913 CopLINE_set(PL_curcop, oldline);
3914 if (paramList == PL_beginav)
3915 sv_catpv(atsv, "BEGIN failed--compilation aborted");
3917 Perl_sv_catpvf(aTHX_ atsv,
3918 "%s failed--call queue aborted",
3919 paramList == PL_checkav ? "CHECK"
3920 : paramList == PL_initav ? "INIT"
3922 while (PL_scopestack_ix > oldscope)
3925 Perl_croak(aTHX_ "%"SVf"", atsv);
3932 /* my_exit() was called */
3933 while (PL_scopestack_ix > oldscope)
3936 PL_curstash = PL_defstash;
3937 PL_curcop = &PL_compiling;
3938 CopLINE_set(PL_curcop, oldline);
3940 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) {
3941 if (paramList == PL_beginav)
3942 Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
3944 Perl_croak(aTHX_ "%s failed--call queue aborted",
3945 paramList == PL_checkav ? "CHECK"
3946 : paramList == PL_initav ? "INIT"
3953 PL_curcop = &PL_compiling;
3954 CopLINE_set(PL_curcop, oldline);
3957 PerlIO_printf(Perl_error_log, "panic: restartop\n");
3965 #ifdef PERL_FLEXIBLE_EXCEPTIONS
3967 S_vcall_list_body(pTHX_ va_list args)
3969 CV *cv = va_arg(args, CV*);
3970 return call_list_body(cv);
3975 S_call_list_body(pTHX_ CV *cv)
3977 PUSHMARK(PL_stack_sp);
3978 call_sv((SV*)cv, G_EVAL|G_DISCARD);
3983 Perl_my_exit(pTHX_ U32 status)
3985 DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
3986 thr, (unsigned long) status));
3995 STATUS_NATIVE_SET(status);
4002 Perl_my_failure_exit(pTHX)
4005 if (vaxc$errno & 1) {
4006 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
4007 STATUS_NATIVE_SET(44);
4010 if (!vaxc$errno && errno) /* unlikely */
4011 STATUS_NATIVE_SET(44);
4013 STATUS_NATIVE_SET(vaxc$errno);
4018 STATUS_POSIX_SET(errno);
4020 exitstatus = STATUS_POSIX >> 8;
4021 if (exitstatus & 255)
4022 STATUS_POSIX_SET(exitstatus);
4024 STATUS_POSIX_SET(255);
4031 S_my_exit_jump(pTHX)
4033 register PERL_CONTEXT *cx;
4038 SvREFCNT_dec(PL_e_script);
4039 PL_e_script = Nullsv;
4042 POPSTACK_TO(PL_mainstack);
4043 if (cxstack_ix >= 0) {
4046 POPBLOCK(cx,PL_curpm);
4054 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen)
4057 p = SvPVX(PL_e_script);
4058 nl = strchr(p, '\n');
4059 nl = (nl) ? nl+1 : SvEND(PL_e_script);
4061 filter_del(read_e_script);
4064 sv_catpvn(buf_sv, p, nl-p);
4065 sv_chop(PL_e_script, nl);