3 * Copyright (c) 1987-2003 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 ((NV)PERL_SUBVERSION / (NV)1000000);
222 SvNOK_on(PL_patchlevel); /* dual valued */
223 SvUTF8_on(PL_patchlevel);
224 SvREADONLY_on(PL_patchlevel);
227 #if defined(LOCAL_PATCH_COUNT)
228 PL_localpatches = local_patches; /* For possible -v */
231 #ifdef HAVE_INTERP_INTERN
235 PerlIO_init(aTHX); /* Hook to IO system */
237 PL_fdpid = newAV(); /* for remembering popen pids by fd */
238 PL_modglobal = newHV(); /* pointers to per-interpreter module globals */
239 PL_errors = newSVpvn("",0);
240 sv_setpvn(PERL_DEBUG_PAD(0), "", 0); /* For regex debugging. */
241 sv_setpvn(PERL_DEBUG_PAD(1), "", 0); /* ext/re needs these */
242 sv_setpvn(PERL_DEBUG_PAD(2), "", 0); /* even without DEBUGGING. */
244 PL_regex_padav = newAV();
245 av_push(PL_regex_padav,(SV*)newAV()); /* First entry is an array of empty elements */
246 PL_regex_pad = AvARRAY(PL_regex_padav);
248 #ifdef USE_REENTRANT_API
249 Perl_reentrant_init(aTHX);
252 /* Note that strtab is a rather special HV. Assumptions are made
253 about not iterating on it, and not adding tie magic to it.
254 It is properly deallocated in perl_destruct() */
257 HvSHAREKEYS_off(PL_strtab); /* mandatory */
258 hv_ksplit(PL_strtab, 512);
260 #if defined(__DYNAMIC__) && (defined(NeXT) || defined(__NeXT__))
261 _dyld_lookup_and_bind
262 ("__environ", (unsigned long *) &environ_pointer, NULL);
265 #ifdef USE_ENVIRON_ARRAY
266 PL_origenviron = environ;
269 /* Use sysconf(_SC_CLK_TCK) if available, if not
270 * available or if the sysconf() fails, use the HZ. */
271 #if defined(HAS_SYSCONF) && defined(_SC_CLK_TCK)
272 PL_clocktick = sysconf(_SC_CLK_TCK);
273 if (PL_clocktick <= 0)
281 =for apidoc nothreadhook
283 Stub that provides thread hook for perl_destruct when there are
290 Perl_nothreadhook(pTHX)
296 =for apidoc perl_destruct
298 Shuts down a Perl interpreter. See L<perlembed>.
306 volatile int destruct_level; /* 0=none, 1=full, 2=full with checks */
308 #ifdef USE_5005THREADS
310 #endif /* USE_5005THREADS */
312 /* wait for all pseudo-forked children to finish */
313 PERL_WAIT_FOR_CHILDREN;
315 destruct_level = PL_perl_destruct_level;
319 if ((s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL"))) {
321 if (destruct_level < i)
328 if(PL_exit_flags & PERL_EXIT_DESTRUCT_END) {
333 if (PL_endav && !PL_minus_c)
334 call_list(PL_scopestack_ix, PL_endav);
340 /* Need to flush since END blocks can produce output */
343 if (CALL_FPTR(PL_threadhook)(aTHX)) {
344 /* Threads hook has vetoed further cleanup */
345 return STATUS_NATIVE_EXPORT;
348 /* We must account for everything. */
350 /* Destroy the main CV and syntax tree */
352 op_free(PL_main_root);
353 PL_main_root = Nullop;
355 PL_curcop = &PL_compiling;
356 PL_main_start = Nullop;
357 SvREFCNT_dec(PL_main_cv);
361 /* Tell PerlIO we are about to tear things apart in case
362 we have layers which are using resources that should
366 PerlIO_destruct(aTHX);
368 if (PL_sv_objcount) {
370 * Try to destruct global references. We do this first so that the
371 * destructors and destructees still exist. Some sv's might remain.
372 * Non-referenced objects are on their own.
377 /* unhook hooks which will soon be, or use, destroyed data */
378 SvREFCNT_dec(PL_warnhook);
379 PL_warnhook = Nullsv;
380 SvREFCNT_dec(PL_diehook);
383 /* call exit list functions */
384 while (PL_exitlistlen-- > 0)
385 PL_exitlist[PL_exitlistlen].fn(aTHX_ PL_exitlist[PL_exitlistlen].ptr);
387 Safefree(PL_exitlist);
389 if (destruct_level == 0){
391 DEBUG_P(debprofdump());
393 #if defined(PERLIO_LAYERS)
394 /* No more IO - including error messages ! */
395 PerlIO_cleanup(aTHX);
398 /* The exit() function will do everything that needs doing. */
399 return STATUS_NATIVE_EXPORT;
402 /* jettison our possibly duplicated environment */
403 /* if PERL_USE_SAFE_PUTENV is defined environ will not have been copied
404 * so we certainly shouldn't free it here
406 #if defined(USE_ENVIRON_ARRAY) && !defined(PERL_USE_SAFE_PUTENV)
407 if (environ != PL_origenviron
409 /* only main thread can free environ[0] contents */
410 && PL_curinterp == aTHX
416 for (i = 0; environ[i]; i++)
417 safesysfree(environ[i]);
419 /* Must use safesysfree() when working with environ. */
420 safesysfree(environ);
422 environ = PL_origenviron;
427 /* the syntax tree is shared between clones
428 * so op_free(PL_main_root) only ReREFCNT_dec's
429 * REGEXPs in the parent interpreter
430 * we need to manually ReREFCNT_dec for the clones
433 I32 i = AvFILLp(PL_regex_padav) + 1;
434 SV **ary = AvARRAY(PL_regex_padav);
438 REGEXP *re = INT2PTR(REGEXP *,SvIVX(resv));
440 if (SvFLAGS(resv) & SVf_BREAK) {
441 /* this is PL_reg_curpm, already freed
442 * flag is set in regexec.c:S_regtry
444 SvFLAGS(resv) &= ~SVf_BREAK;
446 else if(SvREPADTMP(resv)) {
447 SvREPADTMP_off(resv);
454 SvREFCNT_dec(PL_regex_padav);
455 PL_regex_padav = Nullav;
459 /* loosen bonds of global variables */
462 (void)PerlIO_close(PL_rsfp);
466 /* Filters for program text */
467 SvREFCNT_dec(PL_rsfp_filters);
468 PL_rsfp_filters = Nullav;
471 PL_preprocess = FALSE;
477 PL_doswitches = FALSE;
478 PL_dowarn = G_WARN_OFF;
479 PL_doextract = FALSE;
480 PL_sawampersand = FALSE; /* must save all match strings */
483 Safefree(PL_inplace);
485 SvREFCNT_dec(PL_patchlevel);
488 SvREFCNT_dec(PL_e_script);
489 PL_e_script = Nullsv;
492 /* magical thingies */
494 SvREFCNT_dec(PL_ofs_sv); /* $, */
497 SvREFCNT_dec(PL_ors_sv); /* $\ */
500 SvREFCNT_dec(PL_rs); /* $/ */
503 PL_multiline = 0; /* $* */
504 Safefree(PL_osname); /* $^O */
507 SvREFCNT_dec(PL_statname);
508 PL_statname = Nullsv;
511 /* defgv, aka *_ should be taken care of elsewhere */
513 /* clean up after study() */
514 SvREFCNT_dec(PL_lastscream);
515 PL_lastscream = Nullsv;
516 Safefree(PL_screamfirst);
518 Safefree(PL_screamnext);
522 Safefree(PL_efloatbuf);
523 PL_efloatbuf = Nullch;
526 /* startup and shutdown function lists */
527 SvREFCNT_dec(PL_beginav);
528 SvREFCNT_dec(PL_beginav_save);
529 SvREFCNT_dec(PL_endav);
530 SvREFCNT_dec(PL_checkav);
531 SvREFCNT_dec(PL_checkav_save);
532 SvREFCNT_dec(PL_initav);
534 PL_beginav_save = Nullav;
537 PL_checkav_save = Nullav;
540 /* shortcuts just get cleared */
546 PL_argvoutgv = Nullgv;
548 PL_stderrgv = Nullgv;
549 PL_last_in_gv = Nullgv;
551 PL_debstash = Nullhv;
553 /* reset so print() ends up where we expect */
556 SvREFCNT_dec(PL_argvout_stack);
557 PL_argvout_stack = Nullav;
559 SvREFCNT_dec(PL_modglobal);
560 PL_modglobal = Nullhv;
561 SvREFCNT_dec(PL_preambleav);
562 PL_preambleav = Nullav;
563 SvREFCNT_dec(PL_subname);
565 SvREFCNT_dec(PL_linestr);
567 SvREFCNT_dec(PL_pidstatus);
568 PL_pidstatus = Nullhv;
569 SvREFCNT_dec(PL_toptarget);
570 PL_toptarget = Nullsv;
571 SvREFCNT_dec(PL_bodytarget);
572 PL_bodytarget = Nullsv;
573 PL_formtarget = Nullsv;
575 /* free locale stuff */
576 #ifdef USE_LOCALE_COLLATE
577 Safefree(PL_collation_name);
578 PL_collation_name = Nullch;
581 #ifdef USE_LOCALE_NUMERIC
582 Safefree(PL_numeric_name);
583 PL_numeric_name = Nullch;
584 SvREFCNT_dec(PL_numeric_radix_sv);
587 /* clear utf8 character classes */
588 SvREFCNT_dec(PL_utf8_alnum);
589 SvREFCNT_dec(PL_utf8_alnumc);
590 SvREFCNT_dec(PL_utf8_ascii);
591 SvREFCNT_dec(PL_utf8_alpha);
592 SvREFCNT_dec(PL_utf8_space);
593 SvREFCNT_dec(PL_utf8_cntrl);
594 SvREFCNT_dec(PL_utf8_graph);
595 SvREFCNT_dec(PL_utf8_digit);
596 SvREFCNT_dec(PL_utf8_upper);
597 SvREFCNT_dec(PL_utf8_lower);
598 SvREFCNT_dec(PL_utf8_print);
599 SvREFCNT_dec(PL_utf8_punct);
600 SvREFCNT_dec(PL_utf8_xdigit);
601 SvREFCNT_dec(PL_utf8_mark);
602 SvREFCNT_dec(PL_utf8_toupper);
603 SvREFCNT_dec(PL_utf8_totitle);
604 SvREFCNT_dec(PL_utf8_tolower);
605 SvREFCNT_dec(PL_utf8_tofold);
606 SvREFCNT_dec(PL_utf8_idstart);
607 SvREFCNT_dec(PL_utf8_idcont);
608 PL_utf8_alnum = Nullsv;
609 PL_utf8_alnumc = Nullsv;
610 PL_utf8_ascii = Nullsv;
611 PL_utf8_alpha = Nullsv;
612 PL_utf8_space = Nullsv;
613 PL_utf8_cntrl = Nullsv;
614 PL_utf8_graph = Nullsv;
615 PL_utf8_digit = Nullsv;
616 PL_utf8_upper = Nullsv;
617 PL_utf8_lower = Nullsv;
618 PL_utf8_print = Nullsv;
619 PL_utf8_punct = Nullsv;
620 PL_utf8_xdigit = Nullsv;
621 PL_utf8_mark = Nullsv;
622 PL_utf8_toupper = Nullsv;
623 PL_utf8_totitle = Nullsv;
624 PL_utf8_tolower = Nullsv;
625 PL_utf8_tofold = Nullsv;
626 PL_utf8_idstart = Nullsv;
627 PL_utf8_idcont = Nullsv;
629 if (!specialWARN(PL_compiling.cop_warnings))
630 SvREFCNT_dec(PL_compiling.cop_warnings);
631 PL_compiling.cop_warnings = Nullsv;
632 if (!specialCopIO(PL_compiling.cop_io))
633 SvREFCNT_dec(PL_compiling.cop_io);
634 PL_compiling.cop_io = Nullsv;
635 CopFILE_free(&PL_compiling);
636 CopSTASH_free(&PL_compiling);
638 /* Prepare to destruct main symbol table. */
643 SvREFCNT_dec(PL_curstname);
644 PL_curstname = Nullsv;
646 /* clear queued errors */
647 SvREFCNT_dec(PL_errors);
651 if (destruct_level >= 2 && ckWARN_d(WARN_INTERNAL)) {
652 if (PL_scopestack_ix != 0)
653 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
654 "Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
655 (long)PL_scopestack_ix);
656 if (PL_savestack_ix != 0)
657 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
658 "Unbalanced saves: %ld more saves than restores\n",
659 (long)PL_savestack_ix);
660 if (PL_tmps_floor != -1)
661 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced tmps: %ld more allocs than frees\n",
662 (long)PL_tmps_floor + 1);
663 if (cxstack_ix != -1)
664 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced context: %ld more PUSHes than POPs\n",
665 (long)cxstack_ix + 1);
668 /* Now absolutely destruct everything, somehow or other, loops or no. */
669 SvFLAGS(PL_fdpid) |= SVTYPEMASK; /* don't clean out pid table now */
670 SvFLAGS(PL_strtab) |= SVTYPEMASK; /* don't clean out strtab now */
672 /* the 2 is for PL_fdpid and PL_strtab */
673 while (PL_sv_count > 2 && sv_clean_all())
676 SvFLAGS(PL_fdpid) &= ~SVTYPEMASK;
677 SvFLAGS(PL_fdpid) |= SVt_PVAV;
678 SvFLAGS(PL_strtab) &= ~SVTYPEMASK;
679 SvFLAGS(PL_strtab) |= SVt_PVHV;
681 AvREAL_off(PL_fdpid); /* no surviving entries */
682 SvREFCNT_dec(PL_fdpid); /* needed in io_close() */
685 #ifdef HAVE_INTERP_INTERN
689 /* Destruct the global string table. */
691 /* Yell and reset the HeVAL() slots that are still holding refcounts,
692 * so that sv_free() won't fail on them.
700 max = HvMAX(PL_strtab);
701 array = HvARRAY(PL_strtab);
704 if (hent && ckWARN_d(WARN_INTERNAL)) {
705 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
706 "Unbalanced string table refcount: (%d) for \"%s\"",
707 HeVAL(hent) - Nullsv, HeKEY(hent));
708 HeVAL(hent) = Nullsv;
718 SvREFCNT_dec(PL_strtab);
721 /* free the pointer table used for cloning */
722 ptr_table_free(PL_ptr_table);
725 /* free special SVs */
727 SvREFCNT(&PL_sv_yes) = 0;
728 sv_clear(&PL_sv_yes);
729 SvANY(&PL_sv_yes) = NULL;
730 SvFLAGS(&PL_sv_yes) = 0;
732 SvREFCNT(&PL_sv_no) = 0;
734 SvANY(&PL_sv_no) = NULL;
735 SvFLAGS(&PL_sv_no) = 0;
739 for (i=0; i<=2; i++) {
740 SvREFCNT(PERL_DEBUG_PAD(i)) = 0;
741 sv_clear(PERL_DEBUG_PAD(i));
742 SvANY(PERL_DEBUG_PAD(i)) = NULL;
743 SvFLAGS(PERL_DEBUG_PAD(i)) = 0;
747 if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL))
748 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Scalars leaked: %ld\n", (long)PL_sv_count);
750 #ifdef DEBUG_LEAKING_SCALARS
751 if (PL_sv_count != 0) {
756 for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
757 svend = &sva[SvREFCNT(sva)];
758 for (sv = sva + 1; sv < svend; ++sv) {
759 if (SvTYPE(sv) != SVTYPEMASK) {
760 PerlIO_printf(Perl_debug_log, "leaked: 0x%p\n", sv);
768 #if defined(PERLIO_LAYERS)
769 /* No more IO - including error messages ! */
770 PerlIO_cleanup(aTHX);
773 /* sv_undef needs to stay immortal until after PerlIO_cleanup
774 as currently layers use it rather than Nullsv as a marker
775 for no arg - and will try and SvREFCNT_dec it.
777 SvREFCNT(&PL_sv_undef) = 0;
778 SvREADONLY_off(&PL_sv_undef);
780 Safefree(PL_origfilename);
781 Safefree(PL_reg_start_tmp);
783 Safefree(PL_reg_curpm);
784 Safefree(PL_reg_poscache);
785 Safefree(HeKEY_hek(&PL_hv_fetch_ent_mh));
786 Safefree(PL_op_mask);
787 Safefree(PL_psig_ptr);
788 Safefree(PL_psig_name);
789 Safefree(PL_bitcount);
790 Safefree(PL_psig_pend);
792 PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */
794 DEBUG_P(debprofdump());
796 #ifdef USE_REENTRANT_API
797 Perl_reentrant_free(aTHX);
802 /* As the absolutely last thing, free the non-arena SV for mess() */
805 /* it could have accumulated taint magic */
806 if (SvTYPE(PL_mess_sv) >= SVt_PVMG) {
809 for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) {
810 moremagic = mg->mg_moremagic;
811 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global
813 Safefree(mg->mg_ptr);
817 /* we know that type >= SVt_PV */
818 (void)SvOOK_off(PL_mess_sv);
819 Safefree(SvPVX(PL_mess_sv));
820 Safefree(SvANY(PL_mess_sv));
821 Safefree(PL_mess_sv);
824 return STATUS_NATIVE_EXPORT;
828 =for apidoc perl_free
830 Releases a Perl interpreter. See L<perlembed>.
838 #if defined(WIN32) || defined(NETWARE)
839 # if defined(PERL_IMPLICIT_SYS)
841 void *host = nw_internal_host;
843 void *host = w32_internal_host;
847 nw_delete_internal_host(host);
849 win32_delete_internal_host(host);
860 Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
862 Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry);
863 PL_exitlist[PL_exitlistlen].fn = fn;
864 PL_exitlist[PL_exitlistlen].ptr = ptr;
869 =for apidoc perl_parse
871 Tells a Perl interpreter to parse a Perl script. See L<perlembed>.
877 perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
882 #ifdef USE_5005THREADS
886 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
889 Perl_croak(aTHX_ "suidperl is no longer needed since the kernel can now execute\n\
890 setuid perl scripts securely.\n");
899 /* Come here if running an undumped a.out. */
901 PL_origfilename = savepv(argv[0]);
902 PL_do_undump = FALSE;
903 cxstack_ix = -1; /* start label stack again */
905 init_postdump_symbols(argc,argv,env);
910 op_free(PL_main_root);
911 PL_main_root = Nullop;
913 PL_main_start = Nullop;
914 SvREFCNT_dec(PL_main_cv);
918 oldscope = PL_scopestack_ix;
919 PL_dowarn = G_WARN_OFF;
921 #ifdef PERL_FLEXIBLE_EXCEPTIONS
922 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vparse_body), env, xsinit);
928 #ifndef PERL_FLEXIBLE_EXCEPTIONS
929 parse_body(env,xsinit);
932 call_list(oldscope, PL_checkav);
939 /* my_exit() was called */
940 while (PL_scopestack_ix > oldscope)
943 PL_curstash = PL_defstash;
945 call_list(oldscope, PL_checkav);
946 ret = STATUS_NATIVE_EXPORT;
949 PerlIO_printf(Perl_error_log, "panic: top_env\n");
957 #ifdef PERL_FLEXIBLE_EXCEPTIONS
959 S_vparse_body(pTHX_ va_list args)
961 char **env = va_arg(args, char**);
962 XSINIT_t xsinit = va_arg(args, XSINIT_t);
964 return parse_body(env, xsinit);
969 S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
971 int argc = PL_origargc;
972 char **argv = PL_origargv;
973 char *scriptname = NULL;
975 VOL bool dosearch = FALSE;
979 char *cddir = Nullch;
981 sv_setpvn(PL_linestr,"",0);
982 sv = newSVpvn("",0); /* first used for -I flags */
986 for (argc--,argv++; argc > 0; argc--,argv++) {
987 if (argv[0][0] != '-' || !argv[0][1])
991 validarg = " PHOOEY ";
1000 win32_argv2utf8(argc-1, argv+1);
1003 #ifndef PERL_STRICT_CR
1028 if ((s = moreswitches(s)))
1033 if( !PL_tainting ) {
1034 PL_taint_warn = TRUE;
1041 PL_taint_warn = FALSE;
1046 #ifdef MACOS_TRADITIONAL
1047 /* ignore -e for Dev:Pseudo argument */
1048 if (argv[1] && !strcmp(argv[1], "Dev:Pseudo"))
1051 if (PL_euid != PL_uid || PL_egid != PL_gid)
1052 Perl_croak(aTHX_ "No -e allowed in setuid scripts");
1054 PL_e_script = newSVpvn("",0);
1055 filter_add(read_e_script, NULL);
1058 sv_catpv(PL_e_script, s);
1060 sv_catpv(PL_e_script, argv[1]);
1064 Perl_croak(aTHX_ "No code specified for -e");
1065 sv_catpv(PL_e_script, "\n");
1068 case 'I': /* -I handled both here and in moreswitches() */
1070 if (!*++s && (s=argv[1]) != Nullch) {
1075 STRLEN len = strlen(s);
1076 p = savepvn(s, len);
1077 incpush(p, TRUE, TRUE, FALSE);
1078 sv_catpvn(sv, "-I", 2);
1079 sv_catpvn(sv, p, len);
1080 sv_catpvn(sv, " ", 1);
1084 Perl_croak(aTHX_ "No directory specified for -I");
1088 PL_preprocess = TRUE;
1098 PL_preambleav = newAV();
1099 av_push(PL_preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
1101 PL_Sv = newSVpv("print myconfig();",0);
1103 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
1105 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
1107 sv_catpv(PL_Sv,"\" Compile-time options:");
1109 sv_catpv(PL_Sv," DEBUGGING");
1111 # ifdef MULTIPLICITY
1112 sv_catpv(PL_Sv," MULTIPLICITY");
1114 # ifdef USE_5005THREADS
1115 sv_catpv(PL_Sv," USE_5005THREADS");
1117 # ifdef USE_ITHREADS
1118 sv_catpv(PL_Sv," USE_ITHREADS");
1120 # ifdef USE_64_BIT_INT
1121 sv_catpv(PL_Sv," USE_64_BIT_INT");
1123 # ifdef USE_64_BIT_ALL
1124 sv_catpv(PL_Sv," USE_64_BIT_ALL");
1126 # ifdef USE_LONG_DOUBLE
1127 sv_catpv(PL_Sv," USE_LONG_DOUBLE");
1129 # ifdef USE_LARGE_FILES
1130 sv_catpv(PL_Sv," USE_LARGE_FILES");
1133 sv_catpv(PL_Sv," USE_SOCKS");
1135 # ifdef PERL_IMPLICIT_CONTEXT
1136 sv_catpv(PL_Sv," PERL_IMPLICIT_CONTEXT");
1138 # ifdef PERL_IMPLICIT_SYS
1139 sv_catpv(PL_Sv," PERL_IMPLICIT_SYS");
1141 sv_catpv(PL_Sv,"\\n\",");
1143 #if defined(LOCAL_PATCH_COUNT)
1144 if (LOCAL_PATCH_COUNT > 0) {
1146 sv_catpv(PL_Sv,"\" Locally applied patches:\\n\",");
1147 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
1148 if (PL_localpatches[i])
1149 Perl_sv_catpvf(aTHX_ PL_Sv,"q\" \t%s\n\",",PL_localpatches[i]);
1153 Perl_sv_catpvf(aTHX_ PL_Sv,"\" Built under %s\\n\"",OSNAME);
1156 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
1158 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled on %s\\n\"",__DATE__);
1161 sv_catpv(PL_Sv, "; \
1163 @env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; ");
1166 push @env, \"CYGWIN=\\\"$ENV{CYGWIN}\\\"\";");
1169 print \" \\%ENV:\\n @env\\n\" if @env; \
1170 print \" \\@INC:\\n @INC\\n\";");
1173 PL_Sv = newSVpv("config_vars(qw(",0);
1174 sv_catpv(PL_Sv, ++s);
1175 sv_catpv(PL_Sv, "))");
1178 av_push(PL_preambleav, PL_Sv);
1179 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
1182 PL_doextract = TRUE;
1190 if (!*++s || isSPACE(*s)) {
1194 /* catch use of gnu style long options */
1195 if (strEQ(s, "version")) {
1199 if (strEQ(s, "help")) {
1206 Perl_croak(aTHX_ "Unrecognized switch: -%s (-h will show valid options)",s);
1210 sv_setsv(get_sv("/", TRUE), PL_rs);
1213 #ifndef SECURE_INTERNAL_GETENV
1216 (s = PerlEnv_getenv("PERL5OPT")))
1221 if (*s == '-' && *(s+1) == 'T') {
1223 PL_taint_warn = FALSE;
1226 char *popt_copy = Nullch;
1239 if (!strchr("DIMUdmtwA", *s))
1240 Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
1244 popt_copy = SvPVX(sv_2mortal(newSVpv(popt,0)));
1245 s = popt_copy + (s - popt);
1246 d = popt_copy + (d - popt);
1253 if( !PL_tainting ) {
1254 PL_taint_warn = TRUE;
1264 if (PL_taint_warn && PL_dowarn != G_WARN_ALL_OFF) {
1265 PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
1269 scriptname = argv[0];
1272 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
1274 else if (scriptname == Nullch) {
1276 if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
1284 open_script(scriptname,dosearch,sv,&fdscript);
1286 validate_suid(validarg, scriptname,fdscript);
1289 #if defined(SIGCHLD) || defined(SIGCLD)
1292 # define SIGCHLD SIGCLD
1294 Sighandler_t sigstate = rsignal_state(SIGCHLD);
1295 if (sigstate == SIG_IGN) {
1296 if (ckWARN(WARN_SIGNAL))
1297 Perl_warner(aTHX_ packWARN(WARN_SIGNAL),
1298 "Can't ignore signal CHLD, forcing to default");
1299 (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL);
1305 #ifdef MACOS_TRADITIONAL
1306 if (PL_doextract || gMacPerl_AlwaysExtract) {
1311 if (cddir && PerlDir_chdir(cddir) < 0)
1312 Perl_croak(aTHX_ "Can't chdir to %s",cddir);
1316 PL_main_cv = PL_compcv = (CV*)NEWSV(1104,0);
1317 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
1318 CvUNIQUE_on(PL_compcv);
1320 CvPADLIST(PL_compcv) = pad_new(0);
1321 #ifdef USE_5005THREADS
1322 CvOWNER(PL_compcv) = 0;
1323 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
1324 MUTEX_INIT(CvMUTEXP(PL_compcv));
1325 #endif /* USE_5005THREADS */
1328 boot_core_UNIVERSAL();
1330 boot_core_xsutils();
1334 (*xsinit)(aTHX); /* in case linked C routines want magical variables */
1336 #if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__) || defined(EPOC)
1342 # ifdef HAS_SOCKS5_INIT
1343 socks5_init(argv[0]);
1349 init_predump_symbols();
1350 /* init_postdump_symbols not currently designed to be called */
1351 /* more than once (ENV isn't cleared first, for example) */
1352 /* But running with -u leaves %ENV & @ARGV undefined! XXX */
1354 init_postdump_symbols(argc,argv,env);
1356 /* PL_unicode is turned on by -C or by $ENV{PERL_UNICODE}.
1357 * PL_utf8locale is conditionally turned on by
1358 * locale.c:Perl_init_i18nl10n() if the environment
1359 * look like the user wants to use UTF-8. */
1361 /* Requires init_predump_symbols(). */
1362 if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
1367 /* Turn on UTF-8-ness on STDIN, STDOUT, STDERR
1368 * and the default open disciplines. */
1369 if ((PL_unicode & PERL_UNICODE_STDIN_FLAG) &&
1370 PL_stdingv && (io = GvIO(PL_stdingv)) &&
1372 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
1373 if ((PL_unicode & PERL_UNICODE_STDOUT_FLAG) &&
1374 PL_defoutgv && (io = GvIO(PL_defoutgv)) &&
1376 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
1377 if ((PL_unicode & PERL_UNICODE_STDERR_FLAG) &&
1378 PL_stderrgv && (io = GvIO(PL_stderrgv)) &&
1380 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
1381 if ((PL_unicode & PERL_UNICODE_INOUT_FLAG) &&
1382 (sv = GvSV(gv_fetchpv("\017PEN", TRUE, SVt_PV)))) {
1383 U32 in = PL_unicode & PERL_UNICODE_IN_FLAG;
1384 U32 out = PL_unicode & PERL_UNICODE_OUT_FLAG;
1387 sv_setpvn(sv, ":utf8\0:utf8", 11);
1389 sv_setpvn(sv, ":utf8\0", 6);
1392 sv_setpvn(sv, "\0:utf8", 6);
1398 if ((s = PerlEnv_getenv("PERL_SIGNALS"))) {
1399 if (strEQ(s, "unsafe"))
1400 PL_signals |= PERL_SIGNALS_UNSAFE_FLAG;
1401 else if (strEQ(s, "safe"))
1402 PL_signals &= ~PERL_SIGNALS_UNSAFE_FLAG;
1404 Perl_croak(aTHX_ "PERL_SIGNALS illegal: \"%s\"", s);
1409 /* now parse the script */
1411 SETERRNO(0,SS_NORMAL);
1413 #ifdef MACOS_TRADITIONAL
1414 if (gMacPerl_SyntaxError = (yyparse() || PL_error_count)) {
1416 Perl_croak(aTHX_ "%s had compilation errors.\n", MacPerl_MPWFileName(PL_origfilename));
1418 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
1419 MacPerl_MPWFileName(PL_origfilename));
1423 if (yyparse() || PL_error_count) {
1425 Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
1427 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
1432 CopLINE_set(PL_curcop, 0);
1433 PL_curstash = PL_defstash;
1434 PL_preprocess = FALSE;
1436 SvREFCNT_dec(PL_e_script);
1437 PL_e_script = Nullsv;
1444 SAVECOPFILE(PL_curcop);
1445 SAVECOPLINE(PL_curcop);
1446 gv_check(PL_defstash);
1453 if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
1454 dump_mstats("after compilation:");
1463 =for apidoc perl_run
1465 Tells a Perl interpreter to run. See L<perlembed>.
1476 #ifdef USE_5005THREADS
1480 oldscope = PL_scopestack_ix;
1485 #ifdef PERL_FLEXIBLE_EXCEPTIONS
1487 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vrun_body), oldscope);
1493 cxstack_ix = -1; /* start context stack again */
1495 case 0: /* normal completion */
1496 #ifndef PERL_FLEXIBLE_EXCEPTIONS
1501 case 2: /* my_exit() */
1502 while (PL_scopestack_ix > oldscope)
1505 PL_curstash = PL_defstash;
1506 if (!(PL_exit_flags & PERL_EXIT_DESTRUCT_END) &&
1507 PL_endav && !PL_minus_c)
1508 call_list(oldscope, PL_endav);
1510 if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
1511 dump_mstats("after execution: ");
1513 ret = STATUS_NATIVE_EXPORT;
1517 POPSTACK_TO(PL_mainstack);
1520 PerlIO_printf(Perl_error_log, "panic: restartop\n");
1530 #ifdef PERL_FLEXIBLE_EXCEPTIONS
1532 S_vrun_body(pTHX_ va_list args)
1534 I32 oldscope = va_arg(args, I32);
1536 return run_body(oldscope);
1542 S_run_body(pTHX_ I32 oldscope)
1544 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
1545 PL_sawampersand ? "Enabling" : "Omitting"));
1547 if (!PL_restartop) {
1548 DEBUG_x(dump_all());
1549 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
1550 DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%"UVxf"\n",
1554 #ifdef MACOS_TRADITIONAL
1555 PerlIO_printf(Perl_error_log, "%s%s syntax OK\n",
1556 (gMacPerl_ErrorFormat ? "# " : ""),
1557 MacPerl_MPWFileName(PL_origfilename));
1559 PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
1563 if (PERLDB_SINGLE && PL_DBsingle)
1564 sv_setiv(PL_DBsingle, 1);
1566 call_list(oldscope, PL_initav);
1572 PL_op = PL_restartop;
1576 else if (PL_main_start) {
1577 CvDEPTH(PL_main_cv) = 1;
1578 PL_op = PL_main_start;
1588 =head1 SV Manipulation Functions
1590 =for apidoc p||get_sv
1592 Returns the SV of the specified Perl scalar. If C<create> is set and the
1593 Perl variable does not exist then it will be created. If C<create> is not
1594 set and the variable does not exist then NULL is returned.
1600 Perl_get_sv(pTHX_ const char *name, I32 create)
1603 #ifdef USE_5005THREADS
1604 if (name[1] == '\0' && !isALPHA(name[0])) {
1605 PADOFFSET tmp = find_threadsv(name);
1606 if (tmp != NOT_IN_PAD)
1607 return THREADSV(tmp);
1609 #endif /* USE_5005THREADS */
1610 gv = gv_fetchpv(name, create, SVt_PV);
1617 =head1 Array Manipulation Functions
1619 =for apidoc p||get_av
1621 Returns the AV of the specified Perl array. If C<create> is set and the
1622 Perl variable does not exist then it will be created. If C<create> is not
1623 set and the variable does not exist then NULL is returned.
1629 Perl_get_av(pTHX_ const char *name, I32 create)
1631 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1640 =head1 Hash Manipulation Functions
1642 =for apidoc p||get_hv
1644 Returns the HV of the specified Perl hash. If C<create> is set and the
1645 Perl variable does not exist then it will be created. If C<create> is not
1646 set and the variable does not exist then NULL is returned.
1652 Perl_get_hv(pTHX_ const char *name, I32 create)
1654 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1663 =head1 CV Manipulation Functions
1665 =for apidoc p||get_cv
1667 Returns the CV of the specified Perl subroutine. If C<create> is set and
1668 the Perl subroutine does not exist then it will be declared (which has the
1669 same effect as saying C<sub name;>). If C<create> is not set and the
1670 subroutine does not exist then NULL is returned.
1676 Perl_get_cv(pTHX_ const char *name, I32 create)
1678 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
1679 /* XXX unsafe for threads if eval_owner isn't held */
1680 /* XXX this is probably not what they think they're getting.
1681 * It has the same effect as "sub name;", i.e. just a forward
1683 if (create && !GvCVu(gv))
1684 return newSUB(start_subparse(FALSE, 0),
1685 newSVOP(OP_CONST, 0, newSVpv(name,0)),
1693 /* Be sure to refetch the stack pointer after calling these routines. */
1697 =head1 Callback Functions
1699 =for apidoc p||call_argv
1701 Performs a callback to the specified Perl sub. See L<perlcall>.
1707 Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv)
1709 /* See G_* flags in cop.h */
1710 /* null terminated arg list */
1717 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
1722 return call_pv(sub_name, flags);
1726 =for apidoc p||call_pv
1728 Performs a callback to the specified Perl sub. See L<perlcall>.
1734 Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
1735 /* name of the subroutine */
1736 /* See G_* flags in cop.h */
1738 return call_sv((SV*)get_cv(sub_name, TRUE), flags);
1742 =for apidoc p||call_method
1744 Performs a callback to the specified Perl method. The blessed object must
1745 be on the stack. See L<perlcall>.
1751 Perl_call_method(pTHX_ const char *methname, I32 flags)
1752 /* name of the subroutine */
1753 /* See G_* flags in cop.h */
1755 return call_sv(sv_2mortal(newSVpv(methname,0)), flags | G_METHOD);
1758 /* May be called with any of a CV, a GV, or an SV containing the name. */
1760 =for apidoc p||call_sv
1762 Performs a callback to the Perl sub whose name is in the SV. See
1769 Perl_call_sv(pTHX_ SV *sv, I32 flags)
1770 /* See G_* flags in cop.h */
1773 LOGOP myop; /* fake syntax tree node */
1776 volatile I32 retval = 0;
1778 bool oldcatch = CATCH_GET;
1783 if (flags & G_DISCARD) {
1788 Zero(&myop, 1, LOGOP);
1789 myop.op_next = Nullop;
1790 if (!(flags & G_NOARGS))
1791 myop.op_flags |= OPf_STACKED;
1792 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1793 (flags & G_ARRAY) ? OPf_WANT_LIST :
1798 EXTEND(PL_stack_sp, 1);
1799 *++PL_stack_sp = sv;
1801 oldscope = PL_scopestack_ix;
1803 if (PERLDB_SUB && PL_curstash != PL_debstash
1804 /* Handle first BEGIN of -d. */
1805 && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
1806 /* Try harder, since this may have been a sighandler, thus
1807 * curstash may be meaningless. */
1808 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != PL_debstash)
1809 && !(flags & G_NODEBUG))
1810 PL_op->op_private |= OPpENTERSUB_DB;
1812 if (flags & G_METHOD) {
1813 Zero(&method_op, 1, UNOP);
1814 method_op.op_next = PL_op;
1815 method_op.op_ppaddr = PL_ppaddr[OP_METHOD];
1816 myop.op_ppaddr = PL_ppaddr[OP_ENTERSUB];
1817 PL_op = (OP*)&method_op;
1820 if (!(flags & G_EVAL)) {
1822 call_body((OP*)&myop, FALSE);
1823 retval = PL_stack_sp - (PL_stack_base + oldmark);
1824 CATCH_SET(oldcatch);
1827 myop.op_other = (OP*)&myop;
1829 /* we're trying to emulate pp_entertry() here */
1831 register PERL_CONTEXT *cx;
1832 I32 gimme = GIMME_V;
1837 push_return(Nullop);
1838 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
1840 PL_eval_root = PL_op; /* Only needed so that goto works right. */
1842 PL_in_eval = EVAL_INEVAL;
1843 if (flags & G_KEEPERR)
1844 PL_in_eval |= EVAL_KEEPERR;
1850 #ifdef PERL_FLEXIBLE_EXCEPTIONS
1852 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_body),
1859 #ifndef PERL_FLEXIBLE_EXCEPTIONS
1861 call_body((OP*)&myop, FALSE);
1863 retval = PL_stack_sp - (PL_stack_base + oldmark);
1864 if (!(flags & G_KEEPERR))
1871 /* my_exit() was called */
1872 PL_curstash = PL_defstash;
1875 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
1876 Perl_croak(aTHX_ "Callback called exit");
1881 PL_op = PL_restartop;
1885 PL_stack_sp = PL_stack_base + oldmark;
1886 if (flags & G_ARRAY)
1890 *++PL_stack_sp = &PL_sv_undef;
1895 if (PL_scopestack_ix > oldscope) {
1899 register PERL_CONTEXT *cx;
1911 if (flags & G_DISCARD) {
1912 PL_stack_sp = PL_stack_base + oldmark;
1921 #ifdef PERL_FLEXIBLE_EXCEPTIONS
1923 S_vcall_body(pTHX_ va_list args)
1925 OP *myop = va_arg(args, OP*);
1926 int is_eval = va_arg(args, int);
1928 call_body(myop, is_eval);
1934 S_call_body(pTHX_ OP *myop, int is_eval)
1936 if (PL_op == myop) {
1938 PL_op = Perl_pp_entereval(aTHX); /* this doesn't do a POPMARK */
1940 PL_op = Perl_pp_entersub(aTHX); /* this does */
1946 /* Eval a string. The G_EVAL flag is always assumed. */
1949 =for apidoc p||eval_sv
1951 Tells Perl to C<eval> the string in the SV.
1957 Perl_eval_sv(pTHX_ SV *sv, I32 flags)
1959 /* See G_* flags in cop.h */
1962 UNOP myop; /* fake syntax tree node */
1963 volatile I32 oldmark = SP - PL_stack_base;
1964 volatile I32 retval = 0;
1970 if (flags & G_DISCARD) {
1977 Zero(PL_op, 1, UNOP);
1978 EXTEND(PL_stack_sp, 1);
1979 *++PL_stack_sp = sv;
1980 oldscope = PL_scopestack_ix;
1982 if (!(flags & G_NOARGS))
1983 myop.op_flags = OPf_STACKED;
1984 myop.op_next = Nullop;
1985 myop.op_type = OP_ENTEREVAL;
1986 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1987 (flags & G_ARRAY) ? OPf_WANT_LIST :
1989 if (flags & G_KEEPERR)
1990 myop.op_flags |= OPf_SPECIAL;
1992 #ifdef PERL_FLEXIBLE_EXCEPTIONS
1994 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_body),
2001 #ifndef PERL_FLEXIBLE_EXCEPTIONS
2003 call_body((OP*)&myop,TRUE);
2005 retval = PL_stack_sp - (PL_stack_base + oldmark);
2006 if (!(flags & G_KEEPERR))
2013 /* my_exit() was called */
2014 PL_curstash = PL_defstash;
2017 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
2018 Perl_croak(aTHX_ "Callback called exit");
2023 PL_op = PL_restartop;
2027 PL_stack_sp = PL_stack_base + oldmark;
2028 if (flags & G_ARRAY)
2032 *++PL_stack_sp = &PL_sv_undef;
2038 if (flags & G_DISCARD) {
2039 PL_stack_sp = PL_stack_base + oldmark;
2049 =for apidoc p||eval_pv
2051 Tells Perl to C<eval> the given string and return an SV* result.
2057 Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
2060 SV* sv = newSVpv(p, 0);
2062 eval_sv(sv, G_SCALAR);
2069 if (croak_on_error && SvTRUE(ERRSV)) {
2071 Perl_croak(aTHX_ SvPVx(ERRSV, n_a));
2077 /* Require a module. */
2080 =head1 Embedding Functions
2082 =for apidoc p||require_pv
2084 Tells Perl to C<require> the file named by the string argument. It is
2085 analogous to the Perl code C<eval "require '$file'">. It's even
2086 implemented that way; consider using Perl_load_module instead.
2091 Perl_require_pv(pTHX_ const char *pv)
2095 PUSHSTACKi(PERLSI_REQUIRE);
2097 sv = sv_newmortal();
2098 sv_setpv(sv, "require '");
2101 eval_sv(sv, G_DISCARD);
2107 Perl_magicname(pTHX_ char *sym, char *name, I32 namlen)
2111 if ((gv = gv_fetchpv(sym,TRUE, SVt_PV)))
2112 sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, namlen);
2116 S_usage(pTHX_ char *name) /* XXX move this out into a module ? */
2118 /* This message really ought to be max 23 lines.
2119 * Removed -h because the user already knows that option. Others? */
2121 static char *usage_msg[] = {
2122 "-0[octal] specify record separator (\\0, if no argument)",
2123 "-a autosplit mode with -n or -p (splits $_ into @F)",
2124 "-C enable native wide character system interfaces",
2125 "-c check syntax only (runs BEGIN and CHECK blocks)",
2126 "-d[:debugger] run program under debugger",
2127 "-D[number/list] set debugging flags (argument is a bit mask or alphabets)",
2128 "-e 'command' one line of program (several -e's allowed, omit programfile)",
2129 "-F/pattern/ split() pattern for -a switch (//'s are optional)",
2130 "-i[extension] edit <> files in place (makes backup if extension supplied)",
2131 "-Idirectory specify @INC/#include directory (several -I's allowed)",
2132 "-l[octal] enable line ending processing, specifies line terminator",
2133 "-[mM][-]module execute `use/no module...' before executing program",
2134 "-n assume 'while (<>) { ... }' loop around program",
2135 "-p assume loop like -n but print line also, like sed",
2136 "-P run program through C preprocessor before compilation",
2137 "-s enable rudimentary parsing for switches after programfile",
2138 "-S look for programfile using PATH environment variable",
2139 "-T enable tainting checks",
2140 "-t enable tainting warnings",
2141 "-u dump core after parsing program",
2142 "-U allow unsafe operations",
2143 "-v print version, subversion (includes VERY IMPORTANT perl info)",
2144 "-V[:variable] print configuration summary (or a single Config.pm variable)",
2145 "-w enable many useful warnings (RECOMMENDED)",
2146 "-W enable all warnings",
2147 "-X disable all warnings",
2148 "-x[directory] strip off text before #!perl line and perhaps cd to directory",
2152 char **p = usage_msg;
2154 PerlIO_printf(PerlIO_stdout(),
2155 "\nUsage: %s [switches] [--] [programfile] [arguments]",
2158 PerlIO_printf(PerlIO_stdout(), "\n %s", *p++);
2161 /* This routine handles any switches that can be given during run */
2164 Perl_moreswitches(pTHX_ char *s)
2174 rschar = (U32)grok_oct(s, &numlen, &flags, NULL);
2175 SvREFCNT_dec(PL_rs);
2176 if (rschar & ~((U8)~0))
2177 PL_rs = &PL_sv_undef;
2178 else if (!rschar && numlen >= 2)
2179 PL_rs = newSVpvn("", 0);
2181 char ch = (char)rschar;
2182 PL_rs = newSVpvn(&ch, 1);
2188 PL_unicode = parse_unicode_opts(&s);
2193 while (*s && !isSPACE(*s)) ++s;
2195 PL_splitstr = savepv(PL_splitstr);
2208 /* The following permits -d:Mod to accepts arguments following an =
2209 in the fashion that -MSome::Mod does. */
2210 if (*s == ':' || *s == '=') {
2213 sv = newSVpv("use Devel::", 0);
2215 /* We now allow -d:Module=Foo,Bar */
2216 while(isALNUM(*s) || *s==':') ++s;
2218 sv_catpv(sv, start);
2220 sv_catpvn(sv, start, s-start);
2221 sv_catpv(sv, " split(/,/,q{");
2226 my_setenv("PERL5DB", SvPV(sv, PL_na));
2229 PL_perldb = PERLDB_ALL;
2237 if (isALPHA(s[1])) {
2238 /* if adding extra options, remember to update DEBUG_MASK */
2239 static char debopts[] = "psltocPmfrxu HXDSTRJvC";
2242 for (s++; *s && (d = strchr(debopts,*s)); s++)
2243 PL_debug |= 1 << (d - debopts);
2246 PL_debug = atoi(s+1);
2247 for (s++; isDIGIT(*s); s++) ;
2250 if (DEBUG_p_TEST_ && ckWARN_d(WARN_DEBUGGING))
2251 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
2252 "-Dp not implemented on this platform\n");
2254 PL_debug |= DEBUG_TOP_FLAG;
2255 #else /* !DEBUGGING */
2256 if (ckWARN_d(WARN_DEBUGGING))
2257 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
2258 "Recompile perl with -DDEBUGGING to use -D switch\n");
2259 for (s++; isALNUM(*s); s++) ;
2265 usage(PL_origargv[0]);
2269 Safefree(PL_inplace);
2270 #if defined(__CYGWIN__) /* do backup extension automagically */
2271 if (*(s+1) == '\0') {
2272 PL_inplace = savepv(".bak");
2275 #endif /* __CYGWIN__ */
2276 PL_inplace = savepv(s+1);
2278 for (s = PL_inplace; *s && !isSPACE(*s); s++) ;
2281 if (*s == '-') /* Additional switches on #! line. */
2285 case 'I': /* -I handled both here and in parse_body() */
2288 while (*s && isSPACE(*s))
2293 /* ignore trailing spaces (possibly followed by other switches) */
2295 for (e = p; *e && !isSPACE(*e); e++) ;
2299 } while (*p && *p != '-');
2300 e = savepvn(s, e-s);
2301 incpush(e, TRUE, TRUE, FALSE);
2308 Perl_croak(aTHX_ "No directory specified for -I");
2314 SvREFCNT_dec(PL_ors_sv);
2319 PL_ors_sv = newSVpvn("\n",1);
2320 numlen = 3 + (*s == '0');
2321 *SvPVX(PL_ors_sv) = (char)grok_oct(s, &numlen, &flags, NULL);
2325 if (RsPARA(PL_rs)) {
2326 PL_ors_sv = newSVpvn("\n\n",2);
2329 PL_ors_sv = newSVsv(PL_rs);
2336 PL_preambleav = newAV();
2338 SV *sv = newSVpvn("use assertions::activate split(/,/,q{",37);
2342 av_push(PL_preambleav, sv);
2345 av_push(PL_preambleav, newSVpvn("use assertions::activate",24));
2348 forbid_setid("-M"); /* XXX ? */
2351 forbid_setid("-m"); /* XXX ? */
2356 /* -M-foo == 'no foo' */
2357 if (*s == '-') { use = "no "; ++s; }
2358 sv = newSVpv(use,0);
2360 /* We allow -M'Module qw(Foo Bar)' */
2361 while(isALNUM(*s) || *s==':') ++s;
2363 sv_catpv(sv, start);
2364 if (*(start-1) == 'm') {
2366 Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
2367 sv_catpv( sv, " ()");
2371 Perl_croak(aTHX_ "Module name required with -%c option",
2373 sv_catpvn(sv, start, s-start);
2374 sv_catpv(sv, " split(/,/,q{");
2380 PL_preambleav = newAV();
2381 av_push(PL_preambleav, sv);
2384 Perl_croak(aTHX_ "No space allowed after -%c", *(s-1));
2396 PL_doswitches = TRUE;
2401 Perl_croak(aTHX_ "Too late for \"-t\" option");
2406 Perl_croak(aTHX_ "Too late for \"-T\" option");
2410 #ifdef MACOS_TRADITIONAL
2411 Perl_croak(aTHX_ "Believe me, you don't want to use \"-u\" on a Macintosh");
2413 PL_do_undump = TRUE;
2422 PerlIO_printf(PerlIO_stdout(),
2423 Perl_form(aTHX_ "\nThis is perl, v%"VDf" built for %s",
2424 PL_patchlevel, ARCHNAME));
2426 /* Adjust verbose output as in the perl that ships with the DG/UX OS from EMC */
2427 PerlIO_printf(PerlIO_stdout(),
2428 Perl_form(aTHX_ "\nThis is perl, version %vd\n", PL_patchlevel));
2429 PerlIO_printf(PerlIO_stdout(),
2430 Perl_form(aTHX_ " built under %s at %s %s\n",
2431 OSNAME, __DATE__, __TIME__));
2432 PerlIO_printf(PerlIO_stdout(),
2433 Perl_form(aTHX_ " OS Specific Release: %s\n",
2437 #if defined(LOCAL_PATCH_COUNT)
2438 if (LOCAL_PATCH_COUNT > 0)
2439 PerlIO_printf(PerlIO_stdout(),
2440 "\n(with %d registered patch%s, "
2441 "see perl -V for more detail)",
2442 (int)LOCAL_PATCH_COUNT,
2443 (LOCAL_PATCH_COUNT!=1) ? "es" : "");
2446 PerlIO_printf(PerlIO_stdout(),
2447 "\n\nCopyright 1987-2003, Larry Wall\n");
2448 #ifdef MACOS_TRADITIONAL
2449 PerlIO_printf(PerlIO_stdout(),
2450 "\nMac OS port Copyright 1991-2002, Matthias Neeracher;\n"
2451 "maintained by Chris Nandor\n");
2454 PerlIO_printf(PerlIO_stdout(),
2455 "\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
2458 PerlIO_printf(PerlIO_stdout(),
2459 "djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n"
2460 "djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
2463 PerlIO_printf(PerlIO_stdout(),
2464 "\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
2465 "Version 5 port Copyright (c) 1994-2002, Andreas Kaiser, Ilya Zakharevich\n");
2468 PerlIO_printf(PerlIO_stdout(),
2469 "atariST series port, ++jrb bammi@cadence.com\n");
2472 PerlIO_printf(PerlIO_stdout(),
2473 "BeOS port Copyright Tom Spindler, 1997-1999\n");
2476 PerlIO_printf(PerlIO_stdout(),
2477 "MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-2002\n");
2480 PerlIO_printf(PerlIO_stdout(),
2481 "MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
2484 PerlIO_printf(PerlIO_stdout(),
2485 "Stratus VOS port by Paul.Green@stratus.com, 1997-2002\n");
2488 PerlIO_printf(PerlIO_stdout(),
2489 "VM/ESA port by Neale Ferguson, 1998-1999\n");
2492 PerlIO_printf(PerlIO_stdout(),
2493 "BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
2496 PerlIO_printf(PerlIO_stdout(),
2497 "MiNT port by Guido Flohr, 1997-1999\n");
2500 PerlIO_printf(PerlIO_stdout(),
2501 "EPOC port by Olaf Flebbe, 1999-2002\n");
2504 printf("WINCE port by Rainer Keuchel, 2001-2002\n");
2505 printf("Built on " __DATE__ " " __TIME__ "\n\n");
2508 #ifdef BINARY_BUILD_NOTICE
2509 BINARY_BUILD_NOTICE;
2511 PerlIO_printf(PerlIO_stdout(),
2513 Perl may be copied only under the terms of either the Artistic License or the\n\
2514 GNU General Public License, which may be found in the Perl 5 source kit.\n\n\
2515 Complete documentation for Perl, including FAQ lists, should be found on\n\
2516 this system using `man perl' or `perldoc perl'. If you have access to the\n\
2517 Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
2520 if (! (PL_dowarn & G_WARN_ALL_MASK))
2521 PL_dowarn |= G_WARN_ON;
2525 PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
2526 if (!specialWARN(PL_compiling.cop_warnings))
2527 SvREFCNT_dec(PL_compiling.cop_warnings);
2528 PL_compiling.cop_warnings = pWARN_ALL ;
2532 PL_dowarn = G_WARN_ALL_OFF;
2533 if (!specialWARN(PL_compiling.cop_warnings))
2534 SvREFCNT_dec(PL_compiling.cop_warnings);
2535 PL_compiling.cop_warnings = pWARN_NONE ;
2540 if (s[1] == '-') /* Additional switches on #! line. */
2545 #if defined(WIN32) || !defined(PERL_STRICT_CR)
2551 #ifdef ALTERNATE_SHEBANG
2552 case 'S': /* OS/2 needs -S on "extproc" line. */
2560 Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
2565 /* compliments of Tom Christiansen */
2567 /* unexec() can be found in the Gnu emacs distribution */
2568 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
2571 Perl_my_unexec(pTHX)
2579 prog = newSVpv(BIN_EXP, 0);
2580 sv_catpv(prog, "/perl");
2581 file = newSVpv(PL_origfilename, 0);
2582 sv_catpv(file, ".perldump");
2584 unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
2585 /* unexec prints msg to stderr in case of failure */
2586 PerlProc_exit(status);
2589 # include <lib$routines.h>
2590 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
2592 ABORT(); /* for use with undump */
2597 /* initialize curinterp */
2603 # define PERLVAR(var,type)
2604 # define PERLVARA(var,n,type)
2605 # if defined(PERL_IMPLICIT_CONTEXT)
2606 # if defined(USE_5005THREADS)
2607 # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
2608 # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
2609 # else /* !USE_5005THREADS */
2610 # define PERLVARI(var,type,init) aTHX->var = init;
2611 # define PERLVARIC(var,type,init) aTHX->var = init;
2612 # endif /* USE_5005THREADS */
2614 # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
2615 # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
2617 # include "intrpvar.h"
2618 # ifndef USE_5005THREADS
2619 # include "thrdvar.h"
2626 # define PERLVAR(var,type)
2627 # define PERLVARA(var,n,type)
2628 # define PERLVARI(var,type,init) PL_##var = init;
2629 # define PERLVARIC(var,type,init) PL_##var = init;
2630 # include "intrpvar.h"
2631 # ifndef USE_5005THREADS
2632 # include "thrdvar.h"
2643 S_init_main_stash(pTHX)
2647 PL_curstash = PL_defstash = newHV();
2648 PL_curstname = newSVpvn("main",4);
2649 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
2650 SvREFCNT_dec(GvHV(gv));
2651 GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
2653 HvNAME(PL_defstash) = savepv("main");
2654 PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
2655 GvMULTI_on(PL_incgv);
2656 PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
2657 GvMULTI_on(PL_hintgv);
2658 PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
2659 PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
2660 GvMULTI_on(PL_errgv);
2661 PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
2662 GvMULTI_on(PL_replgv);
2663 (void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */
2664 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
2665 sv_setpvn(ERRSV, "", 0);
2666 PL_curstash = PL_defstash;
2667 CopSTASH_set(&PL_compiling, PL_defstash);
2668 PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
2669 PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
2670 /* We must init $/ before switches are processed. */
2671 sv_setpvn(get_sv("/", TRUE), "\n", 1);
2675 S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
2679 char *cpp_discard_flag;
2685 PL_origfilename = savepv("-e");
2688 /* if find_script() returns, it returns a malloc()-ed value */
2689 PL_origfilename = scriptname = find_script(scriptname, dosearch, NULL, 1);
2691 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
2692 char *s = scriptname + 8;
2693 *fdscript = atoi(s);
2697 scriptname = savepv(s + 1);
2698 Safefree(PL_origfilename);
2699 PL_origfilename = scriptname;
2704 CopFILE_free(PL_curcop);
2705 CopFILE_set(PL_curcop, PL_origfilename);
2706 if (strEQ(PL_origfilename,"-"))
2708 if (*fdscript >= 0) {
2709 PL_rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE);
2710 # if defined(HAS_FCNTL) && defined(F_SETFD)
2712 /* ensure close-on-exec */
2713 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
2716 else if (PL_preprocess) {
2717 char *cpp_cfg = CPPSTDIN;
2718 SV *cpp = newSVpvn("",0);
2719 SV *cmd = NEWSV(0,0);
2721 if (strEQ(cpp_cfg, "cppstdin"))
2722 Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
2723 sv_catpv(cpp, cpp_cfg);
2726 sv_catpvn(sv, "-I", 2);
2727 sv_catpv(sv,PRIVLIB_EXP);
2730 DEBUG_P(PerlIO_printf(Perl_debug_log,
2731 "PL_preprocess: scriptname=\"%s\", cpp=\"%s\", sv=\"%s\", CPPMINUS=\"%s\"\n",
2732 scriptname, SvPVX (cpp), SvPVX (sv), CPPMINUS));
2734 # if defined(MSDOS) || defined(WIN32) || defined(VMS)
2741 cpp_discard_flag = "";
2743 cpp_discard_flag = "-C";
2747 perl = os2_execname(aTHX);
2749 perl = PL_origargv[0];
2753 /* This strips off Perl comments which might interfere with
2754 the C pre-processor, including #!. #line directives are
2755 deliberately stripped to avoid confusion with Perl's version
2756 of #line. FWP played some golf with it so it will fit
2757 into VMS's 255 character buffer.
2760 code = "(1../^#!.*perl/i)|/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print";
2762 code = "/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print";
2764 Perl_sv_setpvf(aTHX_ cmd, "\
2765 %s -ne%s%s%s %s | %"SVf" %s %"SVf" %s",
2766 perl, quote, code, quote, scriptname, cpp,
2767 cpp_discard_flag, sv, CPPMINUS);
2769 PL_doextract = FALSE;
2770 # ifdef IAMSUID /* actually, this is caught earlier */
2771 if (PL_euid != PL_uid && !PL_euid) { /* if running suidperl */
2773 (void)seteuid(PL_uid); /* musn't stay setuid root */
2775 # ifdef HAS_SETREUID
2776 (void)setreuid((Uid_t)-1, PL_uid);
2778 # ifdef HAS_SETRESUID
2779 (void)setresuid((Uid_t)-1, PL_uid, (Uid_t)-1);
2781 PerlProc_setuid(PL_uid);
2785 if (PerlProc_geteuid() != PL_uid)
2786 Perl_croak(aTHX_ "Can't do seteuid!\n");
2788 # endif /* IAMSUID */
2790 DEBUG_P(PerlIO_printf(Perl_debug_log,
2791 "PL_preprocess: cmd=\"%s\"\n",
2794 PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
2798 else if (!*scriptname) {
2799 forbid_setid("program input from stdin");
2800 PL_rsfp = PerlIO_stdin();
2803 PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
2804 # if defined(HAS_FCNTL) && defined(F_SETFD)
2806 /* ensure close-on-exec */
2807 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
2812 # ifndef IAMSUID /* in case script is not readable before setuid */
2814 PerlLIO_stat(CopFILE(PL_curcop),&PL_statbuf) >= 0 &&
2815 PL_statbuf.st_mode & (S_ISUID|S_ISGID))
2818 PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT,
2819 BIN_EXP, (int)PERL_REVISION,
2821 (int)PERL_SUBVERSION), PL_origargv);
2822 Perl_croak(aTHX_ "Can't do setuid\n");
2828 Perl_croak(aTHX_ "Can't open perl script: %s\n",
2831 Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
2832 CopFILE(PL_curcop), Strerror(errno));
2838 * I_SYSSTATVFS HAS_FSTATVFS
2840 * I_STATFS HAS_FSTATFS HAS_GETFSSTAT
2841 * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT
2842 * here so that metaconfig picks them up. */
2846 S_fd_on_nosuid_fs(pTHX_ int fd)
2848 int check_okay = 0; /* able to do all the required sys/libcalls */
2849 int on_nosuid = 0; /* the fd is on a nosuid fs */
2851 * Preferred order: fstatvfs(), fstatfs(), ustat()+getmnt(), getmntent().
2852 * fstatvfs() is UNIX98.
2853 * fstatfs() is 4.3 BSD.
2854 * ustat()+getmnt() is pre-4.3 BSD.
2855 * getmntent() is O(number-of-mounted-filesystems) and can hang on
2856 * an irrelevant filesystem while trying to reach the right one.
2859 #undef FD_ON_NOSUID_CHECK_OKAY /* found the syscalls to do the check? */
2861 # if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
2862 defined(HAS_FSTATVFS)
2863 # define FD_ON_NOSUID_CHECK_OKAY
2864 struct statvfs stfs;
2866 check_okay = fstatvfs(fd, &stfs) == 0;
2867 on_nosuid = check_okay && (stfs.f_flag & ST_NOSUID);
2868 # endif /* fstatvfs */
2870 # if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
2871 defined(PERL_MOUNT_NOSUID) && \
2872 defined(HAS_FSTATFS) && \
2873 defined(HAS_STRUCT_STATFS) && \
2874 defined(HAS_STRUCT_STATFS_F_FLAGS)
2875 # define FD_ON_NOSUID_CHECK_OKAY
2878 check_okay = fstatfs(fd, &stfs) == 0;
2879 on_nosuid = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
2880 # endif /* fstatfs */
2882 # if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
2883 defined(PERL_MOUNT_NOSUID) && \
2884 defined(HAS_FSTAT) && \
2885 defined(HAS_USTAT) && \
2886 defined(HAS_GETMNT) && \
2887 defined(HAS_STRUCT_FS_DATA) && \
2889 # define FD_ON_NOSUID_CHECK_OKAY
2892 if (fstat(fd, &fdst) == 0) {
2894 if (ustat(fdst.st_dev, &us) == 0) {
2896 /* NOSTAT_ONE here because we're not examining fields which
2897 * vary between that case and STAT_ONE. */
2898 if (getmnt((int*)0, &fsd, (int)0, NOSTAT_ONE, us.f_fname) == 0) {
2899 size_t cmplen = sizeof(us.f_fname);
2900 if (sizeof(fsd.fd_req.path) < cmplen)
2901 cmplen = sizeof(fsd.fd_req.path);
2902 if (strnEQ(fsd.fd_req.path, us.f_fname, cmplen) &&
2903 fdst.st_dev == fsd.fd_req.dev) {
2905 on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID;
2911 # endif /* fstat+ustat+getmnt */
2913 # if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
2914 defined(HAS_GETMNTENT) && \
2915 defined(HAS_HASMNTOPT) && \
2916 defined(MNTOPT_NOSUID)
2917 # define FD_ON_NOSUID_CHECK_OKAY
2918 FILE *mtab = fopen("/etc/mtab", "r");
2919 struct mntent *entry;
2922 if (mtab && (fstat(fd, &stb) == 0)) {
2923 while (entry = getmntent(mtab)) {
2924 if (stat(entry->mnt_dir, &fsb) == 0
2925 && fsb.st_dev == stb.st_dev)
2927 /* found the filesystem */
2929 if (hasmntopt(entry, MNTOPT_NOSUID))
2932 } /* A single fs may well fail its stat(). */
2937 # endif /* getmntent+hasmntopt */
2940 Perl_croak(aTHX_ "Can't check filesystem of script \"%s\" for nosuid", PL_origfilename);
2943 #endif /* IAMSUID */
2946 S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript)
2952 /* do we need to emulate setuid on scripts? */
2954 /* This code is for those BSD systems that have setuid #! scripts disabled
2955 * in the kernel because of a security problem. Merely defining DOSUID
2956 * in perl will not fix that problem, but if you have disabled setuid
2957 * scripts in the kernel, this will attempt to emulate setuid and setgid
2958 * on scripts that have those now-otherwise-useless bits set. The setuid
2959 * root version must be called suidperl or sperlN.NNN. If regular perl
2960 * discovers that it has opened a setuid script, it calls suidperl with
2961 * the same argv that it had. If suidperl finds that the script it has
2962 * just opened is NOT setuid root, it sets the effective uid back to the
2963 * uid. We don't just make perl setuid root because that loses the
2964 * effective uid we had before invoking perl, if it was different from the
2967 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
2968 * be defined in suidperl only. suidperl must be setuid root. The
2969 * Configure script will set this up for you if you want it.
2975 if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */
2976 Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
2977 if (fdscript < 0 && PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
2982 #ifndef HAS_SETREUID
2983 /* On this access check to make sure the directories are readable,
2984 * there is actually a small window that the user could use to make
2985 * filename point to an accessible directory. So there is a faint
2986 * chance that someone could execute a setuid script down in a
2987 * non-accessible directory. I don't know what to do about that.
2988 * But I don't think it's too important. The manual lies when
2989 * it says access() is useful in setuid programs.
2991 if (PerlLIO_access(CopFILE(PL_curcop),1)) /*double check*/
2992 Perl_croak(aTHX_ "Permission denied");
2994 /* If we can swap euid and uid, then we can determine access rights
2995 * with a simple stat of the file, and then compare device and
2996 * inode to make sure we did stat() on the same file we opened.
2997 * Then we just have to make sure he or she can execute it.
3004 setreuid(PL_euid,PL_uid) < 0
3007 setresuid(PL_euid,PL_uid,(Uid_t)-1) < 0
3010 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
3011 Perl_croak(aTHX_ "Can't swap uid and euid"); /* really paranoid */
3012 if (PerlLIO_stat(CopFILE(PL_curcop),&tmpstatbuf) < 0)
3013 Perl_croak(aTHX_ "Permission denied"); /* testing full pathname here */
3014 #if defined(IAMSUID) && !defined(NO_NOSUID_CHECK)
3015 if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp)))
3016 Perl_croak(aTHX_ "Permission denied");
3018 if (tmpstatbuf.st_dev != PL_statbuf.st_dev ||
3019 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
3020 (void)PerlIO_close(PL_rsfp);
3021 Perl_croak(aTHX_ "Permission denied\n");
3025 setreuid(PL_uid,PL_euid) < 0
3027 # if defined(HAS_SETRESUID)
3028 setresuid(PL_uid,PL_euid,(Uid_t)-1) < 0
3031 || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
3032 Perl_croak(aTHX_ "Can't reswap uid and euid");
3033 if (!cando(S_IXUSR,FALSE,&PL_statbuf)) /* can real uid exec? */
3034 Perl_croak(aTHX_ "Permission denied\n");
3036 #endif /* HAS_SETREUID */
3037 #endif /* IAMSUID */
3039 if (!S_ISREG(PL_statbuf.st_mode))
3040 Perl_croak(aTHX_ "Permission denied");
3041 if (PL_statbuf.st_mode & S_IWOTH)
3042 Perl_croak(aTHX_ "Setuid/gid script is writable by world");
3043 PL_doswitches = FALSE; /* -s is insecure in suid */
3044 CopLINE_inc(PL_curcop);
3045 if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
3046 strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */
3047 Perl_croak(aTHX_ "No #! line");
3048 s = SvPV(PL_linestr,n_a)+2;
3050 while (!isSPACE(*s)) s++;
3051 for (s2 = s; (s2 > SvPV(PL_linestr,n_a)+2 &&
3052 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
3053 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
3054 Perl_croak(aTHX_ "Not a perl script");
3055 while (*s == ' ' || *s == '\t') s++;
3057 * #! arg must be what we saw above. They can invoke it by
3058 * mentioning suidperl explicitly, but they may not add any strange
3059 * arguments beyond what #! says if they do invoke suidperl that way.
3061 len = strlen(validarg);
3062 if (strEQ(validarg," PHOOEY ") ||
3063 strnNE(s,validarg,len) || !isSPACE(s[len]))
3064 Perl_croak(aTHX_ "Args must match #! line");
3067 if (PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
3068 PL_euid == PL_statbuf.st_uid)
3070 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
3071 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
3072 #endif /* IAMSUID */
3074 if (PL_euid) { /* oops, we're not the setuid root perl */
3075 (void)PerlIO_close(PL_rsfp);
3078 PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
3079 (int)PERL_REVISION, (int)PERL_VERSION,
3080 (int)PERL_SUBVERSION), PL_origargv);
3082 Perl_croak(aTHX_ "Can't do setuid\n");
3085 if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
3087 (void)setegid(PL_statbuf.st_gid);
3090 (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
3092 #ifdef HAS_SETRESGID
3093 (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
3095 PerlProc_setgid(PL_statbuf.st_gid);
3099 if (PerlProc_getegid() != PL_statbuf.st_gid)
3100 Perl_croak(aTHX_ "Can't do setegid!\n");
3102 if (PL_statbuf.st_mode & S_ISUID) {
3103 if (PL_statbuf.st_uid != PL_euid)
3105 (void)seteuid(PL_statbuf.st_uid); /* all that for this */
3108 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
3110 #ifdef HAS_SETRESUID
3111 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
3113 PerlProc_setuid(PL_statbuf.st_uid);
3117 if (PerlProc_geteuid() != PL_statbuf.st_uid)
3118 Perl_croak(aTHX_ "Can't do seteuid!\n");
3120 else if (PL_uid) { /* oops, mustn't run as root */
3122 (void)seteuid((Uid_t)PL_uid);
3125 (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
3127 #ifdef HAS_SETRESUID
3128 (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
3130 PerlProc_setuid((Uid_t)PL_uid);
3134 if (PerlProc_geteuid() != PL_uid)
3135 Perl_croak(aTHX_ "Can't do seteuid!\n");
3138 if (!cando(S_IXUSR,TRUE,&PL_statbuf))
3139 Perl_croak(aTHX_ "Permission denied\n"); /* they can't do this */
3142 else if (PL_preprocess)
3143 Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
3144 else if (fdscript >= 0)
3145 Perl_croak(aTHX_ "fd script not allowed in suidperl\n");
3147 Perl_croak(aTHX_ "Script is not setuid/setgid in suidperl\n");
3149 /* We absolutely must clear out any saved ids here, so we */
3150 /* exec the real perl, substituting fd script for scriptname. */
3151 /* (We pass script name as "subdir" of fd, which perl will grok.) */
3152 PerlIO_rewind(PL_rsfp);
3153 PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0); /* just in case rewind didn't */
3154 for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
3155 if (!PL_origargv[which])
3156 Perl_croak(aTHX_ "Permission denied");
3157 PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
3158 PerlIO_fileno(PL_rsfp), PL_origargv[which]));
3159 #if defined(HAS_FCNTL) && defined(F_SETFD)
3160 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */
3162 PerlProc_execv(Perl_form(aTHX_ "%s/perl"PERL_FS_VER_FMT, BIN_EXP,
3163 (int)PERL_REVISION, (int)PERL_VERSION,
3164 (int)PERL_SUBVERSION), PL_origargv);/* try again */
3165 Perl_croak(aTHX_ "Can't do setuid\n");
3166 #endif /* IAMSUID */
3168 if (PL_euid != PL_uid || PL_egid != PL_gid) { /* (suidperl doesn't exist, in fact) */
3169 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
3170 PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf); /* may be either wrapped or real suid */
3171 if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
3173 (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
3176 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
3177 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
3178 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
3179 /* not set-id, must be wrapped */
3185 S_find_beginning(pTHX)
3187 register char *s, *s2;
3188 #ifdef MACOS_TRADITIONAL
3192 /* skip forward in input to the real script? */
3195 #ifdef MACOS_TRADITIONAL
3196 /* Since the Mac OS does not honor #! arguments for us, we do it ourselves */
3198 while (PL_doextract || gMacPerl_AlwaysExtract) {
3199 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
3200 if (!gMacPerl_AlwaysExtract)
3201 Perl_croak(aTHX_ "No Perl script found in input\n");
3203 if (PL_doextract) /* require explicit override ? */
3204 if (!OverrideExtract(PL_origfilename))
3205 Perl_croak(aTHX_ "User aborted script\n");
3207 PL_doextract = FALSE;
3209 /* Pater peccavi, file does not have #! */
3210 PerlIO_rewind(PL_rsfp);
3215 while (PL_doextract) {
3216 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
3217 Perl_croak(aTHX_ "No Perl script found in input\n");
3220 if (*s == '#' && s[1] == '!' && ((s = instr(s,"perl")) || (s = instr(s2,"PERL")))) {
3221 PerlIO_ungetc(PL_rsfp, '\n'); /* to keep line count right */
3222 PL_doextract = FALSE;
3223 while (*s && !(isSPACE (*s) || *s == '#')) s++;
3225 while (*s == ' ' || *s == '\t') s++;
3227 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
3228 if (strnEQ(s2-4,"perl",4))
3230 while ((s = moreswitches(s)))
3233 #ifdef MACOS_TRADITIONAL
3234 /* We are always searching for the #!perl line in MacPerl,
3235 * so if we find it, still keep the line count correct
3236 * by counting lines we already skipped over
3238 for (; maclines > 0 ; maclines--)
3239 PerlIO_ungetc(PL_rsfp, '\n');
3243 /* gMacPerl_AlwaysExtract is false in MPW tool */
3244 } else if (gMacPerl_AlwaysExtract) {
3255 PL_uid = PerlProc_getuid();
3256 PL_euid = PerlProc_geteuid();
3257 PL_gid = PerlProc_getgid();
3258 PL_egid = PerlProc_getegid();
3260 PL_uid |= PL_gid << 16;
3261 PL_euid |= PL_egid << 16;
3263 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
3267 S_forbid_setid(pTHX_ char *s)
3269 if (PL_euid != PL_uid)
3270 Perl_croak(aTHX_ "No %s allowed while running setuid", s);
3271 if (PL_egid != PL_gid)
3272 Perl_croak(aTHX_ "No %s allowed while running setgid", s);
3276 Perl_init_debugger(pTHX)
3278 HV *ostash = PL_curstash;
3280 PL_curstash = PL_debstash;
3281 PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
3282 AvREAL_off(PL_dbargs);
3283 PL_DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
3284 PL_DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
3285 PL_DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
3286 sv_upgrade(GvSV(PL_DBsub), SVt_IV); /* IVX accessed if PERLDB_SUB_NN */
3287 PL_DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
3288 sv_setiv(PL_DBsingle, 0);
3289 PL_DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
3290 sv_setiv(PL_DBtrace, 0);
3291 PL_DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
3292 sv_setiv(PL_DBsignal, 0);
3293 PL_DBassertion = GvSV((gv_fetchpv("assertion", GV_ADDMULTI, SVt_PV)));
3294 sv_setiv(PL_DBassertion, 0);
3295 PL_curstash = ostash;
3298 #ifndef STRESS_REALLOC
3299 #define REASONABLE(size) (size)
3301 #define REASONABLE(size) (1) /* unreasonable */
3305 Perl_init_stacks(pTHX)
3307 /* start with 128-item stack and 8K cxstack */
3308 PL_curstackinfo = new_stackinfo(REASONABLE(128),
3309 REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
3310 PL_curstackinfo->si_type = PERLSI_MAIN;
3311 PL_curstack = PL_curstackinfo->si_stack;
3312 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
3314 PL_stack_base = AvARRAY(PL_curstack);
3315 PL_stack_sp = PL_stack_base;
3316 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
3318 New(50,PL_tmps_stack,REASONABLE(128),SV*);
3321 PL_tmps_max = REASONABLE(128);
3323 New(54,PL_markstack,REASONABLE(32),I32);
3324 PL_markstack_ptr = PL_markstack;
3325 PL_markstack_max = PL_markstack + REASONABLE(32);
3329 New(54,PL_scopestack,REASONABLE(32),I32);
3330 PL_scopestack_ix = 0;
3331 PL_scopestack_max = REASONABLE(32);
3333 New(54,PL_savestack,REASONABLE(128),ANY);
3334 PL_savestack_ix = 0;
3335 PL_savestack_max = REASONABLE(128);
3337 New(54,PL_retstack,REASONABLE(16),OP*);
3339 PL_retstack_max = REASONABLE(16);
3347 while (PL_curstackinfo->si_next)
3348 PL_curstackinfo = PL_curstackinfo->si_next;
3349 while (PL_curstackinfo) {
3350 PERL_SI *p = PL_curstackinfo->si_prev;
3351 /* curstackinfo->si_stack got nuked by sv_free_arenas() */
3352 Safefree(PL_curstackinfo->si_cxstack);
3353 Safefree(PL_curstackinfo);
3354 PL_curstackinfo = p;
3356 Safefree(PL_tmps_stack);
3357 Safefree(PL_markstack);
3358 Safefree(PL_scopestack);
3359 Safefree(PL_savestack);
3360 Safefree(PL_retstack);
3369 lex_start(PL_linestr);
3371 PL_subname = newSVpvn("main",4);
3375 S_init_predump_symbols(pTHX)
3380 sv_setpvn(get_sv("\"", TRUE), " ", 1);
3381 PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
3382 GvMULTI_on(PL_stdingv);
3383 io = GvIOp(PL_stdingv);
3384 IoTYPE(io) = IoTYPE_RDONLY;
3385 IoIFP(io) = PerlIO_stdin();
3386 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
3388 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
3390 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
3393 IoTYPE(io) = IoTYPE_WRONLY;
3394 IoOFP(io) = IoIFP(io) = PerlIO_stdout();
3396 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
3398 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
3400 PL_stderrgv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
3401 GvMULTI_on(PL_stderrgv);
3402 io = GvIOp(PL_stderrgv);
3403 IoTYPE(io) = IoTYPE_WRONLY;
3404 IoOFP(io) = IoIFP(io) = PerlIO_stderr();
3405 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
3407 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
3409 PL_statname = NEWSV(66,0); /* last filename we did stat on */
3412 Safefree(PL_osname);
3413 PL_osname = savepv(OSNAME);
3417 Perl_init_argv_symbols(pTHX_ register int argc, register char **argv)
3420 argc--,argv++; /* skip name of script */
3421 if (PL_doswitches) {
3422 for (; argc > 0 && **argv == '-'; argc--,argv++) {
3425 if (argv[0][1] == '-' && !argv[0][2]) {
3429 if ((s = strchr(argv[0], '='))) {
3431 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
3434 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
3437 if ((PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV))) {
3438 GvMULTI_on(PL_argvgv);
3439 (void)gv_AVadd(PL_argvgv);
3440 av_clear(GvAVn(PL_argvgv));
3441 for (; argc > 0; argc--,argv++) {
3442 SV *sv = newSVpv(argv[0],0);
3443 av_push(GvAVn(PL_argvgv),sv);
3444 if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
3445 if (PL_unicode & PERL_UNICODE_ARGV_FLAG)
3448 if (PL_unicode & PERL_UNICODE_WIDESYSCALLS_FLAG) /* Sarathy? */
3449 (void)sv_utf8_decode(sv);
3454 #ifdef HAS_PROCSELFEXE
3455 /* This is a function so that we don't hold on to MAXPATHLEN
3456 bytes of stack longer than necessary
3459 S_procself_val(pTHX_ SV *sv, char *arg0)
3461 char buf[MAXPATHLEN];
3462 int len = readlink(PROCSELFEXE_PATH, buf, sizeof(buf) - 1);
3464 /* On Playstation2 Linux V1.0 (kernel 2.2.1) readlink(/proc/self/exe)
3465 includes a spurious NUL which will cause $^X to fail in system
3466 or backticks (this will prevent extensions from being built and
3467 many tests from working). readlink is not meant to add a NUL.
3468 Normal readlink works fine.
3470 if (len > 0 && buf[len-1] == '\0') {
3474 /* FreeBSD's implementation is acknowledged to be imperfect, sometimes
3475 returning the text "unknown" from the readlink rather than the path
3476 to the executable (or returning an error from the readlink). Any valid
3477 path has a '/' in it somewhere, so use that to validate the result.
3478 See http://www.freebsd.org/cgi/query-pr.cgi?pr=35703
3480 if (len > 0 && memchr(buf, '/', len)) {
3481 sv_setpvn(sv,buf,len);
3487 #endif /* HAS_PROCSELFEXE */
3490 S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
3496 PL_toptarget = NEWSV(0,0);
3497 sv_upgrade(PL_toptarget, SVt_PVFM);
3498 sv_setpvn(PL_toptarget, "", 0);
3499 PL_bodytarget = NEWSV(0,0);
3500 sv_upgrade(PL_bodytarget, SVt_PVFM);
3501 sv_setpvn(PL_bodytarget, "", 0);
3502 PL_formtarget = PL_bodytarget;
3506 init_argv_symbols(argc,argv);
3508 if ((tmpgv = gv_fetchpv("0",TRUE, SVt_PV))) {
3509 #ifdef MACOS_TRADITIONAL
3510 /* $0 is not majick on a Mac */
3511 sv_setpv(GvSV(tmpgv),MacPerl_MPWFileName(PL_origfilename));
3513 sv_setpv(GvSV(tmpgv),PL_origfilename);
3514 magicname("0", "0", 1);
3517 if ((tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))) {/* $^X */
3518 #ifdef HAS_PROCSELFEXE
3519 S_procself_val(aTHX_ GvSV(tmpgv), PL_origargv[0]);
3522 sv_setpv(GvSV(tmpgv), os2_execname(aTHX));
3524 sv_setpv(GvSV(tmpgv),PL_origargv[0]);
3528 if ((PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV))) {
3530 GvMULTI_on(PL_envgv);
3531 hv = GvHVn(PL_envgv);
3532 hv_magic(hv, Nullgv, PERL_MAGIC_env);
3533 #ifdef USE_ENVIRON_ARRAY
3534 /* Note that if the supplied env parameter is actually a copy
3535 of the global environ then it may now point to free'd memory
3536 if the environment has been modified since. To avoid this
3537 problem we treat env==NULL as meaning 'use the default'
3542 # ifdef USE_ITHREADS
3543 && PL_curinterp == aTHX
3547 environ[0] = Nullch;
3550 for (; *env; env++) {
3551 if (!(s = strchr(*env,'=')))
3558 sv = newSVpv(s+1, 0);
3559 (void)hv_store(hv, *env, s - *env, sv, 0);
3563 #endif /* USE_ENVIRON_ARRAY */
3566 if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV))) {
3567 SvREADONLY_off(GvSV(tmpgv));
3568 sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
3569 SvREADONLY_on(GvSV(tmpgv));
3571 #ifdef THREADS_HAVE_PIDS
3572 PL_ppid = (IV)getppid();
3575 /* touch @F array to prevent spurious warnings 20020415 MJD */
3577 (void) get_av("main::F", TRUE | GV_ADDMULTI);
3579 /* touch @- and @+ arrays to prevent spurious warnings 20020415 MJD */
3580 (void) get_av("main::-", TRUE | GV_ADDMULTI);
3581 (void) get_av("main::+", TRUE | GV_ADDMULTI);
3585 S_init_perllib(pTHX)
3590 s = PerlEnv_getenv("PERL5LIB");
3592 incpush(s, TRUE, TRUE, TRUE);
3594 incpush(PerlEnv_getenv("PERLLIB"), FALSE, FALSE, TRUE);
3596 /* Treat PERL5?LIB as a possible search list logical name -- the
3597 * "natural" VMS idiom for a Unix path string. We allow each
3598 * element to be a set of |-separated directories for compatibility.
3602 if (my_trnlnm("PERL5LIB",buf,0))
3603 do { incpush(buf,TRUE,TRUE,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
3605 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE,FALSE,TRUE);
3609 /* Use the ~-expanded versions of APPLLIB (undocumented),
3610 ARCHLIB PRIVLIB SITEARCH SITELIB VENDORARCH and VENDORLIB
3613 incpush(APPLLIB_EXP, TRUE, TRUE, TRUE);
3617 incpush(ARCHLIB_EXP, FALSE, FALSE, TRUE);
3619 #ifdef MACOS_TRADITIONAL
3622 SV * privdir = NEWSV(55, 0);
3623 char * macperl = PerlEnv_getenv("MACPERL");
3628 Perl_sv_setpvf(aTHX_ privdir, "%slib:", macperl);
3629 if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
3630 incpush(SvPVX(privdir), TRUE, FALSE, TRUE);
3631 Perl_sv_setpvf(aTHX_ privdir, "%ssite_perl:", macperl);
3632 if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
3633 incpush(SvPVX(privdir), TRUE, FALSE, TRUE);
3635 SvREFCNT_dec(privdir);
3638 incpush(":", FALSE, FALSE, TRUE);
3641 # define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
3644 incpush(PRIVLIB_EXP, TRUE, FALSE, TRUE);
3646 incpush(PRIVLIB_EXP, FALSE, FALSE, TRUE);
3650 /* sitearch is always relative to sitelib on Windows for
3651 * DLL-based path intuition to work correctly */
3652 # if !defined(WIN32)
3653 incpush(SITEARCH_EXP, FALSE, FALSE, TRUE);
3659 /* this picks up sitearch as well */
3660 incpush(SITELIB_EXP, TRUE, FALSE, TRUE);
3662 incpush(SITELIB_EXP, FALSE, FALSE, TRUE);
3666 #ifdef SITELIB_STEM /* Search for version-specific dirs below here */
3667 incpush(SITELIB_STEM, FALSE, TRUE, TRUE);
3670 #ifdef PERL_VENDORARCH_EXP
3671 /* vendorarch is always relative to vendorlib on Windows for
3672 * DLL-based path intuition to work correctly */
3673 # if !defined(WIN32)
3674 incpush(PERL_VENDORARCH_EXP, FALSE, FALSE, TRUE);
3678 #ifdef PERL_VENDORLIB_EXP
3680 incpush(PERL_VENDORLIB_EXP, TRUE, FALSE, TRUE); /* this picks up vendorarch as well */
3682 incpush(PERL_VENDORLIB_EXP, FALSE, FALSE, TRUE);
3686 #ifdef PERL_VENDORLIB_STEM /* Search for version-specific dirs below here */
3687 incpush(PERL_VENDORLIB_STEM, FALSE, TRUE, TRUE);
3690 #ifdef PERL_OTHERLIBDIRS
3691 incpush(PERL_OTHERLIBDIRS, TRUE, TRUE, TRUE);
3695 incpush(".", FALSE, FALSE, TRUE);
3696 #endif /* MACOS_TRADITIONAL */
3699 #if defined(DOSISH) || defined(EPOC)
3700 # define PERLLIB_SEP ';'
3703 # define PERLLIB_SEP '|'
3705 # if defined(MACOS_TRADITIONAL)
3706 # define PERLLIB_SEP ','
3708 # define PERLLIB_SEP ':'
3712 #ifndef PERLLIB_MANGLE
3713 # define PERLLIB_MANGLE(s,n) (s)
3717 S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers, int usesep)
3719 SV *subdir = Nullsv;
3724 if (addsubdirs || addoldvers) {
3725 subdir = sv_newmortal();
3728 /* Break at all separators */
3730 SV *libdir = NEWSV(55,0);
3733 /* skip any consecutive separators */
3735 while ( *p == PERLLIB_SEP ) {
3736 /* Uncomment the next line for PATH semantics */
3737 /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */
3742 if ( usesep && (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
3743 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
3748 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
3749 p = Nullch; /* break out */
3751 #ifdef MACOS_TRADITIONAL
3752 if (!strchr(SvPVX(libdir), ':')) {
3755 sv_setpv(libdir, MacPerl_CanonDir(SvPVX(libdir), buf, 0));
3757 if (SvPVX(libdir)[SvCUR(libdir)-1] != ':')
3758 sv_catpv(libdir, ":");
3762 * BEFORE pushing libdir onto @INC we may first push version- and
3763 * archname-specific sub-directories.
3765 if (addsubdirs || addoldvers) {
3766 #ifdef PERL_INC_VERSION_LIST
3767 /* Configure terminates PERL_INC_VERSION_LIST with a NULL */
3768 const char *incverlist[] = { PERL_INC_VERSION_LIST };
3769 const char **incver;
3776 if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) {
3778 while (unix[len-1] == '/') len--; /* Cosmetic */
3779 sv_usepvn(libdir,unix,len);
3782 PerlIO_printf(Perl_error_log,
3783 "Failed to unixify @INC element \"%s\"\n",
3787 #ifdef MACOS_TRADITIONAL
3788 #define PERL_AV_SUFFIX_FMT ""
3789 #define PERL_ARCH_FMT "%s:"
3790 #define PERL_ARCH_FMT_PATH PERL_FS_VER_FMT PERL_AV_SUFFIX_FMT
3792 #define PERL_AV_SUFFIX_FMT "/"
3793 #define PERL_ARCH_FMT "/%s"
3794 #define PERL_ARCH_FMT_PATH PERL_AV_SUFFIX_FMT PERL_FS_VER_FMT
3796 /* .../version/archname if -d .../version/archname */
3797 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH PERL_ARCH_FMT,
3799 (int)PERL_REVISION, (int)PERL_VERSION,
3800 (int)PERL_SUBVERSION, ARCHNAME);
3801 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3802 S_ISDIR(tmpstatbuf.st_mode))
3803 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3805 /* .../version if -d .../version */
3806 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH, libdir,
3807 (int)PERL_REVISION, (int)PERL_VERSION,
3808 (int)PERL_SUBVERSION);
3809 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3810 S_ISDIR(tmpstatbuf.st_mode))
3811 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3813 /* .../archname if -d .../archname */
3814 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, ARCHNAME);
3815 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3816 S_ISDIR(tmpstatbuf.st_mode))
3817 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3820 #ifdef PERL_INC_VERSION_LIST
3822 for (incver = incverlist; *incver; incver++) {
3823 /* .../xxx if -d .../xxx */
3824 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, *incver);
3825 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3826 S_ISDIR(tmpstatbuf.st_mode))
3827 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3833 /* finally push this lib directory on the end of @INC */
3834 av_push(GvAVn(PL_incgv), libdir);
3838 #ifdef USE_5005THREADS
3839 STATIC struct perl_thread *
3840 S_init_main_thread(pTHX)
3842 #if !defined(PERL_IMPLICIT_CONTEXT)
3843 struct perl_thread *thr;
3847 Newz(53, thr, 1, struct perl_thread);
3848 PL_curcop = &PL_compiling;
3849 thr->interp = PERL_GET_INTERP;
3850 thr->cvcache = newHV();
3851 thr->threadsv = newAV();
3852 /* thr->threadsvp is set when find_threadsv is called */
3853 thr->specific = newAV();
3854 thr->flags = THRf_R_JOINABLE;
3855 MUTEX_INIT(&thr->mutex);
3856 /* Handcraft thrsv similarly to mess_sv */
3857 New(53, PL_thrsv, 1, SV);
3858 Newz(53, xpv, 1, XPV);
3859 SvFLAGS(PL_thrsv) = SVt_PV;
3860 SvANY(PL_thrsv) = (void*)xpv;
3861 SvREFCNT(PL_thrsv) = 1 << 30; /* practically infinite */
3862 SvPVX(PL_thrsv) = (char*)thr;
3863 SvCUR_set(PL_thrsv, sizeof(thr));
3864 SvLEN_set(PL_thrsv, sizeof(thr));
3865 *SvEND(PL_thrsv) = '\0'; /* in the trailing_nul field */
3866 thr->oursv = PL_thrsv;
3867 PL_chopset = " \n-";
3870 MUTEX_LOCK(&PL_threads_mutex);
3876 MUTEX_UNLOCK(&PL_threads_mutex);
3878 #ifdef HAVE_THREAD_INTERN
3879 Perl_init_thread_intern(thr);
3882 #ifdef SET_THREAD_SELF
3883 SET_THREAD_SELF(thr);
3885 thr->self = pthread_self();
3886 #endif /* SET_THREAD_SELF */
3890 * These must come after the thread self setting
3891 * because sv_setpvn does SvTAINT and the taint
3892 * fields thread selfness being set.
3894 PL_toptarget = NEWSV(0,0);
3895 sv_upgrade(PL_toptarget, SVt_PVFM);
3896 sv_setpvn(PL_toptarget, "", 0);
3897 PL_bodytarget = NEWSV(0,0);
3898 sv_upgrade(PL_bodytarget, SVt_PVFM);
3899 sv_setpvn(PL_bodytarget, "", 0);
3900 PL_formtarget = PL_bodytarget;
3901 thr->errsv = newSVpvn("", 0);
3902 (void) find_threadsv("@"); /* Ensure $@ is initialised early */
3905 PL_peepp = MEMBER_TO_FPTR(Perl_peep);
3906 PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
3907 PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
3908 PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
3909 PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
3910 PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
3912 PL_reginterp_cnt = 0;
3916 #endif /* USE_5005THREADS */
3919 Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
3922 line_t oldline = CopLINE(PL_curcop);
3928 while (AvFILL(paramList) >= 0) {
3929 cv = (CV*)av_shift(paramList);
3931 if (paramList == PL_beginav) {
3932 /* save PL_beginav for compiler */
3933 if (! PL_beginav_save)
3934 PL_beginav_save = newAV();
3935 av_push(PL_beginav_save, (SV*)cv);
3937 else if (paramList == PL_checkav) {
3938 /* save PL_checkav for compiler */
3939 if (! PL_checkav_save)
3940 PL_checkav_save = newAV();
3941 av_push(PL_checkav_save, (SV*)cv);
3946 #ifdef PERL_FLEXIBLE_EXCEPTIONS
3947 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_list_body), cv);
3953 #ifndef PERL_FLEXIBLE_EXCEPTIONS
3957 (void)SvPV(atsv, len);
3959 PL_curcop = &PL_compiling;
3960 CopLINE_set(PL_curcop, oldline);
3961 if (paramList == PL_beginav)
3962 sv_catpv(atsv, "BEGIN failed--compilation aborted");
3964 Perl_sv_catpvf(aTHX_ atsv,
3965 "%s failed--call queue aborted",
3966 paramList == PL_checkav ? "CHECK"
3967 : paramList == PL_initav ? "INIT"
3969 while (PL_scopestack_ix > oldscope)
3972 Perl_croak(aTHX_ "%"SVf"", atsv);
3979 /* my_exit() was called */
3980 while (PL_scopestack_ix > oldscope)
3983 PL_curstash = PL_defstash;
3984 PL_curcop = &PL_compiling;
3985 CopLINE_set(PL_curcop, oldline);
3987 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) {
3988 if (paramList == PL_beginav)
3989 Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
3991 Perl_croak(aTHX_ "%s failed--call queue aborted",
3992 paramList == PL_checkav ? "CHECK"
3993 : paramList == PL_initav ? "INIT"
4000 PL_curcop = &PL_compiling;
4001 CopLINE_set(PL_curcop, oldline);
4004 PerlIO_printf(Perl_error_log, "panic: restartop\n");
4012 #ifdef PERL_FLEXIBLE_EXCEPTIONS
4014 S_vcall_list_body(pTHX_ va_list args)
4016 CV *cv = va_arg(args, CV*);
4017 return call_list_body(cv);
4022 S_call_list_body(pTHX_ CV *cv)
4024 PUSHMARK(PL_stack_sp);
4025 call_sv((SV*)cv, G_EVAL|G_DISCARD);
4030 Perl_my_exit(pTHX_ U32 status)
4032 DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
4033 thr, (unsigned long) status));
4042 STATUS_NATIVE_SET(status);
4049 Perl_my_failure_exit(pTHX)
4052 if (vaxc$errno & 1) {
4053 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
4054 STATUS_NATIVE_SET(44);
4057 if (!vaxc$errno && errno) /* unlikely */
4058 STATUS_NATIVE_SET(44);
4060 STATUS_NATIVE_SET(vaxc$errno);
4065 STATUS_POSIX_SET(errno);
4067 exitstatus = STATUS_POSIX >> 8;
4068 if (exitstatus & 255)
4069 STATUS_POSIX_SET(exitstatus);
4071 STATUS_POSIX_SET(255);
4078 S_my_exit_jump(pTHX)
4080 register PERL_CONTEXT *cx;
4085 SvREFCNT_dec(PL_e_script);
4086 PL_e_script = Nullsv;
4089 POPSTACK_TO(PL_mainstack);
4090 if (cxstack_ix >= 0) {
4093 POPBLOCK(cx,PL_curpm);
4101 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen)
4104 p = SvPVX(PL_e_script);
4105 nl = strchr(p, '\n');
4106 nl = (nl) ? nl+1 : SvEND(PL_e_script);
4108 filter_del(read_e_script);
4111 sv_catpvn(buf_sv, p, nl-p);
4112 sv_chop(PL_e_script, nl);