3 * Copyright (c) 1987-2002 Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * "A ship then new they built for him/of mithril and of elven glass" --Bilbo
15 #define PERL_IN_PERL_C
17 #include "patchlevel.h" /* for local_patches */
21 char *nw_get_sitelib(const char *pl);
24 /* XXX If this causes problems, set i_unistd=undef in the hint file. */
41 #if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE) && !defined(PERL_MICRO)
42 char *getenv (char *); /* Usually in <stdlib.h> */
45 static I32 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen);
53 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
59 #if defined(USE_ITHREADS)
60 # define INIT_TLS_AND_INTERP \
62 if (!PL_curinterp) { \
63 PERL_SET_INTERP(my_perl); \
66 PERL_SET_THX(my_perl); \
70 PERL_SET_THX(my_perl); \
74 # define INIT_TLS_AND_INTERP \
76 if (!PL_curinterp) { \
77 PERL_SET_INTERP(my_perl); \
79 PERL_SET_THX(my_perl); \
83 #ifdef PERL_IMPLICIT_SYS
85 perl_alloc_using(struct IPerlMem* ipM, struct IPerlMem* ipMS,
86 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
87 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
88 struct IPerlDir* ipD, struct IPerlSock* ipS,
89 struct IPerlProc* ipP)
91 PerlInterpreter *my_perl;
92 /* New() needs interpreter, so call malloc() instead */
93 my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
95 Zero(my_perl, 1, PerlInterpreter);
111 =head1 Embedding Functions
113 =for apidoc perl_alloc
115 Allocates a new Perl interpreter. See L<perlembed>.
123 PerlInterpreter *my_perl;
124 #ifdef USE_5005THREADS
128 /* New() needs interpreter, so call malloc() instead */
129 my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
132 Zero(my_perl, 1, PerlInterpreter);
135 #endif /* PERL_IMPLICIT_SYS */
138 =for apidoc perl_construct
140 Initializes a new Perl interpreter. See L<perlembed>.
146 perl_construct(pTHXx)
150 PL_perl_destruct_level = 1;
152 if (PL_perl_destruct_level > 0)
156 /* Init the real globals (and main thread)? */
159 MUTEX_INIT(&PL_dollarzero_mutex); /* for $0 modifying */
161 #ifdef PERL_FLEXIBLE_EXCEPTIONS
162 PL_protect = MEMBER_TO_FPTR(Perl_default_protect); /* for exceptions */
165 PL_curcop = &PL_compiling; /* needed by ckWARN, right away */
167 PL_linestr = NEWSV(65,79);
168 sv_upgrade(PL_linestr,SVt_PVIV);
170 if (!SvREADONLY(&PL_sv_undef)) {
171 /* set read-only and try to insure than we wont see REFCNT==0
174 SvREADONLY_on(&PL_sv_undef);
175 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
177 sv_setpv(&PL_sv_no,PL_No);
179 SvREADONLY_on(&PL_sv_no);
180 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
182 sv_setpv(&PL_sv_yes,PL_Yes);
184 SvREADONLY_on(&PL_sv_yes);
185 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
188 PL_sighandlerp = Perl_sighandler;
189 PL_pidstatus = newHV();
192 PL_rs = newSVpvn("\n", 1);
197 PL_lex_state = LEX_NOTPARSING;
203 SET_NUMERIC_STANDARD();
207 PL_patchlevel = NEWSV(0,4);
208 (void)SvUPGRADE(PL_patchlevel, SVt_PVNV);
209 if (PERL_REVISION > 127 || PERL_VERSION > 127 || PERL_SUBVERSION > 127)
210 SvGROW(PL_patchlevel, UTF8_MAXLEN*3+1);
211 s = (U8*)SvPVX(PL_patchlevel);
212 /* Build version strings using "native" characters */
213 s = uvchr_to_utf8(s, (UV)PERL_REVISION);
214 s = uvchr_to_utf8(s, (UV)PERL_VERSION);
215 s = uvchr_to_utf8(s, (UV)PERL_SUBVERSION);
217 SvCUR_set(PL_patchlevel, s - (U8*)SvPVX(PL_patchlevel));
218 SvPOK_on(PL_patchlevel);
219 SvNVX(PL_patchlevel) = (NV)PERL_REVISION
220 + ((NV)PERL_VERSION / (NV)1000)
221 #if defined(PERL_SUBVERSION) && PERL_SUBVERSION > 0
222 + ((NV)PERL_SUBVERSION / (NV)1000000)
225 SvNOK_on(PL_patchlevel); /* dual valued */
226 SvUTF8_on(PL_patchlevel);
227 SvREADONLY_on(PL_patchlevel);
230 #if defined(LOCAL_PATCH_COUNT)
231 PL_localpatches = local_patches; /* For possible -v */
234 #ifdef HAVE_INTERP_INTERN
238 PerlIO_init(aTHX); /* Hook to IO system */
240 PL_fdpid = newAV(); /* for remembering popen pids by fd */
241 PL_modglobal = newHV(); /* pointers to per-interpreter module globals */
242 PL_errors = newSVpvn("",0);
243 sv_setpvn(PERL_DEBUG_PAD(0), "", 0); /* For regex debugging. */
244 sv_setpvn(PERL_DEBUG_PAD(1), "", 0); /* ext/re needs these */
245 sv_setpvn(PERL_DEBUG_PAD(2), "", 0); /* even without DEBUGGING. */
247 PL_regex_padav = newAV();
248 av_push(PL_regex_padav,(SV*)newAV()); /* First entry is an array of empty elements */
249 PL_regex_pad = AvARRAY(PL_regex_padav);
251 #ifdef USE_REENTRANT_API
252 Perl_reentrant_init(aTHX);
255 /* Note that strtab is a rather special HV. Assumptions are made
256 about not iterating on it, and not adding tie magic to it.
257 It is properly deallocated in perl_destruct() */
260 HvSHAREKEYS_off(PL_strtab); /* mandatory */
261 hv_ksplit(PL_strtab, 512);
263 #if defined(__DYNAMIC__) && (defined(NeXT) || defined(__NeXT__))
264 _dyld_lookup_and_bind
265 ("__environ", (unsigned long *) &environ_pointer, NULL);
268 #ifdef USE_ENVIRON_ARRAY
269 PL_origenviron = environ;
272 /* Use sysconf(_SC_CLK_TCK) if available, if not
273 * available or if the sysconf() fails, use the HZ. */
274 #if defined(HAS_SYSCONF) && defined(_SC_CLK_TCK)
275 PL_clocktick = sysconf(_SC_CLK_TCK);
276 if (PL_clocktick <= 0)
284 =for apidoc nothreadhook
286 Stub that provides thread hook for perl_destruct when there are
293 Perl_nothreadhook(pTHX)
299 =for apidoc perl_destruct
301 Shuts down a Perl interpreter. See L<perlembed>.
309 volatile int destruct_level; /* 0=none, 1=full, 2=full with checks */
311 #ifdef USE_5005THREADS
313 #endif /* USE_5005THREADS */
315 /* wait for all pseudo-forked children to finish */
316 PERL_WAIT_FOR_CHILDREN;
318 destruct_level = PL_perl_destruct_level;
322 if ((s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL"))) {
324 if (destruct_level < i)
331 if(PL_exit_flags & PERL_EXIT_DESTRUCT_END) {
336 if (PL_endav && !PL_minus_c)
337 call_list(PL_scopestack_ix, PL_endav);
343 /* Need to flush since END blocks can produce output */
346 if (CALL_FPTR(PL_threadhook)(aTHX)) {
347 /* Threads hook has vetoed further cleanup */
348 return STATUS_NATIVE_EXPORT;
351 /* We must account for everything. */
353 /* Destroy the main CV and syntax tree */
355 op_free(PL_main_root);
356 PL_main_root = Nullop;
358 PL_curcop = &PL_compiling;
359 PL_main_start = Nullop;
360 SvREFCNT_dec(PL_main_cv);
364 /* Tell PerlIO we are about to tear things apart in case
365 we have layers which are using resources that should
369 PerlIO_destruct(aTHX);
371 if (PL_sv_objcount) {
373 * Try to destruct global references. We do this first so that the
374 * destructors and destructees still exist. Some sv's might remain.
375 * Non-referenced objects are on their own.
380 /* unhook hooks which will soon be, or use, destroyed data */
381 SvREFCNT_dec(PL_warnhook);
382 PL_warnhook = Nullsv;
383 SvREFCNT_dec(PL_diehook);
386 /* call exit list functions */
387 while (PL_exitlistlen-- > 0)
388 PL_exitlist[PL_exitlistlen].fn(aTHX_ PL_exitlist[PL_exitlistlen].ptr);
390 Safefree(PL_exitlist);
392 if (destruct_level == 0){
394 DEBUG_P(debprofdump());
396 #if defined(PERLIO_LAYERS)
397 /* No more IO - including error messages ! */
398 PerlIO_cleanup(aTHX);
401 /* The exit() function will do everything that needs doing. */
402 return STATUS_NATIVE_EXPORT;
405 /* jettison our possibly duplicated environment */
406 /* if PERL_USE_SAFE_PUTENV is defined environ will not have been copied
407 * so we certainly shouldn't free it here
409 #if defined(USE_ENVIRON_ARRAY) && !defined(PERL_USE_SAFE_PUTENV)
410 if (environ != PL_origenviron
412 /* only main thread can free environ[0] contents */
413 && PL_curinterp == aTHX
419 for (i = 0; environ[i]; i++)
420 safesysfree(environ[i]);
422 /* Must use safesysfree() when working with environ. */
423 safesysfree(environ);
425 environ = PL_origenviron;
430 /* the syntax tree is shared between clones
431 * so op_free(PL_main_root) only ReREFCNT_dec's
432 * REGEXPs in the parent interpreter
433 * we need to manually ReREFCNT_dec for the clones
436 I32 i = AvFILLp(PL_regex_padav) + 1;
437 SV **ary = AvARRAY(PL_regex_padav);
441 REGEXP *re = INT2PTR(REGEXP *,SvIVX(resv));
443 if (SvFLAGS(resv) & SVf_BREAK) {
444 /* this is PL_reg_curpm, already freed
445 * flag is set in regexec.c:S_regtry
447 SvFLAGS(resv) &= ~SVf_BREAK;
449 else if(SvREPADTMP(resv)) {
450 SvREPADTMP_off(resv);
457 SvREFCNT_dec(PL_regex_padav);
458 PL_regex_padav = Nullav;
462 /* loosen bonds of global variables */
465 (void)PerlIO_close(PL_rsfp);
469 /* Filters for program text */
470 SvREFCNT_dec(PL_rsfp_filters);
471 PL_rsfp_filters = Nullav;
474 PL_preprocess = FALSE;
480 PL_doswitches = FALSE;
481 PL_dowarn = G_WARN_OFF;
482 PL_doextract = FALSE;
483 PL_sawampersand = FALSE; /* must save all match strings */
486 Safefree(PL_inplace);
488 SvREFCNT_dec(PL_patchlevel);
491 SvREFCNT_dec(PL_e_script);
492 PL_e_script = Nullsv;
495 /* magical thingies */
497 SvREFCNT_dec(PL_ofs_sv); /* $, */
500 SvREFCNT_dec(PL_ors_sv); /* $\ */
503 SvREFCNT_dec(PL_rs); /* $/ */
506 PL_multiline = 0; /* $* */
507 Safefree(PL_osname); /* $^O */
510 SvREFCNT_dec(PL_statname);
511 PL_statname = Nullsv;
514 /* defgv, aka *_ should be taken care of elsewhere */
516 /* clean up after study() */
517 SvREFCNT_dec(PL_lastscream);
518 PL_lastscream = Nullsv;
519 Safefree(PL_screamfirst);
521 Safefree(PL_screamnext);
525 Safefree(PL_efloatbuf);
526 PL_efloatbuf = Nullch;
529 /* startup and shutdown function lists */
530 SvREFCNT_dec(PL_beginav);
531 SvREFCNT_dec(PL_beginav_save);
532 SvREFCNT_dec(PL_endav);
533 SvREFCNT_dec(PL_checkav);
534 SvREFCNT_dec(PL_checkav_save);
535 SvREFCNT_dec(PL_initav);
537 PL_beginav_save = Nullav;
540 PL_checkav_save = Nullav;
543 /* shortcuts just get cleared */
549 PL_argvoutgv = Nullgv;
551 PL_stderrgv = Nullgv;
552 PL_last_in_gv = Nullgv;
554 PL_debstash = Nullhv;
556 /* reset so print() ends up where we expect */
559 SvREFCNT_dec(PL_argvout_stack);
560 PL_argvout_stack = Nullav;
562 SvREFCNT_dec(PL_modglobal);
563 PL_modglobal = Nullhv;
564 SvREFCNT_dec(PL_preambleav);
565 PL_preambleav = Nullav;
566 SvREFCNT_dec(PL_subname);
568 SvREFCNT_dec(PL_linestr);
570 SvREFCNT_dec(PL_pidstatus);
571 PL_pidstatus = Nullhv;
572 SvREFCNT_dec(PL_toptarget);
573 PL_toptarget = Nullsv;
574 SvREFCNT_dec(PL_bodytarget);
575 PL_bodytarget = Nullsv;
576 PL_formtarget = Nullsv;
578 /* free locale stuff */
579 #ifdef USE_LOCALE_COLLATE
580 Safefree(PL_collation_name);
581 PL_collation_name = Nullch;
584 #ifdef USE_LOCALE_NUMERIC
585 Safefree(PL_numeric_name);
586 PL_numeric_name = Nullch;
587 SvREFCNT_dec(PL_numeric_radix_sv);
590 /* clear utf8 character classes */
591 SvREFCNT_dec(PL_utf8_alnum);
592 SvREFCNT_dec(PL_utf8_alnumc);
593 SvREFCNT_dec(PL_utf8_ascii);
594 SvREFCNT_dec(PL_utf8_alpha);
595 SvREFCNT_dec(PL_utf8_space);
596 SvREFCNT_dec(PL_utf8_cntrl);
597 SvREFCNT_dec(PL_utf8_graph);
598 SvREFCNT_dec(PL_utf8_digit);
599 SvREFCNT_dec(PL_utf8_upper);
600 SvREFCNT_dec(PL_utf8_lower);
601 SvREFCNT_dec(PL_utf8_print);
602 SvREFCNT_dec(PL_utf8_punct);
603 SvREFCNT_dec(PL_utf8_xdigit);
604 SvREFCNT_dec(PL_utf8_mark);
605 SvREFCNT_dec(PL_utf8_toupper);
606 SvREFCNT_dec(PL_utf8_totitle);
607 SvREFCNT_dec(PL_utf8_tolower);
608 SvREFCNT_dec(PL_utf8_tofold);
609 SvREFCNT_dec(PL_utf8_idstart);
610 SvREFCNT_dec(PL_utf8_idcont);
611 PL_utf8_alnum = Nullsv;
612 PL_utf8_alnumc = Nullsv;
613 PL_utf8_ascii = Nullsv;
614 PL_utf8_alpha = Nullsv;
615 PL_utf8_space = Nullsv;
616 PL_utf8_cntrl = Nullsv;
617 PL_utf8_graph = Nullsv;
618 PL_utf8_digit = Nullsv;
619 PL_utf8_upper = Nullsv;
620 PL_utf8_lower = Nullsv;
621 PL_utf8_print = Nullsv;
622 PL_utf8_punct = Nullsv;
623 PL_utf8_xdigit = Nullsv;
624 PL_utf8_mark = Nullsv;
625 PL_utf8_toupper = Nullsv;
626 PL_utf8_totitle = Nullsv;
627 PL_utf8_tolower = Nullsv;
628 PL_utf8_tofold = Nullsv;
629 PL_utf8_idstart = Nullsv;
630 PL_utf8_idcont = Nullsv;
632 if (!specialWARN(PL_compiling.cop_warnings))
633 SvREFCNT_dec(PL_compiling.cop_warnings);
634 PL_compiling.cop_warnings = Nullsv;
635 if (!specialCopIO(PL_compiling.cop_io))
636 SvREFCNT_dec(PL_compiling.cop_io);
637 PL_compiling.cop_io = Nullsv;
638 CopFILE_free(&PL_compiling);
639 CopSTASH_free(&PL_compiling);
641 /* Prepare to destruct main symbol table. */
646 SvREFCNT_dec(PL_curstname);
647 PL_curstname = Nullsv;
649 /* clear queued errors */
650 SvREFCNT_dec(PL_errors);
654 if (destruct_level >= 2 && ckWARN_d(WARN_INTERNAL)) {
655 if (PL_scopestack_ix != 0)
656 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
657 "Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
658 (long)PL_scopestack_ix);
659 if (PL_savestack_ix != 0)
660 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
661 "Unbalanced saves: %ld more saves than restores\n",
662 (long)PL_savestack_ix);
663 if (PL_tmps_floor != -1)
664 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced tmps: %ld more allocs than frees\n",
665 (long)PL_tmps_floor + 1);
666 if (cxstack_ix != -1)
667 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced context: %ld more PUSHes than POPs\n",
668 (long)cxstack_ix + 1);
671 /* Now absolutely destruct everything, somehow or other, loops or no. */
672 SvFLAGS(PL_fdpid) |= SVTYPEMASK; /* don't clean out pid table now */
673 SvFLAGS(PL_strtab) |= SVTYPEMASK; /* don't clean out strtab now */
675 /* the 2 is for PL_fdpid and PL_strtab */
676 while (PL_sv_count > 2 && sv_clean_all())
679 SvFLAGS(PL_fdpid) &= ~SVTYPEMASK;
680 SvFLAGS(PL_fdpid) |= SVt_PVAV;
681 SvFLAGS(PL_strtab) &= ~SVTYPEMASK;
682 SvFLAGS(PL_strtab) |= SVt_PVHV;
684 AvREAL_off(PL_fdpid); /* no surviving entries */
685 SvREFCNT_dec(PL_fdpid); /* needed in io_close() */
688 #ifdef HAVE_INTERP_INTERN
692 /* Destruct the global string table. */
694 /* Yell and reset the HeVAL() slots that are still holding refcounts,
695 * so that sv_free() won't fail on them.
703 max = HvMAX(PL_strtab);
704 array = HvARRAY(PL_strtab);
707 if (hent && ckWARN_d(WARN_INTERNAL)) {
708 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
709 "Unbalanced string table refcount: (%d) for \"%s\"",
710 HeVAL(hent) - Nullsv, HeKEY(hent));
711 HeVAL(hent) = Nullsv;
721 SvREFCNT_dec(PL_strtab);
724 /* free the pointer table used for cloning */
725 ptr_table_free(PL_ptr_table);
728 /* free special SVs */
730 SvREFCNT(&PL_sv_yes) = 0;
731 sv_clear(&PL_sv_yes);
732 SvANY(&PL_sv_yes) = NULL;
733 SvFLAGS(&PL_sv_yes) = 0;
735 SvREFCNT(&PL_sv_no) = 0;
737 SvANY(&PL_sv_no) = NULL;
738 SvFLAGS(&PL_sv_no) = 0;
742 for (i=0; i<=2; i++) {
743 SvREFCNT(PERL_DEBUG_PAD(i)) = 0;
744 sv_clear(PERL_DEBUG_PAD(i));
745 SvANY(PERL_DEBUG_PAD(i)) = NULL;
746 SvFLAGS(PERL_DEBUG_PAD(i)) = 0;
750 if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL))
751 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Scalars leaked: %ld\n", (long)PL_sv_count);
753 #ifdef DEBUG_LEAKING_SCALARS
754 if (PL_sv_count != 0) {
759 for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
760 svend = &sva[SvREFCNT(sva)];
761 for (sv = sva + 1; sv < svend; ++sv) {
762 if (SvTYPE(sv) != SVTYPEMASK) {
763 PerlIO_printf(Perl_debug_log, "leaked: 0x%p\n", sv);
771 #if defined(PERLIO_LAYERS)
772 /* No more IO - including error messages ! */
773 PerlIO_cleanup(aTHX);
776 /* sv_undef needs to stay immortal until after PerlIO_cleanup
777 as currently layers use it rather than Nullsv as a marker
778 for no arg - and will try and SvREFCNT_dec it.
780 SvREFCNT(&PL_sv_undef) = 0;
781 SvREADONLY_off(&PL_sv_undef);
783 Safefree(PL_origfilename);
784 Safefree(PL_reg_start_tmp);
786 Safefree(PL_reg_curpm);
787 Safefree(PL_reg_poscache);
788 Safefree(HeKEY_hek(&PL_hv_fetch_ent_mh));
789 Safefree(PL_op_mask);
790 Safefree(PL_psig_ptr);
791 Safefree(PL_psig_name);
792 Safefree(PL_bitcount);
793 Safefree(PL_psig_pend);
795 PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */
797 DEBUG_P(debprofdump());
799 #ifdef USE_REENTRANT_API
800 Perl_reentrant_free(aTHX);
805 /* As the absolutely last thing, free the non-arena SV for mess() */
808 /* it could have accumulated taint magic */
809 if (SvTYPE(PL_mess_sv) >= SVt_PVMG) {
812 for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) {
813 moremagic = mg->mg_moremagic;
814 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global
816 Safefree(mg->mg_ptr);
820 /* we know that type >= SVt_PV */
821 (void)SvOOK_off(PL_mess_sv);
822 Safefree(SvPVX(PL_mess_sv));
823 Safefree(SvANY(PL_mess_sv));
824 Safefree(PL_mess_sv);
827 return STATUS_NATIVE_EXPORT;
831 =for apidoc perl_free
833 Releases a Perl interpreter. See L<perlembed>.
841 #if defined(WIN32) || defined(NETWARE)
842 # if defined(PERL_IMPLICIT_SYS)
844 void *host = nw_internal_host;
846 void *host = w32_internal_host;
850 nw_delete_internal_host(host);
852 win32_delete_internal_host(host);
863 Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
865 Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry);
866 PL_exitlist[PL_exitlistlen].fn = fn;
867 PL_exitlist[PL_exitlistlen].ptr = ptr;
872 =for apidoc perl_parse
874 Tells a Perl interpreter to parse a Perl script. See L<perlembed>.
880 perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
885 #ifdef USE_5005THREADS
889 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
892 Perl_croak(aTHX_ "suidperl is no longer needed since the kernel can now execute\n\
893 setuid perl scripts securely.\n");
902 /* Come here if running an undumped a.out. */
904 PL_origfilename = savepv(argv[0]);
905 PL_do_undump = FALSE;
906 cxstack_ix = -1; /* start label stack again */
908 init_postdump_symbols(argc,argv,env);
913 op_free(PL_main_root);
914 PL_main_root = Nullop;
916 PL_main_start = Nullop;
917 SvREFCNT_dec(PL_main_cv);
921 oldscope = PL_scopestack_ix;
922 PL_dowarn = G_WARN_OFF;
924 #ifdef PERL_FLEXIBLE_EXCEPTIONS
925 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vparse_body), env, xsinit);
931 #ifndef PERL_FLEXIBLE_EXCEPTIONS
932 parse_body(env,xsinit);
935 call_list(oldscope, PL_checkav);
942 /* my_exit() was called */
943 while (PL_scopestack_ix > oldscope)
946 PL_curstash = PL_defstash;
948 call_list(oldscope, PL_checkav);
949 ret = STATUS_NATIVE_EXPORT;
952 PerlIO_printf(Perl_error_log, "panic: top_env\n");
960 #ifdef PERL_FLEXIBLE_EXCEPTIONS
962 S_vparse_body(pTHX_ va_list args)
964 char **env = va_arg(args, char**);
965 XSINIT_t xsinit = va_arg(args, XSINIT_t);
967 return parse_body(env, xsinit);
972 S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
974 int argc = PL_origargc;
975 char **argv = PL_origargv;
976 char *scriptname = NULL;
978 VOL bool dosearch = FALSE;
982 char *cddir = Nullch;
984 sv_setpvn(PL_linestr,"",0);
985 sv = newSVpvn("",0); /* first used for -I flags */
989 for (argc--,argv++; argc > 0; argc--,argv++) {
990 if (argv[0][0] != '-' || !argv[0][1])
994 validarg = " PHOOEY ";
1003 win32_argv2utf8(argc-1, argv+1);
1006 #ifndef PERL_STRICT_CR
1030 if ((s = moreswitches(s)))
1035 if( !PL_tainting ) {
1036 PL_taint_warn = TRUE;
1043 PL_taint_warn = FALSE;
1048 #ifdef MACOS_TRADITIONAL
1049 /* ignore -e for Dev:Pseudo argument */
1050 if (argv[1] && !strcmp(argv[1], "Dev:Pseudo"))
1053 if (PL_euid != PL_uid || PL_egid != PL_gid)
1054 Perl_croak(aTHX_ "No -e allowed in setuid scripts");
1056 PL_e_script = newSVpvn("",0);
1057 filter_add(read_e_script, NULL);
1060 sv_catpv(PL_e_script, s);
1062 sv_catpv(PL_e_script, argv[1]);
1066 Perl_croak(aTHX_ "No code specified for -e");
1067 sv_catpv(PL_e_script, "\n");
1070 case 'I': /* -I handled both here and in moreswitches() */
1072 if (!*++s && (s=argv[1]) != Nullch) {
1077 STRLEN len = strlen(s);
1078 p = savepvn(s, len);
1079 incpush(p, TRUE, TRUE, FALSE);
1080 sv_catpvn(sv, "-I", 2);
1081 sv_catpvn(sv, p, len);
1082 sv_catpvn(sv, " ", 1);
1086 Perl_croak(aTHX_ "No directory specified for -I");
1090 PL_preprocess = TRUE;
1100 PL_preambleav = newAV();
1101 av_push(PL_preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
1103 PL_Sv = newSVpv("print myconfig();",0);
1105 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
1107 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
1109 sv_catpv(PL_Sv,"\" Compile-time options:");
1111 sv_catpv(PL_Sv," DEBUGGING");
1113 # ifdef MULTIPLICITY
1114 sv_catpv(PL_Sv," MULTIPLICITY");
1116 # ifdef USE_5005THREADS
1117 sv_catpv(PL_Sv," USE_5005THREADS");
1119 # ifdef USE_ITHREADS
1120 sv_catpv(PL_Sv," USE_ITHREADS");
1122 # ifdef USE_64_BIT_INT
1123 sv_catpv(PL_Sv," USE_64_BIT_INT");
1125 # ifdef USE_64_BIT_ALL
1126 sv_catpv(PL_Sv," USE_64_BIT_ALL");
1128 # ifdef USE_LONG_DOUBLE
1129 sv_catpv(PL_Sv," USE_LONG_DOUBLE");
1131 # ifdef USE_LARGE_FILES
1132 sv_catpv(PL_Sv," USE_LARGE_FILES");
1135 sv_catpv(PL_Sv," USE_SOCKS");
1137 # ifdef PERL_IMPLICIT_CONTEXT
1138 sv_catpv(PL_Sv," PERL_IMPLICIT_CONTEXT");
1140 # ifdef PERL_IMPLICIT_SYS
1141 sv_catpv(PL_Sv," PERL_IMPLICIT_SYS");
1143 sv_catpv(PL_Sv,"\\n\",");
1145 #if defined(LOCAL_PATCH_COUNT)
1146 if (LOCAL_PATCH_COUNT > 0) {
1148 sv_catpv(PL_Sv,"\" Locally applied patches:\\n\",");
1149 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
1150 if (PL_localpatches[i])
1151 Perl_sv_catpvf(aTHX_ PL_Sv,"q\" \t%s\n\",",PL_localpatches[i]);
1155 Perl_sv_catpvf(aTHX_ PL_Sv,"\" Built under %s\\n\"",OSNAME);
1158 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
1160 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled on %s\\n\"",__DATE__);
1163 sv_catpv(PL_Sv, "; \
1165 @env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; ");
1168 push @env, \"CYGWIN=\\\"$ENV{CYGWIN}\\\"\";");
1171 print \" \\%ENV:\\n @env\\n\" if @env; \
1172 print \" \\@INC:\\n @INC\\n\";");
1175 PL_Sv = newSVpv("config_vars(qw(",0);
1176 sv_catpv(PL_Sv, ++s);
1177 sv_catpv(PL_Sv, "))");
1180 av_push(PL_preambleav, PL_Sv);
1181 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
1184 PL_doextract = TRUE;
1192 if (!*++s || isSPACE(*s)) {
1196 /* catch use of gnu style long options */
1197 if (strEQ(s, "version")) {
1201 if (strEQ(s, "help")) {
1208 Perl_croak(aTHX_ "Unrecognized switch: -%s (-h will show valid options)",s);
1212 sv_setsv(get_sv("/", TRUE), PL_rs);
1215 #ifndef SECURE_INTERNAL_GETENV
1218 (s = PerlEnv_getenv("PERL5OPT")))
1223 if (*s == '-' && *(s+1) == 'T') {
1225 PL_taint_warn = FALSE;
1228 char *popt_copy = Nullch;
1241 if (!strchr("DIMUdmtw", *s))
1242 Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
1246 popt_copy = SvPVX(sv_2mortal(newSVpv(popt,0)));
1247 s = popt_copy + (s - popt);
1248 d = popt_copy + (d - popt);
1255 if( !PL_tainting ) {
1256 PL_taint_warn = TRUE;
1266 if (PL_taint_warn && PL_dowarn != G_WARN_ALL_OFF) {
1267 PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
1271 scriptname = argv[0];
1274 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
1276 else if (scriptname == Nullch) {
1278 if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
1286 open_script(scriptname,dosearch,sv,&fdscript);
1288 validate_suid(validarg, scriptname,fdscript);
1291 #if defined(SIGCHLD) || defined(SIGCLD)
1294 # define SIGCHLD SIGCLD
1296 Sighandler_t sigstate = rsignal_state(SIGCHLD);
1297 if (sigstate == SIG_IGN) {
1298 if (ckWARN(WARN_SIGNAL))
1299 Perl_warner(aTHX_ packWARN(WARN_SIGNAL),
1300 "Can't ignore signal CHLD, forcing to default");
1301 (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL);
1307 #ifdef MACOS_TRADITIONAL
1308 if (PL_doextract || gMacPerl_AlwaysExtract) {
1313 if (cddir && PerlDir_chdir(cddir) < 0)
1314 Perl_croak(aTHX_ "Can't chdir to %s",cddir);
1318 PL_main_cv = PL_compcv = (CV*)NEWSV(1104,0);
1319 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
1320 CvUNIQUE_on(PL_compcv);
1322 CvPADLIST(PL_compcv) = pad_new(0);
1323 #ifdef USE_5005THREADS
1324 CvOWNER(PL_compcv) = 0;
1325 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
1326 MUTEX_INIT(CvMUTEXP(PL_compcv));
1327 #endif /* USE_5005THREADS */
1330 boot_core_UNIVERSAL();
1332 boot_core_xsutils();
1336 (*xsinit)(aTHX); /* in case linked C routines want magical variables */
1338 #if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__) || defined(EPOC)
1344 # ifdef HAS_SOCKS5_INIT
1345 socks5_init(argv[0]);
1351 init_predump_symbols();
1352 /* init_postdump_symbols not currently designed to be called */
1353 /* more than once (ENV isn't cleared first, for example) */
1354 /* But running with -u leaves %ENV & @ARGV undefined! XXX */
1356 init_postdump_symbols(argc,argv,env);
1358 /* PL_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, FALSE);
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, TRUE);
3546 incpush(PerlEnv_getenv("PERLLIB"), FALSE, FALSE, TRUE);
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,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
3557 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE,FALSE,TRUE);
3561 /* Use the ~-expanded versions of APPLLIB (undocumented),
3562 ARCHLIB PRIVLIB SITEARCH SITELIB VENDORARCH and VENDORLIB
3565 incpush(APPLLIB_EXP, TRUE, TRUE, TRUE);
3569 incpush(ARCHLIB_EXP, FALSE, FALSE, TRUE);
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, TRUE);
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, TRUE);
3587 SvREFCNT_dec(privdir);
3590 incpush(":", FALSE, FALSE, TRUE);
3593 # define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
3596 incpush(PRIVLIB_EXP, TRUE, FALSE, TRUE);
3598 incpush(PRIVLIB_EXP, FALSE, FALSE, TRUE);
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, TRUE);
3611 /* this picks up sitearch as well */
3612 incpush(SITELIB_EXP, TRUE, FALSE, TRUE);
3614 incpush(SITELIB_EXP, FALSE, FALSE, TRUE);
3618 #ifdef SITELIB_STEM /* Search for version-specific dirs below here */
3619 incpush(SITELIB_STEM, FALSE, TRUE, TRUE);
3622 #ifdef PERL_VENDORARCH_EXP
3623 /* vendorarch is always relative to vendorlib on Windows for
3624 * DLL-based path intuition to work correctly */
3625 # if !defined(WIN32)
3626 incpush(PERL_VENDORARCH_EXP, FALSE, FALSE, TRUE);
3630 #ifdef PERL_VENDORLIB_EXP
3632 incpush(PERL_VENDORLIB_EXP, TRUE, FALSE, TRUE); /* this picks up vendorarch as well */
3634 incpush(PERL_VENDORLIB_EXP, FALSE, FALSE, TRUE);
3638 #ifdef PERL_VENDORLIB_STEM /* Search for version-specific dirs below here */
3639 incpush(PERL_VENDORLIB_STEM, FALSE, TRUE, TRUE);
3642 #ifdef PERL_OTHERLIBDIRS
3643 incpush(PERL_OTHERLIBDIRS, TRUE, TRUE, TRUE);
3647 incpush(".", FALSE, FALSE, TRUE);
3648 #endif /* MACOS_TRADITIONAL */
3651 #if defined(DOSISH) || defined(EPOC)
3652 # define PERLLIB_SEP ';'
3655 # define PERLLIB_SEP '|'
3657 # if defined(MACOS_TRADITIONAL)
3658 # define PERLLIB_SEP ','
3660 # define PERLLIB_SEP ':'
3664 #ifndef PERLLIB_MANGLE
3665 # define PERLLIB_MANGLE(s,n) (s)
3669 S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers, int usesep)
3671 SV *subdir = Nullsv;
3676 if (addsubdirs || addoldvers) {
3677 subdir = sv_newmortal();
3680 /* Break at all separators */
3682 SV *libdir = NEWSV(55,0);
3685 /* skip any consecutive separators */
3687 while ( *p == PERLLIB_SEP ) {
3688 /* Uncomment the next line for PATH semantics */
3689 /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */
3694 if ( usesep && (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
3695 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
3700 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
3701 p = Nullch; /* break out */
3703 #ifdef MACOS_TRADITIONAL
3704 if (!strchr(SvPVX(libdir), ':')) {
3707 sv_setpv(libdir, MacPerl_CanonDir(SvPVX(libdir), buf, 0));
3709 if (SvPVX(libdir)[SvCUR(libdir)-1] != ':')
3710 sv_catpv(libdir, ":");
3714 * BEFORE pushing libdir onto @INC we may first push version- and
3715 * archname-specific sub-directories.
3717 if (addsubdirs || addoldvers) {
3718 #ifdef PERL_INC_VERSION_LIST
3719 /* Configure terminates PERL_INC_VERSION_LIST with a NULL */
3720 const char *incverlist[] = { PERL_INC_VERSION_LIST };
3721 const char **incver;
3728 if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) {
3730 while (unix[len-1] == '/') len--; /* Cosmetic */
3731 sv_usepvn(libdir,unix,len);
3734 PerlIO_printf(Perl_error_log,
3735 "Failed to unixify @INC element \"%s\"\n",
3739 #ifdef MACOS_TRADITIONAL
3740 #define PERL_AV_SUFFIX_FMT ""
3741 #define PERL_ARCH_FMT "%s:"
3742 #define PERL_ARCH_FMT_PATH PERL_FS_VER_FMT PERL_AV_SUFFIX_FMT
3744 #define PERL_AV_SUFFIX_FMT "/"
3745 #define PERL_ARCH_FMT "/%s"
3746 #define PERL_ARCH_FMT_PATH PERL_AV_SUFFIX_FMT PERL_FS_VER_FMT
3748 /* .../version/archname if -d .../version/archname */
3749 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH PERL_ARCH_FMT,
3751 (int)PERL_REVISION, (int)PERL_VERSION,
3752 (int)PERL_SUBVERSION, ARCHNAME);
3753 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3754 S_ISDIR(tmpstatbuf.st_mode))
3755 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3757 /* .../version if -d .../version */
3758 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH, libdir,
3759 (int)PERL_REVISION, (int)PERL_VERSION,
3760 (int)PERL_SUBVERSION);
3761 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3762 S_ISDIR(tmpstatbuf.st_mode))
3763 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3765 /* .../archname if -d .../archname */
3766 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, ARCHNAME);
3767 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3768 S_ISDIR(tmpstatbuf.st_mode))
3769 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3772 #ifdef PERL_INC_VERSION_LIST
3774 for (incver = incverlist; *incver; incver++) {
3775 /* .../xxx if -d .../xxx */
3776 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, *incver);
3777 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3778 S_ISDIR(tmpstatbuf.st_mode))
3779 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3785 /* finally push this lib directory on the end of @INC */
3786 av_push(GvAVn(PL_incgv), libdir);
3790 #ifdef USE_5005THREADS
3791 STATIC struct perl_thread *
3792 S_init_main_thread(pTHX)
3794 #if !defined(PERL_IMPLICIT_CONTEXT)
3795 struct perl_thread *thr;
3799 Newz(53, thr, 1, struct perl_thread);
3800 PL_curcop = &PL_compiling;
3801 thr->interp = PERL_GET_INTERP;
3802 thr->cvcache = newHV();
3803 thr->threadsv = newAV();
3804 /* thr->threadsvp is set when find_threadsv is called */
3805 thr->specific = newAV();
3806 thr->flags = THRf_R_JOINABLE;
3807 MUTEX_INIT(&thr->mutex);
3808 /* Handcraft thrsv similarly to mess_sv */
3809 New(53, PL_thrsv, 1, SV);
3810 Newz(53, xpv, 1, XPV);
3811 SvFLAGS(PL_thrsv) = SVt_PV;
3812 SvANY(PL_thrsv) = (void*)xpv;
3813 SvREFCNT(PL_thrsv) = 1 << 30; /* practically infinite */
3814 SvPVX(PL_thrsv) = (char*)thr;
3815 SvCUR_set(PL_thrsv, sizeof(thr));
3816 SvLEN_set(PL_thrsv, sizeof(thr));
3817 *SvEND(PL_thrsv) = '\0'; /* in the trailing_nul field */
3818 thr->oursv = PL_thrsv;
3819 PL_chopset = " \n-";
3822 MUTEX_LOCK(&PL_threads_mutex);
3828 MUTEX_UNLOCK(&PL_threads_mutex);
3830 #ifdef HAVE_THREAD_INTERN
3831 Perl_init_thread_intern(thr);
3834 #ifdef SET_THREAD_SELF
3835 SET_THREAD_SELF(thr);
3837 thr->self = pthread_self();
3838 #endif /* SET_THREAD_SELF */
3842 * These must come after the thread self setting
3843 * because sv_setpvn does SvTAINT and the taint
3844 * fields thread selfness being set.
3846 PL_toptarget = NEWSV(0,0);
3847 sv_upgrade(PL_toptarget, SVt_PVFM);
3848 sv_setpvn(PL_toptarget, "", 0);
3849 PL_bodytarget = NEWSV(0,0);
3850 sv_upgrade(PL_bodytarget, SVt_PVFM);
3851 sv_setpvn(PL_bodytarget, "", 0);
3852 PL_formtarget = PL_bodytarget;
3853 thr->errsv = newSVpvn("", 0);
3854 (void) find_threadsv("@"); /* Ensure $@ is initialised early */
3857 PL_peepp = MEMBER_TO_FPTR(Perl_peep);
3858 PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
3859 PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
3860 PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
3861 PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
3862 PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
3864 PL_reginterp_cnt = 0;
3868 #endif /* USE_5005THREADS */
3871 Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
3874 line_t oldline = CopLINE(PL_curcop);
3880 while (AvFILL(paramList) >= 0) {
3881 cv = (CV*)av_shift(paramList);
3883 if (paramList == PL_beginav) {
3884 /* save PL_beginav for compiler */
3885 if (! PL_beginav_save)
3886 PL_beginav_save = newAV();
3887 av_push(PL_beginav_save, (SV*)cv);
3889 else if (paramList == PL_checkav) {
3890 /* save PL_checkav for compiler */
3891 if (! PL_checkav_save)
3892 PL_checkav_save = newAV();
3893 av_push(PL_checkav_save, (SV*)cv);
3898 #ifdef PERL_FLEXIBLE_EXCEPTIONS
3899 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_list_body), cv);
3905 #ifndef PERL_FLEXIBLE_EXCEPTIONS
3909 (void)SvPV(atsv, len);
3912 PL_curcop = &PL_compiling;
3913 CopLINE_set(PL_curcop, oldline);
3914 if (paramList == PL_beginav)
3915 sv_catpv(atsv, "BEGIN failed--compilation aborted");
3917 Perl_sv_catpvf(aTHX_ atsv,
3918 "%s failed--call queue aborted",
3919 paramList == PL_checkav ? "CHECK"
3920 : paramList == PL_initav ? "INIT"
3922 while (PL_scopestack_ix > oldscope)
3925 Perl_croak(aTHX_ "%s", SvPVx(atsv, n_a));
3932 /* my_exit() was called */
3933 while (PL_scopestack_ix > oldscope)
3936 PL_curstash = PL_defstash;
3937 PL_curcop = &PL_compiling;
3938 CopLINE_set(PL_curcop, oldline);
3940 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) {
3941 if (paramList == PL_beginav)
3942 Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
3944 Perl_croak(aTHX_ "%s failed--call queue aborted",
3945 paramList == PL_checkav ? "CHECK"
3946 : paramList == PL_initav ? "INIT"
3953 PL_curcop = &PL_compiling;
3954 CopLINE_set(PL_curcop, oldline);
3957 PerlIO_printf(Perl_error_log, "panic: restartop\n");
3965 #ifdef PERL_FLEXIBLE_EXCEPTIONS
3967 S_vcall_list_body(pTHX_ va_list args)
3969 CV *cv = va_arg(args, CV*);
3970 return call_list_body(cv);
3975 S_call_list_body(pTHX_ CV *cv)
3977 PUSHMARK(PL_stack_sp);
3978 call_sv((SV*)cv, G_EVAL|G_DISCARD);
3983 Perl_my_exit(pTHX_ U32 status)
3985 DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
3986 thr, (unsigned long) status));
3995 STATUS_NATIVE_SET(status);
4002 Perl_my_failure_exit(pTHX)
4005 if (vaxc$errno & 1) {
4006 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
4007 STATUS_NATIVE_SET(44);
4010 if (!vaxc$errno && errno) /* unlikely */
4011 STATUS_NATIVE_SET(44);
4013 STATUS_NATIVE_SET(vaxc$errno);
4018 STATUS_POSIX_SET(errno);
4020 exitstatus = STATUS_POSIX >> 8;
4021 if (exitstatus & 255)
4022 STATUS_POSIX_SET(exitstatus);
4024 STATUS_POSIX_SET(255);
4031 S_my_exit_jump(pTHX)
4033 register PERL_CONTEXT *cx;
4038 SvREFCNT_dec(PL_e_script);
4039 PL_e_script = Nullsv;
4042 POPSTACK_TO(PL_mainstack);
4043 if (cxstack_ix >= 0) {
4046 POPBLOCK(cx,PL_curpm);
4054 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen)
4057 p = SvPVX(PL_e_script);
4058 nl = strchr(p, '\n');
4059 nl = (nl) ? nl+1 : SvEND(PL_e_script);
4061 filter_del(read_e_script);
4064 sv_catpvn(buf_sv, p, nl-p);
4065 sv_chop(PL_e_script, nl);