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)? */
158 #ifdef PERL_FLEXIBLE_EXCEPTIONS
159 PL_protect = MEMBER_TO_FPTR(Perl_default_protect); /* for exceptions */
162 PL_curcop = &PL_compiling; /* needed by ckWARN, right away */
164 PL_linestr = NEWSV(65,79);
165 sv_upgrade(PL_linestr,SVt_PVIV);
167 if (!SvREADONLY(&PL_sv_undef)) {
168 /* set read-only and try to insure than we wont see REFCNT==0
171 SvREADONLY_on(&PL_sv_undef);
172 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
174 sv_setpv(&PL_sv_no,PL_No);
176 SvREADONLY_on(&PL_sv_no);
177 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
179 sv_setpv(&PL_sv_yes,PL_Yes);
181 SvREADONLY_on(&PL_sv_yes);
182 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
185 PL_sighandlerp = Perl_sighandler;
186 PL_pidstatus = newHV();
189 PL_rs = newSVpvn("\n", 1);
194 PL_lex_state = LEX_NOTPARSING;
200 SET_NUMERIC_STANDARD();
204 PL_patchlevel = NEWSV(0,4);
205 (void)SvUPGRADE(PL_patchlevel, SVt_PVNV);
206 if (PERL_REVISION > 127 || PERL_VERSION > 127 || PERL_SUBVERSION > 127)
207 SvGROW(PL_patchlevel, UTF8_MAXLEN*3+1);
208 s = (U8*)SvPVX(PL_patchlevel);
209 /* Build version strings using "native" characters */
210 s = uvchr_to_utf8(s, (UV)PERL_REVISION);
211 s = uvchr_to_utf8(s, (UV)PERL_VERSION);
212 s = uvchr_to_utf8(s, (UV)PERL_SUBVERSION);
214 SvCUR_set(PL_patchlevel, s - (U8*)SvPVX(PL_patchlevel));
215 SvPOK_on(PL_patchlevel);
216 SvNVX(PL_patchlevel) = (NV)PERL_REVISION
217 + ((NV)PERL_VERSION / (NV)1000)
218 #if defined(PERL_SUBVERSION) && PERL_SUBVERSION > 0
219 + ((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 */
353 op_free(PL_main_root);
354 PL_main_root = Nullop;
356 PL_curcop = &PL_compiling;
357 PL_main_start = Nullop;
358 SvREFCNT_dec(PL_main_cv);
362 /* Tell PerlIO we are about to tear things apart in case
363 we have layers which are using resources that should
367 PerlIO_destruct(aTHX);
369 if (PL_sv_objcount) {
371 * Try to destruct global references. We do this first so that the
372 * destructors and destructees still exist. Some sv's might remain.
373 * Non-referenced objects are on their own.
378 /* unhook hooks which will soon be, or use, destroyed data */
379 SvREFCNT_dec(PL_warnhook);
380 PL_warnhook = Nullsv;
381 SvREFCNT_dec(PL_diehook);
384 /* call exit list functions */
385 while (PL_exitlistlen-- > 0)
386 PL_exitlist[PL_exitlistlen].fn(aTHX_ PL_exitlist[PL_exitlistlen].ptr);
388 Safefree(PL_exitlist);
390 if (destruct_level == 0){
392 DEBUG_P(debprofdump());
394 #if defined(PERLIO_LAYERS)
395 /* No more IO - including error messages ! */
396 PerlIO_cleanup(aTHX);
399 /* The exit() function will do everything that needs doing. */
400 return STATUS_NATIVE_EXPORT;
403 /* jettison our possibly duplicated environment */
404 /* if PERL_USE_SAFE_PUTENV is defined environ will not have been copied
405 * so we certainly shouldn't free it here
407 #if defined(USE_ENVIRON_ARRAY) && !defined(PERL_USE_SAFE_PUTENV)
408 if (environ != PL_origenviron
410 /* only main thread can free environ[0] contents */
411 && PL_curinterp == aTHX
417 for (i = 0; environ[i]; i++)
418 safesysfree(environ[i]);
420 /* Must use safesysfree() when working with environ. */
421 safesysfree(environ);
423 environ = PL_origenviron;
428 /* the syntax tree is shared between clones
429 * so op_free(PL_main_root) only ReREFCNT_dec's
430 * REGEXPs in the parent interpreter
431 * we need to manually ReREFCNT_dec for the clones
434 I32 i = AvFILLp(PL_regex_padav) + 1;
435 SV **ary = AvARRAY(PL_regex_padav);
439 REGEXP *re = INT2PTR(REGEXP *,SvIVX(resv));
441 if (SvFLAGS(resv) & SVf_BREAK) {
442 /* this is PL_reg_curpm, already freed
443 * flag is set in regexec.c:S_regtry
445 SvFLAGS(resv) &= ~SVf_BREAK;
447 else if(SvREPADTMP(resv)) {
448 SvREPADTMP_off(resv);
455 SvREFCNT_dec(PL_regex_padav);
456 PL_regex_padav = Nullav;
460 /* loosen bonds of global variables */
463 (void)PerlIO_close(PL_rsfp);
467 /* Filters for program text */
468 SvREFCNT_dec(PL_rsfp_filters);
469 PL_rsfp_filters = Nullav;
472 PL_preprocess = FALSE;
478 PL_doswitches = FALSE;
479 PL_dowarn = G_WARN_OFF;
480 PL_doextract = FALSE;
481 PL_sawampersand = FALSE; /* must save all match strings */
484 Safefree(PL_inplace);
486 SvREFCNT_dec(PL_patchlevel);
489 SvREFCNT_dec(PL_e_script);
490 PL_e_script = Nullsv;
493 while (--PL_origargc >= 0) {
494 Safefree(PL_origargv[PL_origargc]);
496 Safefree(PL_origargv);
498 /* magical thingies */
500 SvREFCNT_dec(PL_ofs_sv); /* $, */
503 SvREFCNT_dec(PL_ors_sv); /* $\ */
506 SvREFCNT_dec(PL_rs); /* $/ */
509 PL_multiline = 0; /* $* */
510 Safefree(PL_osname); /* $^O */
513 SvREFCNT_dec(PL_statname);
514 PL_statname = Nullsv;
517 /* defgv, aka *_ should be taken care of elsewhere */
519 /* clean up after study() */
520 SvREFCNT_dec(PL_lastscream);
521 PL_lastscream = Nullsv;
522 Safefree(PL_screamfirst);
524 Safefree(PL_screamnext);
528 Safefree(PL_efloatbuf);
529 PL_efloatbuf = Nullch;
532 /* startup and shutdown function lists */
533 SvREFCNT_dec(PL_beginav);
534 SvREFCNT_dec(PL_beginav_save);
535 SvREFCNT_dec(PL_endav);
536 SvREFCNT_dec(PL_checkav);
537 SvREFCNT_dec(PL_checkav_save);
538 SvREFCNT_dec(PL_initav);
540 PL_beginav_save = Nullav;
543 PL_checkav_save = Nullav;
546 /* shortcuts just get cleared */
552 PL_argvoutgv = Nullgv;
554 PL_stderrgv = Nullgv;
555 PL_last_in_gv = Nullgv;
557 PL_debstash = Nullhv;
559 /* reset so print() ends up where we expect */
562 SvREFCNT_dec(PL_argvout_stack);
563 PL_argvout_stack = Nullav;
565 SvREFCNT_dec(PL_modglobal);
566 PL_modglobal = Nullhv;
567 SvREFCNT_dec(PL_preambleav);
568 PL_preambleav = Nullav;
569 SvREFCNT_dec(PL_subname);
571 SvREFCNT_dec(PL_linestr);
573 SvREFCNT_dec(PL_pidstatus);
574 PL_pidstatus = Nullhv;
575 SvREFCNT_dec(PL_toptarget);
576 PL_toptarget = Nullsv;
577 SvREFCNT_dec(PL_bodytarget);
578 PL_bodytarget = Nullsv;
579 PL_formtarget = Nullsv;
581 /* free locale stuff */
582 #ifdef USE_LOCALE_COLLATE
583 Safefree(PL_collation_name);
584 PL_collation_name = Nullch;
587 #ifdef USE_LOCALE_NUMERIC
588 Safefree(PL_numeric_name);
589 PL_numeric_name = Nullch;
590 SvREFCNT_dec(PL_numeric_radix_sv);
593 /* clear utf8 character classes */
594 SvREFCNT_dec(PL_utf8_alnum);
595 SvREFCNT_dec(PL_utf8_alnumc);
596 SvREFCNT_dec(PL_utf8_ascii);
597 SvREFCNT_dec(PL_utf8_alpha);
598 SvREFCNT_dec(PL_utf8_space);
599 SvREFCNT_dec(PL_utf8_cntrl);
600 SvREFCNT_dec(PL_utf8_graph);
601 SvREFCNT_dec(PL_utf8_digit);
602 SvREFCNT_dec(PL_utf8_upper);
603 SvREFCNT_dec(PL_utf8_lower);
604 SvREFCNT_dec(PL_utf8_print);
605 SvREFCNT_dec(PL_utf8_punct);
606 SvREFCNT_dec(PL_utf8_xdigit);
607 SvREFCNT_dec(PL_utf8_mark);
608 SvREFCNT_dec(PL_utf8_toupper);
609 SvREFCNT_dec(PL_utf8_totitle);
610 SvREFCNT_dec(PL_utf8_tolower);
611 SvREFCNT_dec(PL_utf8_tofold);
612 SvREFCNT_dec(PL_utf8_idstart);
613 SvREFCNT_dec(PL_utf8_idcont);
614 PL_utf8_alnum = Nullsv;
615 PL_utf8_alnumc = Nullsv;
616 PL_utf8_ascii = Nullsv;
617 PL_utf8_alpha = Nullsv;
618 PL_utf8_space = Nullsv;
619 PL_utf8_cntrl = Nullsv;
620 PL_utf8_graph = Nullsv;
621 PL_utf8_digit = Nullsv;
622 PL_utf8_upper = Nullsv;
623 PL_utf8_lower = Nullsv;
624 PL_utf8_print = Nullsv;
625 PL_utf8_punct = Nullsv;
626 PL_utf8_xdigit = Nullsv;
627 PL_utf8_mark = Nullsv;
628 PL_utf8_toupper = Nullsv;
629 PL_utf8_totitle = Nullsv;
630 PL_utf8_tolower = Nullsv;
631 PL_utf8_tofold = Nullsv;
632 PL_utf8_idstart = Nullsv;
633 PL_utf8_idcont = Nullsv;
635 if (!specialWARN(PL_compiling.cop_warnings))
636 SvREFCNT_dec(PL_compiling.cop_warnings);
637 PL_compiling.cop_warnings = Nullsv;
638 if (!specialCopIO(PL_compiling.cop_io))
639 SvREFCNT_dec(PL_compiling.cop_io);
640 PL_compiling.cop_io = Nullsv;
641 CopFILE_free(&PL_compiling);
642 CopSTASH_free(&PL_compiling);
644 /* Prepare to destruct main symbol table. */
649 SvREFCNT_dec(PL_curstname);
650 PL_curstname = Nullsv;
652 /* clear queued errors */
653 SvREFCNT_dec(PL_errors);
657 if (destruct_level >= 2 && ckWARN_d(WARN_INTERNAL)) {
658 if (PL_scopestack_ix != 0)
659 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
660 "Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
661 (long)PL_scopestack_ix);
662 if (PL_savestack_ix != 0)
663 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
664 "Unbalanced saves: %ld more saves than restores\n",
665 (long)PL_savestack_ix);
666 if (PL_tmps_floor != -1)
667 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced tmps: %ld more allocs than frees\n",
668 (long)PL_tmps_floor + 1);
669 if (cxstack_ix != -1)
670 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced context: %ld more PUSHes than POPs\n",
671 (long)cxstack_ix + 1);
674 /* Now absolutely destruct everything, somehow or other, loops or no. */
675 SvFLAGS(PL_fdpid) |= SVTYPEMASK; /* don't clean out pid table now */
676 SvFLAGS(PL_strtab) |= SVTYPEMASK; /* don't clean out strtab now */
678 /* the 2 is for PL_fdpid and PL_strtab */
679 while (PL_sv_count > 2 && sv_clean_all())
682 SvFLAGS(PL_fdpid) &= ~SVTYPEMASK;
683 SvFLAGS(PL_fdpid) |= SVt_PVAV;
684 SvFLAGS(PL_strtab) &= ~SVTYPEMASK;
685 SvFLAGS(PL_strtab) |= SVt_PVHV;
687 AvREAL_off(PL_fdpid); /* no surviving entries */
688 SvREFCNT_dec(PL_fdpid); /* needed in io_close() */
691 #ifdef HAVE_INTERP_INTERN
695 /* Destruct the global string table. */
697 /* Yell and reset the HeVAL() slots that are still holding refcounts,
698 * so that sv_free() won't fail on them.
706 max = HvMAX(PL_strtab);
707 array = HvARRAY(PL_strtab);
710 if (hent && ckWARN_d(WARN_INTERNAL)) {
711 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
712 "Unbalanced string table refcount: (%d) for \"%s\"",
713 HeVAL(hent) - Nullsv, HeKEY(hent));
714 HeVAL(hent) = Nullsv;
724 SvREFCNT_dec(PL_strtab);
727 /* free the pointer table used for cloning */
728 ptr_table_free(PL_ptr_table);
731 /* free special SVs */
733 SvREFCNT(&PL_sv_yes) = 0;
734 sv_clear(&PL_sv_yes);
735 SvANY(&PL_sv_yes) = NULL;
736 SvFLAGS(&PL_sv_yes) = 0;
738 SvREFCNT(&PL_sv_no) = 0;
740 SvANY(&PL_sv_no) = NULL;
741 SvFLAGS(&PL_sv_no) = 0;
745 for (i=0; i<=2; i++) {
746 SvREFCNT(PERL_DEBUG_PAD(i)) = 0;
747 sv_clear(PERL_DEBUG_PAD(i));
748 SvANY(PERL_DEBUG_PAD(i)) = NULL;
749 SvFLAGS(PERL_DEBUG_PAD(i)) = 0;
753 if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL))
754 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Scalars leaked: %ld\n", (long)PL_sv_count);
756 #if defined(PERLIO_LAYERS)
757 /* No more IO - including error messages ! */
758 PerlIO_cleanup(aTHX);
761 /* sv_undef needs to stay immortal until after PerlIO_cleanup
762 as currently layers use it rather than Nullsv as a marker
763 for no arg - and will try and SvREFCNT_dec it.
765 SvREFCNT(&PL_sv_undef) = 0;
766 SvREADONLY_off(&PL_sv_undef);
768 Safefree(PL_origfilename);
769 Safefree(PL_reg_start_tmp);
771 Safefree(PL_reg_curpm);
772 Safefree(PL_reg_poscache);
773 Safefree(HeKEY_hek(&PL_hv_fetch_ent_mh));
774 Safefree(PL_op_mask);
775 Safefree(PL_psig_ptr);
776 Safefree(PL_psig_name);
777 Safefree(PL_bitcount);
778 Safefree(PL_psig_pend);
780 PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */
782 DEBUG_P(debprofdump());
784 #ifdef USE_REENTRANT_API
785 Perl_reentrant_free(aTHX);
790 /* As the absolutely last thing, free the non-arena SV for mess() */
793 /* it could have accumulated taint magic */
794 if (SvTYPE(PL_mess_sv) >= SVt_PVMG) {
797 for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) {
798 moremagic = mg->mg_moremagic;
799 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global
801 Safefree(mg->mg_ptr);
805 /* we know that type >= SVt_PV */
806 (void)SvOOK_off(PL_mess_sv);
807 Safefree(SvPVX(PL_mess_sv));
808 Safefree(SvANY(PL_mess_sv));
809 Safefree(PL_mess_sv);
812 return STATUS_NATIVE_EXPORT;
816 =for apidoc perl_free
818 Releases a Perl interpreter. See L<perlembed>.
826 #if defined(WIN32) || defined(NETWARE)
827 # if defined(PERL_IMPLICIT_SYS)
829 void *host = nw_internal_host;
831 void *host = w32_internal_host;
835 nw_delete_internal_host(host);
837 win32_delete_internal_host(host);
848 Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
850 Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry);
851 PL_exitlist[PL_exitlistlen].fn = fn;
852 PL_exitlist[PL_exitlistlen].ptr = ptr;
857 =for apidoc perl_parse
859 Tells a Perl interpreter to parse a Perl script. See L<perlembed>.
865 perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
870 #ifdef USE_5005THREADS
874 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
877 Perl_croak(aTHX_ "suidperl is no longer needed since the kernel can now execute\n\
878 setuid perl scripts securely.\n");
884 /* we copy rather than point to argv
885 * since perl_clone will copy and perl_destruct
886 * has no way of knowing if we've made a copy or
890 New(0, PL_origargv, i+1, char*);
891 PL_origargv[i] = '\0';
893 PL_origargv[i] = savepv(argv[i]);
901 /* Come here if running an undumped a.out. */
903 PL_origfilename = savepv(argv[0]);
904 PL_do_undump = FALSE;
905 cxstack_ix = -1; /* start label stack again */
907 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);
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_wantutf8 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 if (PL_wantutf8) { /* Requires init_predump_symbols(). */
1365 /* Turn on UTF-8-ness on STDIN, STDOUT, STDERR
1366 * _and_ the default open discipline. */
1367 if (PL_stdingv && (io = GvIO(PL_stdingv)) && (fp = IoIFP(io)))
1368 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
1369 if (PL_defoutgv && (io = GvIO(PL_defoutgv)) && (fp = IoOFP(io)))
1370 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
1371 if (PL_stderrgv && (io = GvIO(PL_stderrgv)) && (fp = IoOFP(io)))
1372 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
1373 if ((sv = GvSV(gv_fetchpv("\017PEN", TRUE, SVt_PV)))) {
1374 sv_setpvn(sv, ":utf8\0:utf8", 11);
1381 /* now parse the script */
1383 SETERRNO(0,SS_NORMAL);
1385 #ifdef MACOS_TRADITIONAL
1386 if (gMacPerl_SyntaxError = (yyparse() || PL_error_count)) {
1388 Perl_croak(aTHX_ "%s had compilation errors.\n", MacPerl_MPWFileName(PL_origfilename));
1390 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
1391 MacPerl_MPWFileName(PL_origfilename));
1395 if (yyparse() || PL_error_count) {
1397 Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
1399 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
1404 CopLINE_set(PL_curcop, 0);
1405 PL_curstash = PL_defstash;
1406 PL_preprocess = FALSE;
1408 SvREFCNT_dec(PL_e_script);
1409 PL_e_script = Nullsv;
1416 SAVECOPFILE(PL_curcop);
1417 SAVECOPLINE(PL_curcop);
1418 gv_check(PL_defstash);
1425 if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
1426 dump_mstats("after compilation:");
1435 =for apidoc perl_run
1437 Tells a Perl interpreter to run. See L<perlembed>.
1448 #ifdef USE_5005THREADS
1452 oldscope = PL_scopestack_ix;
1457 #ifdef PERL_FLEXIBLE_EXCEPTIONS
1459 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vrun_body), oldscope);
1465 cxstack_ix = -1; /* start context stack again */
1467 case 0: /* normal completion */
1468 #ifndef PERL_FLEXIBLE_EXCEPTIONS
1473 case 2: /* my_exit() */
1474 while (PL_scopestack_ix > oldscope)
1477 PL_curstash = PL_defstash;
1478 if (!(PL_exit_flags & PERL_EXIT_DESTRUCT_END) &&
1479 PL_endav && !PL_minus_c)
1480 call_list(oldscope, PL_endav);
1482 if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
1483 dump_mstats("after execution: ");
1485 ret = STATUS_NATIVE_EXPORT;
1489 POPSTACK_TO(PL_mainstack);
1492 PerlIO_printf(Perl_error_log, "panic: restartop\n");
1502 #ifdef PERL_FLEXIBLE_EXCEPTIONS
1504 S_vrun_body(pTHX_ va_list args)
1506 I32 oldscope = va_arg(args, I32);
1508 return run_body(oldscope);
1514 S_run_body(pTHX_ I32 oldscope)
1516 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
1517 PL_sawampersand ? "Enabling" : "Omitting"));
1519 if (!PL_restartop) {
1520 DEBUG_x(dump_all());
1521 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
1522 DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%"UVxf"\n",
1526 #ifdef MACOS_TRADITIONAL
1527 PerlIO_printf(Perl_error_log, "%s%s syntax OK\n",
1528 (gMacPerl_ErrorFormat ? "# " : ""),
1529 MacPerl_MPWFileName(PL_origfilename));
1531 PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
1535 if (PERLDB_SINGLE && PL_DBsingle)
1536 sv_setiv(PL_DBsingle, 1);
1538 call_list(oldscope, PL_initav);
1544 PL_op = PL_restartop;
1548 else if (PL_main_start) {
1549 CvDEPTH(PL_main_cv) = 1;
1550 PL_op = PL_main_start;
1560 =head1 SV Manipulation Functions
1562 =for apidoc p||get_sv
1564 Returns the SV of the specified Perl scalar. If C<create> is set and the
1565 Perl variable does not exist then it will be created. If C<create> is not
1566 set and the variable does not exist then NULL is returned.
1572 Perl_get_sv(pTHX_ const char *name, I32 create)
1575 #ifdef USE_5005THREADS
1576 if (name[1] == '\0' && !isALPHA(name[0])) {
1577 PADOFFSET tmp = find_threadsv(name);
1578 if (tmp != NOT_IN_PAD)
1579 return THREADSV(tmp);
1581 #endif /* USE_5005THREADS */
1582 gv = gv_fetchpv(name, create, SVt_PV);
1589 =head1 Array Manipulation Functions
1591 =for apidoc p||get_av
1593 Returns the AV of the specified Perl array. If C<create> is set and the
1594 Perl variable does not exist then it will be created. If C<create> is not
1595 set and the variable does not exist then NULL is returned.
1601 Perl_get_av(pTHX_ const char *name, I32 create)
1603 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1612 =head1 Hash Manipulation Functions
1614 =for apidoc p||get_hv
1616 Returns the HV of the specified Perl hash. If C<create> is set and the
1617 Perl variable does not exist then it will be created. If C<create> is not
1618 set and the variable does not exist then NULL is returned.
1624 Perl_get_hv(pTHX_ const char *name, I32 create)
1626 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1635 =head1 CV Manipulation Functions
1637 =for apidoc p||get_cv
1639 Returns the CV of the specified Perl subroutine. If C<create> is set and
1640 the Perl subroutine does not exist then it will be declared (which has the
1641 same effect as saying C<sub name;>). If C<create> is not set and the
1642 subroutine does not exist then NULL is returned.
1648 Perl_get_cv(pTHX_ const char *name, I32 create)
1650 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
1651 /* XXX unsafe for threads if eval_owner isn't held */
1652 /* XXX this is probably not what they think they're getting.
1653 * It has the same effect as "sub name;", i.e. just a forward
1655 if (create && !GvCVu(gv))
1656 return newSUB(start_subparse(FALSE, 0),
1657 newSVOP(OP_CONST, 0, newSVpv(name,0)),
1665 /* Be sure to refetch the stack pointer after calling these routines. */
1669 =head1 Callback Functions
1671 =for apidoc p||call_argv
1673 Performs a callback to the specified Perl sub. See L<perlcall>.
1679 Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv)
1681 /* See G_* flags in cop.h */
1682 /* null terminated arg list */
1689 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
1694 return call_pv(sub_name, flags);
1698 =for apidoc p||call_pv
1700 Performs a callback to the specified Perl sub. See L<perlcall>.
1706 Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
1707 /* name of the subroutine */
1708 /* See G_* flags in cop.h */
1710 return call_sv((SV*)get_cv(sub_name, TRUE), flags);
1714 =for apidoc p||call_method
1716 Performs a callback to the specified Perl method. The blessed object must
1717 be on the stack. See L<perlcall>.
1723 Perl_call_method(pTHX_ const char *methname, I32 flags)
1724 /* name of the subroutine */
1725 /* See G_* flags in cop.h */
1727 return call_sv(sv_2mortal(newSVpv(methname,0)), flags | G_METHOD);
1730 /* May be called with any of a CV, a GV, or an SV containing the name. */
1732 =for apidoc p||call_sv
1734 Performs a callback to the Perl sub whose name is in the SV. See
1741 Perl_call_sv(pTHX_ SV *sv, I32 flags)
1742 /* See G_* flags in cop.h */
1745 LOGOP myop; /* fake syntax tree node */
1748 volatile I32 retval = 0;
1750 bool oldcatch = CATCH_GET;
1755 if (flags & G_DISCARD) {
1760 Zero(&myop, 1, LOGOP);
1761 myop.op_next = Nullop;
1762 if (!(flags & G_NOARGS))
1763 myop.op_flags |= OPf_STACKED;
1764 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1765 (flags & G_ARRAY) ? OPf_WANT_LIST :
1770 EXTEND(PL_stack_sp, 1);
1771 *++PL_stack_sp = sv;
1773 oldscope = PL_scopestack_ix;
1775 if (PERLDB_SUB && PL_curstash != PL_debstash
1776 /* Handle first BEGIN of -d. */
1777 && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
1778 /* Try harder, since this may have been a sighandler, thus
1779 * curstash may be meaningless. */
1780 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != PL_debstash)
1781 && !(flags & G_NODEBUG))
1782 PL_op->op_private |= OPpENTERSUB_DB;
1784 if (flags & G_METHOD) {
1785 Zero(&method_op, 1, UNOP);
1786 method_op.op_next = PL_op;
1787 method_op.op_ppaddr = PL_ppaddr[OP_METHOD];
1788 myop.op_ppaddr = PL_ppaddr[OP_ENTERSUB];
1789 PL_op = (OP*)&method_op;
1792 if (!(flags & G_EVAL)) {
1794 call_body((OP*)&myop, FALSE);
1795 retval = PL_stack_sp - (PL_stack_base + oldmark);
1796 CATCH_SET(oldcatch);
1799 myop.op_other = (OP*)&myop;
1801 /* we're trying to emulate pp_entertry() here */
1803 register PERL_CONTEXT *cx;
1804 I32 gimme = GIMME_V;
1809 push_return(Nullop);
1810 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
1812 PL_eval_root = PL_op; /* Only needed so that goto works right. */
1814 PL_in_eval = EVAL_INEVAL;
1815 if (flags & G_KEEPERR)
1816 PL_in_eval |= EVAL_KEEPERR;
1822 #ifdef PERL_FLEXIBLE_EXCEPTIONS
1824 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_body),
1831 #ifndef PERL_FLEXIBLE_EXCEPTIONS
1833 call_body((OP*)&myop, FALSE);
1835 retval = PL_stack_sp - (PL_stack_base + oldmark);
1836 if (!(flags & G_KEEPERR))
1843 /* my_exit() was called */
1844 PL_curstash = PL_defstash;
1847 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
1848 Perl_croak(aTHX_ "Callback called exit");
1853 PL_op = PL_restartop;
1857 PL_stack_sp = PL_stack_base + oldmark;
1858 if (flags & G_ARRAY)
1862 *++PL_stack_sp = &PL_sv_undef;
1867 if (PL_scopestack_ix > oldscope) {
1871 register PERL_CONTEXT *cx;
1883 if (flags & G_DISCARD) {
1884 PL_stack_sp = PL_stack_base + oldmark;
1893 #ifdef PERL_FLEXIBLE_EXCEPTIONS
1895 S_vcall_body(pTHX_ va_list args)
1897 OP *myop = va_arg(args, OP*);
1898 int is_eval = va_arg(args, int);
1900 call_body(myop, is_eval);
1906 S_call_body(pTHX_ OP *myop, int is_eval)
1908 if (PL_op == myop) {
1910 PL_op = Perl_pp_entereval(aTHX); /* this doesn't do a POPMARK */
1912 PL_op = Perl_pp_entersub(aTHX); /* this does */
1918 /* Eval a string. The G_EVAL flag is always assumed. */
1921 =for apidoc p||eval_sv
1923 Tells Perl to C<eval> the string in the SV.
1929 Perl_eval_sv(pTHX_ SV *sv, I32 flags)
1931 /* See G_* flags in cop.h */
1934 UNOP myop; /* fake syntax tree node */
1935 volatile I32 oldmark = SP - PL_stack_base;
1936 volatile I32 retval = 0;
1942 if (flags & G_DISCARD) {
1949 Zero(PL_op, 1, UNOP);
1950 EXTEND(PL_stack_sp, 1);
1951 *++PL_stack_sp = sv;
1952 oldscope = PL_scopestack_ix;
1954 if (!(flags & G_NOARGS))
1955 myop.op_flags = OPf_STACKED;
1956 myop.op_next = Nullop;
1957 myop.op_type = OP_ENTEREVAL;
1958 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1959 (flags & G_ARRAY) ? OPf_WANT_LIST :
1961 if (flags & G_KEEPERR)
1962 myop.op_flags |= OPf_SPECIAL;
1964 #ifdef PERL_FLEXIBLE_EXCEPTIONS
1966 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_body),
1973 #ifndef PERL_FLEXIBLE_EXCEPTIONS
1975 call_body((OP*)&myop,TRUE);
1977 retval = PL_stack_sp - (PL_stack_base + oldmark);
1978 if (!(flags & G_KEEPERR))
1985 /* my_exit() was called */
1986 PL_curstash = PL_defstash;
1989 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
1990 Perl_croak(aTHX_ "Callback called exit");
1995 PL_op = PL_restartop;
1999 PL_stack_sp = PL_stack_base + oldmark;
2000 if (flags & G_ARRAY)
2004 *++PL_stack_sp = &PL_sv_undef;
2010 if (flags & G_DISCARD) {
2011 PL_stack_sp = PL_stack_base + oldmark;
2021 =for apidoc p||eval_pv
2023 Tells Perl to C<eval> the given string and return an SV* result.
2029 Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
2032 SV* sv = newSVpv(p, 0);
2034 eval_sv(sv, G_SCALAR);
2041 if (croak_on_error && SvTRUE(ERRSV)) {
2043 Perl_croak(aTHX_ SvPVx(ERRSV, n_a));
2049 /* Require a module. */
2052 =head1 Embedding Functions
2054 =for apidoc p||require_pv
2056 Tells Perl to C<require> the file named by the string argument. It is
2057 analogous to the Perl code C<eval "require '$file'">. It's even
2058 implemented that way; consider using Perl_load_module instead.
2063 Perl_require_pv(pTHX_ const char *pv)
2067 PUSHSTACKi(PERLSI_REQUIRE);
2069 sv = sv_newmortal();
2070 sv_setpv(sv, "require '");
2073 eval_sv(sv, G_DISCARD);
2079 Perl_magicname(pTHX_ char *sym, char *name, I32 namlen)
2083 if ((gv = gv_fetchpv(sym,TRUE, SVt_PV)))
2084 sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, namlen);
2088 S_usage(pTHX_ char *name) /* XXX move this out into a module ? */
2090 /* This message really ought to be max 23 lines.
2091 * Removed -h because the user already knows that option. Others? */
2093 static char *usage_msg[] = {
2094 "-0[octal] specify record separator (\\0, if no argument)",
2095 "-a autosplit mode with -n or -p (splits $_ into @F)",
2096 "-C enable native wide character system interfaces",
2097 "-c check syntax only (runs BEGIN and CHECK blocks)",
2098 "-d[:debugger] run program under debugger",
2099 "-D[number/list] set debugging flags (argument is a bit mask or alphabets)",
2100 "-e 'command' one line of program (several -e's allowed, omit programfile)",
2101 "-F/pattern/ split() pattern for -a switch (//'s are optional)",
2102 "-i[extension] edit <> files in place (makes backup if extension supplied)",
2103 "-Idirectory specify @INC/#include directory (several -I's allowed)",
2104 "-l[octal] enable line ending processing, specifies line terminator",
2105 "-[mM][-]module execute `use/no module...' before executing program",
2106 "-n assume 'while (<>) { ... }' loop around program",
2107 "-p assume loop like -n but print line also, like sed",
2108 "-P run program through C preprocessor before compilation",
2109 "-s enable rudimentary parsing for switches after programfile",
2110 "-S look for programfile using PATH environment variable",
2111 "-T enable tainting checks",
2112 "-t enable tainting warnings",
2113 "-u dump core after parsing program",
2114 "-U allow unsafe operations",
2115 "-v print version, subversion (includes VERY IMPORTANT perl info)",
2116 "-V[:variable] print configuration summary (or a single Config.pm variable)",
2117 "-w enable many useful warnings (RECOMMENDED)",
2118 "-W enable all warnings",
2119 "-X disable all warnings",
2120 "-x[directory] strip off text before #!perl line and perhaps cd to directory",
2124 char **p = usage_msg;
2126 PerlIO_printf(PerlIO_stdout(),
2127 "\nUsage: %s [switches] [--] [programfile] [arguments]",
2130 PerlIO_printf(PerlIO_stdout(), "\n %s", *p++);
2133 /* This routine handles any switches that can be given during run */
2136 Perl_moreswitches(pTHX_ char *s)
2146 rschar = (U32)grok_oct(s, &numlen, &flags, NULL);
2147 SvREFCNT_dec(PL_rs);
2148 if (rschar & ~((U8)~0))
2149 PL_rs = &PL_sv_undef;
2150 else if (!rschar && numlen >= 2)
2151 PL_rs = newSVpvn("", 0);
2153 char ch = (char)rschar;
2154 PL_rs = newSVpvn(&ch, 1);
2159 PL_widesyscalls = TRUE;
2165 while (*s && !isSPACE(*s)) ++s;
2167 PL_splitstr = savepv(PL_splitstr);
2180 /* The following permits -d:Mod to accepts arguments following an =
2181 in the fashion that -MSome::Mod does. */
2182 if (*s == ':' || *s == '=') {
2185 sv = newSVpv("use Devel::", 0);
2187 /* We now allow -d:Module=Foo,Bar */
2188 while(isALNUM(*s) || *s==':') ++s;
2190 sv_catpv(sv, start);
2192 sv_catpvn(sv, start, s-start);
2193 sv_catpv(sv, " split(/,/,q{");
2198 my_setenv("PERL5DB", SvPV(sv, PL_na));
2201 PL_perldb = PERLDB_ALL;
2209 if (isALPHA(s[1])) {
2210 /* if adding extra options, remember to update DEBUG_MASK */
2211 static char debopts[] = "psltocPmfrxu HXDSTRJvC";
2214 for (s++; *s && (d = strchr(debopts,*s)); s++)
2215 PL_debug |= 1 << (d - debopts);
2218 PL_debug = atoi(s+1);
2219 for (s++; isDIGIT(*s); s++) ;
2222 if (DEBUG_p_TEST_ && ckWARN_d(WARN_DEBUGGING))
2223 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
2224 "-Dp not implemented on this platform\n");
2226 PL_debug |= DEBUG_TOP_FLAG;
2227 #else /* !DEBUGGING */
2228 if (ckWARN_d(WARN_DEBUGGING))
2229 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
2230 "Recompile perl with -DDEBUGGING to use -D switch\n");
2231 for (s++; isALNUM(*s); s++) ;
2237 usage(PL_origargv[0]);
2241 Safefree(PL_inplace);
2242 #if defined(__CYGWIN__) /* do backup extension automagically */
2243 if (*(s+1) == '\0') {
2244 PL_inplace = savepv(".bak");
2247 #endif /* __CYGWIN__ */
2248 PL_inplace = savepv(s+1);
2250 for (s = PL_inplace; *s && !isSPACE(*s); s++) ;
2253 if (*s == '-') /* Additional switches on #! line. */
2257 case 'I': /* -I handled both here and in parse_body() */
2260 while (*s && isSPACE(*s))
2265 /* ignore trailing spaces (possibly followed by other switches) */
2267 for (e = p; *e && !isSPACE(*e); e++) ;
2271 } while (*p && *p != '-');
2272 e = savepvn(s, e-s);
2273 incpush(e, TRUE, TRUE);
2280 Perl_croak(aTHX_ "No directory specified for -I");
2286 SvREFCNT_dec(PL_ors_sv);
2291 PL_ors_sv = newSVpvn("\n",1);
2292 numlen = 3 + (*s == '0');
2293 *SvPVX(PL_ors_sv) = (char)grok_oct(s, &numlen, &flags, NULL);
2297 if (RsPARA(PL_rs)) {
2298 PL_ors_sv = newSVpvn("\n\n",2);
2301 PL_ors_sv = newSVsv(PL_rs);
2306 forbid_setid("-M"); /* XXX ? */
2309 forbid_setid("-m"); /* XXX ? */
2314 /* -M-foo == 'no foo' */
2315 if (*s == '-') { use = "no "; ++s; }
2316 sv = newSVpv(use,0);
2318 /* We allow -M'Module qw(Foo Bar)' */
2319 while(isALNUM(*s) || *s==':') ++s;
2321 sv_catpv(sv, start);
2322 if (*(start-1) == 'm') {
2324 Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
2325 sv_catpv( sv, " ()");
2329 Perl_croak(aTHX_ "Module name required with -%c option",
2331 sv_catpvn(sv, start, s-start);
2332 sv_catpv(sv, " split(/,/,q{");
2338 PL_preambleav = newAV();
2339 av_push(PL_preambleav, sv);
2342 Perl_croak(aTHX_ "No space allowed after -%c", *(s-1));
2354 PL_doswitches = TRUE;
2359 Perl_croak(aTHX_ "Too late for \"-t\" option");
2364 Perl_croak(aTHX_ "Too late for \"-T\" option");
2368 #ifdef MACOS_TRADITIONAL
2369 Perl_croak(aTHX_ "Believe me, you don't want to use \"-u\" on a Macintosh");
2371 PL_do_undump = TRUE;
2380 PerlIO_printf(PerlIO_stdout(),
2381 Perl_form(aTHX_ "\nThis is perl, v%"VDf" built for %s",
2382 PL_patchlevel, ARCHNAME));
2384 /* Adjust verbose output as in the perl that ships with the DG/UX OS from EMC */
2385 PerlIO_printf(PerlIO_stdout(),
2386 Perl_form(aTHX_ "\nThis is perl, version %vd\n", PL_patchlevel));
2387 PerlIO_printf(PerlIO_stdout(),
2388 Perl_form(aTHX_ " built under %s at %s %s\n",
2389 OSNAME, __DATE__, __TIME__));
2390 PerlIO_printf(PerlIO_stdout(),
2391 Perl_form(aTHX_ " OS Specific Release: %s\n",
2395 #if defined(LOCAL_PATCH_COUNT)
2396 if (LOCAL_PATCH_COUNT > 0)
2397 PerlIO_printf(PerlIO_stdout(),
2398 "\n(with %d registered patch%s, "
2399 "see perl -V for more detail)",
2400 (int)LOCAL_PATCH_COUNT,
2401 (LOCAL_PATCH_COUNT!=1) ? "es" : "");
2404 PerlIO_printf(PerlIO_stdout(),
2405 "\n\nCopyright 1987-2002, Larry Wall\n");
2406 #ifdef MACOS_TRADITIONAL
2407 PerlIO_printf(PerlIO_stdout(),
2408 "\nMac OS port Copyright 1991-2002, Matthias Neeracher;\n"
2409 "maintained by Chris Nandor\n");
2412 PerlIO_printf(PerlIO_stdout(),
2413 "\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
2416 PerlIO_printf(PerlIO_stdout(),
2417 "djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n"
2418 "djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
2421 PerlIO_printf(PerlIO_stdout(),
2422 "\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
2423 "Version 5 port Copyright (c) 1994-2002, Andreas Kaiser, Ilya Zakharevich\n");
2426 PerlIO_printf(PerlIO_stdout(),
2427 "atariST series port, ++jrb bammi@cadence.com\n");
2430 PerlIO_printf(PerlIO_stdout(),
2431 "BeOS port Copyright Tom Spindler, 1997-1999\n");
2434 PerlIO_printf(PerlIO_stdout(),
2435 "MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-2002\n");
2438 PerlIO_printf(PerlIO_stdout(),
2439 "MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
2442 PerlIO_printf(PerlIO_stdout(),
2443 "Stratus VOS port by Paul.Green@stratus.com, 1997-2002\n");
2446 PerlIO_printf(PerlIO_stdout(),
2447 "VM/ESA port by Neale Ferguson, 1998-1999\n");
2450 PerlIO_printf(PerlIO_stdout(),
2451 "BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
2454 PerlIO_printf(PerlIO_stdout(),
2455 "MiNT port by Guido Flohr, 1997-1999\n");
2458 PerlIO_printf(PerlIO_stdout(),
2459 "EPOC port by Olaf Flebbe, 1999-2002\n");
2462 printf("WINCE port by Rainer Keuchel, 2001-2002\n");
2463 printf("Built on " __DATE__ " " __TIME__ "\n\n");
2466 #ifdef BINARY_BUILD_NOTICE
2467 BINARY_BUILD_NOTICE;
2469 PerlIO_printf(PerlIO_stdout(),
2471 Perl may be copied only under the terms of either the Artistic License or the\n\
2472 GNU General Public License, which may be found in the Perl 5 source kit.\n\n\
2473 Complete documentation for Perl, including FAQ lists, should be found on\n\
2474 this system using `man perl' or `perldoc perl'. If you have access to the\n\
2475 Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
2478 if (! (PL_dowarn & G_WARN_ALL_MASK))
2479 PL_dowarn |= G_WARN_ON;
2483 PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
2484 if (!specialWARN(PL_compiling.cop_warnings))
2485 SvREFCNT_dec(PL_compiling.cop_warnings);
2486 PL_compiling.cop_warnings = pWARN_ALL ;
2490 PL_dowarn = G_WARN_ALL_OFF;
2491 if (!specialWARN(PL_compiling.cop_warnings))
2492 SvREFCNT_dec(PL_compiling.cop_warnings);
2493 PL_compiling.cop_warnings = pWARN_NONE ;
2498 if (s[1] == '-') /* Additional switches on #! line. */
2503 #if defined(WIN32) || !defined(PERL_STRICT_CR)
2509 #ifdef ALTERNATE_SHEBANG
2510 case 'S': /* OS/2 needs -S on "extproc" line. */
2518 Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
2523 /* compliments of Tom Christiansen */
2525 /* unexec() can be found in the Gnu emacs distribution */
2526 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
2529 Perl_my_unexec(pTHX)
2537 prog = newSVpv(BIN_EXP, 0);
2538 sv_catpv(prog, "/perl");
2539 file = newSVpv(PL_origfilename, 0);
2540 sv_catpv(file, ".perldump");
2542 unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
2543 /* unexec prints msg to stderr in case of failure */
2544 PerlProc_exit(status);
2547 # include <lib$routines.h>
2548 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
2550 ABORT(); /* for use with undump */
2555 /* initialize curinterp */
2561 # define PERLVAR(var,type)
2562 # define PERLVARA(var,n,type)
2563 # if defined(PERL_IMPLICIT_CONTEXT)
2564 # if defined(USE_5005THREADS)
2565 # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
2566 # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
2567 # else /* !USE_5005THREADS */
2568 # define PERLVARI(var,type,init) aTHX->var = init;
2569 # define PERLVARIC(var,type,init) aTHX->var = init;
2570 # endif /* USE_5005THREADS */
2572 # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
2573 # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
2575 # include "intrpvar.h"
2576 # ifndef USE_5005THREADS
2577 # include "thrdvar.h"
2584 # define PERLVAR(var,type)
2585 # define PERLVARA(var,n,type)
2586 # define PERLVARI(var,type,init) PL_##var = init;
2587 # define PERLVARIC(var,type,init) PL_##var = init;
2588 # include "intrpvar.h"
2589 # ifndef USE_5005THREADS
2590 # include "thrdvar.h"
2601 S_init_main_stash(pTHX)
2605 PL_curstash = PL_defstash = newHV();
2606 PL_curstname = newSVpvn("main",4);
2607 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
2608 SvREFCNT_dec(GvHV(gv));
2609 GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
2611 HvNAME(PL_defstash) = savepv("main");
2612 PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
2613 GvMULTI_on(PL_incgv);
2614 PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
2615 GvMULTI_on(PL_hintgv);
2616 PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
2617 PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
2618 GvMULTI_on(PL_errgv);
2619 PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
2620 GvMULTI_on(PL_replgv);
2621 (void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */
2622 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
2623 sv_setpvn(ERRSV, "", 0);
2624 PL_curstash = PL_defstash;
2625 CopSTASH_set(&PL_compiling, PL_defstash);
2626 PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
2627 PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
2628 /* We must init $/ before switches are processed. */
2629 sv_setpvn(get_sv("/", TRUE), "\n", 1);
2633 S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
2637 char *cpp_discard_flag;
2643 PL_origfilename = savepv("-e");
2646 /* if find_script() returns, it returns a malloc()-ed value */
2647 PL_origfilename = scriptname = find_script(scriptname, dosearch, NULL, 1);
2649 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
2650 char *s = scriptname + 8;
2651 *fdscript = atoi(s);
2655 scriptname = savepv(s + 1);
2656 Safefree(PL_origfilename);
2657 PL_origfilename = scriptname;
2662 CopFILE_free(PL_curcop);
2663 CopFILE_set(PL_curcop, PL_origfilename);
2664 if (strEQ(PL_origfilename,"-"))
2666 if (*fdscript >= 0) {
2667 PL_rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE);
2668 # if defined(HAS_FCNTL) && defined(F_SETFD)
2670 /* ensure close-on-exec */
2671 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
2674 else if (PL_preprocess) {
2675 char *cpp_cfg = CPPSTDIN;
2676 SV *cpp = newSVpvn("",0);
2677 SV *cmd = NEWSV(0,0);
2679 if (strEQ(cpp_cfg, "cppstdin"))
2680 Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
2681 sv_catpv(cpp, cpp_cfg);
2684 sv_catpvn(sv, "-I", 2);
2685 sv_catpv(sv,PRIVLIB_EXP);
2688 DEBUG_P(PerlIO_printf(Perl_debug_log,
2689 "PL_preprocess: scriptname=\"%s\", cpp=\"%s\", sv=\"%s\", CPPMINUS=\"%s\"\n",
2690 scriptname, SvPVX (cpp), SvPVX (sv), CPPMINUS));
2692 # if defined(MSDOS) || defined(WIN32) || defined(VMS)
2699 cpp_discard_flag = "";
2701 cpp_discard_flag = "-C";
2705 perl = os2_execname(aTHX);
2707 perl = PL_origargv[0];
2711 /* This strips off Perl comments which might interfere with
2712 the C pre-processor, including #!. #line directives are
2713 deliberately stripped to avoid confusion with Perl's version
2714 of #line. FWP played some golf with it so it will fit
2715 into VMS's 255 character buffer.
2718 code = "(1../^#!.*perl/i)|/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print";
2720 code = "/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print";
2722 Perl_sv_setpvf(aTHX_ cmd, "\
2723 %s -ne%s%s%s %s | %"SVf" %s %"SVf" %s",
2724 perl, quote, code, quote, scriptname, cpp,
2725 cpp_discard_flag, sv, CPPMINUS);
2727 PL_doextract = FALSE;
2728 # ifdef IAMSUID /* actually, this is caught earlier */
2729 if (PL_euid != PL_uid && !PL_euid) { /* if running suidperl */
2731 (void)seteuid(PL_uid); /* musn't stay setuid root */
2733 # ifdef HAS_SETREUID
2734 (void)setreuid((Uid_t)-1, PL_uid);
2736 # ifdef HAS_SETRESUID
2737 (void)setresuid((Uid_t)-1, PL_uid, (Uid_t)-1);
2739 PerlProc_setuid(PL_uid);
2743 if (PerlProc_geteuid() != PL_uid)
2744 Perl_croak(aTHX_ "Can't do seteuid!\n");
2746 # endif /* IAMSUID */
2748 DEBUG_P(PerlIO_printf(Perl_debug_log,
2749 "PL_preprocess: cmd=\"%s\"\n",
2752 PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
2756 else if (!*scriptname) {
2757 forbid_setid("program input from stdin");
2758 PL_rsfp = PerlIO_stdin();
2761 PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
2762 # if defined(HAS_FCNTL) && defined(F_SETFD)
2764 /* ensure close-on-exec */
2765 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
2770 # ifndef IAMSUID /* in case script is not readable before setuid */
2772 PerlLIO_stat(CopFILE(PL_curcop),&PL_statbuf) >= 0 &&
2773 PL_statbuf.st_mode & (S_ISUID|S_ISGID))
2776 PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT,
2777 BIN_EXP, (int)PERL_REVISION,
2779 (int)PERL_SUBVERSION), PL_origargv);
2780 Perl_croak(aTHX_ "Can't do setuid\n");
2786 Perl_croak(aTHX_ "Can't open perl script: %s\n",
2789 Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
2790 CopFILE(PL_curcop), Strerror(errno));
2796 * I_SYSSTATVFS HAS_FSTATVFS
2798 * I_STATFS HAS_FSTATFS HAS_GETFSSTAT
2799 * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT
2800 * here so that metaconfig picks them up. */
2804 S_fd_on_nosuid_fs(pTHX_ int fd)
2806 int check_okay = 0; /* able to do all the required sys/libcalls */
2807 int on_nosuid = 0; /* the fd is on a nosuid fs */
2809 * Preferred order: fstatvfs(), fstatfs(), ustat()+getmnt(), getmntent().
2810 * fstatvfs() is UNIX98.
2811 * fstatfs() is 4.3 BSD.
2812 * ustat()+getmnt() is pre-4.3 BSD.
2813 * getmntent() is O(number-of-mounted-filesystems) and can hang on
2814 * an irrelevant filesystem while trying to reach the right one.
2817 #undef FD_ON_NOSUID_CHECK_OKAY /* found the syscalls to do the check? */
2819 # if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
2820 defined(HAS_FSTATVFS)
2821 # define FD_ON_NOSUID_CHECK_OKAY
2822 struct statvfs stfs;
2824 check_okay = fstatvfs(fd, &stfs) == 0;
2825 on_nosuid = check_okay && (stfs.f_flag & ST_NOSUID);
2826 # endif /* fstatvfs */
2828 # if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
2829 defined(PERL_MOUNT_NOSUID) && \
2830 defined(HAS_FSTATFS) && \
2831 defined(HAS_STRUCT_STATFS) && \
2832 defined(HAS_STRUCT_STATFS_F_FLAGS)
2833 # define FD_ON_NOSUID_CHECK_OKAY
2836 check_okay = fstatfs(fd, &stfs) == 0;
2837 on_nosuid = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
2838 # endif /* fstatfs */
2840 # if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
2841 defined(PERL_MOUNT_NOSUID) && \
2842 defined(HAS_FSTAT) && \
2843 defined(HAS_USTAT) && \
2844 defined(HAS_GETMNT) && \
2845 defined(HAS_STRUCT_FS_DATA) && \
2847 # define FD_ON_NOSUID_CHECK_OKAY
2850 if (fstat(fd, &fdst) == 0) {
2852 if (ustat(fdst.st_dev, &us) == 0) {
2854 /* NOSTAT_ONE here because we're not examining fields which
2855 * vary between that case and STAT_ONE. */
2856 if (getmnt((int*)0, &fsd, (int)0, NOSTAT_ONE, us.f_fname) == 0) {
2857 size_t cmplen = sizeof(us.f_fname);
2858 if (sizeof(fsd.fd_req.path) < cmplen)
2859 cmplen = sizeof(fsd.fd_req.path);
2860 if (strnEQ(fsd.fd_req.path, us.f_fname, cmplen) &&
2861 fdst.st_dev == fsd.fd_req.dev) {
2863 on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID;
2869 # endif /* fstat+ustat+getmnt */
2871 # if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
2872 defined(HAS_GETMNTENT) && \
2873 defined(HAS_HASMNTOPT) && \
2874 defined(MNTOPT_NOSUID)
2875 # define FD_ON_NOSUID_CHECK_OKAY
2876 FILE *mtab = fopen("/etc/mtab", "r");
2877 struct mntent *entry;
2880 if (mtab && (fstat(fd, &stb) == 0)) {
2881 while (entry = getmntent(mtab)) {
2882 if (stat(entry->mnt_dir, &fsb) == 0
2883 && fsb.st_dev == stb.st_dev)
2885 /* found the filesystem */
2887 if (hasmntopt(entry, MNTOPT_NOSUID))
2890 } /* A single fs may well fail its stat(). */
2895 # endif /* getmntent+hasmntopt */
2898 Perl_croak(aTHX_ "Can't check filesystem of script \"%s\" for nosuid", PL_origfilename);
2901 #endif /* IAMSUID */
2904 S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript)
2910 /* do we need to emulate setuid on scripts? */
2912 /* This code is for those BSD systems that have setuid #! scripts disabled
2913 * in the kernel because of a security problem. Merely defining DOSUID
2914 * in perl will not fix that problem, but if you have disabled setuid
2915 * scripts in the kernel, this will attempt to emulate setuid and setgid
2916 * on scripts that have those now-otherwise-useless bits set. The setuid
2917 * root version must be called suidperl or sperlN.NNN. If regular perl
2918 * discovers that it has opened a setuid script, it calls suidperl with
2919 * the same argv that it had. If suidperl finds that the script it has
2920 * just opened is NOT setuid root, it sets the effective uid back to the
2921 * uid. We don't just make perl setuid root because that loses the
2922 * effective uid we had before invoking perl, if it was different from the
2925 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
2926 * be defined in suidperl only. suidperl must be setuid root. The
2927 * Configure script will set this up for you if you want it.
2933 if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */
2934 Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
2935 if (fdscript < 0 && PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
2940 #ifndef HAS_SETREUID
2941 /* On this access check to make sure the directories are readable,
2942 * there is actually a small window that the user could use to make
2943 * filename point to an accessible directory. So there is a faint
2944 * chance that someone could execute a setuid script down in a
2945 * non-accessible directory. I don't know what to do about that.
2946 * But I don't think it's too important. The manual lies when
2947 * it says access() is useful in setuid programs.
2949 if (PerlLIO_access(CopFILE(PL_curcop),1)) /*double check*/
2950 Perl_croak(aTHX_ "Permission denied");
2952 /* If we can swap euid and uid, then we can determine access rights
2953 * with a simple stat of the file, and then compare device and
2954 * inode to make sure we did stat() on the same file we opened.
2955 * Then we just have to make sure he or she can execute it.
2962 setreuid(PL_euid,PL_uid) < 0
2965 setresuid(PL_euid,PL_uid,(Uid_t)-1) < 0
2968 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
2969 Perl_croak(aTHX_ "Can't swap uid and euid"); /* really paranoid */
2970 if (PerlLIO_stat(CopFILE(PL_curcop),&tmpstatbuf) < 0)
2971 Perl_croak(aTHX_ "Permission denied"); /* testing full pathname here */
2972 #if defined(IAMSUID) && !defined(NO_NOSUID_CHECK)
2973 if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp)))
2974 Perl_croak(aTHX_ "Permission denied");
2976 if (tmpstatbuf.st_dev != PL_statbuf.st_dev ||
2977 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
2978 (void)PerlIO_close(PL_rsfp);
2979 Perl_croak(aTHX_ "Permission denied\n");
2983 setreuid(PL_uid,PL_euid) < 0
2985 # if defined(HAS_SETRESUID)
2986 setresuid(PL_uid,PL_euid,(Uid_t)-1) < 0
2989 || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
2990 Perl_croak(aTHX_ "Can't reswap uid and euid");
2991 if (!cando(S_IXUSR,FALSE,&PL_statbuf)) /* can real uid exec? */
2992 Perl_croak(aTHX_ "Permission denied\n");
2994 #endif /* HAS_SETREUID */
2995 #endif /* IAMSUID */
2997 if (!S_ISREG(PL_statbuf.st_mode))
2998 Perl_croak(aTHX_ "Permission denied");
2999 if (PL_statbuf.st_mode & S_IWOTH)
3000 Perl_croak(aTHX_ "Setuid/gid script is writable by world");
3001 PL_doswitches = FALSE; /* -s is insecure in suid */
3002 CopLINE_inc(PL_curcop);
3003 if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
3004 strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */
3005 Perl_croak(aTHX_ "No #! line");
3006 s = SvPV(PL_linestr,n_a)+2;
3008 while (!isSPACE(*s)) s++;
3009 for (s2 = s; (s2 > SvPV(PL_linestr,n_a)+2 &&
3010 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
3011 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
3012 Perl_croak(aTHX_ "Not a perl script");
3013 while (*s == ' ' || *s == '\t') s++;
3015 * #! arg must be what we saw above. They can invoke it by
3016 * mentioning suidperl explicitly, but they may not add any strange
3017 * arguments beyond what #! says if they do invoke suidperl that way.
3019 len = strlen(validarg);
3020 if (strEQ(validarg," PHOOEY ") ||
3021 strnNE(s,validarg,len) || !isSPACE(s[len]))
3022 Perl_croak(aTHX_ "Args must match #! line");
3025 if (PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
3026 PL_euid == PL_statbuf.st_uid)
3028 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
3029 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
3030 #endif /* IAMSUID */
3032 if (PL_euid) { /* oops, we're not the setuid root perl */
3033 (void)PerlIO_close(PL_rsfp);
3036 PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
3037 (int)PERL_REVISION, (int)PERL_VERSION,
3038 (int)PERL_SUBVERSION), PL_origargv);
3040 Perl_croak(aTHX_ "Can't do setuid\n");
3043 if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
3045 (void)setegid(PL_statbuf.st_gid);
3048 (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
3050 #ifdef HAS_SETRESGID
3051 (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
3053 PerlProc_setgid(PL_statbuf.st_gid);
3057 if (PerlProc_getegid() != PL_statbuf.st_gid)
3058 Perl_croak(aTHX_ "Can't do setegid!\n");
3060 if (PL_statbuf.st_mode & S_ISUID) {
3061 if (PL_statbuf.st_uid != PL_euid)
3063 (void)seteuid(PL_statbuf.st_uid); /* all that for this */
3066 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
3068 #ifdef HAS_SETRESUID
3069 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
3071 PerlProc_setuid(PL_statbuf.st_uid);
3075 if (PerlProc_geteuid() != PL_statbuf.st_uid)
3076 Perl_croak(aTHX_ "Can't do seteuid!\n");
3078 else if (PL_uid) { /* oops, mustn't run as root */
3080 (void)seteuid((Uid_t)PL_uid);
3083 (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
3085 #ifdef HAS_SETRESUID
3086 (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
3088 PerlProc_setuid((Uid_t)PL_uid);
3092 if (PerlProc_geteuid() != PL_uid)
3093 Perl_croak(aTHX_ "Can't do seteuid!\n");
3096 if (!cando(S_IXUSR,TRUE,&PL_statbuf))
3097 Perl_croak(aTHX_ "Permission denied\n"); /* they can't do this */
3100 else if (PL_preprocess)
3101 Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
3102 else if (fdscript >= 0)
3103 Perl_croak(aTHX_ "fd script not allowed in suidperl\n");
3105 Perl_croak(aTHX_ "Script is not setuid/setgid in suidperl\n");
3107 /* We absolutely must clear out any saved ids here, so we */
3108 /* exec the real perl, substituting fd script for scriptname. */
3109 /* (We pass script name as "subdir" of fd, which perl will grok.) */
3110 PerlIO_rewind(PL_rsfp);
3111 PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0); /* just in case rewind didn't */
3112 for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
3113 if (!PL_origargv[which])
3114 Perl_croak(aTHX_ "Permission denied");
3115 PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
3116 PerlIO_fileno(PL_rsfp), PL_origargv[which]));
3117 #if defined(HAS_FCNTL) && defined(F_SETFD)
3118 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */
3120 PerlProc_execv(Perl_form(aTHX_ "%s/perl"PERL_FS_VER_FMT, BIN_EXP,
3121 (int)PERL_REVISION, (int)PERL_VERSION,
3122 (int)PERL_SUBVERSION), PL_origargv);/* try again */
3123 Perl_croak(aTHX_ "Can't do setuid\n");
3124 #endif /* IAMSUID */
3126 if (PL_euid != PL_uid || PL_egid != PL_gid) { /* (suidperl doesn't exist, in fact) */
3127 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
3128 PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf); /* may be either wrapped or real suid */
3129 if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
3131 (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
3134 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
3135 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
3136 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
3137 /* not set-id, must be wrapped */
3143 S_find_beginning(pTHX)
3145 register char *s, *s2;
3146 #ifdef MACOS_TRADITIONAL
3150 /* skip forward in input to the real script? */
3153 #ifdef MACOS_TRADITIONAL
3154 /* Since the Mac OS does not honor #! arguments for us, we do it ourselves */
3156 while (PL_doextract || gMacPerl_AlwaysExtract) {
3157 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
3158 if (!gMacPerl_AlwaysExtract)
3159 Perl_croak(aTHX_ "No Perl script found in input\n");
3161 if (PL_doextract) /* require explicit override ? */
3162 if (!OverrideExtract(PL_origfilename))
3163 Perl_croak(aTHX_ "User aborted script\n");
3165 PL_doextract = FALSE;
3167 /* Pater peccavi, file does not have #! */
3168 PerlIO_rewind(PL_rsfp);
3173 while (PL_doextract) {
3174 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
3175 Perl_croak(aTHX_ "No Perl script found in input\n");
3178 if (*s == '#' && s[1] == '!' && ((s = instr(s,"perl")) || (s = instr(s2,"PERL")))) {
3179 PerlIO_ungetc(PL_rsfp, '\n'); /* to keep line count right */
3180 PL_doextract = FALSE;
3181 while (*s && !(isSPACE (*s) || *s == '#')) s++;
3183 while (*s == ' ' || *s == '\t') s++;
3185 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
3186 if (strnEQ(s2-4,"perl",4))
3188 while ((s = moreswitches(s)))
3191 #ifdef MACOS_TRADITIONAL
3192 /* We are always searching for the #!perl line in MacPerl,
3193 * so if we find it, still keep the line count correct
3194 * by counting lines we already skipped over
3196 for (; maclines > 0 ; maclines--)
3197 PerlIO_ungetc(PL_rsfp, '\n');
3201 /* gMacPerl_AlwaysExtract is false in MPW tool */
3202 } else if (gMacPerl_AlwaysExtract) {
3213 PL_uid = PerlProc_getuid();
3214 PL_euid = PerlProc_geteuid();
3215 PL_gid = PerlProc_getgid();
3216 PL_egid = PerlProc_getegid();
3218 PL_uid |= PL_gid << 16;
3219 PL_euid |= PL_egid << 16;
3221 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
3225 S_forbid_setid(pTHX_ char *s)
3227 if (PL_euid != PL_uid)
3228 Perl_croak(aTHX_ "No %s allowed while running setuid", s);
3229 if (PL_egid != PL_gid)
3230 Perl_croak(aTHX_ "No %s allowed while running setgid", s);
3234 Perl_init_debugger(pTHX)
3236 HV *ostash = PL_curstash;
3238 PL_curstash = PL_debstash;
3239 PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
3240 AvREAL_off(PL_dbargs);
3241 PL_DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
3242 PL_DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
3243 PL_DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
3244 sv_upgrade(GvSV(PL_DBsub), SVt_IV); /* IVX accessed if PERLDB_SUB_NN */
3245 PL_DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
3246 sv_setiv(PL_DBsingle, 0);
3247 PL_DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
3248 sv_setiv(PL_DBtrace, 0);
3249 PL_DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
3250 sv_setiv(PL_DBsignal, 0);
3251 PL_curstash = ostash;
3254 #ifndef STRESS_REALLOC
3255 #define REASONABLE(size) (size)
3257 #define REASONABLE(size) (1) /* unreasonable */
3261 Perl_init_stacks(pTHX)
3263 /* start with 128-item stack and 8K cxstack */
3264 PL_curstackinfo = new_stackinfo(REASONABLE(128),
3265 REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
3266 PL_curstackinfo->si_type = PERLSI_MAIN;
3267 PL_curstack = PL_curstackinfo->si_stack;
3268 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
3270 PL_stack_base = AvARRAY(PL_curstack);
3271 PL_stack_sp = PL_stack_base;
3272 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
3274 New(50,PL_tmps_stack,REASONABLE(128),SV*);
3277 PL_tmps_max = REASONABLE(128);
3279 New(54,PL_markstack,REASONABLE(32),I32);
3280 PL_markstack_ptr = PL_markstack;
3281 PL_markstack_max = PL_markstack + REASONABLE(32);
3285 New(54,PL_scopestack,REASONABLE(32),I32);
3286 PL_scopestack_ix = 0;
3287 PL_scopestack_max = REASONABLE(32);
3289 New(54,PL_savestack,REASONABLE(128),ANY);
3290 PL_savestack_ix = 0;
3291 PL_savestack_max = REASONABLE(128);
3293 New(54,PL_retstack,REASONABLE(16),OP*);
3295 PL_retstack_max = REASONABLE(16);
3303 while (PL_curstackinfo->si_next)
3304 PL_curstackinfo = PL_curstackinfo->si_next;
3305 while (PL_curstackinfo) {
3306 PERL_SI *p = PL_curstackinfo->si_prev;
3307 /* curstackinfo->si_stack got nuked by sv_free_arenas() */
3308 Safefree(PL_curstackinfo->si_cxstack);
3309 Safefree(PL_curstackinfo);
3310 PL_curstackinfo = p;
3312 Safefree(PL_tmps_stack);
3313 Safefree(PL_markstack);
3314 Safefree(PL_scopestack);
3315 Safefree(PL_savestack);
3316 Safefree(PL_retstack);
3325 lex_start(PL_linestr);
3327 PL_subname = newSVpvn("main",4);
3331 S_init_predump_symbols(pTHX)
3336 sv_setpvn(get_sv("\"", TRUE), " ", 1);
3337 PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
3338 GvMULTI_on(PL_stdingv);
3339 io = GvIOp(PL_stdingv);
3340 IoTYPE(io) = IoTYPE_RDONLY;
3341 IoIFP(io) = PerlIO_stdin();
3342 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
3344 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
3346 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
3349 IoTYPE(io) = IoTYPE_WRONLY;
3350 IoOFP(io) = IoIFP(io) = PerlIO_stdout();
3352 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
3354 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
3356 PL_stderrgv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
3357 GvMULTI_on(PL_stderrgv);
3358 io = GvIOp(PL_stderrgv);
3359 IoTYPE(io) = IoTYPE_WRONLY;
3360 IoOFP(io) = IoIFP(io) = PerlIO_stderr();
3361 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
3363 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
3365 PL_statname = NEWSV(66,0); /* last filename we did stat on */
3368 Safefree(PL_osname);
3369 PL_osname = savepv(OSNAME);
3373 Perl_init_argv_symbols(pTHX_ register int argc, register char **argv)
3376 argc--,argv++; /* skip name of script */
3377 if (PL_doswitches) {
3378 for (; argc > 0 && **argv == '-'; argc--,argv++) {
3381 if (argv[0][1] == '-' && !argv[0][2]) {
3385 if ((s = strchr(argv[0], '='))) {
3387 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
3390 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
3393 if ((PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV))) {
3394 GvMULTI_on(PL_argvgv);
3395 (void)gv_AVadd(PL_argvgv);
3396 av_clear(GvAVn(PL_argvgv));
3397 for (; argc > 0; argc--,argv++) {
3398 SV *sv = newSVpv(argv[0],0);
3399 av_push(GvAVn(PL_argvgv),sv);
3400 if (PL_widesyscalls)
3401 (void)sv_utf8_decode(sv);
3406 #ifdef HAS_PROCSELFEXE
3407 /* This is a function so that we don't hold on to MAXPATHLEN
3408 bytes of stack longer than necessary
3411 S_procself_val(pTHX_ SV *sv, char *arg0)
3413 char buf[MAXPATHLEN];
3414 int len = readlink(PROCSELFEXE_PATH, buf, sizeof(buf) - 1);
3416 /* On Playstation2 Linux V1.0 (kernel 2.2.1) readlink(/proc/self/exe)
3417 includes a spurious NUL which will cause $^X to fail in system
3418 or backticks (this will prevent extensions from being built and
3419 many tests from working). readlink is not meant to add a NUL.
3420 Normal readlink works fine.
3422 if (len > 0 && buf[len-1] == '\0') {
3426 /* FreeBSD's implementation is acknowledged to be imperfect, sometimes
3427 returning the text "unknown" from the readlink rather than the path
3428 to the executable (or returning an error from the readlink). Any valid
3429 path has a '/' in it somewhere, so use that to validate the result.
3430 See http://www.freebsd.org/cgi/query-pr.cgi?pr=35703
3432 if (len > 0 && memchr(buf, '/', len)) {
3433 sv_setpvn(sv,buf,len);
3439 #endif /* HAS_PROCSELFEXE */
3442 S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
3448 PL_toptarget = NEWSV(0,0);
3449 sv_upgrade(PL_toptarget, SVt_PVFM);
3450 sv_setpvn(PL_toptarget, "", 0);
3451 PL_bodytarget = NEWSV(0,0);
3452 sv_upgrade(PL_bodytarget, SVt_PVFM);
3453 sv_setpvn(PL_bodytarget, "", 0);
3454 PL_formtarget = PL_bodytarget;
3458 init_argv_symbols(argc,argv);
3460 if ((tmpgv = gv_fetchpv("0",TRUE, SVt_PV))) {
3461 #ifdef MACOS_TRADITIONAL
3462 /* $0 is not majick on a Mac */
3463 sv_setpv(GvSV(tmpgv),MacPerl_MPWFileName(PL_origfilename));
3465 sv_setpv(GvSV(tmpgv),PL_origfilename);
3466 magicname("0", "0", 1);
3469 if ((tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))) {/* $^X */
3470 #ifdef HAS_PROCSELFEXE
3471 S_procself_val(aTHX_ GvSV(tmpgv), PL_origargv[0]);
3474 sv_setpv(GvSV(tmpgv), os2_execname(aTHX));
3476 sv_setpv(GvSV(tmpgv),PL_origargv[0]);
3480 if ((PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV))) {
3482 GvMULTI_on(PL_envgv);
3483 hv = GvHVn(PL_envgv);
3484 hv_magic(hv, Nullgv, PERL_MAGIC_env);
3485 #ifdef USE_ENVIRON_ARRAY
3486 /* Note that if the supplied env parameter is actually a copy
3487 of the global environ then it may now point to free'd memory
3488 if the environment has been modified since. To avoid this
3489 problem we treat env==NULL as meaning 'use the default'
3494 # ifdef USE_ITHREADS
3495 && PL_curinterp == aTHX
3499 environ[0] = Nullch;
3502 for (; *env; env++) {
3503 if (!(s = strchr(*env,'=')))
3510 sv = newSVpv(s+1, 0);
3511 (void)hv_store(hv, *env, s - *env, sv, 0);
3515 #endif /* USE_ENVIRON_ARRAY */
3518 if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV))) {
3519 SvREADONLY_off(GvSV(tmpgv));
3520 sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
3521 SvREADONLY_on(GvSV(tmpgv));
3523 #ifdef THREADS_HAVE_PIDS
3524 PL_ppid = (IV)getppid();
3527 /* touch @F array to prevent spurious warnings 20020415 MJD */
3529 (void) get_av("main::F", TRUE | GV_ADDMULTI);
3531 /* touch @- and @+ arrays to prevent spurious warnings 20020415 MJD */
3532 (void) get_av("main::-", TRUE | GV_ADDMULTI);
3533 (void) get_av("main::+", TRUE | GV_ADDMULTI);
3537 S_init_perllib(pTHX)
3542 s = PerlEnv_getenv("PERL5LIB");
3544 incpush(s, TRUE, TRUE);
3546 incpush(PerlEnv_getenv("PERLLIB"), FALSE, FALSE);
3548 /* Treat PERL5?LIB as a possible search list logical name -- the
3549 * "natural" VMS idiom for a Unix path string. We allow each
3550 * element to be a set of |-separated directories for compatibility.
3554 if (my_trnlnm("PERL5LIB",buf,0))
3555 do { incpush(buf,TRUE,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
3557 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE,FALSE);
3561 /* Use the ~-expanded versions of APPLLIB (undocumented),
3562 ARCHLIB PRIVLIB SITEARCH SITELIB VENDORARCH and VENDORLIB
3565 incpush(APPLLIB_EXP, TRUE, TRUE);
3569 incpush(ARCHLIB_EXP, FALSE, FALSE);
3571 #ifdef MACOS_TRADITIONAL
3574 SV * privdir = NEWSV(55, 0);
3575 char * macperl = PerlEnv_getenv("MACPERL");
3580 Perl_sv_setpvf(aTHX_ privdir, "%slib:", macperl);
3581 if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
3582 incpush(SvPVX(privdir), TRUE, FALSE);
3583 Perl_sv_setpvf(aTHX_ privdir, "%ssite_perl:", macperl);
3584 if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
3585 incpush(SvPVX(privdir), TRUE, FALSE);
3587 SvREFCNT_dec(privdir);
3590 incpush(":", FALSE, FALSE);
3593 # define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
3596 incpush(PRIVLIB_EXP, TRUE, FALSE);
3598 incpush(PRIVLIB_EXP, FALSE, FALSE);
3602 /* sitearch is always relative to sitelib on Windows for
3603 * DLL-based path intuition to work correctly */
3604 # if !defined(WIN32)
3605 incpush(SITEARCH_EXP, FALSE, FALSE);
3611 incpush(SITELIB_EXP, TRUE, FALSE); /* this picks up sitearch as well */
3613 incpush(SITELIB_EXP, FALSE, FALSE);
3617 #ifdef SITELIB_STEM /* Search for version-specific dirs below here */
3618 incpush(SITELIB_STEM, FALSE, TRUE);
3621 #ifdef PERL_VENDORARCH_EXP
3622 /* vendorarch is always relative to vendorlib on Windows for
3623 * DLL-based path intuition to work correctly */
3624 # if !defined(WIN32)
3625 incpush(PERL_VENDORARCH_EXP, FALSE, FALSE);
3629 #ifdef PERL_VENDORLIB_EXP
3631 incpush(PERL_VENDORLIB_EXP, TRUE, FALSE); /* this picks up vendorarch as well */
3633 incpush(PERL_VENDORLIB_EXP, FALSE, FALSE);
3637 #ifdef PERL_VENDORLIB_STEM /* Search for version-specific dirs below here */
3638 incpush(PERL_VENDORLIB_STEM, FALSE, TRUE);
3641 #ifdef PERL_OTHERLIBDIRS
3642 incpush(PERL_OTHERLIBDIRS, TRUE, TRUE);
3646 incpush(".", FALSE, FALSE);
3647 #endif /* MACOS_TRADITIONAL */
3650 #if defined(DOSISH) || defined(EPOC)
3651 # define PERLLIB_SEP ';'
3654 # define PERLLIB_SEP '|'
3656 # if defined(MACOS_TRADITIONAL)
3657 # define PERLLIB_SEP ','
3659 # define PERLLIB_SEP ':'
3663 #ifndef PERLLIB_MANGLE
3664 # define PERLLIB_MANGLE(s,n) (s)
3668 S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers)
3670 SV *subdir = Nullsv;
3675 if (addsubdirs || addoldvers) {
3676 subdir = sv_newmortal();
3679 /* Break at all separators */
3681 SV *libdir = NEWSV(55,0);
3684 /* skip any consecutive separators */
3685 while ( *p == PERLLIB_SEP ) {
3686 /* Uncomment the next line for PATH semantics */
3687 /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */
3691 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
3692 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
3697 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
3698 p = Nullch; /* break out */
3700 #ifdef MACOS_TRADITIONAL
3701 if (!strchr(SvPVX(libdir), ':')) {
3704 sv_setpv(libdir, MacPerl_CanonDir(SvPVX(libdir), buf, 0));
3706 if (SvPVX(libdir)[SvCUR(libdir)-1] != ':')
3707 sv_catpv(libdir, ":");
3711 * BEFORE pushing libdir onto @INC we may first push version- and
3712 * archname-specific sub-directories.
3714 if (addsubdirs || addoldvers) {
3715 #ifdef PERL_INC_VERSION_LIST
3716 /* Configure terminates PERL_INC_VERSION_LIST with a NULL */
3717 const char *incverlist[] = { PERL_INC_VERSION_LIST };
3718 const char **incver;
3725 if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) {
3727 while (unix[len-1] == '/') len--; /* Cosmetic */
3728 sv_usepvn(libdir,unix,len);
3731 PerlIO_printf(Perl_error_log,
3732 "Failed to unixify @INC element \"%s\"\n",
3736 #ifdef MACOS_TRADITIONAL
3737 #define PERL_AV_SUFFIX_FMT ""
3738 #define PERL_ARCH_FMT "%s:"
3739 #define PERL_ARCH_FMT_PATH PERL_FS_VER_FMT PERL_AV_SUFFIX_FMT
3741 #define PERL_AV_SUFFIX_FMT "/"
3742 #define PERL_ARCH_FMT "/%s"
3743 #define PERL_ARCH_FMT_PATH PERL_AV_SUFFIX_FMT PERL_FS_VER_FMT
3745 /* .../version/archname if -d .../version/archname */
3746 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH PERL_ARCH_FMT,
3748 (int)PERL_REVISION, (int)PERL_VERSION,
3749 (int)PERL_SUBVERSION, ARCHNAME);
3750 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3751 S_ISDIR(tmpstatbuf.st_mode))
3752 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3754 /* .../version if -d .../version */
3755 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH, libdir,
3756 (int)PERL_REVISION, (int)PERL_VERSION,
3757 (int)PERL_SUBVERSION);
3758 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3759 S_ISDIR(tmpstatbuf.st_mode))
3760 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3762 /* .../archname if -d .../archname */
3763 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, ARCHNAME);
3764 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3765 S_ISDIR(tmpstatbuf.st_mode))
3766 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3769 #ifdef PERL_INC_VERSION_LIST
3771 for (incver = incverlist; *incver; incver++) {
3772 /* .../xxx if -d .../xxx */
3773 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, *incver);
3774 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3775 S_ISDIR(tmpstatbuf.st_mode))
3776 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3782 /* finally push this lib directory on the end of @INC */
3783 av_push(GvAVn(PL_incgv), libdir);
3787 #ifdef USE_5005THREADS
3788 STATIC struct perl_thread *
3789 S_init_main_thread(pTHX)
3791 #if !defined(PERL_IMPLICIT_CONTEXT)
3792 struct perl_thread *thr;
3796 Newz(53, thr, 1, struct perl_thread);
3797 PL_curcop = &PL_compiling;
3798 thr->interp = PERL_GET_INTERP;
3799 thr->cvcache = newHV();
3800 thr->threadsv = newAV();
3801 /* thr->threadsvp is set when find_threadsv is called */
3802 thr->specific = newAV();
3803 thr->flags = THRf_R_JOINABLE;
3804 MUTEX_INIT(&thr->mutex);
3805 /* Handcraft thrsv similarly to mess_sv */
3806 New(53, PL_thrsv, 1, SV);
3807 Newz(53, xpv, 1, XPV);
3808 SvFLAGS(PL_thrsv) = SVt_PV;
3809 SvANY(PL_thrsv) = (void*)xpv;
3810 SvREFCNT(PL_thrsv) = 1 << 30; /* practically infinite */
3811 SvPVX(PL_thrsv) = (char*)thr;
3812 SvCUR_set(PL_thrsv, sizeof(thr));
3813 SvLEN_set(PL_thrsv, sizeof(thr));
3814 *SvEND(PL_thrsv) = '\0'; /* in the trailing_nul field */
3815 thr->oursv = PL_thrsv;
3816 PL_chopset = " \n-";
3819 MUTEX_LOCK(&PL_threads_mutex);
3825 MUTEX_UNLOCK(&PL_threads_mutex);
3827 #ifdef HAVE_THREAD_INTERN
3828 Perl_init_thread_intern(thr);
3831 #ifdef SET_THREAD_SELF
3832 SET_THREAD_SELF(thr);
3834 thr->self = pthread_self();
3835 #endif /* SET_THREAD_SELF */
3839 * These must come after the thread self setting
3840 * because sv_setpvn does SvTAINT and the taint
3841 * fields thread selfness being set.
3843 PL_toptarget = NEWSV(0,0);
3844 sv_upgrade(PL_toptarget, SVt_PVFM);
3845 sv_setpvn(PL_toptarget, "", 0);
3846 PL_bodytarget = NEWSV(0,0);
3847 sv_upgrade(PL_bodytarget, SVt_PVFM);
3848 sv_setpvn(PL_bodytarget, "", 0);
3849 PL_formtarget = PL_bodytarget;
3850 thr->errsv = newSVpvn("", 0);
3851 (void) find_threadsv("@"); /* Ensure $@ is initialised early */
3854 PL_peepp = MEMBER_TO_FPTR(Perl_peep);
3855 PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
3856 PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
3857 PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
3858 PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
3859 PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
3861 PL_reginterp_cnt = 0;
3865 #endif /* USE_5005THREADS */
3868 Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
3871 line_t oldline = CopLINE(PL_curcop);
3877 while (AvFILL(paramList) >= 0) {
3878 cv = (CV*)av_shift(paramList);
3880 if (paramList == PL_beginav) {
3881 /* save PL_beginav for compiler */
3882 if (! PL_beginav_save)
3883 PL_beginav_save = newAV();
3884 av_push(PL_beginav_save, (SV*)cv);
3886 else if (paramList == PL_checkav) {
3887 /* save PL_checkav for compiler */
3888 if (! PL_checkav_save)
3889 PL_checkav_save = newAV();
3890 av_push(PL_checkav_save, (SV*)cv);
3895 #ifdef PERL_FLEXIBLE_EXCEPTIONS
3896 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_list_body), cv);
3902 #ifndef PERL_FLEXIBLE_EXCEPTIONS
3906 (void)SvPV(atsv, len);
3909 PL_curcop = &PL_compiling;
3910 CopLINE_set(PL_curcop, oldline);
3911 if (paramList == PL_beginav)
3912 sv_catpv(atsv, "BEGIN failed--compilation aborted");
3914 Perl_sv_catpvf(aTHX_ atsv,
3915 "%s failed--call queue aborted",
3916 paramList == PL_checkav ? "CHECK"
3917 : paramList == PL_initav ? "INIT"
3919 while (PL_scopestack_ix > oldscope)
3922 Perl_croak(aTHX_ "%s", SvPVx(atsv, n_a));
3929 /* my_exit() was called */
3930 while (PL_scopestack_ix > oldscope)
3933 PL_curstash = PL_defstash;
3934 PL_curcop = &PL_compiling;
3935 CopLINE_set(PL_curcop, oldline);
3937 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) {
3938 if (paramList == PL_beginav)
3939 Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
3941 Perl_croak(aTHX_ "%s failed--call queue aborted",
3942 paramList == PL_checkav ? "CHECK"
3943 : paramList == PL_initav ? "INIT"
3950 PL_curcop = &PL_compiling;
3951 CopLINE_set(PL_curcop, oldline);
3954 PerlIO_printf(Perl_error_log, "panic: restartop\n");
3962 #ifdef PERL_FLEXIBLE_EXCEPTIONS
3964 S_vcall_list_body(pTHX_ va_list args)
3966 CV *cv = va_arg(args, CV*);
3967 return call_list_body(cv);
3972 S_call_list_body(pTHX_ CV *cv)
3974 PUSHMARK(PL_stack_sp);
3975 call_sv((SV*)cv, G_EVAL|G_DISCARD);
3980 Perl_my_exit(pTHX_ U32 status)
3982 DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
3983 thr, (unsigned long) status));
3992 STATUS_NATIVE_SET(status);
3999 Perl_my_failure_exit(pTHX)
4002 if (vaxc$errno & 1) {
4003 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
4004 STATUS_NATIVE_SET(44);
4007 if (!vaxc$errno && errno) /* unlikely */
4008 STATUS_NATIVE_SET(44);
4010 STATUS_NATIVE_SET(vaxc$errno);
4015 STATUS_POSIX_SET(errno);
4017 exitstatus = STATUS_POSIX >> 8;
4018 if (exitstatus & 255)
4019 STATUS_POSIX_SET(exitstatus);
4021 STATUS_POSIX_SET(255);
4028 S_my_exit_jump(pTHX)
4030 register PERL_CONTEXT *cx;
4035 SvREFCNT_dec(PL_e_script);
4036 PL_e_script = Nullsv;
4039 POPSTACK_TO(PL_mainstack);
4040 if (cxstack_ix >= 0) {
4043 POPBLOCK(cx,PL_curpm);
4051 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen)
4054 p = SvPVX(PL_e_script);
4055 nl = strchr(p, '\n');
4056 nl = (nl) ? nl+1 : SvEND(PL_e_script);
4058 filter_del(read_e_script);
4061 sv_catpvn(buf_sv, p, nl-p);
4062 sv_chop(PL_e_script, nl);