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 */
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 while (--PL_origargc >= 0) {
493 Safefree(PL_origargv[PL_origargc]);
495 Safefree(PL_origargv);
497 /* magical thingies */
499 SvREFCNT_dec(PL_ofs_sv); /* $, */
502 SvREFCNT_dec(PL_ors_sv); /* $\ */
505 SvREFCNT_dec(PL_rs); /* $/ */
508 PL_multiline = 0; /* $* */
509 Safefree(PL_osname); /* $^O */
512 SvREFCNT_dec(PL_statname);
513 PL_statname = Nullsv;
516 /* defgv, aka *_ should be taken care of elsewhere */
518 /* clean up after study() */
519 SvREFCNT_dec(PL_lastscream);
520 PL_lastscream = Nullsv;
521 Safefree(PL_screamfirst);
523 Safefree(PL_screamnext);
527 Safefree(PL_efloatbuf);
528 PL_efloatbuf = Nullch;
531 /* startup and shutdown function lists */
532 SvREFCNT_dec(PL_beginav);
533 SvREFCNT_dec(PL_beginav_save);
534 SvREFCNT_dec(PL_endav);
535 SvREFCNT_dec(PL_checkav);
536 SvREFCNT_dec(PL_checkav_save);
537 SvREFCNT_dec(PL_initav);
539 PL_beginav_save = Nullav;
542 PL_checkav_save = Nullav;
545 /* shortcuts just get cleared */
551 PL_argvoutgv = Nullgv;
553 PL_stderrgv = Nullgv;
554 PL_last_in_gv = Nullgv;
556 PL_debstash = Nullhv;
558 /* reset so print() ends up where we expect */
561 SvREFCNT_dec(PL_argvout_stack);
562 PL_argvout_stack = Nullav;
564 SvREFCNT_dec(PL_modglobal);
565 PL_modglobal = Nullhv;
566 SvREFCNT_dec(PL_preambleav);
567 PL_preambleav = Nullav;
568 SvREFCNT_dec(PL_subname);
570 SvREFCNT_dec(PL_linestr);
572 SvREFCNT_dec(PL_pidstatus);
573 PL_pidstatus = Nullhv;
574 SvREFCNT_dec(PL_toptarget);
575 PL_toptarget = Nullsv;
576 SvREFCNT_dec(PL_bodytarget);
577 PL_bodytarget = Nullsv;
578 PL_formtarget = Nullsv;
580 /* free locale stuff */
581 #ifdef USE_LOCALE_COLLATE
582 Safefree(PL_collation_name);
583 PL_collation_name = Nullch;
586 #ifdef USE_LOCALE_NUMERIC
587 Safefree(PL_numeric_name);
588 PL_numeric_name = Nullch;
589 SvREFCNT_dec(PL_numeric_radix_sv);
592 /* clear utf8 character classes */
593 SvREFCNT_dec(PL_utf8_alnum);
594 SvREFCNT_dec(PL_utf8_alnumc);
595 SvREFCNT_dec(PL_utf8_ascii);
596 SvREFCNT_dec(PL_utf8_alpha);
597 SvREFCNT_dec(PL_utf8_space);
598 SvREFCNT_dec(PL_utf8_cntrl);
599 SvREFCNT_dec(PL_utf8_graph);
600 SvREFCNT_dec(PL_utf8_digit);
601 SvREFCNT_dec(PL_utf8_upper);
602 SvREFCNT_dec(PL_utf8_lower);
603 SvREFCNT_dec(PL_utf8_print);
604 SvREFCNT_dec(PL_utf8_punct);
605 SvREFCNT_dec(PL_utf8_xdigit);
606 SvREFCNT_dec(PL_utf8_mark);
607 SvREFCNT_dec(PL_utf8_toupper);
608 SvREFCNT_dec(PL_utf8_totitle);
609 SvREFCNT_dec(PL_utf8_tolower);
610 SvREFCNT_dec(PL_utf8_tofold);
611 SvREFCNT_dec(PL_utf8_idstart);
612 SvREFCNT_dec(PL_utf8_idcont);
613 PL_utf8_alnum = Nullsv;
614 PL_utf8_alnumc = Nullsv;
615 PL_utf8_ascii = Nullsv;
616 PL_utf8_alpha = Nullsv;
617 PL_utf8_space = Nullsv;
618 PL_utf8_cntrl = Nullsv;
619 PL_utf8_graph = Nullsv;
620 PL_utf8_digit = Nullsv;
621 PL_utf8_upper = Nullsv;
622 PL_utf8_lower = Nullsv;
623 PL_utf8_print = Nullsv;
624 PL_utf8_punct = Nullsv;
625 PL_utf8_xdigit = Nullsv;
626 PL_utf8_mark = Nullsv;
627 PL_utf8_toupper = Nullsv;
628 PL_utf8_totitle = Nullsv;
629 PL_utf8_tolower = Nullsv;
630 PL_utf8_tofold = Nullsv;
631 PL_utf8_idstart = Nullsv;
632 PL_utf8_idcont = Nullsv;
634 if (!specialWARN(PL_compiling.cop_warnings))
635 SvREFCNT_dec(PL_compiling.cop_warnings);
636 PL_compiling.cop_warnings = Nullsv;
637 if (!specialCopIO(PL_compiling.cop_io))
638 SvREFCNT_dec(PL_compiling.cop_io);
639 PL_compiling.cop_io = Nullsv;
640 CopFILE_free(&PL_compiling);
641 CopSTASH_free(&PL_compiling);
643 /* Prepare to destruct main symbol table. */
648 SvREFCNT_dec(PL_curstname);
649 PL_curstname = Nullsv;
651 /* clear queued errors */
652 SvREFCNT_dec(PL_errors);
656 if (destruct_level >= 2 && ckWARN_d(WARN_INTERNAL)) {
657 if (PL_scopestack_ix != 0)
658 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
659 "Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
660 (long)PL_scopestack_ix);
661 if (PL_savestack_ix != 0)
662 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
663 "Unbalanced saves: %ld more saves than restores\n",
664 (long)PL_savestack_ix);
665 if (PL_tmps_floor != -1)
666 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced tmps: %ld more allocs than frees\n",
667 (long)PL_tmps_floor + 1);
668 if (cxstack_ix != -1)
669 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced context: %ld more PUSHes than POPs\n",
670 (long)cxstack_ix + 1);
673 /* Now absolutely destruct everything, somehow or other, loops or no. */
674 SvFLAGS(PL_fdpid) |= SVTYPEMASK; /* don't clean out pid table now */
675 SvFLAGS(PL_strtab) |= SVTYPEMASK; /* don't clean out strtab now */
677 /* the 2 is for PL_fdpid and PL_strtab */
678 while (PL_sv_count > 2 && sv_clean_all())
681 SvFLAGS(PL_fdpid) &= ~SVTYPEMASK;
682 SvFLAGS(PL_fdpid) |= SVt_PVAV;
683 SvFLAGS(PL_strtab) &= ~SVTYPEMASK;
684 SvFLAGS(PL_strtab) |= SVt_PVHV;
686 AvREAL_off(PL_fdpid); /* no surviving entries */
687 SvREFCNT_dec(PL_fdpid); /* needed in io_close() */
690 #ifdef HAVE_INTERP_INTERN
694 /* Destruct the global string table. */
696 /* Yell and reset the HeVAL() slots that are still holding refcounts,
697 * so that sv_free() won't fail on them.
705 max = HvMAX(PL_strtab);
706 array = HvARRAY(PL_strtab);
709 if (hent && ckWARN_d(WARN_INTERNAL)) {
710 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
711 "Unbalanced string table refcount: (%d) for \"%s\"",
712 HeVAL(hent) - Nullsv, HeKEY(hent));
713 HeVAL(hent) = Nullsv;
723 SvREFCNT_dec(PL_strtab);
726 /* free the pointer table used for cloning */
727 ptr_table_free(PL_ptr_table);
730 /* free special SVs */
732 SvREFCNT(&PL_sv_yes) = 0;
733 sv_clear(&PL_sv_yes);
734 SvANY(&PL_sv_yes) = NULL;
735 SvFLAGS(&PL_sv_yes) = 0;
737 SvREFCNT(&PL_sv_no) = 0;
739 SvANY(&PL_sv_no) = NULL;
740 SvFLAGS(&PL_sv_no) = 0;
744 for (i=0; i<=2; i++) {
745 SvREFCNT(PERL_DEBUG_PAD(i)) = 0;
746 sv_clear(PERL_DEBUG_PAD(i));
747 SvANY(PERL_DEBUG_PAD(i)) = NULL;
748 SvFLAGS(PERL_DEBUG_PAD(i)) = 0;
752 if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL))
753 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Scalars leaked: %ld\n", (long)PL_sv_count);
755 #ifdef DEBUG_LEAKING_SCALARS
756 if (PL_sv_count != 0) {
761 for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
762 svend = &sva[SvREFCNT(sva)];
763 for (sv = sva + 1; sv < svend; ++sv) {
764 if (SvTYPE(sv) != SVTYPEMASK) {
765 PerlIO_printf(Perl_debug_log, "leaked: 0x%p\n", sv);
773 #if defined(PERLIO_LAYERS)
774 /* No more IO - including error messages ! */
775 PerlIO_cleanup(aTHX);
778 /* sv_undef needs to stay immortal until after PerlIO_cleanup
779 as currently layers use it rather than Nullsv as a marker
780 for no arg - and will try and SvREFCNT_dec it.
782 SvREFCNT(&PL_sv_undef) = 0;
783 SvREADONLY_off(&PL_sv_undef);
785 Safefree(PL_origfilename);
786 Safefree(PL_reg_start_tmp);
788 Safefree(PL_reg_curpm);
789 Safefree(PL_reg_poscache);
790 Safefree(HeKEY_hek(&PL_hv_fetch_ent_mh));
791 Safefree(PL_op_mask);
792 Safefree(PL_psig_ptr);
793 Safefree(PL_psig_name);
794 Safefree(PL_bitcount);
795 Safefree(PL_psig_pend);
797 PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */
799 DEBUG_P(debprofdump());
801 #ifdef USE_REENTRANT_API
802 Perl_reentrant_free(aTHX);
807 /* As the absolutely last thing, free the non-arena SV for mess() */
810 /* it could have accumulated taint magic */
811 if (SvTYPE(PL_mess_sv) >= SVt_PVMG) {
814 for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) {
815 moremagic = mg->mg_moremagic;
816 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global
818 Safefree(mg->mg_ptr);
822 /* we know that type >= SVt_PV */
823 (void)SvOOK_off(PL_mess_sv);
824 Safefree(SvPVX(PL_mess_sv));
825 Safefree(SvANY(PL_mess_sv));
826 Safefree(PL_mess_sv);
829 return STATUS_NATIVE_EXPORT;
833 =for apidoc perl_free
835 Releases a Perl interpreter. See L<perlembed>.
843 #if defined(WIN32) || defined(NETWARE)
844 # if defined(PERL_IMPLICIT_SYS)
846 void *host = nw_internal_host;
848 void *host = w32_internal_host;
852 nw_delete_internal_host(host);
854 win32_delete_internal_host(host);
865 Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
867 Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry);
868 PL_exitlist[PL_exitlistlen].fn = fn;
869 PL_exitlist[PL_exitlistlen].ptr = ptr;
874 =for apidoc perl_parse
876 Tells a Perl interpreter to parse a Perl script. See L<perlembed>.
882 perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
887 #ifdef USE_5005THREADS
891 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
894 Perl_croak(aTHX_ "suidperl is no longer needed since the kernel can now execute\n\
895 setuid perl scripts securely.\n");
901 /* we copy rather than point to argv
902 * since perl_clone will copy and perl_destruct
903 * has no way of knowing if we've made a copy or
907 New(0, PL_origargv, i+1, char*);
908 PL_origargv[i] = '\0';
910 PL_origargv[i] = savepv(argv[i]);
918 /* Come here if running an undumped a.out. */
920 PL_origfilename = savepv(argv[0]);
921 PL_do_undump = FALSE;
922 cxstack_ix = -1; /* start label stack again */
924 init_postdump_symbols(argc,argv,env);
929 op_free(PL_main_root);
930 PL_main_root = Nullop;
932 PL_main_start = Nullop;
933 SvREFCNT_dec(PL_main_cv);
937 oldscope = PL_scopestack_ix;
938 PL_dowarn = G_WARN_OFF;
940 #ifdef PERL_FLEXIBLE_EXCEPTIONS
941 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vparse_body), env, xsinit);
947 #ifndef PERL_FLEXIBLE_EXCEPTIONS
948 parse_body(env,xsinit);
951 call_list(oldscope, PL_checkav);
958 /* my_exit() was called */
959 while (PL_scopestack_ix > oldscope)
962 PL_curstash = PL_defstash;
964 call_list(oldscope, PL_checkav);
965 ret = STATUS_NATIVE_EXPORT;
968 PerlIO_printf(Perl_error_log, "panic: top_env\n");
976 #ifdef PERL_FLEXIBLE_EXCEPTIONS
978 S_vparse_body(pTHX_ va_list args)
980 char **env = va_arg(args, char**);
981 XSINIT_t xsinit = va_arg(args, XSINIT_t);
983 return parse_body(env, xsinit);
988 S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
990 int argc = PL_origargc;
991 char **argv = PL_origargv;
992 char *scriptname = NULL;
994 VOL bool dosearch = FALSE;
998 char *cddir = Nullch;
1000 sv_setpvn(PL_linestr,"",0);
1001 sv = newSVpvn("",0); /* first used for -I flags */
1005 for (argc--,argv++; argc > 0; argc--,argv++) {
1006 if (argv[0][0] != '-' || !argv[0][1])
1010 validarg = " PHOOEY ";
1019 win32_argv2utf8(argc-1, argv+1);
1022 #ifndef PERL_STRICT_CR
1046 if ((s = moreswitches(s)))
1051 if( !PL_tainting ) {
1052 PL_taint_warn = TRUE;
1059 PL_taint_warn = FALSE;
1064 #ifdef MACOS_TRADITIONAL
1065 /* ignore -e for Dev:Pseudo argument */
1066 if (argv[1] && !strcmp(argv[1], "Dev:Pseudo"))
1069 if (PL_euid != PL_uid || PL_egid != PL_gid)
1070 Perl_croak(aTHX_ "No -e allowed in setuid scripts");
1072 PL_e_script = newSVpvn("",0);
1073 filter_add(read_e_script, NULL);
1076 sv_catpv(PL_e_script, s);
1078 sv_catpv(PL_e_script, argv[1]);
1082 Perl_croak(aTHX_ "No code specified for -e");
1083 sv_catpv(PL_e_script, "\n");
1086 case 'I': /* -I handled both here and in moreswitches() */
1088 if (!*++s && (s=argv[1]) != Nullch) {
1093 STRLEN len = strlen(s);
1094 p = savepvn(s, len);
1095 incpush(p, TRUE, TRUE, FALSE);
1096 sv_catpvn(sv, "-I", 2);
1097 sv_catpvn(sv, p, len);
1098 sv_catpvn(sv, " ", 1);
1102 Perl_croak(aTHX_ "No directory specified for -I");
1106 PL_preprocess = TRUE;
1116 PL_preambleav = newAV();
1117 av_push(PL_preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
1119 PL_Sv = newSVpv("print myconfig();",0);
1121 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
1123 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
1125 sv_catpv(PL_Sv,"\" Compile-time options:");
1127 sv_catpv(PL_Sv," DEBUGGING");
1129 # ifdef MULTIPLICITY
1130 sv_catpv(PL_Sv," MULTIPLICITY");
1132 # ifdef USE_5005THREADS
1133 sv_catpv(PL_Sv," USE_5005THREADS");
1135 # ifdef USE_ITHREADS
1136 sv_catpv(PL_Sv," USE_ITHREADS");
1138 # ifdef USE_64_BIT_INT
1139 sv_catpv(PL_Sv," USE_64_BIT_INT");
1141 # ifdef USE_64_BIT_ALL
1142 sv_catpv(PL_Sv," USE_64_BIT_ALL");
1144 # ifdef USE_LONG_DOUBLE
1145 sv_catpv(PL_Sv," USE_LONG_DOUBLE");
1147 # ifdef USE_LARGE_FILES
1148 sv_catpv(PL_Sv," USE_LARGE_FILES");
1151 sv_catpv(PL_Sv," USE_SOCKS");
1153 # ifdef PERL_IMPLICIT_CONTEXT
1154 sv_catpv(PL_Sv," PERL_IMPLICIT_CONTEXT");
1156 # ifdef PERL_IMPLICIT_SYS
1157 sv_catpv(PL_Sv," PERL_IMPLICIT_SYS");
1159 sv_catpv(PL_Sv,"\\n\",");
1161 #if defined(LOCAL_PATCH_COUNT)
1162 if (LOCAL_PATCH_COUNT > 0) {
1164 sv_catpv(PL_Sv,"\" Locally applied patches:\\n\",");
1165 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
1166 if (PL_localpatches[i])
1167 Perl_sv_catpvf(aTHX_ PL_Sv,"q\" \t%s\n\",",PL_localpatches[i]);
1171 Perl_sv_catpvf(aTHX_ PL_Sv,"\" Built under %s\\n\"",OSNAME);
1174 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
1176 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled on %s\\n\"",__DATE__);
1179 sv_catpv(PL_Sv, "; \
1181 @env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; ");
1184 push @env, \"CYGWIN=\\\"$ENV{CYGWIN}\\\"\";");
1187 print \" \\%ENV:\\n @env\\n\" if @env; \
1188 print \" \\@INC:\\n @INC\\n\";");
1191 PL_Sv = newSVpv("config_vars(qw(",0);
1192 sv_catpv(PL_Sv, ++s);
1193 sv_catpv(PL_Sv, "))");
1196 av_push(PL_preambleav, PL_Sv);
1197 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
1200 PL_doextract = TRUE;
1208 if (!*++s || isSPACE(*s)) {
1212 /* catch use of gnu style long options */
1213 if (strEQ(s, "version")) {
1217 if (strEQ(s, "help")) {
1224 Perl_croak(aTHX_ "Unrecognized switch: -%s (-h will show valid options)",s);
1228 sv_setsv(get_sv("/", TRUE), PL_rs);
1231 #ifndef SECURE_INTERNAL_GETENV
1234 (s = PerlEnv_getenv("PERL5OPT")))
1239 if (*s == '-' && *(s+1) == 'T') {
1241 PL_taint_warn = FALSE;
1244 char *popt_copy = Nullch;
1257 if (!strchr("DIMUdmtw", *s))
1258 Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
1262 popt_copy = SvPVX(sv_2mortal(newSVpv(popt,0)));
1263 s = popt_copy + (s - popt);
1264 d = popt_copy + (d - popt);
1271 if( !PL_tainting ) {
1272 PL_taint_warn = TRUE;
1282 if (PL_taint_warn && PL_dowarn != G_WARN_ALL_OFF) {
1283 PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
1287 scriptname = argv[0];
1290 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
1292 else if (scriptname == Nullch) {
1294 if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
1302 open_script(scriptname,dosearch,sv,&fdscript);
1304 validate_suid(validarg, scriptname,fdscript);
1307 #if defined(SIGCHLD) || defined(SIGCLD)
1310 # define SIGCHLD SIGCLD
1312 Sighandler_t sigstate = rsignal_state(SIGCHLD);
1313 if (sigstate == SIG_IGN) {
1314 if (ckWARN(WARN_SIGNAL))
1315 Perl_warner(aTHX_ packWARN(WARN_SIGNAL),
1316 "Can't ignore signal CHLD, forcing to default");
1317 (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL);
1323 #ifdef MACOS_TRADITIONAL
1324 if (PL_doextract || gMacPerl_AlwaysExtract) {
1329 if (cddir && PerlDir_chdir(cddir) < 0)
1330 Perl_croak(aTHX_ "Can't chdir to %s",cddir);
1334 PL_main_cv = PL_compcv = (CV*)NEWSV(1104,0);
1335 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
1336 CvUNIQUE_on(PL_compcv);
1338 CvPADLIST(PL_compcv) = pad_new(0);
1339 #ifdef USE_5005THREADS
1340 CvOWNER(PL_compcv) = 0;
1341 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
1342 MUTEX_INIT(CvMUTEXP(PL_compcv));
1343 #endif /* USE_5005THREADS */
1346 boot_core_UNIVERSAL();
1348 boot_core_xsutils();
1352 (*xsinit)(aTHX); /* in case linked C routines want magical variables */
1354 #if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__) || defined(EPOC)
1360 # ifdef HAS_SOCKS5_INIT
1361 socks5_init(argv[0]);
1367 init_predump_symbols();
1368 /* init_postdump_symbols not currently designed to be called */
1369 /* more than once (ENV isn't cleared first, for example) */
1370 /* But running with -u leaves %ENV & @ARGV undefined! XXX */
1372 init_postdump_symbols(argc,argv,env);
1374 /* PL_wantutf8 is conditionally turned on by
1375 * locale.c:Perl_init_i18nl10n() if the environment
1376 * look like the user wants to use UTF-8. */
1377 if (PL_wantutf8) { /* Requires init_predump_symbols(). */
1381 /* Turn on UTF-8-ness on STDIN, STDOUT, STDERR
1382 * _and_ the default open discipline. */
1383 if (PL_stdingv && (io = GvIO(PL_stdingv)) && (fp = IoIFP(io)))
1384 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
1385 if (PL_defoutgv && (io = GvIO(PL_defoutgv)) && (fp = IoOFP(io)))
1386 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
1387 if (PL_stderrgv && (io = GvIO(PL_stderrgv)) && (fp = IoOFP(io)))
1388 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
1389 if ((sv = GvSV(gv_fetchpv("\017PEN", TRUE, SVt_PV)))) {
1390 sv_setpvn(sv, ":utf8\0:utf8", 11);
1397 /* now parse the script */
1399 SETERRNO(0,SS_NORMAL);
1401 #ifdef MACOS_TRADITIONAL
1402 if (gMacPerl_SyntaxError = (yyparse() || PL_error_count)) {
1404 Perl_croak(aTHX_ "%s had compilation errors.\n", MacPerl_MPWFileName(PL_origfilename));
1406 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
1407 MacPerl_MPWFileName(PL_origfilename));
1411 if (yyparse() || PL_error_count) {
1413 Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
1415 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
1420 CopLINE_set(PL_curcop, 0);
1421 PL_curstash = PL_defstash;
1422 PL_preprocess = FALSE;
1424 SvREFCNT_dec(PL_e_script);
1425 PL_e_script = Nullsv;
1432 SAVECOPFILE(PL_curcop);
1433 SAVECOPLINE(PL_curcop);
1434 gv_check(PL_defstash);
1441 if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
1442 dump_mstats("after compilation:");
1451 =for apidoc perl_run
1453 Tells a Perl interpreter to run. See L<perlembed>.
1464 #ifdef USE_5005THREADS
1468 oldscope = PL_scopestack_ix;
1473 #ifdef PERL_FLEXIBLE_EXCEPTIONS
1475 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vrun_body), oldscope);
1481 cxstack_ix = -1; /* start context stack again */
1483 case 0: /* normal completion */
1484 #ifndef PERL_FLEXIBLE_EXCEPTIONS
1489 case 2: /* my_exit() */
1490 while (PL_scopestack_ix > oldscope)
1493 PL_curstash = PL_defstash;
1494 if (!(PL_exit_flags & PERL_EXIT_DESTRUCT_END) &&
1495 PL_endav && !PL_minus_c)
1496 call_list(oldscope, PL_endav);
1498 if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
1499 dump_mstats("after execution: ");
1501 ret = STATUS_NATIVE_EXPORT;
1505 POPSTACK_TO(PL_mainstack);
1508 PerlIO_printf(Perl_error_log, "panic: restartop\n");
1518 #ifdef PERL_FLEXIBLE_EXCEPTIONS
1520 S_vrun_body(pTHX_ va_list args)
1522 I32 oldscope = va_arg(args, I32);
1524 return run_body(oldscope);
1530 S_run_body(pTHX_ I32 oldscope)
1532 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
1533 PL_sawampersand ? "Enabling" : "Omitting"));
1535 if (!PL_restartop) {
1536 DEBUG_x(dump_all());
1537 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
1538 DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%"UVxf"\n",
1542 #ifdef MACOS_TRADITIONAL
1543 PerlIO_printf(Perl_error_log, "%s%s syntax OK\n",
1544 (gMacPerl_ErrorFormat ? "# " : ""),
1545 MacPerl_MPWFileName(PL_origfilename));
1547 PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
1551 if (PERLDB_SINGLE && PL_DBsingle)
1552 sv_setiv(PL_DBsingle, 1);
1554 call_list(oldscope, PL_initav);
1560 PL_op = PL_restartop;
1564 else if (PL_main_start) {
1565 CvDEPTH(PL_main_cv) = 1;
1566 PL_op = PL_main_start;
1576 =head1 SV Manipulation Functions
1578 =for apidoc p||get_sv
1580 Returns the SV of the specified Perl scalar. If C<create> is set and the
1581 Perl variable does not exist then it will be created. If C<create> is not
1582 set and the variable does not exist then NULL is returned.
1588 Perl_get_sv(pTHX_ const char *name, I32 create)
1591 #ifdef USE_5005THREADS
1592 if (name[1] == '\0' && !isALPHA(name[0])) {
1593 PADOFFSET tmp = find_threadsv(name);
1594 if (tmp != NOT_IN_PAD)
1595 return THREADSV(tmp);
1597 #endif /* USE_5005THREADS */
1598 gv = gv_fetchpv(name, create, SVt_PV);
1605 =head1 Array Manipulation Functions
1607 =for apidoc p||get_av
1609 Returns the AV of the specified Perl array. If C<create> is set and the
1610 Perl variable does not exist then it will be created. If C<create> is not
1611 set and the variable does not exist then NULL is returned.
1617 Perl_get_av(pTHX_ const char *name, I32 create)
1619 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1628 =head1 Hash Manipulation Functions
1630 =for apidoc p||get_hv
1632 Returns the HV of the specified Perl hash. If C<create> is set and the
1633 Perl variable does not exist then it will be created. If C<create> is not
1634 set and the variable does not exist then NULL is returned.
1640 Perl_get_hv(pTHX_ const char *name, I32 create)
1642 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1651 =head1 CV Manipulation Functions
1653 =for apidoc p||get_cv
1655 Returns the CV of the specified Perl subroutine. If C<create> is set and
1656 the Perl subroutine does not exist then it will be declared (which has the
1657 same effect as saying C<sub name;>). If C<create> is not set and the
1658 subroutine does not exist then NULL is returned.
1664 Perl_get_cv(pTHX_ const char *name, I32 create)
1666 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
1667 /* XXX unsafe for threads if eval_owner isn't held */
1668 /* XXX this is probably not what they think they're getting.
1669 * It has the same effect as "sub name;", i.e. just a forward
1671 if (create && !GvCVu(gv))
1672 return newSUB(start_subparse(FALSE, 0),
1673 newSVOP(OP_CONST, 0, newSVpv(name,0)),
1681 /* Be sure to refetch the stack pointer after calling these routines. */
1685 =head1 Callback Functions
1687 =for apidoc p||call_argv
1689 Performs a callback to the specified Perl sub. See L<perlcall>.
1695 Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv)
1697 /* See G_* flags in cop.h */
1698 /* null terminated arg list */
1705 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
1710 return call_pv(sub_name, flags);
1714 =for apidoc p||call_pv
1716 Performs a callback to the specified Perl sub. See L<perlcall>.
1722 Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
1723 /* name of the subroutine */
1724 /* See G_* flags in cop.h */
1726 return call_sv((SV*)get_cv(sub_name, TRUE), flags);
1730 =for apidoc p||call_method
1732 Performs a callback to the specified Perl method. The blessed object must
1733 be on the stack. See L<perlcall>.
1739 Perl_call_method(pTHX_ const char *methname, I32 flags)
1740 /* name of the subroutine */
1741 /* See G_* flags in cop.h */
1743 return call_sv(sv_2mortal(newSVpv(methname,0)), flags | G_METHOD);
1746 /* May be called with any of a CV, a GV, or an SV containing the name. */
1748 =for apidoc p||call_sv
1750 Performs a callback to the Perl sub whose name is in the SV. See
1757 Perl_call_sv(pTHX_ SV *sv, I32 flags)
1758 /* See G_* flags in cop.h */
1761 LOGOP myop; /* fake syntax tree node */
1764 volatile I32 retval = 0;
1766 bool oldcatch = CATCH_GET;
1771 if (flags & G_DISCARD) {
1776 Zero(&myop, 1, LOGOP);
1777 myop.op_next = Nullop;
1778 if (!(flags & G_NOARGS))
1779 myop.op_flags |= OPf_STACKED;
1780 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1781 (flags & G_ARRAY) ? OPf_WANT_LIST :
1786 EXTEND(PL_stack_sp, 1);
1787 *++PL_stack_sp = sv;
1789 oldscope = PL_scopestack_ix;
1791 if (PERLDB_SUB && PL_curstash != PL_debstash
1792 /* Handle first BEGIN of -d. */
1793 && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
1794 /* Try harder, since this may have been a sighandler, thus
1795 * curstash may be meaningless. */
1796 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != PL_debstash)
1797 && !(flags & G_NODEBUG))
1798 PL_op->op_private |= OPpENTERSUB_DB;
1800 if (flags & G_METHOD) {
1801 Zero(&method_op, 1, UNOP);
1802 method_op.op_next = PL_op;
1803 method_op.op_ppaddr = PL_ppaddr[OP_METHOD];
1804 myop.op_ppaddr = PL_ppaddr[OP_ENTERSUB];
1805 PL_op = (OP*)&method_op;
1808 if (!(flags & G_EVAL)) {
1810 call_body((OP*)&myop, FALSE);
1811 retval = PL_stack_sp - (PL_stack_base + oldmark);
1812 CATCH_SET(oldcatch);
1815 myop.op_other = (OP*)&myop;
1817 /* we're trying to emulate pp_entertry() here */
1819 register PERL_CONTEXT *cx;
1820 I32 gimme = GIMME_V;
1825 push_return(Nullop);
1826 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
1828 PL_eval_root = PL_op; /* Only needed so that goto works right. */
1830 PL_in_eval = EVAL_INEVAL;
1831 if (flags & G_KEEPERR)
1832 PL_in_eval |= EVAL_KEEPERR;
1838 #ifdef PERL_FLEXIBLE_EXCEPTIONS
1840 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_body),
1847 #ifndef PERL_FLEXIBLE_EXCEPTIONS
1849 call_body((OP*)&myop, FALSE);
1851 retval = PL_stack_sp - (PL_stack_base + oldmark);
1852 if (!(flags & G_KEEPERR))
1859 /* my_exit() was called */
1860 PL_curstash = PL_defstash;
1863 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
1864 Perl_croak(aTHX_ "Callback called exit");
1869 PL_op = PL_restartop;
1873 PL_stack_sp = PL_stack_base + oldmark;
1874 if (flags & G_ARRAY)
1878 *++PL_stack_sp = &PL_sv_undef;
1883 if (PL_scopestack_ix > oldscope) {
1887 register PERL_CONTEXT *cx;
1899 if (flags & G_DISCARD) {
1900 PL_stack_sp = PL_stack_base + oldmark;
1909 #ifdef PERL_FLEXIBLE_EXCEPTIONS
1911 S_vcall_body(pTHX_ va_list args)
1913 OP *myop = va_arg(args, OP*);
1914 int is_eval = va_arg(args, int);
1916 call_body(myop, is_eval);
1922 S_call_body(pTHX_ OP *myop, int is_eval)
1924 if (PL_op == myop) {
1926 PL_op = Perl_pp_entereval(aTHX); /* this doesn't do a POPMARK */
1928 PL_op = Perl_pp_entersub(aTHX); /* this does */
1934 /* Eval a string. The G_EVAL flag is always assumed. */
1937 =for apidoc p||eval_sv
1939 Tells Perl to C<eval> the string in the SV.
1945 Perl_eval_sv(pTHX_ SV *sv, I32 flags)
1947 /* See G_* flags in cop.h */
1950 UNOP myop; /* fake syntax tree node */
1951 volatile I32 oldmark = SP - PL_stack_base;
1952 volatile I32 retval = 0;
1958 if (flags & G_DISCARD) {
1965 Zero(PL_op, 1, UNOP);
1966 EXTEND(PL_stack_sp, 1);
1967 *++PL_stack_sp = sv;
1968 oldscope = PL_scopestack_ix;
1970 if (!(flags & G_NOARGS))
1971 myop.op_flags = OPf_STACKED;
1972 myop.op_next = Nullop;
1973 myop.op_type = OP_ENTEREVAL;
1974 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1975 (flags & G_ARRAY) ? OPf_WANT_LIST :
1977 if (flags & G_KEEPERR)
1978 myop.op_flags |= OPf_SPECIAL;
1980 #ifdef PERL_FLEXIBLE_EXCEPTIONS
1982 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_body),
1989 #ifndef PERL_FLEXIBLE_EXCEPTIONS
1991 call_body((OP*)&myop,TRUE);
1993 retval = PL_stack_sp - (PL_stack_base + oldmark);
1994 if (!(flags & G_KEEPERR))
2001 /* my_exit() was called */
2002 PL_curstash = PL_defstash;
2005 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
2006 Perl_croak(aTHX_ "Callback called exit");
2011 PL_op = PL_restartop;
2015 PL_stack_sp = PL_stack_base + oldmark;
2016 if (flags & G_ARRAY)
2020 *++PL_stack_sp = &PL_sv_undef;
2026 if (flags & G_DISCARD) {
2027 PL_stack_sp = PL_stack_base + oldmark;
2037 =for apidoc p||eval_pv
2039 Tells Perl to C<eval> the given string and return an SV* result.
2045 Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
2048 SV* sv = newSVpv(p, 0);
2050 eval_sv(sv, G_SCALAR);
2057 if (croak_on_error && SvTRUE(ERRSV)) {
2059 Perl_croak(aTHX_ SvPVx(ERRSV, n_a));
2065 /* Require a module. */
2068 =head1 Embedding Functions
2070 =for apidoc p||require_pv
2072 Tells Perl to C<require> the file named by the string argument. It is
2073 analogous to the Perl code C<eval "require '$file'">. It's even
2074 implemented that way; consider using Perl_load_module instead.
2079 Perl_require_pv(pTHX_ const char *pv)
2083 PUSHSTACKi(PERLSI_REQUIRE);
2085 sv = sv_newmortal();
2086 sv_setpv(sv, "require '");
2089 eval_sv(sv, G_DISCARD);
2095 Perl_magicname(pTHX_ char *sym, char *name, I32 namlen)
2099 if ((gv = gv_fetchpv(sym,TRUE, SVt_PV)))
2100 sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, namlen);
2104 S_usage(pTHX_ char *name) /* XXX move this out into a module ? */
2106 /* This message really ought to be max 23 lines.
2107 * Removed -h because the user already knows that option. Others? */
2109 static char *usage_msg[] = {
2110 "-0[octal] specify record separator (\\0, if no argument)",
2111 "-a autosplit mode with -n or -p (splits $_ into @F)",
2112 "-C enable native wide character system interfaces",
2113 "-c check syntax only (runs BEGIN and CHECK blocks)",
2114 "-d[:debugger] run program under debugger",
2115 "-D[number/list] set debugging flags (argument is a bit mask or alphabets)",
2116 "-e 'command' one line of program (several -e's allowed, omit programfile)",
2117 "-F/pattern/ split() pattern for -a switch (//'s are optional)",
2118 "-i[extension] edit <> files in place (makes backup if extension supplied)",
2119 "-Idirectory specify @INC/#include directory (several -I's allowed)",
2120 "-l[octal] enable line ending processing, specifies line terminator",
2121 "-[mM][-]module execute `use/no module...' before executing program",
2122 "-n assume 'while (<>) { ... }' loop around program",
2123 "-p assume loop like -n but print line also, like sed",
2124 "-P run program through C preprocessor before compilation",
2125 "-s enable rudimentary parsing for switches after programfile",
2126 "-S look for programfile using PATH environment variable",
2127 "-T enable tainting checks",
2128 "-t enable tainting warnings",
2129 "-u dump core after parsing program",
2130 "-U allow unsafe operations",
2131 "-v print version, subversion (includes VERY IMPORTANT perl info)",
2132 "-V[:variable] print configuration summary (or a single Config.pm variable)",
2133 "-w enable many useful warnings (RECOMMENDED)",
2134 "-W enable all warnings",
2135 "-X disable all warnings",
2136 "-x[directory] strip off text before #!perl line and perhaps cd to directory",
2140 char **p = usage_msg;
2142 PerlIO_printf(PerlIO_stdout(),
2143 "\nUsage: %s [switches] [--] [programfile] [arguments]",
2146 PerlIO_printf(PerlIO_stdout(), "\n %s", *p++);
2149 /* This routine handles any switches that can be given during run */
2152 Perl_moreswitches(pTHX_ char *s)
2162 rschar = (U32)grok_oct(s, &numlen, &flags, NULL);
2163 SvREFCNT_dec(PL_rs);
2164 if (rschar & ~((U8)~0))
2165 PL_rs = &PL_sv_undef;
2166 else if (!rschar && numlen >= 2)
2167 PL_rs = newSVpvn("", 0);
2169 char ch = (char)rschar;
2170 PL_rs = newSVpvn(&ch, 1);
2175 PL_widesyscalls = TRUE;
2181 while (*s && !isSPACE(*s)) ++s;
2183 PL_splitstr = savepv(PL_splitstr);
2196 /* The following permits -d:Mod to accepts arguments following an =
2197 in the fashion that -MSome::Mod does. */
2198 if (*s == ':' || *s == '=') {
2201 sv = newSVpv("use Devel::", 0);
2203 /* We now allow -d:Module=Foo,Bar */
2204 while(isALNUM(*s) || *s==':') ++s;
2206 sv_catpv(sv, start);
2208 sv_catpvn(sv, start, s-start);
2209 sv_catpv(sv, " split(/,/,q{");
2214 my_setenv("PERL5DB", SvPV(sv, PL_na));
2217 PL_perldb = PERLDB_ALL;
2225 if (isALPHA(s[1])) {
2226 /* if adding extra options, remember to update DEBUG_MASK */
2227 static char debopts[] = "psltocPmfrxu HXDSTRJvC";
2230 for (s++; *s && (d = strchr(debopts,*s)); s++)
2231 PL_debug |= 1 << (d - debopts);
2234 PL_debug = atoi(s+1);
2235 for (s++; isDIGIT(*s); s++) ;
2238 if (DEBUG_p_TEST_ && ckWARN_d(WARN_DEBUGGING))
2239 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
2240 "-Dp not implemented on this platform\n");
2242 PL_debug |= DEBUG_TOP_FLAG;
2243 #else /* !DEBUGGING */
2244 if (ckWARN_d(WARN_DEBUGGING))
2245 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
2246 "Recompile perl with -DDEBUGGING to use -D switch\n");
2247 for (s++; isALNUM(*s); s++) ;
2253 usage(PL_origargv[0]);
2257 Safefree(PL_inplace);
2258 #if defined(__CYGWIN__) /* do backup extension automagically */
2259 if (*(s+1) == '\0') {
2260 PL_inplace = savepv(".bak");
2263 #endif /* __CYGWIN__ */
2264 PL_inplace = savepv(s+1);
2266 for (s = PL_inplace; *s && !isSPACE(*s); s++) ;
2269 if (*s == '-') /* Additional switches on #! line. */
2273 case 'I': /* -I handled both here and in parse_body() */
2276 while (*s && isSPACE(*s))
2281 /* ignore trailing spaces (possibly followed by other switches) */
2283 for (e = p; *e && !isSPACE(*e); e++) ;
2287 } while (*p && *p != '-');
2288 e = savepvn(s, e-s);
2289 incpush(e, TRUE, TRUE, FALSE);
2296 Perl_croak(aTHX_ "No directory specified for -I");
2302 SvREFCNT_dec(PL_ors_sv);
2307 PL_ors_sv = newSVpvn("\n",1);
2308 numlen = 3 + (*s == '0');
2309 *SvPVX(PL_ors_sv) = (char)grok_oct(s, &numlen, &flags, NULL);
2313 if (RsPARA(PL_rs)) {
2314 PL_ors_sv = newSVpvn("\n\n",2);
2317 PL_ors_sv = newSVsv(PL_rs);
2322 forbid_setid("-M"); /* XXX ? */
2325 forbid_setid("-m"); /* XXX ? */
2330 /* -M-foo == 'no foo' */
2331 if (*s == '-') { use = "no "; ++s; }
2332 sv = newSVpv(use,0);
2334 /* We allow -M'Module qw(Foo Bar)' */
2335 while(isALNUM(*s) || *s==':') ++s;
2337 sv_catpv(sv, start);
2338 if (*(start-1) == 'm') {
2340 Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
2341 sv_catpv( sv, " ()");
2345 Perl_croak(aTHX_ "Module name required with -%c option",
2347 sv_catpvn(sv, start, s-start);
2348 sv_catpv(sv, " split(/,/,q{");
2354 PL_preambleav = newAV();
2355 av_push(PL_preambleav, sv);
2358 Perl_croak(aTHX_ "No space allowed after -%c", *(s-1));
2370 PL_doswitches = TRUE;
2375 Perl_croak(aTHX_ "Too late for \"-t\" option");
2380 Perl_croak(aTHX_ "Too late for \"-T\" option");
2384 #ifdef MACOS_TRADITIONAL
2385 Perl_croak(aTHX_ "Believe me, you don't want to use \"-u\" on a Macintosh");
2387 PL_do_undump = TRUE;
2396 PerlIO_printf(PerlIO_stdout(),
2397 Perl_form(aTHX_ "\nThis is perl, v%"VDf" built for %s",
2398 PL_patchlevel, ARCHNAME));
2400 /* Adjust verbose output as in the perl that ships with the DG/UX OS from EMC */
2401 PerlIO_printf(PerlIO_stdout(),
2402 Perl_form(aTHX_ "\nThis is perl, version %vd\n", PL_patchlevel));
2403 PerlIO_printf(PerlIO_stdout(),
2404 Perl_form(aTHX_ " built under %s at %s %s\n",
2405 OSNAME, __DATE__, __TIME__));
2406 PerlIO_printf(PerlIO_stdout(),
2407 Perl_form(aTHX_ " OS Specific Release: %s\n",
2411 #if defined(LOCAL_PATCH_COUNT)
2412 if (LOCAL_PATCH_COUNT > 0)
2413 PerlIO_printf(PerlIO_stdout(),
2414 "\n(with %d registered patch%s, "
2415 "see perl -V for more detail)",
2416 (int)LOCAL_PATCH_COUNT,
2417 (LOCAL_PATCH_COUNT!=1) ? "es" : "");
2420 PerlIO_printf(PerlIO_stdout(),
2421 "\n\nCopyright 1987-2002, Larry Wall\n");
2422 #ifdef MACOS_TRADITIONAL
2423 PerlIO_printf(PerlIO_stdout(),
2424 "\nMac OS port Copyright 1991-2002, Matthias Neeracher;\n"
2425 "maintained by Chris Nandor\n");
2428 PerlIO_printf(PerlIO_stdout(),
2429 "\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
2432 PerlIO_printf(PerlIO_stdout(),
2433 "djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n"
2434 "djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
2437 PerlIO_printf(PerlIO_stdout(),
2438 "\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
2439 "Version 5 port Copyright (c) 1994-2002, Andreas Kaiser, Ilya Zakharevich\n");
2442 PerlIO_printf(PerlIO_stdout(),
2443 "atariST series port, ++jrb bammi@cadence.com\n");
2446 PerlIO_printf(PerlIO_stdout(),
2447 "BeOS port Copyright Tom Spindler, 1997-1999\n");
2450 PerlIO_printf(PerlIO_stdout(),
2451 "MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-2002\n");
2454 PerlIO_printf(PerlIO_stdout(),
2455 "MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
2458 PerlIO_printf(PerlIO_stdout(),
2459 "Stratus VOS port by Paul.Green@stratus.com, 1997-2002\n");
2462 PerlIO_printf(PerlIO_stdout(),
2463 "VM/ESA port by Neale Ferguson, 1998-1999\n");
2466 PerlIO_printf(PerlIO_stdout(),
2467 "BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
2470 PerlIO_printf(PerlIO_stdout(),
2471 "MiNT port by Guido Flohr, 1997-1999\n");
2474 PerlIO_printf(PerlIO_stdout(),
2475 "EPOC port by Olaf Flebbe, 1999-2002\n");
2478 printf("WINCE port by Rainer Keuchel, 2001-2002\n");
2479 printf("Built on " __DATE__ " " __TIME__ "\n\n");
2482 #ifdef BINARY_BUILD_NOTICE
2483 BINARY_BUILD_NOTICE;
2485 PerlIO_printf(PerlIO_stdout(),
2487 Perl may be copied only under the terms of either the Artistic License or the\n\
2488 GNU General Public License, which may be found in the Perl 5 source kit.\n\n\
2489 Complete documentation for Perl, including FAQ lists, should be found on\n\
2490 this system using `man perl' or `perldoc perl'. If you have access to the\n\
2491 Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
2494 if (! (PL_dowarn & G_WARN_ALL_MASK))
2495 PL_dowarn |= G_WARN_ON;
2499 PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
2500 if (!specialWARN(PL_compiling.cop_warnings))
2501 SvREFCNT_dec(PL_compiling.cop_warnings);
2502 PL_compiling.cop_warnings = pWARN_ALL ;
2506 PL_dowarn = G_WARN_ALL_OFF;
2507 if (!specialWARN(PL_compiling.cop_warnings))
2508 SvREFCNT_dec(PL_compiling.cop_warnings);
2509 PL_compiling.cop_warnings = pWARN_NONE ;
2514 if (s[1] == '-') /* Additional switches on #! line. */
2519 #if defined(WIN32) || !defined(PERL_STRICT_CR)
2525 #ifdef ALTERNATE_SHEBANG
2526 case 'S': /* OS/2 needs -S on "extproc" line. */
2534 Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
2539 /* compliments of Tom Christiansen */
2541 /* unexec() can be found in the Gnu emacs distribution */
2542 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
2545 Perl_my_unexec(pTHX)
2553 prog = newSVpv(BIN_EXP, 0);
2554 sv_catpv(prog, "/perl");
2555 file = newSVpv(PL_origfilename, 0);
2556 sv_catpv(file, ".perldump");
2558 unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
2559 /* unexec prints msg to stderr in case of failure */
2560 PerlProc_exit(status);
2563 # include <lib$routines.h>
2564 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
2566 ABORT(); /* for use with undump */
2571 /* initialize curinterp */
2577 # define PERLVAR(var,type)
2578 # define PERLVARA(var,n,type)
2579 # if defined(PERL_IMPLICIT_CONTEXT)
2580 # if defined(USE_5005THREADS)
2581 # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
2582 # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
2583 # else /* !USE_5005THREADS */
2584 # define PERLVARI(var,type,init) aTHX->var = init;
2585 # define PERLVARIC(var,type,init) aTHX->var = init;
2586 # endif /* USE_5005THREADS */
2588 # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
2589 # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
2591 # include "intrpvar.h"
2592 # ifndef USE_5005THREADS
2593 # include "thrdvar.h"
2600 # define PERLVAR(var,type)
2601 # define PERLVARA(var,n,type)
2602 # define PERLVARI(var,type,init) PL_##var = init;
2603 # define PERLVARIC(var,type,init) PL_##var = init;
2604 # include "intrpvar.h"
2605 # ifndef USE_5005THREADS
2606 # include "thrdvar.h"
2617 S_init_main_stash(pTHX)
2621 PL_curstash = PL_defstash = newHV();
2622 PL_curstname = newSVpvn("main",4);
2623 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
2624 SvREFCNT_dec(GvHV(gv));
2625 GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
2627 HvNAME(PL_defstash) = savepv("main");
2628 PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
2629 GvMULTI_on(PL_incgv);
2630 PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
2631 GvMULTI_on(PL_hintgv);
2632 PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
2633 PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
2634 GvMULTI_on(PL_errgv);
2635 PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
2636 GvMULTI_on(PL_replgv);
2637 (void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */
2638 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
2639 sv_setpvn(ERRSV, "", 0);
2640 PL_curstash = PL_defstash;
2641 CopSTASH_set(&PL_compiling, PL_defstash);
2642 PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
2643 PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
2644 /* We must init $/ before switches are processed. */
2645 sv_setpvn(get_sv("/", TRUE), "\n", 1);
2649 S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
2653 char *cpp_discard_flag;
2659 PL_origfilename = savepv("-e");
2662 /* if find_script() returns, it returns a malloc()-ed value */
2663 PL_origfilename = scriptname = find_script(scriptname, dosearch, NULL, 1);
2665 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
2666 char *s = scriptname + 8;
2667 *fdscript = atoi(s);
2671 scriptname = savepv(s + 1);
2672 Safefree(PL_origfilename);
2673 PL_origfilename = scriptname;
2678 CopFILE_free(PL_curcop);
2679 CopFILE_set(PL_curcop, PL_origfilename);
2680 if (strEQ(PL_origfilename,"-"))
2682 if (*fdscript >= 0) {
2683 PL_rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE);
2684 # if defined(HAS_FCNTL) && defined(F_SETFD)
2686 /* ensure close-on-exec */
2687 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
2690 else if (PL_preprocess) {
2691 char *cpp_cfg = CPPSTDIN;
2692 SV *cpp = newSVpvn("",0);
2693 SV *cmd = NEWSV(0,0);
2695 if (strEQ(cpp_cfg, "cppstdin"))
2696 Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
2697 sv_catpv(cpp, cpp_cfg);
2700 sv_catpvn(sv, "-I", 2);
2701 sv_catpv(sv,PRIVLIB_EXP);
2704 DEBUG_P(PerlIO_printf(Perl_debug_log,
2705 "PL_preprocess: scriptname=\"%s\", cpp=\"%s\", sv=\"%s\", CPPMINUS=\"%s\"\n",
2706 scriptname, SvPVX (cpp), SvPVX (sv), CPPMINUS));
2708 # if defined(MSDOS) || defined(WIN32) || defined(VMS)
2715 cpp_discard_flag = "";
2717 cpp_discard_flag = "-C";
2721 perl = os2_execname(aTHX);
2723 perl = PL_origargv[0];
2727 /* This strips off Perl comments which might interfere with
2728 the C pre-processor, including #!. #line directives are
2729 deliberately stripped to avoid confusion with Perl's version
2730 of #line. FWP played some golf with it so it will fit
2731 into VMS's 255 character buffer.
2734 code = "(1../^#!.*perl/i)|/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print";
2736 code = "/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print";
2738 Perl_sv_setpvf(aTHX_ cmd, "\
2739 %s -ne%s%s%s %s | %"SVf" %s %"SVf" %s",
2740 perl, quote, code, quote, scriptname, cpp,
2741 cpp_discard_flag, sv, CPPMINUS);
2743 PL_doextract = FALSE;
2744 # ifdef IAMSUID /* actually, this is caught earlier */
2745 if (PL_euid != PL_uid && !PL_euid) { /* if running suidperl */
2747 (void)seteuid(PL_uid); /* musn't stay setuid root */
2749 # ifdef HAS_SETREUID
2750 (void)setreuid((Uid_t)-1, PL_uid);
2752 # ifdef HAS_SETRESUID
2753 (void)setresuid((Uid_t)-1, PL_uid, (Uid_t)-1);
2755 PerlProc_setuid(PL_uid);
2759 if (PerlProc_geteuid() != PL_uid)
2760 Perl_croak(aTHX_ "Can't do seteuid!\n");
2762 # endif /* IAMSUID */
2764 DEBUG_P(PerlIO_printf(Perl_debug_log,
2765 "PL_preprocess: cmd=\"%s\"\n",
2768 PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
2772 else if (!*scriptname) {
2773 forbid_setid("program input from stdin");
2774 PL_rsfp = PerlIO_stdin();
2777 PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
2778 # if defined(HAS_FCNTL) && defined(F_SETFD)
2780 /* ensure close-on-exec */
2781 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
2786 # ifndef IAMSUID /* in case script is not readable before setuid */
2788 PerlLIO_stat(CopFILE(PL_curcop),&PL_statbuf) >= 0 &&
2789 PL_statbuf.st_mode & (S_ISUID|S_ISGID))
2792 PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT,
2793 BIN_EXP, (int)PERL_REVISION,
2795 (int)PERL_SUBVERSION), PL_origargv);
2796 Perl_croak(aTHX_ "Can't do setuid\n");
2802 Perl_croak(aTHX_ "Can't open perl script: %s\n",
2805 Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
2806 CopFILE(PL_curcop), Strerror(errno));
2812 * I_SYSSTATVFS HAS_FSTATVFS
2814 * I_STATFS HAS_FSTATFS HAS_GETFSSTAT
2815 * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT
2816 * here so that metaconfig picks them up. */
2820 S_fd_on_nosuid_fs(pTHX_ int fd)
2822 int check_okay = 0; /* able to do all the required sys/libcalls */
2823 int on_nosuid = 0; /* the fd is on a nosuid fs */
2825 * Preferred order: fstatvfs(), fstatfs(), ustat()+getmnt(), getmntent().
2826 * fstatvfs() is UNIX98.
2827 * fstatfs() is 4.3 BSD.
2828 * ustat()+getmnt() is pre-4.3 BSD.
2829 * getmntent() is O(number-of-mounted-filesystems) and can hang on
2830 * an irrelevant filesystem while trying to reach the right one.
2833 #undef FD_ON_NOSUID_CHECK_OKAY /* found the syscalls to do the check? */
2835 # if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
2836 defined(HAS_FSTATVFS)
2837 # define FD_ON_NOSUID_CHECK_OKAY
2838 struct statvfs stfs;
2840 check_okay = fstatvfs(fd, &stfs) == 0;
2841 on_nosuid = check_okay && (stfs.f_flag & ST_NOSUID);
2842 # endif /* fstatvfs */
2844 # if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
2845 defined(PERL_MOUNT_NOSUID) && \
2846 defined(HAS_FSTATFS) && \
2847 defined(HAS_STRUCT_STATFS) && \
2848 defined(HAS_STRUCT_STATFS_F_FLAGS)
2849 # define FD_ON_NOSUID_CHECK_OKAY
2852 check_okay = fstatfs(fd, &stfs) == 0;
2853 on_nosuid = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
2854 # endif /* fstatfs */
2856 # if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
2857 defined(PERL_MOUNT_NOSUID) && \
2858 defined(HAS_FSTAT) && \
2859 defined(HAS_USTAT) && \
2860 defined(HAS_GETMNT) && \
2861 defined(HAS_STRUCT_FS_DATA) && \
2863 # define FD_ON_NOSUID_CHECK_OKAY
2866 if (fstat(fd, &fdst) == 0) {
2868 if (ustat(fdst.st_dev, &us) == 0) {
2870 /* NOSTAT_ONE here because we're not examining fields which
2871 * vary between that case and STAT_ONE. */
2872 if (getmnt((int*)0, &fsd, (int)0, NOSTAT_ONE, us.f_fname) == 0) {
2873 size_t cmplen = sizeof(us.f_fname);
2874 if (sizeof(fsd.fd_req.path) < cmplen)
2875 cmplen = sizeof(fsd.fd_req.path);
2876 if (strnEQ(fsd.fd_req.path, us.f_fname, cmplen) &&
2877 fdst.st_dev == fsd.fd_req.dev) {
2879 on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID;
2885 # endif /* fstat+ustat+getmnt */
2887 # if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
2888 defined(HAS_GETMNTENT) && \
2889 defined(HAS_HASMNTOPT) && \
2890 defined(MNTOPT_NOSUID)
2891 # define FD_ON_NOSUID_CHECK_OKAY
2892 FILE *mtab = fopen("/etc/mtab", "r");
2893 struct mntent *entry;
2896 if (mtab && (fstat(fd, &stb) == 0)) {
2897 while (entry = getmntent(mtab)) {
2898 if (stat(entry->mnt_dir, &fsb) == 0
2899 && fsb.st_dev == stb.st_dev)
2901 /* found the filesystem */
2903 if (hasmntopt(entry, MNTOPT_NOSUID))
2906 } /* A single fs may well fail its stat(). */
2911 # endif /* getmntent+hasmntopt */
2914 Perl_croak(aTHX_ "Can't check filesystem of script \"%s\" for nosuid", PL_origfilename);
2917 #endif /* IAMSUID */
2920 S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript)
2926 /* do we need to emulate setuid on scripts? */
2928 /* This code is for those BSD systems that have setuid #! scripts disabled
2929 * in the kernel because of a security problem. Merely defining DOSUID
2930 * in perl will not fix that problem, but if you have disabled setuid
2931 * scripts in the kernel, this will attempt to emulate setuid and setgid
2932 * on scripts that have those now-otherwise-useless bits set. The setuid
2933 * root version must be called suidperl or sperlN.NNN. If regular perl
2934 * discovers that it has opened a setuid script, it calls suidperl with
2935 * the same argv that it had. If suidperl finds that the script it has
2936 * just opened is NOT setuid root, it sets the effective uid back to the
2937 * uid. We don't just make perl setuid root because that loses the
2938 * effective uid we had before invoking perl, if it was different from the
2941 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
2942 * be defined in suidperl only. suidperl must be setuid root. The
2943 * Configure script will set this up for you if you want it.
2949 if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */
2950 Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
2951 if (fdscript < 0 && PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
2956 #ifndef HAS_SETREUID
2957 /* On this access check to make sure the directories are readable,
2958 * there is actually a small window that the user could use to make
2959 * filename point to an accessible directory. So there is a faint
2960 * chance that someone could execute a setuid script down in a
2961 * non-accessible directory. I don't know what to do about that.
2962 * But I don't think it's too important. The manual lies when
2963 * it says access() is useful in setuid programs.
2965 if (PerlLIO_access(CopFILE(PL_curcop),1)) /*double check*/
2966 Perl_croak(aTHX_ "Permission denied");
2968 /* If we can swap euid and uid, then we can determine access rights
2969 * with a simple stat of the file, and then compare device and
2970 * inode to make sure we did stat() on the same file we opened.
2971 * Then we just have to make sure he or she can execute it.
2978 setreuid(PL_euid,PL_uid) < 0
2981 setresuid(PL_euid,PL_uid,(Uid_t)-1) < 0
2984 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
2985 Perl_croak(aTHX_ "Can't swap uid and euid"); /* really paranoid */
2986 if (PerlLIO_stat(CopFILE(PL_curcop),&tmpstatbuf) < 0)
2987 Perl_croak(aTHX_ "Permission denied"); /* testing full pathname here */
2988 #if defined(IAMSUID) && !defined(NO_NOSUID_CHECK)
2989 if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp)))
2990 Perl_croak(aTHX_ "Permission denied");
2992 if (tmpstatbuf.st_dev != PL_statbuf.st_dev ||
2993 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
2994 (void)PerlIO_close(PL_rsfp);
2995 Perl_croak(aTHX_ "Permission denied\n");
2999 setreuid(PL_uid,PL_euid) < 0
3001 # if defined(HAS_SETRESUID)
3002 setresuid(PL_uid,PL_euid,(Uid_t)-1) < 0
3005 || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
3006 Perl_croak(aTHX_ "Can't reswap uid and euid");
3007 if (!cando(S_IXUSR,FALSE,&PL_statbuf)) /* can real uid exec? */
3008 Perl_croak(aTHX_ "Permission denied\n");
3010 #endif /* HAS_SETREUID */
3011 #endif /* IAMSUID */
3013 if (!S_ISREG(PL_statbuf.st_mode))
3014 Perl_croak(aTHX_ "Permission denied");
3015 if (PL_statbuf.st_mode & S_IWOTH)
3016 Perl_croak(aTHX_ "Setuid/gid script is writable by world");
3017 PL_doswitches = FALSE; /* -s is insecure in suid */
3018 CopLINE_inc(PL_curcop);
3019 if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
3020 strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */
3021 Perl_croak(aTHX_ "No #! line");
3022 s = SvPV(PL_linestr,n_a)+2;
3024 while (!isSPACE(*s)) s++;
3025 for (s2 = s; (s2 > SvPV(PL_linestr,n_a)+2 &&
3026 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
3027 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
3028 Perl_croak(aTHX_ "Not a perl script");
3029 while (*s == ' ' || *s == '\t') s++;
3031 * #! arg must be what we saw above. They can invoke it by
3032 * mentioning suidperl explicitly, but they may not add any strange
3033 * arguments beyond what #! says if they do invoke suidperl that way.
3035 len = strlen(validarg);
3036 if (strEQ(validarg," PHOOEY ") ||
3037 strnNE(s,validarg,len) || !isSPACE(s[len]))
3038 Perl_croak(aTHX_ "Args must match #! line");
3041 if (PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
3042 PL_euid == PL_statbuf.st_uid)
3044 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
3045 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
3046 #endif /* IAMSUID */
3048 if (PL_euid) { /* oops, we're not the setuid root perl */
3049 (void)PerlIO_close(PL_rsfp);
3052 PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
3053 (int)PERL_REVISION, (int)PERL_VERSION,
3054 (int)PERL_SUBVERSION), PL_origargv);
3056 Perl_croak(aTHX_ "Can't do setuid\n");
3059 if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
3061 (void)setegid(PL_statbuf.st_gid);
3064 (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
3066 #ifdef HAS_SETRESGID
3067 (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
3069 PerlProc_setgid(PL_statbuf.st_gid);
3073 if (PerlProc_getegid() != PL_statbuf.st_gid)
3074 Perl_croak(aTHX_ "Can't do setegid!\n");
3076 if (PL_statbuf.st_mode & S_ISUID) {
3077 if (PL_statbuf.st_uid != PL_euid)
3079 (void)seteuid(PL_statbuf.st_uid); /* all that for this */
3082 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
3084 #ifdef HAS_SETRESUID
3085 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
3087 PerlProc_setuid(PL_statbuf.st_uid);
3091 if (PerlProc_geteuid() != PL_statbuf.st_uid)
3092 Perl_croak(aTHX_ "Can't do seteuid!\n");
3094 else if (PL_uid) { /* oops, mustn't run as root */
3096 (void)seteuid((Uid_t)PL_uid);
3099 (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
3101 #ifdef HAS_SETRESUID
3102 (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
3104 PerlProc_setuid((Uid_t)PL_uid);
3108 if (PerlProc_geteuid() != PL_uid)
3109 Perl_croak(aTHX_ "Can't do seteuid!\n");
3112 if (!cando(S_IXUSR,TRUE,&PL_statbuf))
3113 Perl_croak(aTHX_ "Permission denied\n"); /* they can't do this */
3116 else if (PL_preprocess)
3117 Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
3118 else if (fdscript >= 0)
3119 Perl_croak(aTHX_ "fd script not allowed in suidperl\n");
3121 Perl_croak(aTHX_ "Script is not setuid/setgid in suidperl\n");
3123 /* We absolutely must clear out any saved ids here, so we */
3124 /* exec the real perl, substituting fd script for scriptname. */
3125 /* (We pass script name as "subdir" of fd, which perl will grok.) */
3126 PerlIO_rewind(PL_rsfp);
3127 PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0); /* just in case rewind didn't */
3128 for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
3129 if (!PL_origargv[which])
3130 Perl_croak(aTHX_ "Permission denied");
3131 PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
3132 PerlIO_fileno(PL_rsfp), PL_origargv[which]));
3133 #if defined(HAS_FCNTL) && defined(F_SETFD)
3134 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */
3136 PerlProc_execv(Perl_form(aTHX_ "%s/perl"PERL_FS_VER_FMT, BIN_EXP,
3137 (int)PERL_REVISION, (int)PERL_VERSION,
3138 (int)PERL_SUBVERSION), PL_origargv);/* try again */
3139 Perl_croak(aTHX_ "Can't do setuid\n");
3140 #endif /* IAMSUID */
3142 if (PL_euid != PL_uid || PL_egid != PL_gid) { /* (suidperl doesn't exist, in fact) */
3143 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
3144 PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf); /* may be either wrapped or real suid */
3145 if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
3147 (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
3150 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
3151 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
3152 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
3153 /* not set-id, must be wrapped */
3159 S_find_beginning(pTHX)
3161 register char *s, *s2;
3162 #ifdef MACOS_TRADITIONAL
3166 /* skip forward in input to the real script? */
3169 #ifdef MACOS_TRADITIONAL
3170 /* Since the Mac OS does not honor #! arguments for us, we do it ourselves */
3172 while (PL_doextract || gMacPerl_AlwaysExtract) {
3173 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
3174 if (!gMacPerl_AlwaysExtract)
3175 Perl_croak(aTHX_ "No Perl script found in input\n");
3177 if (PL_doextract) /* require explicit override ? */
3178 if (!OverrideExtract(PL_origfilename))
3179 Perl_croak(aTHX_ "User aborted script\n");
3181 PL_doextract = FALSE;
3183 /* Pater peccavi, file does not have #! */
3184 PerlIO_rewind(PL_rsfp);
3189 while (PL_doextract) {
3190 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
3191 Perl_croak(aTHX_ "No Perl script found in input\n");
3194 if (*s == '#' && s[1] == '!' && ((s = instr(s,"perl")) || (s = instr(s2,"PERL")))) {
3195 PerlIO_ungetc(PL_rsfp, '\n'); /* to keep line count right */
3196 PL_doextract = FALSE;
3197 while (*s && !(isSPACE (*s) || *s == '#')) s++;
3199 while (*s == ' ' || *s == '\t') s++;
3201 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
3202 if (strnEQ(s2-4,"perl",4))
3204 while ((s = moreswitches(s)))
3207 #ifdef MACOS_TRADITIONAL
3208 /* We are always searching for the #!perl line in MacPerl,
3209 * so if we find it, still keep the line count correct
3210 * by counting lines we already skipped over
3212 for (; maclines > 0 ; maclines--)
3213 PerlIO_ungetc(PL_rsfp, '\n');
3217 /* gMacPerl_AlwaysExtract is false in MPW tool */
3218 } else if (gMacPerl_AlwaysExtract) {
3229 PL_uid = PerlProc_getuid();
3230 PL_euid = PerlProc_geteuid();
3231 PL_gid = PerlProc_getgid();
3232 PL_egid = PerlProc_getegid();
3234 PL_uid |= PL_gid << 16;
3235 PL_euid |= PL_egid << 16;
3237 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
3241 S_forbid_setid(pTHX_ char *s)
3243 if (PL_euid != PL_uid)
3244 Perl_croak(aTHX_ "No %s allowed while running setuid", s);
3245 if (PL_egid != PL_gid)
3246 Perl_croak(aTHX_ "No %s allowed while running setgid", s);
3250 Perl_init_debugger(pTHX)
3252 HV *ostash = PL_curstash;
3254 PL_curstash = PL_debstash;
3255 PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
3256 AvREAL_off(PL_dbargs);
3257 PL_DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
3258 PL_DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
3259 PL_DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
3260 sv_upgrade(GvSV(PL_DBsub), SVt_IV); /* IVX accessed if PERLDB_SUB_NN */
3261 PL_DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
3262 sv_setiv(PL_DBsingle, 0);
3263 PL_DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
3264 sv_setiv(PL_DBtrace, 0);
3265 PL_DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
3266 sv_setiv(PL_DBsignal, 0);
3267 PL_curstash = ostash;
3270 #ifndef STRESS_REALLOC
3271 #define REASONABLE(size) (size)
3273 #define REASONABLE(size) (1) /* unreasonable */
3277 Perl_init_stacks(pTHX)
3279 /* start with 128-item stack and 8K cxstack */
3280 PL_curstackinfo = new_stackinfo(REASONABLE(128),
3281 REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
3282 PL_curstackinfo->si_type = PERLSI_MAIN;
3283 PL_curstack = PL_curstackinfo->si_stack;
3284 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
3286 PL_stack_base = AvARRAY(PL_curstack);
3287 PL_stack_sp = PL_stack_base;
3288 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
3290 New(50,PL_tmps_stack,REASONABLE(128),SV*);
3293 PL_tmps_max = REASONABLE(128);
3295 New(54,PL_markstack,REASONABLE(32),I32);
3296 PL_markstack_ptr = PL_markstack;
3297 PL_markstack_max = PL_markstack + REASONABLE(32);
3301 New(54,PL_scopestack,REASONABLE(32),I32);
3302 PL_scopestack_ix = 0;
3303 PL_scopestack_max = REASONABLE(32);
3305 New(54,PL_savestack,REASONABLE(128),ANY);
3306 PL_savestack_ix = 0;
3307 PL_savestack_max = REASONABLE(128);
3309 New(54,PL_retstack,REASONABLE(16),OP*);
3311 PL_retstack_max = REASONABLE(16);
3319 while (PL_curstackinfo->si_next)
3320 PL_curstackinfo = PL_curstackinfo->si_next;
3321 while (PL_curstackinfo) {
3322 PERL_SI *p = PL_curstackinfo->si_prev;
3323 /* curstackinfo->si_stack got nuked by sv_free_arenas() */
3324 Safefree(PL_curstackinfo->si_cxstack);
3325 Safefree(PL_curstackinfo);
3326 PL_curstackinfo = p;
3328 Safefree(PL_tmps_stack);
3329 Safefree(PL_markstack);
3330 Safefree(PL_scopestack);
3331 Safefree(PL_savestack);
3332 Safefree(PL_retstack);
3341 lex_start(PL_linestr);
3343 PL_subname = newSVpvn("main",4);
3347 S_init_predump_symbols(pTHX)
3352 sv_setpvn(get_sv("\"", TRUE), " ", 1);
3353 PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
3354 GvMULTI_on(PL_stdingv);
3355 io = GvIOp(PL_stdingv);
3356 IoTYPE(io) = IoTYPE_RDONLY;
3357 IoIFP(io) = PerlIO_stdin();
3358 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
3360 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
3362 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
3365 IoTYPE(io) = IoTYPE_WRONLY;
3366 IoOFP(io) = IoIFP(io) = PerlIO_stdout();
3368 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
3370 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
3372 PL_stderrgv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
3373 GvMULTI_on(PL_stderrgv);
3374 io = GvIOp(PL_stderrgv);
3375 IoTYPE(io) = IoTYPE_WRONLY;
3376 IoOFP(io) = IoIFP(io) = PerlIO_stderr();
3377 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
3379 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
3381 PL_statname = NEWSV(66,0); /* last filename we did stat on */
3384 Safefree(PL_osname);
3385 PL_osname = savepv(OSNAME);
3389 Perl_init_argv_symbols(pTHX_ register int argc, register char **argv)
3392 argc--,argv++; /* skip name of script */
3393 if (PL_doswitches) {
3394 for (; argc > 0 && **argv == '-'; argc--,argv++) {
3397 if (argv[0][1] == '-' && !argv[0][2]) {
3401 if ((s = strchr(argv[0], '='))) {
3403 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
3406 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
3409 if ((PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV))) {
3410 GvMULTI_on(PL_argvgv);
3411 (void)gv_AVadd(PL_argvgv);
3412 av_clear(GvAVn(PL_argvgv));
3413 for (; argc > 0; argc--,argv++) {
3414 SV *sv = newSVpv(argv[0],0);
3415 av_push(GvAVn(PL_argvgv),sv);
3416 if (PL_widesyscalls)
3417 (void)sv_utf8_decode(sv);
3422 #ifdef HAS_PROCSELFEXE
3423 /* This is a function so that we don't hold on to MAXPATHLEN
3424 bytes of stack longer than necessary
3427 S_procself_val(pTHX_ SV *sv, char *arg0)
3429 char buf[MAXPATHLEN];
3430 int len = readlink(PROCSELFEXE_PATH, buf, sizeof(buf) - 1);
3432 /* On Playstation2 Linux V1.0 (kernel 2.2.1) readlink(/proc/self/exe)
3433 includes a spurious NUL which will cause $^X to fail in system
3434 or backticks (this will prevent extensions from being built and
3435 many tests from working). readlink is not meant to add a NUL.
3436 Normal readlink works fine.
3438 if (len > 0 && buf[len-1] == '\0') {
3442 /* FreeBSD's implementation is acknowledged to be imperfect, sometimes
3443 returning the text "unknown" from the readlink rather than the path
3444 to the executable (or returning an error from the readlink). Any valid
3445 path has a '/' in it somewhere, so use that to validate the result.
3446 See http://www.freebsd.org/cgi/query-pr.cgi?pr=35703
3448 if (len > 0 && memchr(buf, '/', len)) {
3449 sv_setpvn(sv,buf,len);
3455 #endif /* HAS_PROCSELFEXE */
3458 S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
3464 PL_toptarget = NEWSV(0,0);
3465 sv_upgrade(PL_toptarget, SVt_PVFM);
3466 sv_setpvn(PL_toptarget, "", 0);
3467 PL_bodytarget = NEWSV(0,0);
3468 sv_upgrade(PL_bodytarget, SVt_PVFM);
3469 sv_setpvn(PL_bodytarget, "", 0);
3470 PL_formtarget = PL_bodytarget;
3474 init_argv_symbols(argc,argv);
3476 if ((tmpgv = gv_fetchpv("0",TRUE, SVt_PV))) {
3477 #ifdef MACOS_TRADITIONAL
3478 /* $0 is not majick on a Mac */
3479 sv_setpv(GvSV(tmpgv),MacPerl_MPWFileName(PL_origfilename));
3481 sv_setpv(GvSV(tmpgv),PL_origfilename);
3482 magicname("0", "0", 1);
3485 if ((tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))) {/* $^X */
3486 #ifdef HAS_PROCSELFEXE
3487 S_procself_val(aTHX_ GvSV(tmpgv), PL_origargv[0]);
3490 sv_setpv(GvSV(tmpgv), os2_execname(aTHX));
3492 sv_setpv(GvSV(tmpgv),PL_origargv[0]);
3496 if ((PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV))) {
3498 GvMULTI_on(PL_envgv);
3499 hv = GvHVn(PL_envgv);
3500 hv_magic(hv, Nullgv, PERL_MAGIC_env);
3501 #ifdef USE_ENVIRON_ARRAY
3502 /* Note that if the supplied env parameter is actually a copy
3503 of the global environ then it may now point to free'd memory
3504 if the environment has been modified since. To avoid this
3505 problem we treat env==NULL as meaning 'use the default'
3510 # ifdef USE_ITHREADS
3511 && PL_curinterp == aTHX
3515 environ[0] = Nullch;
3518 for (; *env; env++) {
3519 if (!(s = strchr(*env,'=')))
3526 sv = newSVpv(s+1, 0);
3527 (void)hv_store(hv, *env, s - *env, sv, 0);
3531 #endif /* USE_ENVIRON_ARRAY */
3534 if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV))) {
3535 SvREADONLY_off(GvSV(tmpgv));
3536 sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
3537 SvREADONLY_on(GvSV(tmpgv));
3539 #ifdef THREADS_HAVE_PIDS
3540 PL_ppid = (IV)getppid();
3543 /* touch @F array to prevent spurious warnings 20020415 MJD */
3545 (void) get_av("main::F", TRUE | GV_ADDMULTI);
3547 /* touch @- and @+ arrays to prevent spurious warnings 20020415 MJD */
3548 (void) get_av("main::-", TRUE | GV_ADDMULTI);
3549 (void) get_av("main::+", TRUE | GV_ADDMULTI);
3553 S_init_perllib(pTHX)
3558 s = PerlEnv_getenv("PERL5LIB");
3560 incpush(s, TRUE, TRUE, TRUE);
3562 incpush(PerlEnv_getenv("PERLLIB"), FALSE, FALSE, TRUE);
3564 /* Treat PERL5?LIB as a possible search list logical name -- the
3565 * "natural" VMS idiom for a Unix path string. We allow each
3566 * element to be a set of |-separated directories for compatibility.
3570 if (my_trnlnm("PERL5LIB",buf,0))
3571 do { incpush(buf,TRUE,TRUE,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
3573 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE,FALSE,TRUE);
3577 /* Use the ~-expanded versions of APPLLIB (undocumented),
3578 ARCHLIB PRIVLIB SITEARCH SITELIB VENDORARCH and VENDORLIB
3581 incpush(APPLLIB_EXP, TRUE, TRUE, TRUE);
3585 incpush(ARCHLIB_EXP, FALSE, FALSE, TRUE);
3587 #ifdef MACOS_TRADITIONAL
3590 SV * privdir = NEWSV(55, 0);
3591 char * macperl = PerlEnv_getenv("MACPERL");
3596 Perl_sv_setpvf(aTHX_ privdir, "%slib:", macperl);
3597 if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
3598 incpush(SvPVX(privdir), TRUE, FALSE, TRUE);
3599 Perl_sv_setpvf(aTHX_ privdir, "%ssite_perl:", macperl);
3600 if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
3601 incpush(SvPVX(privdir), TRUE, FALSE, TRUE);
3603 SvREFCNT_dec(privdir);
3606 incpush(":", FALSE, FALSE, TRUE);
3609 # define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
3612 incpush(PRIVLIB_EXP, TRUE, FALSE, TRUE);
3614 incpush(PRIVLIB_EXP, FALSE, FALSE, TRUE);
3618 /* sitearch is always relative to sitelib on Windows for
3619 * DLL-based path intuition to work correctly */
3620 # if !defined(WIN32)
3621 incpush(SITEARCH_EXP, FALSE, FALSE, TRUE);
3627 /* this picks up sitearch as well */
3628 incpush(SITELIB_EXP, TRUE, FALSE, TRUE);
3630 incpush(SITELIB_EXP, FALSE, FALSE, TRUE);
3634 #ifdef SITELIB_STEM /* Search for version-specific dirs below here */
3635 incpush(SITELIB_STEM, FALSE, TRUE, TRUE);
3638 #ifdef PERL_VENDORARCH_EXP
3639 /* vendorarch is always relative to vendorlib on Windows for
3640 * DLL-based path intuition to work correctly */
3641 # if !defined(WIN32)
3642 incpush(PERL_VENDORARCH_EXP, FALSE, FALSE, TRUE);
3646 #ifdef PERL_VENDORLIB_EXP
3648 incpush(PERL_VENDORLIB_EXP, TRUE, FALSE, TRUE); /* this picks up vendorarch as well */
3650 incpush(PERL_VENDORLIB_EXP, FALSE, FALSE, TRUE);
3654 #ifdef PERL_VENDORLIB_STEM /* Search for version-specific dirs below here */
3655 incpush(PERL_VENDORLIB_STEM, FALSE, TRUE, TRUE);
3658 #ifdef PERL_OTHERLIBDIRS
3659 incpush(PERL_OTHERLIBDIRS, TRUE, TRUE, TRUE);
3663 incpush(".", FALSE, FALSE, TRUE);
3664 #endif /* MACOS_TRADITIONAL */
3667 #if defined(DOSISH) || defined(EPOC)
3668 # define PERLLIB_SEP ';'
3671 # define PERLLIB_SEP '|'
3673 # if defined(MACOS_TRADITIONAL)
3674 # define PERLLIB_SEP ','
3676 # define PERLLIB_SEP ':'
3680 #ifndef PERLLIB_MANGLE
3681 # define PERLLIB_MANGLE(s,n) (s)
3685 S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers, int usesep)
3687 SV *subdir = Nullsv;
3692 if (addsubdirs || addoldvers) {
3693 subdir = sv_newmortal();
3696 /* Break at all separators */
3698 SV *libdir = NEWSV(55,0);
3701 /* skip any consecutive separators */
3703 while ( *p == PERLLIB_SEP ) {
3704 /* Uncomment the next line for PATH semantics */
3705 /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */
3710 if ( usesep && (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
3711 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
3716 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
3717 p = Nullch; /* break out */
3719 #ifdef MACOS_TRADITIONAL
3720 if (!strchr(SvPVX(libdir), ':')) {
3723 sv_setpv(libdir, MacPerl_CanonDir(SvPVX(libdir), buf, 0));
3725 if (SvPVX(libdir)[SvCUR(libdir)-1] != ':')
3726 sv_catpv(libdir, ":");
3730 * BEFORE pushing libdir onto @INC we may first push version- and
3731 * archname-specific sub-directories.
3733 if (addsubdirs || addoldvers) {
3734 #ifdef PERL_INC_VERSION_LIST
3735 /* Configure terminates PERL_INC_VERSION_LIST with a NULL */
3736 const char *incverlist[] = { PERL_INC_VERSION_LIST };
3737 const char **incver;
3744 if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) {
3746 while (unix[len-1] == '/') len--; /* Cosmetic */
3747 sv_usepvn(libdir,unix,len);
3750 PerlIO_printf(Perl_error_log,
3751 "Failed to unixify @INC element \"%s\"\n",
3755 #ifdef MACOS_TRADITIONAL
3756 #define PERL_AV_SUFFIX_FMT ""
3757 #define PERL_ARCH_FMT "%s:"
3758 #define PERL_ARCH_FMT_PATH PERL_FS_VER_FMT PERL_AV_SUFFIX_FMT
3760 #define PERL_AV_SUFFIX_FMT "/"
3761 #define PERL_ARCH_FMT "/%s"
3762 #define PERL_ARCH_FMT_PATH PERL_AV_SUFFIX_FMT PERL_FS_VER_FMT
3764 /* .../version/archname if -d .../version/archname */
3765 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH PERL_ARCH_FMT,
3767 (int)PERL_REVISION, (int)PERL_VERSION,
3768 (int)PERL_SUBVERSION, ARCHNAME);
3769 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3770 S_ISDIR(tmpstatbuf.st_mode))
3771 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3773 /* .../version if -d .../version */
3774 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH, libdir,
3775 (int)PERL_REVISION, (int)PERL_VERSION,
3776 (int)PERL_SUBVERSION);
3777 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3778 S_ISDIR(tmpstatbuf.st_mode))
3779 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3781 /* .../archname if -d .../archname */
3782 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, ARCHNAME);
3783 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3784 S_ISDIR(tmpstatbuf.st_mode))
3785 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3788 #ifdef PERL_INC_VERSION_LIST
3790 for (incver = incverlist; *incver; incver++) {
3791 /* .../xxx if -d .../xxx */
3792 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, *incver);
3793 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3794 S_ISDIR(tmpstatbuf.st_mode))
3795 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3801 /* finally push this lib directory on the end of @INC */
3802 av_push(GvAVn(PL_incgv), libdir);
3806 #ifdef USE_5005THREADS
3807 STATIC struct perl_thread *
3808 S_init_main_thread(pTHX)
3810 #if !defined(PERL_IMPLICIT_CONTEXT)
3811 struct perl_thread *thr;
3815 Newz(53, thr, 1, struct perl_thread);
3816 PL_curcop = &PL_compiling;
3817 thr->interp = PERL_GET_INTERP;
3818 thr->cvcache = newHV();
3819 thr->threadsv = newAV();
3820 /* thr->threadsvp is set when find_threadsv is called */
3821 thr->specific = newAV();
3822 thr->flags = THRf_R_JOINABLE;
3823 MUTEX_INIT(&thr->mutex);
3824 /* Handcraft thrsv similarly to mess_sv */
3825 New(53, PL_thrsv, 1, SV);
3826 Newz(53, xpv, 1, XPV);
3827 SvFLAGS(PL_thrsv) = SVt_PV;
3828 SvANY(PL_thrsv) = (void*)xpv;
3829 SvREFCNT(PL_thrsv) = 1 << 30; /* practically infinite */
3830 SvPVX(PL_thrsv) = (char*)thr;
3831 SvCUR_set(PL_thrsv, sizeof(thr));
3832 SvLEN_set(PL_thrsv, sizeof(thr));
3833 *SvEND(PL_thrsv) = '\0'; /* in the trailing_nul field */
3834 thr->oursv = PL_thrsv;
3835 PL_chopset = " \n-";
3838 MUTEX_LOCK(&PL_threads_mutex);
3844 MUTEX_UNLOCK(&PL_threads_mutex);
3846 #ifdef HAVE_THREAD_INTERN
3847 Perl_init_thread_intern(thr);
3850 #ifdef SET_THREAD_SELF
3851 SET_THREAD_SELF(thr);
3853 thr->self = pthread_self();
3854 #endif /* SET_THREAD_SELF */
3858 * These must come after the thread self setting
3859 * because sv_setpvn does SvTAINT and the taint
3860 * fields thread selfness being set.
3862 PL_toptarget = NEWSV(0,0);
3863 sv_upgrade(PL_toptarget, SVt_PVFM);
3864 sv_setpvn(PL_toptarget, "", 0);
3865 PL_bodytarget = NEWSV(0,0);
3866 sv_upgrade(PL_bodytarget, SVt_PVFM);
3867 sv_setpvn(PL_bodytarget, "", 0);
3868 PL_formtarget = PL_bodytarget;
3869 thr->errsv = newSVpvn("", 0);
3870 (void) find_threadsv("@"); /* Ensure $@ is initialised early */
3873 PL_peepp = MEMBER_TO_FPTR(Perl_peep);
3874 PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
3875 PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
3876 PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
3877 PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
3878 PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
3880 PL_reginterp_cnt = 0;
3884 #endif /* USE_5005THREADS */
3887 Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
3890 line_t oldline = CopLINE(PL_curcop);
3896 while (AvFILL(paramList) >= 0) {
3897 cv = (CV*)av_shift(paramList);
3899 if (paramList == PL_beginav) {
3900 /* save PL_beginav for compiler */
3901 if (! PL_beginav_save)
3902 PL_beginav_save = newAV();
3903 av_push(PL_beginav_save, (SV*)cv);
3905 else if (paramList == PL_checkav) {
3906 /* save PL_checkav for compiler */
3907 if (! PL_checkav_save)
3908 PL_checkav_save = newAV();
3909 av_push(PL_checkav_save, (SV*)cv);
3914 #ifdef PERL_FLEXIBLE_EXCEPTIONS
3915 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_list_body), cv);
3921 #ifndef PERL_FLEXIBLE_EXCEPTIONS
3925 (void)SvPV(atsv, len);
3928 PL_curcop = &PL_compiling;
3929 CopLINE_set(PL_curcop, oldline);
3930 if (paramList == PL_beginav)
3931 sv_catpv(atsv, "BEGIN failed--compilation aborted");
3933 Perl_sv_catpvf(aTHX_ atsv,
3934 "%s failed--call queue aborted",
3935 paramList == PL_checkav ? "CHECK"
3936 : paramList == PL_initav ? "INIT"
3938 while (PL_scopestack_ix > oldscope)
3941 Perl_croak(aTHX_ "%s", SvPVx(atsv, n_a));
3948 /* my_exit() was called */
3949 while (PL_scopestack_ix > oldscope)
3952 PL_curstash = PL_defstash;
3953 PL_curcop = &PL_compiling;
3954 CopLINE_set(PL_curcop, oldline);
3956 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) {
3957 if (paramList == PL_beginav)
3958 Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
3960 Perl_croak(aTHX_ "%s failed--call queue aborted",
3961 paramList == PL_checkav ? "CHECK"
3962 : paramList == PL_initav ? "INIT"
3969 PL_curcop = &PL_compiling;
3970 CopLINE_set(PL_curcop, oldline);
3973 PerlIO_printf(Perl_error_log, "panic: restartop\n");
3981 #ifdef PERL_FLEXIBLE_EXCEPTIONS
3983 S_vcall_list_body(pTHX_ va_list args)
3985 CV *cv = va_arg(args, CV*);
3986 return call_list_body(cv);
3991 S_call_list_body(pTHX_ CV *cv)
3993 PUSHMARK(PL_stack_sp);
3994 call_sv((SV*)cv, G_EVAL|G_DISCARD);
3999 Perl_my_exit(pTHX_ U32 status)
4001 DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
4002 thr, (unsigned long) status));
4011 STATUS_NATIVE_SET(status);
4018 Perl_my_failure_exit(pTHX)
4021 if (vaxc$errno & 1) {
4022 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
4023 STATUS_NATIVE_SET(44);
4026 if (!vaxc$errno && errno) /* unlikely */
4027 STATUS_NATIVE_SET(44);
4029 STATUS_NATIVE_SET(vaxc$errno);
4034 STATUS_POSIX_SET(errno);
4036 exitstatus = STATUS_POSIX >> 8;
4037 if (exitstatus & 255)
4038 STATUS_POSIX_SET(exitstatus);
4040 STATUS_POSIX_SET(255);
4047 S_my_exit_jump(pTHX)
4049 register PERL_CONTEXT *cx;
4054 SvREFCNT_dec(PL_e_script);
4055 PL_e_script = Nullsv;
4058 POPSTACK_TO(PL_mainstack);
4059 if (cxstack_ix >= 0) {
4062 POPBLOCK(cx,PL_curpm);
4070 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen)
4073 p = SvPVX(PL_e_script);
4074 nl = strchr(p, '\n');
4075 nl = (nl) ? nl+1 : SvEND(PL_e_script);
4077 filter_del(read_e_script);
4080 sv_catpvn(buf_sv, p, nl-p);
4081 sv_chop(PL_e_script, nl);