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. */
29 #if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE) && !defined(PERL_MICRO)
30 char *getenv (char *); /* Usually in <stdlib.h> */
33 static I32 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen);
41 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
47 #if defined(USE_5005THREADS)
48 # define INIT_TLS_AND_INTERP \
50 if (!PL_curinterp) { \
51 PERL_SET_INTERP(my_perl); \
57 # if defined(USE_ITHREADS)
58 # define INIT_TLS_AND_INTERP \
60 if (!PL_curinterp) { \
61 PERL_SET_INTERP(my_perl); \
64 PERL_SET_THX(my_perl); \
68 PERL_SET_THX(my_perl); \
72 # define INIT_TLS_AND_INTERP \
74 if (!PL_curinterp) { \
75 PERL_SET_INTERP(my_perl); \
77 PERL_SET_THX(my_perl); \
82 #ifdef PERL_IMPLICIT_SYS
84 perl_alloc_using(struct IPerlMem* ipM, struct IPerlMem* ipMS,
85 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
86 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
87 struct IPerlDir* ipD, struct IPerlSock* ipS,
88 struct IPerlProc* ipP)
90 PerlInterpreter *my_perl;
91 /* New() needs interpreter, so call malloc() instead */
92 my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
94 Zero(my_perl, 1, PerlInterpreter);
110 =head1 Embedding Functions
112 =for apidoc perl_alloc
114 Allocates a new Perl interpreter. See L<perlembed>.
122 PerlInterpreter *my_perl;
123 #ifdef USE_5005THREADS
127 /* New() needs interpreter, so call malloc() instead */
128 my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
131 Zero(my_perl, 1, PerlInterpreter);
134 #endif /* PERL_IMPLICIT_SYS */
137 =for apidoc perl_construct
139 Initializes a new Perl interpreter. See L<perlembed>.
145 perl_construct(pTHXx)
147 #ifdef USE_5005THREADS
149 struct perl_thread *thr = NULL;
150 #endif /* FAKE_THREADS */
151 #endif /* USE_5005THREADS */
155 PL_perl_destruct_level = 1;
157 if (PL_perl_destruct_level > 0)
161 /* Init the real globals (and main thread)? */
163 #ifdef USE_5005THREADS
164 MUTEX_INIT(&PL_sv_mutex);
166 * Safe to use basic SV functions from now on (though
167 * not things like mortals or tainting yet).
169 MUTEX_INIT(&PL_eval_mutex);
170 COND_INIT(&PL_eval_cond);
171 MUTEX_INIT(&PL_threads_mutex);
172 COND_INIT(&PL_nthreads_cond);
173 # ifdef EMULATE_ATOMIC_REFCOUNTS
174 MUTEX_INIT(&PL_svref_mutex);
175 # endif /* EMULATE_ATOMIC_REFCOUNTS */
177 MUTEX_INIT(&PL_cred_mutex);
178 MUTEX_INIT(&PL_sv_lock_mutex);
179 MUTEX_INIT(&PL_fdpid_mutex);
181 thr = init_main_thread();
182 #endif /* USE_5005THREADS */
184 #ifdef PERL_FLEXIBLE_EXCEPTIONS
185 PL_protect = MEMBER_TO_FPTR(Perl_default_protect); /* for exceptions */
188 PL_curcop = &PL_compiling; /* needed by ckWARN, right away */
190 PL_linestr = NEWSV(65,79);
191 sv_upgrade(PL_linestr,SVt_PVIV);
193 if (!SvREADONLY(&PL_sv_undef)) {
194 /* set read-only and try to insure than we wont see REFCNT==0
197 SvREADONLY_on(&PL_sv_undef);
198 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
200 sv_setpv(&PL_sv_no,PL_No);
202 SvREADONLY_on(&PL_sv_no);
203 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
205 sv_setpv(&PL_sv_yes,PL_Yes);
207 SvREADONLY_on(&PL_sv_yes);
208 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
211 PL_sighandlerp = Perl_sighandler;
212 PL_pidstatus = newHV();
215 PL_rs = newSVpvn("\n", 1);
220 PL_lex_state = LEX_NOTPARSING;
226 SET_NUMERIC_STANDARD();
230 PL_patchlevel = NEWSV(0,4);
231 (void)SvUPGRADE(PL_patchlevel, SVt_PVNV);
232 if (PERL_REVISION > 127 || PERL_VERSION > 127 || PERL_SUBVERSION > 127)
233 SvGROW(PL_patchlevel, UTF8_MAXLEN*3+1);
234 s = (U8*)SvPVX(PL_patchlevel);
235 /* Build version strings using "native" characters */
236 s = uvchr_to_utf8(s, (UV)PERL_REVISION);
237 s = uvchr_to_utf8(s, (UV)PERL_VERSION);
238 s = uvchr_to_utf8(s, (UV)PERL_SUBVERSION);
240 SvCUR_set(PL_patchlevel, s - (U8*)SvPVX(PL_patchlevel));
241 SvPOK_on(PL_patchlevel);
242 SvNVX(PL_patchlevel) = (NV)PERL_REVISION
243 + ((NV)PERL_VERSION / (NV)1000)
244 #if defined(PERL_SUBVERSION) && PERL_SUBVERSION > 0
245 + ((NV)PERL_SUBVERSION / (NV)1000000)
248 SvNOK_on(PL_patchlevel); /* dual valued */
249 SvUTF8_on(PL_patchlevel);
250 SvREADONLY_on(PL_patchlevel);
253 #if defined(LOCAL_PATCH_COUNT)
254 PL_localpatches = local_patches; /* For possible -v */
257 #ifdef HAVE_INTERP_INTERN
261 PerlIO_init(aTHX); /* Hook to IO system */
263 PL_fdpid = newAV(); /* for remembering popen pids by fd */
264 PL_modglobal = newHV(); /* pointers to per-interpreter module globals */
265 PL_errors = newSVpvn("",0);
266 sv_setpvn(PERL_DEBUG_PAD(0), "", 0); /* For regex debugging. */
267 sv_setpvn(PERL_DEBUG_PAD(1), "", 0); /* ext/re needs these */
268 sv_setpvn(PERL_DEBUG_PAD(2), "", 0); /* even without DEBUGGING. */
270 PL_regex_padav = newAV();
271 av_push(PL_regex_padav,(SV*)newAV()); /* First entry is an array of empty elements */
272 PL_regex_pad = AvARRAY(PL_regex_padav);
274 #ifdef USE_REENTRANT_API
275 Perl_reentrant_init(aTHX);
278 /* Note that strtab is a rather special HV. Assumptions are made
279 about not iterating on it, and not adding tie magic to it.
280 It is properly deallocated in perl_destruct() */
283 #ifdef USE_5005THREADS
284 MUTEX_INIT(&PL_strtab_mutex);
286 HvSHAREKEYS_off(PL_strtab); /* mandatory */
287 hv_ksplit(PL_strtab, 512);
289 #if defined(__DYNAMIC__) && (defined(NeXT) || defined(__NeXT__))
290 _dyld_lookup_and_bind
291 ("__environ", (unsigned long *) &environ_pointer, NULL);
294 #ifdef USE_ENVIRON_ARRAY
295 PL_origenviron = environ;
302 =for apidoc nothreadhook
304 Stub that provides thread hook for perl_destruct when there are
311 Perl_nothreadhook(pTHX)
317 =for apidoc perl_destruct
319 Shuts down a Perl interpreter. See L<perlembed>.
327 volatile int destruct_level; /* 0=none, 1=full, 2=full with checks */
329 #ifdef USE_5005THREADS
332 #endif /* USE_5005THREADS */
334 /* wait for all pseudo-forked children to finish */
335 PERL_WAIT_FOR_CHILDREN;
337 #ifdef USE_5005THREADS
339 /* Pass 1 on any remaining threads: detach joinables, join zombies */
341 MUTEX_LOCK(&PL_threads_mutex);
342 DEBUG_S(PerlIO_printf(Perl_debug_log,
343 "perl_destruct: waiting for %d threads...\n",
345 for (t = thr->next; t != thr; t = t->next) {
346 MUTEX_LOCK(&t->mutex);
347 switch (ThrSTATE(t)) {
350 DEBUG_S(PerlIO_printf(Perl_debug_log,
351 "perl_destruct: joining zombie %p\n", t));
352 ThrSETSTATE(t, THRf_DEAD);
353 MUTEX_UNLOCK(&t->mutex);
356 * The SvREFCNT_dec below may take a long time (e.g. av
357 * may contain an object scalar whose destructor gets
358 * called) so we have to unlock threads_mutex and start
361 MUTEX_UNLOCK(&PL_threads_mutex);
363 SvREFCNT_dec((SV*)av);
364 DEBUG_S(PerlIO_printf(Perl_debug_log,
365 "perl_destruct: joined zombie %p OK\n", t));
367 case THRf_R_JOINABLE:
368 DEBUG_S(PerlIO_printf(Perl_debug_log,
369 "perl_destruct: detaching thread %p\n", t));
370 ThrSETSTATE(t, THRf_R_DETACHED);
372 * We unlock threads_mutex and t->mutex in the opposite order
373 * from which we locked them just so that DETACH won't
374 * deadlock if it panics. It's only a breach of good style
375 * not a bug since they are unlocks not locks.
377 MUTEX_UNLOCK(&PL_threads_mutex);
379 MUTEX_UNLOCK(&t->mutex);
382 DEBUG_S(PerlIO_printf(Perl_debug_log,
383 "perl_destruct: ignoring %p (state %u)\n",
385 MUTEX_UNLOCK(&t->mutex);
386 /* fall through and out */
389 /* We leave the above "Pass 1" loop with threads_mutex still locked */
391 /* Pass 2 on remaining threads: wait for the thread count to drop to one */
392 while (PL_nthreads > 1)
394 DEBUG_S(PerlIO_printf(Perl_debug_log,
395 "perl_destruct: final wait for %d threads\n",
397 COND_WAIT(&PL_nthreads_cond, &PL_threads_mutex);
399 /* At this point, we're the last thread */
400 MUTEX_UNLOCK(&PL_threads_mutex);
401 DEBUG_S(PerlIO_printf(Perl_debug_log, "perl_destruct: armageddon has arrived\n"));
402 MUTEX_DESTROY(&PL_threads_mutex);
403 COND_DESTROY(&PL_nthreads_cond);
405 #endif /* !defined(FAKE_THREADS) */
406 #endif /* USE_5005THREADS */
408 destruct_level = PL_perl_destruct_level;
412 if ((s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL"))) {
414 if (destruct_level < i)
421 if(PL_exit_flags & PERL_EXIT_DESTRUCT_END) {
426 if (PL_endav && !PL_minus_c)
427 call_list(PL_scopestack_ix, PL_endav);
433 /* Need to flush since END blocks can produce output */
434 PerlIO_flush((PerlIO*)NULL);
436 if (CALL_FPTR(PL_threadhook)(aTHX)) {
437 /* Threads hook has vetoed further cleanup */
438 return STATUS_NATIVE_EXPORT;;
441 /* We must account for everything. */
443 /* Destroy the main CV and syntax tree */
445 PL_curpad = AvARRAY(PL_comppad);
446 op_free(PL_main_root);
447 PL_main_root = Nullop;
449 PL_curcop = &PL_compiling;
450 PL_main_start = Nullop;
451 SvREFCNT_dec(PL_main_cv);
455 /* Tell PerlIO we are about to tear things apart in case
456 we have layers which are using resources that should
460 PerlIO_destruct(aTHX);
462 if (PL_sv_objcount) {
464 * Try to destruct global references. We do this first so that the
465 * destructors and destructees still exist. Some sv's might remain.
466 * Non-referenced objects are on their own.
471 /* unhook hooks which will soon be, or use, destroyed data */
472 SvREFCNT_dec(PL_warnhook);
473 PL_warnhook = Nullsv;
474 SvREFCNT_dec(PL_diehook);
477 /* call exit list functions */
478 while (PL_exitlistlen-- > 0)
479 PL_exitlist[PL_exitlistlen].fn(aTHX_ PL_exitlist[PL_exitlistlen].ptr);
481 Safefree(PL_exitlist);
483 if (destruct_level == 0){
485 DEBUG_P(debprofdump());
487 #if defined(PERLIO_LAYERS)
488 /* No more IO - including error messages ! */
489 PerlIO_cleanup(aTHX);
492 /* The exit() function will do everything that needs doing. */
493 return STATUS_NATIVE_EXPORT;;
496 /* jettison our possibly duplicated environment */
497 /* if PERL_USE_SAFE_PUTENV is defined environ will not have been copied
498 * so we certainly shouldn't free it here
500 #if defined(USE_ENVIRON_ARRAY) && !defined(PERL_USE_SAFE_PUTENV)
501 if (environ != PL_origenviron
503 /* only main thread can free environ[0] contents */
504 && PL_curinterp == aTHX
510 for (i = 0; environ[i]; i++)
511 safesysfree(environ[i]);
513 /* Must use safesysfree() when working with environ. */
514 safesysfree(environ);
516 environ = PL_origenviron;
521 /* the syntax tree is shared between clones
522 * so op_free(PL_main_root) only ReREFCNT_dec's
523 * REGEXPs in the parent interpreter
524 * we need to manually ReREFCNT_dec for the clones
527 I32 i = AvFILLp(PL_regex_padav) + 1;
528 SV **ary = AvARRAY(PL_regex_padav);
532 REGEXP *re = INT2PTR(REGEXP *,SvIVX(resv));
534 if (SvFLAGS(resv) & SVf_BREAK) {
535 /* this is PL_reg_curpm, already freed
536 * flag is set in regexec.c:S_regtry
538 SvFLAGS(resv) &= ~SVf_BREAK;
540 else if(SvREPADTMP(resv)) {
541 SvREPADTMP_off(resv);
548 SvREFCNT_dec(PL_regex_padav);
549 PL_regex_padav = Nullav;
553 /* loosen bonds of global variables */
556 (void)PerlIO_close(PL_rsfp);
560 /* Filters for program text */
561 SvREFCNT_dec(PL_rsfp_filters);
562 PL_rsfp_filters = Nullav;
565 PL_preprocess = FALSE;
571 PL_doswitches = FALSE;
572 PL_dowarn = G_WARN_OFF;
573 PL_doextract = FALSE;
574 PL_sawampersand = FALSE; /* must save all match strings */
577 Safefree(PL_inplace);
579 SvREFCNT_dec(PL_patchlevel);
582 SvREFCNT_dec(PL_e_script);
583 PL_e_script = Nullsv;
586 while (--PL_origargc >= 0) {
587 Safefree(PL_origargv[PL_origargc]);
589 Safefree(PL_origargv);
591 /* magical thingies */
593 SvREFCNT_dec(PL_ofs_sv); /* $, */
596 SvREFCNT_dec(PL_ors_sv); /* $\ */
599 SvREFCNT_dec(PL_rs); /* $/ */
602 PL_multiline = 0; /* $* */
603 Safefree(PL_osname); /* $^O */
606 SvREFCNT_dec(PL_statname);
607 PL_statname = Nullsv;
610 /* defgv, aka *_ should be taken care of elsewhere */
612 /* clean up after study() */
613 SvREFCNT_dec(PL_lastscream);
614 PL_lastscream = Nullsv;
615 Safefree(PL_screamfirst);
617 Safefree(PL_screamnext);
621 Safefree(PL_efloatbuf);
622 PL_efloatbuf = Nullch;
625 /* startup and shutdown function lists */
626 SvREFCNT_dec(PL_beginav);
627 SvREFCNT_dec(PL_beginav_save);
628 SvREFCNT_dec(PL_endav);
629 SvREFCNT_dec(PL_checkav);
630 SvREFCNT_dec(PL_initav);
632 PL_beginav_save = Nullav;
637 /* shortcuts just get cleared */
643 PL_argvoutgv = Nullgv;
645 PL_stderrgv = Nullgv;
646 PL_last_in_gv = Nullgv;
648 PL_debstash = Nullhv;
650 /* reset so print() ends up where we expect */
653 SvREFCNT_dec(PL_argvout_stack);
654 PL_argvout_stack = Nullav;
656 SvREFCNT_dec(PL_modglobal);
657 PL_modglobal = Nullhv;
658 SvREFCNT_dec(PL_preambleav);
659 PL_preambleav = Nullav;
660 SvREFCNT_dec(PL_subname);
662 SvREFCNT_dec(PL_linestr);
664 SvREFCNT_dec(PL_pidstatus);
665 PL_pidstatus = Nullhv;
666 SvREFCNT_dec(PL_toptarget);
667 PL_toptarget = Nullsv;
668 SvREFCNT_dec(PL_bodytarget);
669 PL_bodytarget = Nullsv;
670 PL_formtarget = Nullsv;
672 /* free locale stuff */
673 #ifdef USE_LOCALE_COLLATE
674 Safefree(PL_collation_name);
675 PL_collation_name = Nullch;
678 #ifdef USE_LOCALE_NUMERIC
679 Safefree(PL_numeric_name);
680 PL_numeric_name = Nullch;
681 SvREFCNT_dec(PL_numeric_radix_sv);
684 /* clear utf8 character classes */
685 SvREFCNT_dec(PL_utf8_alnum);
686 SvREFCNT_dec(PL_utf8_alnumc);
687 SvREFCNT_dec(PL_utf8_ascii);
688 SvREFCNT_dec(PL_utf8_alpha);
689 SvREFCNT_dec(PL_utf8_space);
690 SvREFCNT_dec(PL_utf8_cntrl);
691 SvREFCNT_dec(PL_utf8_graph);
692 SvREFCNT_dec(PL_utf8_digit);
693 SvREFCNT_dec(PL_utf8_upper);
694 SvREFCNT_dec(PL_utf8_lower);
695 SvREFCNT_dec(PL_utf8_print);
696 SvREFCNT_dec(PL_utf8_punct);
697 SvREFCNT_dec(PL_utf8_xdigit);
698 SvREFCNT_dec(PL_utf8_mark);
699 SvREFCNT_dec(PL_utf8_toupper);
700 SvREFCNT_dec(PL_utf8_totitle);
701 SvREFCNT_dec(PL_utf8_tolower);
702 SvREFCNT_dec(PL_utf8_tofold);
703 SvREFCNT_dec(PL_utf8_idstart);
704 SvREFCNT_dec(PL_utf8_idcont);
705 PL_utf8_alnum = Nullsv;
706 PL_utf8_alnumc = Nullsv;
707 PL_utf8_ascii = Nullsv;
708 PL_utf8_alpha = Nullsv;
709 PL_utf8_space = Nullsv;
710 PL_utf8_cntrl = Nullsv;
711 PL_utf8_graph = Nullsv;
712 PL_utf8_digit = Nullsv;
713 PL_utf8_upper = Nullsv;
714 PL_utf8_lower = Nullsv;
715 PL_utf8_print = Nullsv;
716 PL_utf8_punct = Nullsv;
717 PL_utf8_xdigit = Nullsv;
718 PL_utf8_mark = Nullsv;
719 PL_utf8_toupper = Nullsv;
720 PL_utf8_totitle = Nullsv;
721 PL_utf8_tolower = Nullsv;
722 PL_utf8_tofold = Nullsv;
723 PL_utf8_idstart = Nullsv;
724 PL_utf8_idcont = Nullsv;
726 if (!specialWARN(PL_compiling.cop_warnings))
727 SvREFCNT_dec(PL_compiling.cop_warnings);
728 PL_compiling.cop_warnings = Nullsv;
729 if (!specialCopIO(PL_compiling.cop_io))
730 SvREFCNT_dec(PL_compiling.cop_io);
731 PL_compiling.cop_io = Nullsv;
732 CopFILE_free(&PL_compiling);
733 CopSTASH_free(&PL_compiling);
735 /* Prepare to destruct main symbol table. */
740 SvREFCNT_dec(PL_curstname);
741 PL_curstname = Nullsv;
743 /* clear queued errors */
744 SvREFCNT_dec(PL_errors);
748 if (destruct_level >= 2 && ckWARN_d(WARN_INTERNAL)) {
749 if (PL_scopestack_ix != 0)
750 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
751 "Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
752 (long)PL_scopestack_ix);
753 if (PL_savestack_ix != 0)
754 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
755 "Unbalanced saves: %ld more saves than restores\n",
756 (long)PL_savestack_ix);
757 if (PL_tmps_floor != -1)
758 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced tmps: %ld more allocs than frees\n",
759 (long)PL_tmps_floor + 1);
760 if (cxstack_ix != -1)
761 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced context: %ld more PUSHes than POPs\n",
762 (long)cxstack_ix + 1);
765 /* Now absolutely destruct everything, somehow or other, loops or no. */
766 SvFLAGS(PL_fdpid) |= SVTYPEMASK; /* don't clean out pid table now */
767 SvFLAGS(PL_strtab) |= SVTYPEMASK; /* don't clean out strtab now */
769 /* the 2 is for PL_fdpid and PL_strtab */
770 while (PL_sv_count > 2 && sv_clean_all())
773 SvFLAGS(PL_fdpid) &= ~SVTYPEMASK;
774 SvFLAGS(PL_fdpid) |= SVt_PVAV;
775 SvFLAGS(PL_strtab) &= ~SVTYPEMASK;
776 SvFLAGS(PL_strtab) |= SVt_PVHV;
778 AvREAL_off(PL_fdpid); /* no surviving entries */
779 SvREFCNT_dec(PL_fdpid); /* needed in io_close() */
782 #ifdef HAVE_INTERP_INTERN
786 /* Destruct the global string table. */
788 /* Yell and reset the HeVAL() slots that are still holding refcounts,
789 * so that sv_free() won't fail on them.
797 max = HvMAX(PL_strtab);
798 array = HvARRAY(PL_strtab);
801 if (hent && ckWARN_d(WARN_INTERNAL)) {
802 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
803 "Unbalanced string table refcount: (%d) for \"%s\"",
804 HeVAL(hent) - Nullsv, HeKEY(hent));
805 HeVAL(hent) = Nullsv;
815 SvREFCNT_dec(PL_strtab);
818 /* free the pointer table used for cloning */
819 ptr_table_free(PL_ptr_table);
822 /* free special SVs */
824 SvREFCNT(&PL_sv_yes) = 0;
825 sv_clear(&PL_sv_yes);
826 SvANY(&PL_sv_yes) = NULL;
827 SvFLAGS(&PL_sv_yes) = 0;
829 SvREFCNT(&PL_sv_no) = 0;
831 SvANY(&PL_sv_no) = NULL;
832 SvFLAGS(&PL_sv_no) = 0;
836 for (i=0; i<=2; i++) {
837 SvREFCNT(PERL_DEBUG_PAD(i)) = 0;
838 sv_clear(PERL_DEBUG_PAD(i));
839 SvANY(PERL_DEBUG_PAD(i)) = NULL;
840 SvFLAGS(PERL_DEBUG_PAD(i)) = 0;
844 if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL))
845 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Scalars leaked: %ld\n", (long)PL_sv_count);
847 #if defined(PERLIO_LAYERS)
848 /* No more IO - including error messages ! */
849 PerlIO_cleanup(aTHX);
852 /* sv_undef needs to stay immortal until after PerlIO_cleanup
853 as currently layers use it rather than Nullsv as a marker
854 for no arg - and will try and SvREFCNT_dec it.
856 SvREFCNT(&PL_sv_undef) = 0;
857 SvREADONLY_off(&PL_sv_undef);
859 Safefree(PL_origfilename);
860 Safefree(PL_reg_start_tmp);
862 Safefree(PL_reg_curpm);
863 Safefree(PL_reg_poscache);
864 Safefree(HeKEY_hek(&PL_hv_fetch_ent_mh));
865 Safefree(PL_op_mask);
866 Safefree(PL_psig_ptr);
867 Safefree(PL_psig_name);
868 Safefree(PL_bitcount);
869 Safefree(PL_psig_pend);
871 PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */
873 DEBUG_P(debprofdump());
874 #ifdef USE_5005THREADS
875 MUTEX_DESTROY(&PL_strtab_mutex);
876 MUTEX_DESTROY(&PL_sv_mutex);
877 MUTEX_DESTROY(&PL_eval_mutex);
878 MUTEX_DESTROY(&PL_cred_mutex);
879 MUTEX_DESTROY(&PL_fdpid_mutex);
880 COND_DESTROY(&PL_eval_cond);
881 #ifdef EMULATE_ATOMIC_REFCOUNTS
882 MUTEX_DESTROY(&PL_svref_mutex);
883 #endif /* EMULATE_ATOMIC_REFCOUNTS */
885 /* As the penultimate thing, free the non-arena SV for thrsv */
886 Safefree(SvPVX(PL_thrsv));
887 Safefree(SvANY(PL_thrsv));
890 #endif /* USE_5005THREADS */
892 #ifdef USE_REENTRANT_API
893 Perl_reentrant_free(aTHX);
898 /* As the absolutely last thing, free the non-arena SV for mess() */
901 /* it could have accumulated taint magic */
902 if (SvTYPE(PL_mess_sv) >= SVt_PVMG) {
905 for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) {
906 moremagic = mg->mg_moremagic;
907 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global
909 Safefree(mg->mg_ptr);
913 /* we know that type >= SVt_PV */
914 (void)SvOOK_off(PL_mess_sv);
915 Safefree(SvPVX(PL_mess_sv));
916 Safefree(SvANY(PL_mess_sv));
917 Safefree(PL_mess_sv);
920 return STATUS_NATIVE_EXPORT;
924 =for apidoc perl_free
926 Releases a Perl interpreter. See L<perlembed>.
934 #if defined(WIN32) || defined(NETWARE)
935 # if defined(PERL_IMPLICIT_SYS)
937 void *host = nw_internal_host;
939 void *host = w32_internal_host;
943 nw_delete_internal_host(host);
945 win32_delete_internal_host(host);
956 Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
958 Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry);
959 PL_exitlist[PL_exitlistlen].fn = fn;
960 PL_exitlist[PL_exitlistlen].ptr = ptr;
965 =for apidoc perl_parse
967 Tells a Perl interpreter to parse a Perl script. See L<perlembed>.
973 perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
978 #ifdef USE_5005THREADS
982 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
985 Perl_croak(aTHX_ "suidperl is no longer needed since the kernel can now execute\n\
986 setuid perl scripts securely.\n");
992 /* we copy rather than point to argv
993 * since perl_clone will copy and perl_destruct
994 * has no way of knowing if we've made a copy or
998 New(0, PL_origargv, i+1, char*);
999 PL_origargv[i] = '\0';
1001 PL_origargv[i] = savepv(argv[i]);
1009 /* Come here if running an undumped a.out. */
1011 PL_origfilename = savepv(argv[0]);
1012 PL_do_undump = FALSE;
1013 cxstack_ix = -1; /* start label stack again */
1015 init_postdump_symbols(argc,argv,env);
1020 PL_curpad = AvARRAY(PL_comppad);
1021 op_free(PL_main_root);
1022 PL_main_root = Nullop;
1024 PL_main_start = Nullop;
1025 SvREFCNT_dec(PL_main_cv);
1026 PL_main_cv = Nullcv;
1029 oldscope = PL_scopestack_ix;
1030 PL_dowarn = G_WARN_OFF;
1032 #ifdef PERL_FLEXIBLE_EXCEPTIONS
1033 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vparse_body), env, xsinit);
1039 #ifndef PERL_FLEXIBLE_EXCEPTIONS
1040 parse_body(env,xsinit);
1043 call_list(oldscope, PL_checkav);
1050 /* my_exit() was called */
1051 while (PL_scopestack_ix > oldscope)
1054 PL_curstash = PL_defstash;
1056 call_list(oldscope, PL_checkav);
1057 ret = STATUS_NATIVE_EXPORT;
1060 PerlIO_printf(Perl_error_log, "panic: top_env\n");
1068 #ifdef PERL_FLEXIBLE_EXCEPTIONS
1070 S_vparse_body(pTHX_ va_list args)
1072 char **env = va_arg(args, char**);
1073 XSINIT_t xsinit = va_arg(args, XSINIT_t);
1075 return parse_body(env, xsinit);
1080 S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
1082 int argc = PL_origargc;
1083 char **argv = PL_origargv;
1084 char *scriptname = NULL;
1086 VOL bool dosearch = FALSE;
1087 char *validarg = "";
1091 char *cddir = Nullch;
1093 sv_setpvn(PL_linestr,"",0);
1094 sv = newSVpvn("",0); /* first used for -I flags */
1098 for (argc--,argv++; argc > 0; argc--,argv++) {
1099 if (argv[0][0] != '-' || !argv[0][1])
1103 validarg = " PHOOEY ";
1112 win32_argv2utf8(argc-1, argv+1);
1115 #ifndef PERL_STRICT_CR
1139 if ((s = moreswitches(s)))
1144 if( !PL_tainting ) {
1145 PL_taint_warn = TRUE;
1152 PL_taint_warn = FALSE;
1157 #ifdef MACOS_TRADITIONAL
1158 /* ignore -e for Dev:Pseudo argument */
1159 if (argv[1] && !strcmp(argv[1], "Dev:Pseudo"))
1162 if (PL_euid != PL_uid || PL_egid != PL_gid)
1163 Perl_croak(aTHX_ "No -e allowed in setuid scripts");
1165 PL_e_script = newSVpvn("",0);
1166 filter_add(read_e_script, NULL);
1169 sv_catpv(PL_e_script, s);
1171 sv_catpv(PL_e_script, argv[1]);
1175 Perl_croak(aTHX_ "No code specified for -e");
1176 sv_catpv(PL_e_script, "\n");
1179 case 'I': /* -I handled both here and in moreswitches() */
1181 if (!*++s && (s=argv[1]) != Nullch) {
1186 STRLEN len = strlen(s);
1187 p = savepvn(s, len);
1188 incpush(p, TRUE, TRUE);
1189 sv_catpvn(sv, "-I", 2);
1190 sv_catpvn(sv, p, len);
1191 sv_catpvn(sv, " ", 1);
1195 Perl_croak(aTHX_ "No directory specified for -I");
1199 PL_preprocess = TRUE;
1209 PL_preambleav = newAV();
1210 av_push(PL_preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
1212 PL_Sv = newSVpv("print myconfig();",0);
1214 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
1216 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
1218 sv_catpv(PL_Sv,"\" Compile-time options:");
1220 sv_catpv(PL_Sv," DEBUGGING");
1222 # ifdef MULTIPLICITY
1223 sv_catpv(PL_Sv," MULTIPLICITY");
1225 # ifdef USE_5005THREADS
1226 sv_catpv(PL_Sv," USE_5005THREADS");
1228 # ifdef USE_ITHREADS
1229 sv_catpv(PL_Sv," USE_ITHREADS");
1231 # ifdef USE_64_BIT_INT
1232 sv_catpv(PL_Sv," USE_64_BIT_INT");
1234 # ifdef USE_64_BIT_ALL
1235 sv_catpv(PL_Sv," USE_64_BIT_ALL");
1237 # ifdef USE_LONG_DOUBLE
1238 sv_catpv(PL_Sv," USE_LONG_DOUBLE");
1240 # ifdef USE_LARGE_FILES
1241 sv_catpv(PL_Sv," USE_LARGE_FILES");
1244 sv_catpv(PL_Sv," USE_SOCKS");
1246 # ifdef PERL_IMPLICIT_CONTEXT
1247 sv_catpv(PL_Sv," PERL_IMPLICIT_CONTEXT");
1249 # ifdef PERL_IMPLICIT_SYS
1250 sv_catpv(PL_Sv," PERL_IMPLICIT_SYS");
1252 sv_catpv(PL_Sv,"\\n\",");
1254 #if defined(LOCAL_PATCH_COUNT)
1255 if (LOCAL_PATCH_COUNT > 0) {
1257 sv_catpv(PL_Sv,"\" Locally applied patches:\\n\",");
1258 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
1259 if (PL_localpatches[i])
1260 Perl_sv_catpvf(aTHX_ PL_Sv,"q\" \t%s\n\",",PL_localpatches[i]);
1264 Perl_sv_catpvf(aTHX_ PL_Sv,"\" Built under %s\\n\"",OSNAME);
1267 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
1269 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled on %s\\n\"",__DATE__);
1272 sv_catpv(PL_Sv, "; \
1274 @env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; ");
1277 push @env, \"CYGWIN=\\\"$ENV{CYGWIN}\\\"\";");
1280 print \" \\%ENV:\\n @env\\n\" if @env; \
1281 print \" \\@INC:\\n @INC\\n\";");
1284 PL_Sv = newSVpv("config_vars(qw(",0);
1285 sv_catpv(PL_Sv, ++s);
1286 sv_catpv(PL_Sv, "))");
1289 av_push(PL_preambleav, PL_Sv);
1290 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
1293 PL_doextract = TRUE;
1301 if (!*++s || isSPACE(*s)) {
1305 /* catch use of gnu style long options */
1306 if (strEQ(s, "version")) {
1310 if (strEQ(s, "help")) {
1317 Perl_croak(aTHX_ "Unrecognized switch: -%s (-h will show valid options)",s);
1323 #ifndef SECURE_INTERNAL_GETENV
1326 (s = PerlEnv_getenv("PERL5OPT")))
1331 if (*s == '-' && *(s+1) == 'T') {
1333 PL_taint_warn = FALSE;
1336 char *popt_copy = Nullch;
1349 if (!strchr("DIMUdmtw", *s))
1350 Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
1354 popt_copy = SvPVX(sv_2mortal(newSVpv(popt,0)));
1355 s = popt_copy + (s - popt);
1356 d = popt_copy + (d - popt);
1363 if( !PL_tainting ) {
1364 PL_taint_warn = TRUE;
1374 if (PL_taint_warn && PL_dowarn != G_WARN_ALL_OFF) {
1375 PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
1379 scriptname = argv[0];
1382 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
1384 else if (scriptname == Nullch) {
1386 if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
1394 open_script(scriptname,dosearch,sv,&fdscript);
1396 validate_suid(validarg, scriptname,fdscript);
1399 #if defined(SIGCHLD) || defined(SIGCLD)
1402 # define SIGCHLD SIGCLD
1404 Sighandler_t sigstate = rsignal_state(SIGCHLD);
1405 if (sigstate == SIG_IGN) {
1406 if (ckWARN(WARN_SIGNAL))
1407 Perl_warner(aTHX_ packWARN(WARN_SIGNAL),
1408 "Can't ignore signal CHLD, forcing to default");
1409 (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL);
1415 #ifdef MACOS_TRADITIONAL
1416 if (PL_doextract || gMacPerl_AlwaysExtract) {
1421 if (cddir && PerlDir_chdir(cddir) < 0)
1422 Perl_croak(aTHX_ "Can't chdir to %s",cddir);
1426 PL_main_cv = PL_compcv = (CV*)NEWSV(1104,0);
1427 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
1428 CvUNIQUE_on(PL_compcv);
1430 PL_comppad = newAV();
1431 av_push(PL_comppad, Nullsv);
1432 PL_curpad = AvARRAY(PL_comppad);
1433 PL_comppad_name = newAV();
1434 PL_comppad_name_fill = 0;
1435 PL_min_intro_pending = 0;
1437 #ifdef USE_5005THREADS
1438 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
1439 PL_curpad[0] = (SV*)newAV();
1440 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
1441 CvOWNER(PL_compcv) = 0;
1442 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
1443 MUTEX_INIT(CvMUTEXP(PL_compcv));
1444 #endif /* USE_5005THREADS */
1446 comppadlist = newAV();
1447 AvREAL_off(comppadlist);
1448 av_store(comppadlist, 0, (SV*)PL_comppad_name);
1449 av_store(comppadlist, 1, (SV*)PL_comppad);
1450 CvPADLIST(PL_compcv) = comppadlist;
1453 boot_core_UNIVERSAL();
1455 boot_core_xsutils();
1459 (*xsinit)(aTHX); /* in case linked C routines want magical variables */
1461 #if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__) || defined(EPOC)
1467 # ifdef HAS_SOCKS5_INIT
1468 socks5_init(argv[0]);
1474 init_predump_symbols();
1475 /* init_postdump_symbols not currently designed to be called */
1476 /* more than once (ENV isn't cleared first, for example) */
1477 /* But running with -u leaves %ENV & @ARGV undefined! XXX */
1479 init_postdump_symbols(argc,argv,env);
1481 if (PL_wantutf8) { /* Requires init_predump_symbols(). */
1485 if (PL_stdingv && (io = GvIO(PL_stdingv)) && (fp = IoIFP(io)))
1486 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
1487 if (PL_defoutgv && (io = GvIO(PL_defoutgv)) && (fp = IoOFP(io)))
1488 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
1489 if (PL_stderrgv && (io = GvIO(PL_stderrgv)) && (fp = IoOFP(io)))
1490 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
1491 if ((sv = GvSV(gv_fetchpv("\017PEN", TRUE, SVt_PV)))) {
1492 sv_setpvn(sv, ":utf8\0:utf8", 11);
1499 /* now parse the script */
1501 SETERRNO(0,SS$_NORMAL);
1503 #ifdef MACOS_TRADITIONAL
1504 if (gMacPerl_SyntaxError = (yyparse() || PL_error_count)) {
1506 Perl_croak(aTHX_ "%s had compilation errors.\n", MacPerl_MPWFileName(PL_origfilename));
1508 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
1509 MacPerl_MPWFileName(PL_origfilename));
1513 if (yyparse() || PL_error_count) {
1515 Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
1517 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
1522 CopLINE_set(PL_curcop, 0);
1523 PL_curstash = PL_defstash;
1524 PL_preprocess = FALSE;
1526 SvREFCNT_dec(PL_e_script);
1527 PL_e_script = Nullsv;
1531 Not sure that this is still the right place to do this now that we
1532 no longer use PL_nrs. HVDS 2001/09/09
1534 sv_setsv(get_sv("/", TRUE), PL_rs);
1540 SAVECOPFILE(PL_curcop);
1541 SAVECOPLINE(PL_curcop);
1542 gv_check(PL_defstash);
1549 if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
1550 dump_mstats("after compilation:");
1559 =for apidoc perl_run
1561 Tells a Perl interpreter to run. See L<perlembed>.
1572 #ifdef USE_5005THREADS
1576 oldscope = PL_scopestack_ix;
1581 #ifdef PERL_FLEXIBLE_EXCEPTIONS
1583 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vrun_body), oldscope);
1589 cxstack_ix = -1; /* start context stack again */
1591 case 0: /* normal completion */
1592 #ifndef PERL_FLEXIBLE_EXCEPTIONS
1597 case 2: /* my_exit() */
1598 while (PL_scopestack_ix > oldscope)
1601 PL_curstash = PL_defstash;
1602 if (!(PL_exit_flags & PERL_EXIT_DESTRUCT_END) &&
1603 PL_endav && !PL_minus_c)
1604 call_list(oldscope, PL_endav);
1606 if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
1607 dump_mstats("after execution: ");
1609 ret = STATUS_NATIVE_EXPORT;
1613 POPSTACK_TO(PL_mainstack);
1616 PerlIO_printf(Perl_error_log, "panic: restartop\n");
1626 #ifdef PERL_FLEXIBLE_EXCEPTIONS
1628 S_vrun_body(pTHX_ va_list args)
1630 I32 oldscope = va_arg(args, I32);
1632 return run_body(oldscope);
1638 S_run_body(pTHX_ I32 oldscope)
1640 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
1641 PL_sawampersand ? "Enabling" : "Omitting"));
1643 if (!PL_restartop) {
1644 DEBUG_x(dump_all());
1645 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
1646 DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%"UVxf"\n",
1650 #ifdef MACOS_TRADITIONAL
1651 PerlIO_printf(Perl_error_log, "# %s syntax OK\n", MacPerl_MPWFileName(PL_origfilename));
1653 PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
1657 if (PERLDB_SINGLE && PL_DBsingle)
1658 sv_setiv(PL_DBsingle, 1);
1660 call_list(oldscope, PL_initav);
1666 PL_op = PL_restartop;
1670 else if (PL_main_start) {
1671 CvDEPTH(PL_main_cv) = 1;
1672 PL_op = PL_main_start;
1682 =head1 SV Manipulation Functions
1684 =for apidoc p||get_sv
1686 Returns the SV of the specified Perl scalar. If C<create> is set and the
1687 Perl variable does not exist then it will be created. If C<create> is not
1688 set and the variable does not exist then NULL is returned.
1694 Perl_get_sv(pTHX_ const char *name, I32 create)
1697 #ifdef USE_5005THREADS
1698 if (name[1] == '\0' && !isALPHA(name[0])) {
1699 PADOFFSET tmp = find_threadsv(name);
1700 if (tmp != NOT_IN_PAD)
1701 return THREADSV(tmp);
1703 #endif /* USE_5005THREADS */
1704 gv = gv_fetchpv(name, create, SVt_PV);
1711 =head1 Array Manipulation Functions
1713 =for apidoc p||get_av
1715 Returns the AV of the specified Perl array. If C<create> is set and the
1716 Perl variable does not exist then it will be created. If C<create> is not
1717 set and the variable does not exist then NULL is returned.
1723 Perl_get_av(pTHX_ const char *name, I32 create)
1725 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1734 =head1 Hash Manipulation Functions
1736 =for apidoc p||get_hv
1738 Returns the HV of the specified Perl hash. If C<create> is set and the
1739 Perl variable does not exist then it will be created. If C<create> is not
1740 set and the variable does not exist then NULL is returned.
1746 Perl_get_hv(pTHX_ const char *name, I32 create)
1748 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1757 =head1 CV Manipulation Functions
1759 =for apidoc p||get_cv
1761 Returns the CV of the specified Perl subroutine. If C<create> is set and
1762 the Perl subroutine does not exist then it will be declared (which has the
1763 same effect as saying C<sub name;>). If C<create> is not set and the
1764 subroutine does not exist then NULL is returned.
1770 Perl_get_cv(pTHX_ const char *name, I32 create)
1772 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
1773 /* XXX unsafe for threads if eval_owner isn't held */
1774 /* XXX this is probably not what they think they're getting.
1775 * It has the same effect as "sub name;", i.e. just a forward
1777 if (create && !GvCVu(gv))
1778 return newSUB(start_subparse(FALSE, 0),
1779 newSVOP(OP_CONST, 0, newSVpv(name,0)),
1787 /* Be sure to refetch the stack pointer after calling these routines. */
1791 =head1 Callback Functions
1793 =for apidoc p||call_argv
1795 Performs a callback to the specified Perl sub. See L<perlcall>.
1801 Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv)
1803 /* See G_* flags in cop.h */
1804 /* null terminated arg list */
1811 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
1816 return call_pv(sub_name, flags);
1820 =for apidoc p||call_pv
1822 Performs a callback to the specified Perl sub. See L<perlcall>.
1828 Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
1829 /* name of the subroutine */
1830 /* See G_* flags in cop.h */
1832 return call_sv((SV*)get_cv(sub_name, TRUE), flags);
1836 =for apidoc p||call_method
1838 Performs a callback to the specified Perl method. The blessed object must
1839 be on the stack. See L<perlcall>.
1845 Perl_call_method(pTHX_ const char *methname, I32 flags)
1846 /* name of the subroutine */
1847 /* See G_* flags in cop.h */
1849 return call_sv(sv_2mortal(newSVpv(methname,0)), flags | G_METHOD);
1852 /* May be called with any of a CV, a GV, or an SV containing the name. */
1854 =for apidoc p||call_sv
1856 Performs a callback to the Perl sub whose name is in the SV. See
1863 Perl_call_sv(pTHX_ SV *sv, I32 flags)
1864 /* See G_* flags in cop.h */
1867 LOGOP myop; /* fake syntax tree node */
1870 volatile I32 retval = 0;
1872 bool oldcatch = CATCH_GET;
1877 if (flags & G_DISCARD) {
1882 Zero(&myop, 1, LOGOP);
1883 myop.op_next = Nullop;
1884 if (!(flags & G_NOARGS))
1885 myop.op_flags |= OPf_STACKED;
1886 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1887 (flags & G_ARRAY) ? OPf_WANT_LIST :
1892 EXTEND(PL_stack_sp, 1);
1893 *++PL_stack_sp = sv;
1895 oldscope = PL_scopestack_ix;
1897 if (PERLDB_SUB && PL_curstash != PL_debstash
1898 /* Handle first BEGIN of -d. */
1899 && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
1900 /* Try harder, since this may have been a sighandler, thus
1901 * curstash may be meaningless. */
1902 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != PL_debstash)
1903 && !(flags & G_NODEBUG))
1904 PL_op->op_private |= OPpENTERSUB_DB;
1906 if (flags & G_METHOD) {
1907 Zero(&method_op, 1, UNOP);
1908 method_op.op_next = PL_op;
1909 method_op.op_ppaddr = PL_ppaddr[OP_METHOD];
1910 myop.op_ppaddr = PL_ppaddr[OP_ENTERSUB];
1911 PL_op = (OP*)&method_op;
1914 if (!(flags & G_EVAL)) {
1916 call_body((OP*)&myop, FALSE);
1917 retval = PL_stack_sp - (PL_stack_base + oldmark);
1918 CATCH_SET(oldcatch);
1921 myop.op_other = (OP*)&myop;
1923 /* we're trying to emulate pp_entertry() here */
1925 register PERL_CONTEXT *cx;
1926 I32 gimme = GIMME_V;
1931 push_return(Nullop);
1932 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
1934 PL_eval_root = PL_op; /* Only needed so that goto works right. */
1936 PL_in_eval = EVAL_INEVAL;
1937 if (flags & G_KEEPERR)
1938 PL_in_eval |= EVAL_KEEPERR;
1944 #ifdef PERL_FLEXIBLE_EXCEPTIONS
1946 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_body),
1953 #ifndef PERL_FLEXIBLE_EXCEPTIONS
1955 call_body((OP*)&myop, FALSE);
1957 retval = PL_stack_sp - (PL_stack_base + oldmark);
1958 if (!(flags & G_KEEPERR))
1965 /* my_exit() was called */
1966 PL_curstash = PL_defstash;
1969 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
1970 Perl_croak(aTHX_ "Callback called exit");
1975 PL_op = PL_restartop;
1979 PL_stack_sp = PL_stack_base + oldmark;
1980 if (flags & G_ARRAY)
1984 *++PL_stack_sp = &PL_sv_undef;
1989 if (PL_scopestack_ix > oldscope) {
1993 register PERL_CONTEXT *cx;
2005 if (flags & G_DISCARD) {
2006 PL_stack_sp = PL_stack_base + oldmark;
2015 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2017 S_vcall_body(pTHX_ va_list args)
2019 OP *myop = va_arg(args, OP*);
2020 int is_eval = va_arg(args, int);
2022 call_body(myop, is_eval);
2028 S_call_body(pTHX_ OP *myop, int is_eval)
2030 if (PL_op == myop) {
2032 PL_op = Perl_pp_entereval(aTHX); /* this doesn't do a POPMARK */
2034 PL_op = Perl_pp_entersub(aTHX); /* this does */
2040 /* Eval a string. The G_EVAL flag is always assumed. */
2043 =for apidoc p||eval_sv
2045 Tells Perl to C<eval> the string in the SV.
2051 Perl_eval_sv(pTHX_ SV *sv, I32 flags)
2053 /* See G_* flags in cop.h */
2056 UNOP myop; /* fake syntax tree node */
2057 volatile I32 oldmark = SP - PL_stack_base;
2058 volatile I32 retval = 0;
2064 if (flags & G_DISCARD) {
2071 Zero(PL_op, 1, UNOP);
2072 EXTEND(PL_stack_sp, 1);
2073 *++PL_stack_sp = sv;
2074 oldscope = PL_scopestack_ix;
2076 if (!(flags & G_NOARGS))
2077 myop.op_flags = OPf_STACKED;
2078 myop.op_next = Nullop;
2079 myop.op_type = OP_ENTEREVAL;
2080 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
2081 (flags & G_ARRAY) ? OPf_WANT_LIST :
2083 if (flags & G_KEEPERR)
2084 myop.op_flags |= OPf_SPECIAL;
2086 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2088 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_body),
2095 #ifndef PERL_FLEXIBLE_EXCEPTIONS
2097 call_body((OP*)&myop,TRUE);
2099 retval = PL_stack_sp - (PL_stack_base + oldmark);
2100 if (!(flags & G_KEEPERR))
2107 /* my_exit() was called */
2108 PL_curstash = PL_defstash;
2111 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
2112 Perl_croak(aTHX_ "Callback called exit");
2117 PL_op = PL_restartop;
2121 PL_stack_sp = PL_stack_base + oldmark;
2122 if (flags & G_ARRAY)
2126 *++PL_stack_sp = &PL_sv_undef;
2132 if (flags & G_DISCARD) {
2133 PL_stack_sp = PL_stack_base + oldmark;
2143 =for apidoc p||eval_pv
2145 Tells Perl to C<eval> the given string and return an SV* result.
2151 Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
2154 SV* sv = newSVpv(p, 0);
2156 eval_sv(sv, G_SCALAR);
2163 if (croak_on_error && SvTRUE(ERRSV)) {
2165 Perl_croak(aTHX_ SvPVx(ERRSV, n_a));
2171 /* Require a module. */
2174 =head1 Embedding Functions
2176 =for apidoc p||require_pv
2178 Tells Perl to C<require> the file named by the string argument. It is
2179 analogous to the Perl code C<eval "require '$file'">. It's even
2180 implemented that way; consider using Perl_load_module instead.
2185 Perl_require_pv(pTHX_ const char *pv)
2189 PUSHSTACKi(PERLSI_REQUIRE);
2191 sv = sv_newmortal();
2192 sv_setpv(sv, "require '");
2195 eval_sv(sv, G_DISCARD);
2201 Perl_magicname(pTHX_ char *sym, char *name, I32 namlen)
2205 if ((gv = gv_fetchpv(sym,TRUE, SVt_PV)))
2206 sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, namlen);
2210 S_usage(pTHX_ char *name) /* XXX move this out into a module ? */
2212 /* This message really ought to be max 23 lines.
2213 * Removed -h because the user already knows that option. Others? */
2215 static char *usage_msg[] = {
2216 "-0[octal] specify record separator (\\0, if no argument)",
2217 "-a autosplit mode with -n or -p (splits $_ into @F)",
2218 "-C enable native wide character system interfaces",
2219 "-c check syntax only (runs BEGIN and CHECK blocks)",
2220 "-d[:debugger] run program under debugger",
2221 "-D[number/list] set debugging flags (argument is a bit mask or alphabets)",
2222 "-e 'command' one line of program (several -e's allowed, omit programfile)",
2223 "-F/pattern/ split() pattern for -a switch (//'s are optional)",
2224 "-i[extension] edit <> files in place (makes backup if extension supplied)",
2225 "-Idirectory specify @INC/#include directory (several -I's allowed)",
2226 "-l[octal] enable line ending processing, specifies line terminator",
2227 "-[mM][-]module execute `use/no module...' before executing program",
2228 "-n assume 'while (<>) { ... }' loop around program",
2229 "-p assume loop like -n but print line also, like sed",
2230 "-P run program through C preprocessor before compilation",
2231 "-s enable rudimentary parsing for switches after programfile",
2232 "-S look for programfile using PATH environment variable",
2233 "-T enable tainting checks",
2234 "-t enable tainting warnings",
2235 "-u dump core after parsing program",
2236 "-U allow unsafe operations",
2237 "-v print version, subversion (includes VERY IMPORTANT perl info)",
2238 "-V[:variable] print configuration summary (or a single Config.pm variable)",
2239 "-w enable many useful warnings (RECOMMENDED)",
2240 "-W enable all warnings",
2241 "-X disable all warnings",
2242 "-x[directory] strip off text before #!perl line and perhaps cd to directory",
2246 char **p = usage_msg;
2248 PerlIO_printf(PerlIO_stdout(),
2249 "\nUsage: %s [switches] [--] [programfile] [arguments]",
2252 PerlIO_printf(PerlIO_stdout(), "\n %s", *p++);
2255 /* This routine handles any switches that can be given during run */
2258 Perl_moreswitches(pTHX_ char *s)
2268 rschar = (U32)grok_oct(s, &numlen, &flags, NULL);
2269 SvREFCNT_dec(PL_rs);
2270 if (rschar & ~((U8)~0))
2271 PL_rs = &PL_sv_undef;
2272 else if (!rschar && numlen >= 2)
2273 PL_rs = newSVpvn("", 0);
2275 char ch = (char)rschar;
2276 PL_rs = newSVpvn(&ch, 1);
2281 PL_widesyscalls = TRUE;
2287 while (*s && !isSPACE(*s)) ++s;
2289 PL_splitstr = savepv(PL_splitstr);
2302 /* The following permits -d:Mod to accepts arguments following an =
2303 in the fashion that -MSome::Mod does. */
2304 if (*s == ':' || *s == '=') {
2307 sv = newSVpv("use Devel::", 0);
2309 /* We now allow -d:Module=Foo,Bar */
2310 while(isALNUM(*s) || *s==':') ++s;
2312 sv_catpv(sv, start);
2314 sv_catpvn(sv, start, s-start);
2315 sv_catpv(sv, " split(/,/,q{");
2320 my_setenv("PERL5DB", SvPV(sv, PL_na));
2323 PL_perldb = PERLDB_ALL;
2331 if (isALPHA(s[1])) {
2332 /* if adding extra options, remember to update DEBUG_MASK */
2333 static char debopts[] = "psltocPmfrxuLHXDSTRJ";
2336 for (s++; *s && (d = strchr(debopts,*s)); s++)
2337 PL_debug |= 1 << (d - debopts);
2340 PL_debug = atoi(s+1);
2341 for (s++; isDIGIT(*s); s++) ;
2344 if (DEBUG_p_TEST_ && ckWARN_d(WARN_DEBUGGING))
2345 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
2346 "-Dp not implemented on this platform\n");
2348 PL_debug |= DEBUG_TOP_FLAG;
2349 #else /* !DEBUGGING */
2350 if (ckWARN_d(WARN_DEBUGGING))
2351 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
2352 "Recompile perl with -DDEBUGGING to use -D switch\n");
2353 for (s++; isALNUM(*s); s++) ;
2359 usage(PL_origargv[0]);
2363 Safefree(PL_inplace);
2364 PL_inplace = savepv(s+1);
2366 for (s = PL_inplace; *s && !isSPACE(*s); s++) ;
2369 if (*s == '-') /* Additional switches on #! line. */
2373 case 'I': /* -I handled both here and in parse_body() */
2376 while (*s && isSPACE(*s))
2381 /* ignore trailing spaces (possibly followed by other switches) */
2383 for (e = p; *e && !isSPACE(*e); e++) ;
2387 } while (*p && *p != '-');
2388 e = savepvn(s, e-s);
2389 incpush(e, TRUE, TRUE);
2396 Perl_croak(aTHX_ "No directory specified for -I");
2402 SvREFCNT_dec(PL_ors_sv);
2407 PL_ors_sv = newSVpvn("\n",1);
2408 numlen = 3 + (*s == '0');
2409 *SvPVX(PL_ors_sv) = (char)grok_oct(s, &numlen, &flags, NULL);
2413 if (RsPARA(PL_rs)) {
2414 PL_ors_sv = newSVpvn("\n\n",2);
2417 PL_ors_sv = newSVsv(PL_rs);
2422 forbid_setid("-M"); /* XXX ? */
2425 forbid_setid("-m"); /* XXX ? */
2430 /* -M-foo == 'no foo' */
2431 if (*s == '-') { use = "no "; ++s; }
2432 sv = newSVpv(use,0);
2434 /* We allow -M'Module qw(Foo Bar)' */
2435 while(isALNUM(*s) || *s==':') ++s;
2437 sv_catpv(sv, start);
2438 if (*(start-1) == 'm') {
2440 Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
2441 sv_catpv( sv, " ()");
2445 Perl_croak(aTHX_ "Module name required with -%c option",
2447 sv_catpvn(sv, start, s-start);
2448 sv_catpv(sv, " split(/,/,q{");
2454 PL_preambleav = newAV();
2455 av_push(PL_preambleav, sv);
2458 Perl_croak(aTHX_ "No space allowed after -%c", *(s-1));
2470 PL_doswitches = TRUE;
2475 Perl_croak(aTHX_ "Too late for \"-t\" option");
2480 Perl_croak(aTHX_ "Too late for \"-T\" option");
2484 #ifdef MACOS_TRADITIONAL
2485 Perl_croak(aTHX_ "Believe me, you don't want to use \"-u\" on a Macintosh");
2487 PL_do_undump = TRUE;
2496 PerlIO_printf(PerlIO_stdout(),
2497 Perl_form(aTHX_ "\nThis is perl, v%"VDf" built for %s",
2498 PL_patchlevel, ARCHNAME));
2500 /* Adjust verbose output as in the perl that ships with the DG/UX OS from EMC */
2501 PerlIO_printf(PerlIO_stdout(),
2502 Perl_form(aTHX_ "\nThis is perl, version %vd\n", PL_patchlevel));
2503 PerlIO_printf(PerlIO_stdout(),
2504 Perl_form(aTHX_ " built under %s at %s %s\n",
2505 OSNAME, __DATE__, __TIME__));
2506 PerlIO_printf(PerlIO_stdout(),
2507 Perl_form(aTHX_ " OS Specific Release: %s\n",
2511 #if defined(LOCAL_PATCH_COUNT)
2512 if (LOCAL_PATCH_COUNT > 0)
2513 PerlIO_printf(PerlIO_stdout(),
2514 "\n(with %d registered patch%s, "
2515 "see perl -V for more detail)",
2516 (int)LOCAL_PATCH_COUNT,
2517 (LOCAL_PATCH_COUNT!=1) ? "es" : "");
2520 PerlIO_printf(PerlIO_stdout(),
2521 "\n\nCopyright 1987-2002, Larry Wall\n");
2522 #ifdef MACOS_TRADITIONAL
2523 PerlIO_printf(PerlIO_stdout(),
2524 "\nMac OS port Copyright 1991-2002, Matthias Neeracher;\n"
2525 "maintained by Chris Nandor\n");
2528 PerlIO_printf(PerlIO_stdout(),
2529 "\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
2532 PerlIO_printf(PerlIO_stdout(),
2533 "djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n"
2534 "djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
2537 PerlIO_printf(PerlIO_stdout(),
2538 "\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
2539 "Version 5 port Copyright (c) 1994-2002, Andreas Kaiser, Ilya Zakharevich\n");
2542 PerlIO_printf(PerlIO_stdout(),
2543 "atariST series port, ++jrb bammi@cadence.com\n");
2546 PerlIO_printf(PerlIO_stdout(),
2547 "BeOS port Copyright Tom Spindler, 1997-1999\n");
2550 PerlIO_printf(PerlIO_stdout(),
2551 "MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-2002\n");
2554 PerlIO_printf(PerlIO_stdout(),
2555 "MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
2558 PerlIO_printf(PerlIO_stdout(),
2559 "Stratus VOS port by Paul.Green@stratus.com, 1997-2002\n");
2562 PerlIO_printf(PerlIO_stdout(),
2563 "VM/ESA port by Neale Ferguson, 1998-1999\n");
2566 PerlIO_printf(PerlIO_stdout(),
2567 "BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
2570 PerlIO_printf(PerlIO_stdout(),
2571 "MiNT port by Guido Flohr, 1997-1999\n");
2574 PerlIO_printf(PerlIO_stdout(),
2575 "EPOC port by Olaf Flebbe, 1999-2002\n");
2578 printf("WINCE port by Rainer Keuchel, 2001-2002\n");
2579 printf("Built on " __DATE__ " " __TIME__ "\n\n");
2582 #ifdef BINARY_BUILD_NOTICE
2583 BINARY_BUILD_NOTICE;
2585 PerlIO_printf(PerlIO_stdout(),
2587 Perl may be copied only under the terms of either the Artistic License or the\n\
2588 GNU General Public License, which may be found in the Perl 5 source kit.\n\n\
2589 Complete documentation for Perl, including FAQ lists, should be found on\n\
2590 this system using `man perl' or `perldoc perl'. If you have access to the\n\
2591 Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
2594 if (! (PL_dowarn & G_WARN_ALL_MASK))
2595 PL_dowarn |= G_WARN_ON;
2599 PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
2600 if (!specialWARN(PL_compiling.cop_warnings))
2601 SvREFCNT_dec(PL_compiling.cop_warnings);
2602 PL_compiling.cop_warnings = pWARN_ALL ;
2606 PL_dowarn = G_WARN_ALL_OFF;
2607 if (!specialWARN(PL_compiling.cop_warnings))
2608 SvREFCNT_dec(PL_compiling.cop_warnings);
2609 PL_compiling.cop_warnings = pWARN_NONE ;
2614 if (s[1] == '-') /* Additional switches on #! line. */
2619 #if defined(WIN32) || !defined(PERL_STRICT_CR)
2625 #ifdef ALTERNATE_SHEBANG
2626 case 'S': /* OS/2 needs -S on "extproc" line. */
2634 Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
2639 /* compliments of Tom Christiansen */
2641 /* unexec() can be found in the Gnu emacs distribution */
2642 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
2645 Perl_my_unexec(pTHX)
2653 prog = newSVpv(BIN_EXP, 0);
2654 sv_catpv(prog, "/perl");
2655 file = newSVpv(PL_origfilename, 0);
2656 sv_catpv(file, ".perldump");
2658 unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
2659 /* unexec prints msg to stderr in case of failure */
2660 PerlProc_exit(status);
2663 # include <lib$routines.h>
2664 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
2666 ABORT(); /* for use with undump */
2671 /* initialize curinterp */
2677 # define PERLVAR(var,type)
2678 # define PERLVARA(var,n,type)
2679 # if defined(PERL_IMPLICIT_CONTEXT)
2680 # if defined(USE_5005THREADS)
2681 # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
2682 # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
2683 # else /* !USE_5005THREADS */
2684 # define PERLVARI(var,type,init) aTHX->var = init;
2685 # define PERLVARIC(var,type,init) aTHX->var = init;
2686 # endif /* USE_5005THREADS */
2688 # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
2689 # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
2691 # include "intrpvar.h"
2692 # ifndef USE_5005THREADS
2693 # include "thrdvar.h"
2700 # define PERLVAR(var,type)
2701 # define PERLVARA(var,n,type)
2702 # define PERLVARI(var,type,init) PL_##var = init;
2703 # define PERLVARIC(var,type,init) PL_##var = init;
2704 # include "intrpvar.h"
2705 # ifndef USE_5005THREADS
2706 # include "thrdvar.h"
2717 S_init_main_stash(pTHX)
2721 PL_curstash = PL_defstash = newHV();
2722 PL_curstname = newSVpvn("main",4);
2723 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
2724 SvREFCNT_dec(GvHV(gv));
2725 GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
2727 HvNAME(PL_defstash) = savepv("main");
2728 PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
2729 GvMULTI_on(PL_incgv);
2730 PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
2731 GvMULTI_on(PL_hintgv);
2732 PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
2733 PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
2734 GvMULTI_on(PL_errgv);
2735 PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
2736 GvMULTI_on(PL_replgv);
2737 (void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */
2738 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
2739 sv_setpvn(ERRSV, "", 0);
2740 PL_curstash = PL_defstash;
2741 CopSTASH_set(&PL_compiling, PL_defstash);
2742 PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
2743 PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
2744 PL_nullstash = GvHV(gv_fetchpv("<none>::", GV_ADDMULTI, SVt_PVHV));
2745 /* We must init $/ before switches are processed. */
2746 sv_setpvn(get_sv("/", TRUE), "\n", 1);
2750 S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
2754 char *cpp_discard_flag;
2760 PL_origfilename = savepv("-e");
2763 /* if find_script() returns, it returns a malloc()-ed value */
2764 PL_origfilename = scriptname = find_script(scriptname, dosearch, NULL, 1);
2766 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
2767 char *s = scriptname + 8;
2768 *fdscript = atoi(s);
2772 scriptname = savepv(s + 1);
2773 Safefree(PL_origfilename);
2774 PL_origfilename = scriptname;
2779 CopFILE_free(PL_curcop);
2780 CopFILE_set(PL_curcop, PL_origfilename);
2781 if (strEQ(PL_origfilename,"-"))
2783 if (*fdscript >= 0) {
2784 PL_rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE);
2785 # if defined(HAS_FCNTL) && defined(F_SETFD)
2787 /* ensure close-on-exec */
2788 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
2791 else if (PL_preprocess) {
2792 char *cpp_cfg = CPPSTDIN;
2793 SV *cpp = newSVpvn("",0);
2794 SV *cmd = NEWSV(0,0);
2796 if (strEQ(cpp_cfg, "cppstdin"))
2797 Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
2798 sv_catpv(cpp, cpp_cfg);
2801 sv_catpvn(sv, "-I", 2);
2802 sv_catpv(sv,PRIVLIB_EXP);
2805 DEBUG_P(PerlIO_printf(Perl_debug_log,
2806 "PL_preprocess: scriptname=\"%s\", cpp=\"%s\", sv=\"%s\", CPPMINUS=\"%s\"\n",
2807 scriptname, SvPVX (cpp), SvPVX (sv), CPPMINUS));
2809 # if defined(MSDOS) || defined(WIN32) || defined(VMS)
2816 cpp_discard_flag = "";
2818 cpp_discard_flag = "-C";
2822 perl = os2_execname(aTHX);
2824 perl = PL_origargv[0];
2828 /* This strips off Perl comments which might interfere with
2829 the C pre-processor, including #!. #line directives are
2830 deliberately stripped to avoid confusion with Perl's version
2831 of #line. FWP played some golf with it so it will fit
2832 into VMS's 255 character buffer.
2835 code = "(1../^#!.*perl/i)|/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print";
2837 code = "/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print";
2839 Perl_sv_setpvf(aTHX_ cmd, "\
2840 %s -ne%s%s%s %s | %"SVf" %s %"SVf" %s",
2841 perl, quote, code, quote, scriptname, cpp,
2842 cpp_discard_flag, sv, CPPMINUS);
2844 PL_doextract = FALSE;
2845 # ifdef IAMSUID /* actually, this is caught earlier */
2846 if (PL_euid != PL_uid && !PL_euid) { /* if running suidperl */
2848 (void)seteuid(PL_uid); /* musn't stay setuid root */
2850 # ifdef HAS_SETREUID
2851 (void)setreuid((Uid_t)-1, PL_uid);
2853 # ifdef HAS_SETRESUID
2854 (void)setresuid((Uid_t)-1, PL_uid, (Uid_t)-1);
2856 PerlProc_setuid(PL_uid);
2860 if (PerlProc_geteuid() != PL_uid)
2861 Perl_croak(aTHX_ "Can't do seteuid!\n");
2863 # endif /* IAMSUID */
2865 DEBUG_P(PerlIO_printf(Perl_debug_log,
2866 "PL_preprocess: cmd=\"%s\"\n",
2869 PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
2873 else if (!*scriptname) {
2874 forbid_setid("program input from stdin");
2875 PL_rsfp = PerlIO_stdin();
2878 PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
2879 # if defined(HAS_FCNTL) && defined(F_SETFD)
2881 /* ensure close-on-exec */
2882 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
2887 # ifndef IAMSUID /* in case script is not readable before setuid */
2889 PerlLIO_stat(CopFILE(PL_curcop),&PL_statbuf) >= 0 &&
2890 PL_statbuf.st_mode & (S_ISUID|S_ISGID))
2893 PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT,
2894 BIN_EXP, (int)PERL_REVISION,
2896 (int)PERL_SUBVERSION), PL_origargv);
2897 Perl_croak(aTHX_ "Can't do setuid\n");
2903 Perl_croak(aTHX_ "Can't open perl script: %s\n",
2906 Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
2907 CopFILE(PL_curcop), Strerror(errno));
2913 * I_SYSSTATVFS HAS_FSTATVFS
2915 * I_STATFS HAS_FSTATFS HAS_GETFSSTAT
2916 * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT
2917 * here so that metaconfig picks them up. */
2921 S_fd_on_nosuid_fs(pTHX_ int fd)
2923 int check_okay = 0; /* able to do all the required sys/libcalls */
2924 int on_nosuid = 0; /* the fd is on a nosuid fs */
2926 * Preferred order: fstatvfs(), fstatfs(), ustat()+getmnt(), getmntent().
2927 * fstatvfs() is UNIX98.
2928 * fstatfs() is 4.3 BSD.
2929 * ustat()+getmnt() is pre-4.3 BSD.
2930 * getmntent() is O(number-of-mounted-filesystems) and can hang on
2931 * an irrelevant filesystem while trying to reach the right one.
2934 #undef FD_ON_NOSUID_CHECK_OKAY /* found the syscalls to do the check? */
2936 # if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
2937 defined(HAS_FSTATVFS)
2938 # define FD_ON_NOSUID_CHECK_OKAY
2939 struct statvfs stfs;
2941 check_okay = fstatvfs(fd, &stfs) == 0;
2942 on_nosuid = check_okay && (stfs.f_flag & ST_NOSUID);
2943 # endif /* fstatvfs */
2945 # if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
2946 defined(PERL_MOUNT_NOSUID) && \
2947 defined(HAS_FSTATFS) && \
2948 defined(HAS_STRUCT_STATFS) && \
2949 defined(HAS_STRUCT_STATFS_F_FLAGS)
2950 # define FD_ON_NOSUID_CHECK_OKAY
2953 check_okay = fstatfs(fd, &stfs) == 0;
2954 on_nosuid = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
2955 # endif /* fstatfs */
2957 # if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
2958 defined(PERL_MOUNT_NOSUID) && \
2959 defined(HAS_FSTAT) && \
2960 defined(HAS_USTAT) && \
2961 defined(HAS_GETMNT) && \
2962 defined(HAS_STRUCT_FS_DATA) && \
2964 # define FD_ON_NOSUID_CHECK_OKAY
2967 if (fstat(fd, &fdst) == 0) {
2969 if (ustat(fdst.st_dev, &us) == 0) {
2971 /* NOSTAT_ONE here because we're not examining fields which
2972 * vary between that case and STAT_ONE. */
2973 if (getmnt((int*)0, &fsd, (int)0, NOSTAT_ONE, us.f_fname) == 0) {
2974 size_t cmplen = sizeof(us.f_fname);
2975 if (sizeof(fsd.fd_req.path) < cmplen)
2976 cmplen = sizeof(fsd.fd_req.path);
2977 if (strnEQ(fsd.fd_req.path, us.f_fname, cmplen) &&
2978 fdst.st_dev == fsd.fd_req.dev) {
2980 on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID;
2986 # endif /* fstat+ustat+getmnt */
2988 # if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
2989 defined(HAS_GETMNTENT) && \
2990 defined(HAS_HASMNTOPT) && \
2991 defined(MNTOPT_NOSUID)
2992 # define FD_ON_NOSUID_CHECK_OKAY
2993 FILE *mtab = fopen("/etc/mtab", "r");
2994 struct mntent *entry;
2997 if (mtab && (fstat(fd, &stb) == 0)) {
2998 while (entry = getmntent(mtab)) {
2999 if (stat(entry->mnt_dir, &fsb) == 0
3000 && fsb.st_dev == stb.st_dev)
3002 /* found the filesystem */
3004 if (hasmntopt(entry, MNTOPT_NOSUID))
3007 } /* A single fs may well fail its stat(). */
3012 # endif /* getmntent+hasmntopt */
3015 Perl_croak(aTHX_ "Can't check filesystem of script \"%s\" for nosuid", PL_origfilename);
3018 #endif /* IAMSUID */
3021 S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript)
3027 /* do we need to emulate setuid on scripts? */
3029 /* This code is for those BSD systems that have setuid #! scripts disabled
3030 * in the kernel because of a security problem. Merely defining DOSUID
3031 * in perl will not fix that problem, but if you have disabled setuid
3032 * scripts in the kernel, this will attempt to emulate setuid and setgid
3033 * on scripts that have those now-otherwise-useless bits set. The setuid
3034 * root version must be called suidperl or sperlN.NNN. If regular perl
3035 * discovers that it has opened a setuid script, it calls suidperl with
3036 * the same argv that it had. If suidperl finds that the script it has
3037 * just opened is NOT setuid root, it sets the effective uid back to the
3038 * uid. We don't just make perl setuid root because that loses the
3039 * effective uid we had before invoking perl, if it was different from the
3042 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
3043 * be defined in suidperl only. suidperl must be setuid root. The
3044 * Configure script will set this up for you if you want it.
3050 if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */
3051 Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
3052 if (fdscript < 0 && PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
3057 #ifndef HAS_SETREUID
3058 /* On this access check to make sure the directories are readable,
3059 * there is actually a small window that the user could use to make
3060 * filename point to an accessible directory. So there is a faint
3061 * chance that someone could execute a setuid script down in a
3062 * non-accessible directory. I don't know what to do about that.
3063 * But I don't think it's too important. The manual lies when
3064 * it says access() is useful in setuid programs.
3066 if (PerlLIO_access(CopFILE(PL_curcop),1)) /*double check*/
3067 Perl_croak(aTHX_ "Permission denied");
3069 /* If we can swap euid and uid, then we can determine access rights
3070 * with a simple stat of the file, and then compare device and
3071 * inode to make sure we did stat() on the same file we opened.
3072 * Then we just have to make sure he or she can execute it.
3079 setreuid(PL_euid,PL_uid) < 0
3082 setresuid(PL_euid,PL_uid,(Uid_t)-1) < 0
3085 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
3086 Perl_croak(aTHX_ "Can't swap uid and euid"); /* really paranoid */
3087 if (PerlLIO_stat(CopFILE(PL_curcop),&tmpstatbuf) < 0)
3088 Perl_croak(aTHX_ "Permission denied"); /* testing full pathname here */
3089 #if defined(IAMSUID) && !defined(NO_NOSUID_CHECK)
3090 if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp)))
3091 Perl_croak(aTHX_ "Permission denied");
3093 if (tmpstatbuf.st_dev != PL_statbuf.st_dev ||
3094 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
3095 (void)PerlIO_close(PL_rsfp);
3096 Perl_croak(aTHX_ "Permission denied\n");
3100 setreuid(PL_uid,PL_euid) < 0
3102 # if defined(HAS_SETRESUID)
3103 setresuid(PL_uid,PL_euid,(Uid_t)-1) < 0
3106 || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
3107 Perl_croak(aTHX_ "Can't reswap uid and euid");
3108 if (!cando(S_IXUSR,FALSE,&PL_statbuf)) /* can real uid exec? */
3109 Perl_croak(aTHX_ "Permission denied\n");
3111 #endif /* HAS_SETREUID */
3112 #endif /* IAMSUID */
3114 if (!S_ISREG(PL_statbuf.st_mode))
3115 Perl_croak(aTHX_ "Permission denied");
3116 if (PL_statbuf.st_mode & S_IWOTH)
3117 Perl_croak(aTHX_ "Setuid/gid script is writable by world");
3118 PL_doswitches = FALSE; /* -s is insecure in suid */
3119 CopLINE_inc(PL_curcop);
3120 if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
3121 strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */
3122 Perl_croak(aTHX_ "No #! line");
3123 s = SvPV(PL_linestr,n_a)+2;
3125 while (!isSPACE(*s)) s++;
3126 for (s2 = s; (s2 > SvPV(PL_linestr,n_a)+2 &&
3127 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
3128 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
3129 Perl_croak(aTHX_ "Not a perl script");
3130 while (*s == ' ' || *s == '\t') s++;
3132 * #! arg must be what we saw above. They can invoke it by
3133 * mentioning suidperl explicitly, but they may not add any strange
3134 * arguments beyond what #! says if they do invoke suidperl that way.
3136 len = strlen(validarg);
3137 if (strEQ(validarg," PHOOEY ") ||
3138 strnNE(s,validarg,len) || !isSPACE(s[len]))
3139 Perl_croak(aTHX_ "Args must match #! line");
3142 if (PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
3143 PL_euid == PL_statbuf.st_uid)
3145 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
3146 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
3147 #endif /* IAMSUID */
3149 if (PL_euid) { /* oops, we're not the setuid root perl */
3150 (void)PerlIO_close(PL_rsfp);
3153 PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
3154 (int)PERL_REVISION, (int)PERL_VERSION,
3155 (int)PERL_SUBVERSION), PL_origargv);
3157 Perl_croak(aTHX_ "Can't do setuid\n");
3160 if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
3162 (void)setegid(PL_statbuf.st_gid);
3165 (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
3167 #ifdef HAS_SETRESGID
3168 (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
3170 PerlProc_setgid(PL_statbuf.st_gid);
3174 if (PerlProc_getegid() != PL_statbuf.st_gid)
3175 Perl_croak(aTHX_ "Can't do setegid!\n");
3177 if (PL_statbuf.st_mode & S_ISUID) {
3178 if (PL_statbuf.st_uid != PL_euid)
3180 (void)seteuid(PL_statbuf.st_uid); /* all that for this */
3183 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
3185 #ifdef HAS_SETRESUID
3186 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
3188 PerlProc_setuid(PL_statbuf.st_uid);
3192 if (PerlProc_geteuid() != PL_statbuf.st_uid)
3193 Perl_croak(aTHX_ "Can't do seteuid!\n");
3195 else if (PL_uid) { /* oops, mustn't run as root */
3197 (void)seteuid((Uid_t)PL_uid);
3200 (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
3202 #ifdef HAS_SETRESUID
3203 (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
3205 PerlProc_setuid((Uid_t)PL_uid);
3209 if (PerlProc_geteuid() != PL_uid)
3210 Perl_croak(aTHX_ "Can't do seteuid!\n");
3213 if (!cando(S_IXUSR,TRUE,&PL_statbuf))
3214 Perl_croak(aTHX_ "Permission denied\n"); /* they can't do this */
3217 else if (PL_preprocess)
3218 Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
3219 else if (fdscript >= 0)
3220 Perl_croak(aTHX_ "fd script not allowed in suidperl\n");
3222 Perl_croak(aTHX_ "Script is not setuid/setgid in suidperl\n");
3224 /* We absolutely must clear out any saved ids here, so we */
3225 /* exec the real perl, substituting fd script for scriptname. */
3226 /* (We pass script name as "subdir" of fd, which perl will grok.) */
3227 PerlIO_rewind(PL_rsfp);
3228 PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0); /* just in case rewind didn't */
3229 for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
3230 if (!PL_origargv[which])
3231 Perl_croak(aTHX_ "Permission denied");
3232 PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
3233 PerlIO_fileno(PL_rsfp), PL_origargv[which]));
3234 #if defined(HAS_FCNTL) && defined(F_SETFD)
3235 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */
3237 PerlProc_execv(Perl_form(aTHX_ "%s/perl"PERL_FS_VER_FMT, BIN_EXP,
3238 (int)PERL_REVISION, (int)PERL_VERSION,
3239 (int)PERL_SUBVERSION), PL_origargv);/* try again */
3240 Perl_croak(aTHX_ "Can't do setuid\n");
3241 #endif /* IAMSUID */
3243 if (PL_euid != PL_uid || PL_egid != PL_gid) { /* (suidperl doesn't exist, in fact) */
3244 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
3245 PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf); /* may be either wrapped or real suid */
3246 if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
3248 (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
3251 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
3252 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
3253 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
3254 /* not set-id, must be wrapped */
3260 S_find_beginning(pTHX)
3262 register char *s, *s2;
3264 /* skip forward in input to the real script? */
3267 #ifdef MACOS_TRADITIONAL
3268 /* Since the Mac OS does not honor #! arguments for us, we do it ourselves */
3270 while (PL_doextract || gMacPerl_AlwaysExtract) {
3271 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
3272 if (!gMacPerl_AlwaysExtract)
3273 Perl_croak(aTHX_ "No Perl script found in input\n");
3275 if (PL_doextract) /* require explicit override ? */
3276 if (!OverrideExtract(PL_origfilename))
3277 Perl_croak(aTHX_ "User aborted script\n");
3279 PL_doextract = FALSE;
3281 /* Pater peccavi, file does not have #! */
3282 PerlIO_rewind(PL_rsfp);
3287 while (PL_doextract) {
3288 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
3289 Perl_croak(aTHX_ "No Perl script found in input\n");
3292 if (*s == '#' && s[1] == '!' && ((s = instr(s,"perl")) || (s = instr(s2,"PERL")))) {
3293 PerlIO_ungetc(PL_rsfp, '\n'); /* to keep line count right */
3294 PL_doextract = FALSE;
3295 while (*s && !(isSPACE (*s) || *s == '#')) s++;
3297 while (*s == ' ' || *s == '\t') s++;
3299 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
3300 if (strnEQ(s2-4,"perl",4))
3302 while ((s = moreswitches(s)))
3305 #ifdef MACOS_TRADITIONAL
3316 PL_uid = PerlProc_getuid();
3317 PL_euid = PerlProc_geteuid();
3318 PL_gid = PerlProc_getgid();
3319 PL_egid = PerlProc_getegid();
3321 PL_uid |= PL_gid << 16;
3322 PL_euid |= PL_egid << 16;
3324 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
3328 S_forbid_setid(pTHX_ char *s)
3330 if (PL_euid != PL_uid)
3331 Perl_croak(aTHX_ "No %s allowed while running setuid", s);
3332 if (PL_egid != PL_gid)
3333 Perl_croak(aTHX_ "No %s allowed while running setgid", s);
3337 Perl_init_debugger(pTHX)
3339 HV *ostash = PL_curstash;
3341 PL_curstash = PL_debstash;
3342 PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
3343 AvREAL_off(PL_dbargs);
3344 PL_DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
3345 PL_DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
3346 PL_DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
3347 sv_upgrade(GvSV(PL_DBsub), SVt_IV); /* IVX accessed if PERLDB_SUB_NN */
3348 PL_DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
3349 sv_setiv(PL_DBsingle, 0);
3350 PL_DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
3351 sv_setiv(PL_DBtrace, 0);
3352 PL_DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
3353 sv_setiv(PL_DBsignal, 0);
3354 PL_curstash = ostash;
3357 #ifndef STRESS_REALLOC
3358 #define REASONABLE(size) (size)
3360 #define REASONABLE(size) (1) /* unreasonable */
3364 Perl_init_stacks(pTHX)
3366 /* start with 128-item stack and 8K cxstack */
3367 PL_curstackinfo = new_stackinfo(REASONABLE(128),
3368 REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
3369 PL_curstackinfo->si_type = PERLSI_MAIN;
3370 PL_curstack = PL_curstackinfo->si_stack;
3371 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
3373 PL_stack_base = AvARRAY(PL_curstack);
3374 PL_stack_sp = PL_stack_base;
3375 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
3377 New(50,PL_tmps_stack,REASONABLE(128),SV*);
3380 PL_tmps_max = REASONABLE(128);
3382 New(54,PL_markstack,REASONABLE(32),I32);
3383 PL_markstack_ptr = PL_markstack;
3384 PL_markstack_max = PL_markstack + REASONABLE(32);
3388 New(54,PL_scopestack,REASONABLE(32),I32);
3389 PL_scopestack_ix = 0;
3390 PL_scopestack_max = REASONABLE(32);
3392 New(54,PL_savestack,REASONABLE(128),ANY);
3393 PL_savestack_ix = 0;
3394 PL_savestack_max = REASONABLE(128);
3396 New(54,PL_retstack,REASONABLE(16),OP*);
3398 PL_retstack_max = REASONABLE(16);
3406 while (PL_curstackinfo->si_next)
3407 PL_curstackinfo = PL_curstackinfo->si_next;
3408 while (PL_curstackinfo) {
3409 PERL_SI *p = PL_curstackinfo->si_prev;
3410 /* curstackinfo->si_stack got nuked by sv_free_arenas() */
3411 Safefree(PL_curstackinfo->si_cxstack);
3412 Safefree(PL_curstackinfo);
3413 PL_curstackinfo = p;
3415 Safefree(PL_tmps_stack);
3416 Safefree(PL_markstack);
3417 Safefree(PL_scopestack);
3418 Safefree(PL_savestack);
3419 Safefree(PL_retstack);
3428 lex_start(PL_linestr);
3430 PL_subname = newSVpvn("main",4);
3434 S_init_predump_symbols(pTHX)
3439 sv_setpvn(get_sv("\"", TRUE), " ", 1);
3440 PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
3441 GvMULTI_on(PL_stdingv);
3442 io = GvIOp(PL_stdingv);
3443 IoTYPE(io) = IoTYPE_RDONLY;
3444 IoIFP(io) = PerlIO_stdin();
3445 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
3447 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
3449 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
3452 IoTYPE(io) = IoTYPE_WRONLY;
3453 IoOFP(io) = IoIFP(io) = PerlIO_stdout();
3455 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
3457 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
3459 PL_stderrgv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
3460 GvMULTI_on(PL_stderrgv);
3461 io = GvIOp(PL_stderrgv);
3462 IoTYPE(io) = IoTYPE_WRONLY;
3463 IoOFP(io) = IoIFP(io) = PerlIO_stderr();
3464 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
3466 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
3468 PL_statname = NEWSV(66,0); /* last filename we did stat on */
3471 Safefree(PL_osname);
3472 PL_osname = savepv(OSNAME);
3476 Perl_init_argv_symbols(pTHX_ register int argc, register char **argv)
3479 argc--,argv++; /* skip name of script */
3480 if (PL_doswitches) {
3481 for (; argc > 0 && **argv == '-'; argc--,argv++) {
3484 if (argv[0][1] == '-' && !argv[0][2]) {
3488 if ((s = strchr(argv[0], '='))) {
3490 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
3493 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
3496 if ((PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV))) {
3497 GvMULTI_on(PL_argvgv);
3498 (void)gv_AVadd(PL_argvgv);
3499 av_clear(GvAVn(PL_argvgv));
3500 for (; argc > 0; argc--,argv++) {
3501 SV *sv = newSVpv(argv[0],0);
3502 av_push(GvAVn(PL_argvgv),sv);
3503 if (PL_widesyscalls)
3504 (void)sv_utf8_decode(sv);
3509 #ifdef HAS_PROCSELFEXE
3510 /* This is a function so that we don't hold on to MAXPATHLEN
3511 bytes of stack longer than necessary
3514 S_procself_val(pTHX_ SV *sv, char *arg0)
3516 char buf[MAXPATHLEN];
3517 int len = readlink(PROCSELFEXE_PATH, buf, sizeof(buf) - 1);
3518 /* FreeBSD's implementation is acknowledged to be imperfect, sometimes
3519 returning the text "unknown" from the readlink rather than the path
3520 to the executable (or returning an error from the readlink). Any valid
3521 path has a '/' in it somewhere, so use that to validate the result.
3522 See http://www.freebsd.org/cgi/query-pr.cgi?pr=35703
3524 if (len > 0 && memchr(buf, '/', len)) {
3525 sv_setpvn(sv,buf,len);
3531 #endif /* HAS_PROCSELFEXE */
3534 S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
3540 PL_toptarget = NEWSV(0,0);
3541 sv_upgrade(PL_toptarget, SVt_PVFM);
3542 sv_setpvn(PL_toptarget, "", 0);
3543 PL_bodytarget = NEWSV(0,0);
3544 sv_upgrade(PL_bodytarget, SVt_PVFM);
3545 sv_setpvn(PL_bodytarget, "", 0);
3546 PL_formtarget = PL_bodytarget;
3550 init_argv_symbols(argc,argv);
3552 if ((tmpgv = gv_fetchpv("0",TRUE, SVt_PV))) {
3553 #ifdef MACOS_TRADITIONAL
3554 /* $0 is not majick on a Mac */
3555 sv_setpv(GvSV(tmpgv),MacPerl_MPWFileName(PL_origfilename));
3557 sv_setpv(GvSV(tmpgv),PL_origfilename);
3558 magicname("0", "0", 1);
3561 if ((tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))) {/* $^X */
3562 #ifdef HAS_PROCSELFEXE
3563 S_procself_val(aTHX_ GvSV(tmpgv), PL_origargv[0]);
3566 sv_setpv(GvSV(tmpgv), os2_execname(aTHX));
3568 sv_setpv(GvSV(tmpgv),PL_origargv[0]);
3572 if ((PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV))) {
3574 GvMULTI_on(PL_envgv);
3575 hv = GvHVn(PL_envgv);
3576 hv_magic(hv, Nullgv, PERL_MAGIC_env);
3577 #ifdef USE_ENVIRON_ARRAY
3578 /* Note that if the supplied env parameter is actually a copy
3579 of the global environ then it may now point to free'd memory
3580 if the environment has been modified since. To avoid this
3581 problem we treat env==NULL as meaning 'use the default'
3586 # ifdef USE_ITHREADS
3587 && PL_curinterp == aTHX
3591 environ[0] = Nullch;
3594 for (; *env; env++) {
3595 if (!(s = strchr(*env,'=')))
3602 sv = newSVpv(s+1, 0);
3603 (void)hv_store(hv, *env, s - *env, sv, 0);
3607 #endif /* USE_ENVIRON_ARRAY */
3610 if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV))) {
3611 SvREADONLY_off(GvSV(tmpgv));
3612 sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
3613 SvREADONLY_on(GvSV(tmpgv));
3616 /* touch @F array to prevent spurious warnings 20020415 MJD */
3618 (void) get_av("main::F", TRUE | GV_ADDMULTI);
3620 /* touch @- and @+ arrays to prevent spurious warnings 20020415 MJD */
3621 (void) get_av("main::-", TRUE | GV_ADDMULTI);
3622 (void) get_av("main::+", TRUE | GV_ADDMULTI);
3626 S_init_perllib(pTHX)
3631 s = PerlEnv_getenv("PERL5LIB");
3633 incpush(s, TRUE, TRUE);
3635 incpush(PerlEnv_getenv("PERLLIB"), FALSE, FALSE);
3637 /* Treat PERL5?LIB as a possible search list logical name -- the
3638 * "natural" VMS idiom for a Unix path string. We allow each
3639 * element to be a set of |-separated directories for compatibility.
3643 if (my_trnlnm("PERL5LIB",buf,0))
3644 do { incpush(buf,TRUE,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
3646 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE,FALSE);
3650 /* Use the ~-expanded versions of APPLLIB (undocumented),
3651 ARCHLIB PRIVLIB SITEARCH SITELIB VENDORARCH and VENDORLIB
3654 incpush(APPLLIB_EXP, TRUE, TRUE);
3658 incpush(ARCHLIB_EXP, FALSE, FALSE);
3660 #ifdef MACOS_TRADITIONAL
3663 SV * privdir = NEWSV(55, 0);
3664 char * macperl = PerlEnv_getenv("MACPERL");
3669 Perl_sv_setpvf(aTHX_ privdir, "%slib:", macperl);
3670 if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
3671 incpush(SvPVX(privdir), TRUE, FALSE);
3672 Perl_sv_setpvf(aTHX_ privdir, "%ssite_perl:", macperl);
3673 if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
3674 incpush(SvPVX(privdir), TRUE, FALSE);
3676 SvREFCNT_dec(privdir);
3679 incpush(":", FALSE, FALSE);
3682 # define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
3685 incpush(PRIVLIB_EXP, TRUE, FALSE);
3687 incpush(PRIVLIB_EXP, FALSE, FALSE);
3691 /* sitearch is always relative to sitelib on Windows for
3692 * DLL-based path intuition to work correctly */
3693 # if !defined(WIN32)
3694 incpush(SITEARCH_EXP, FALSE, FALSE);
3700 incpush(SITELIB_EXP, TRUE, FALSE); /* this picks up sitearch as well */
3702 incpush(SITELIB_EXP, FALSE, FALSE);
3706 #ifdef SITELIB_STEM /* Search for version-specific dirs below here */
3707 incpush(SITELIB_STEM, FALSE, TRUE);
3710 #ifdef PERL_VENDORARCH_EXP
3711 /* vendorarch is always relative to vendorlib on Windows for
3712 * DLL-based path intuition to work correctly */
3713 # if !defined(WIN32)
3714 incpush(PERL_VENDORARCH_EXP, FALSE, FALSE);
3718 #ifdef PERL_VENDORLIB_EXP
3720 incpush(PERL_VENDORLIB_EXP, TRUE, FALSE); /* this picks up vendorarch as well */
3722 incpush(PERL_VENDORLIB_EXP, FALSE, FALSE);
3726 #ifdef PERL_VENDORLIB_STEM /* Search for version-specific dirs below here */
3727 incpush(PERL_VENDORLIB_STEM, FALSE, TRUE);
3730 #ifdef PERL_OTHERLIBDIRS
3731 incpush(PERL_OTHERLIBDIRS, TRUE, TRUE);
3735 incpush(".", FALSE, FALSE);
3736 #endif /* MACOS_TRADITIONAL */
3739 #if defined(DOSISH) || defined(EPOC)
3740 # define PERLLIB_SEP ';'
3743 # define PERLLIB_SEP '|'
3745 # if defined(MACOS_TRADITIONAL)
3746 # define PERLLIB_SEP ','
3748 # define PERLLIB_SEP ':'
3752 #ifndef PERLLIB_MANGLE
3753 # define PERLLIB_MANGLE(s,n) (s)
3757 S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers)
3759 SV *subdir = Nullsv;
3764 if (addsubdirs || addoldvers) {
3765 subdir = sv_newmortal();
3768 /* Break at all separators */
3770 SV *libdir = NEWSV(55,0);
3773 /* skip any consecutive separators */
3774 while ( *p == PERLLIB_SEP ) {
3775 /* Uncomment the next line for PATH semantics */
3776 /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */
3780 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
3781 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
3786 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
3787 p = Nullch; /* break out */
3789 #ifdef MACOS_TRADITIONAL
3790 if (!strchr(SvPVX(libdir), ':'))
3791 sv_insert(libdir, 0, 0, ":", 1);
3792 if (SvPVX(libdir)[SvCUR(libdir)-1] != ':')
3793 sv_catpv(libdir, ":");
3797 * BEFORE pushing libdir onto @INC we may first push version- and
3798 * archname-specific sub-directories.
3800 if (addsubdirs || addoldvers) {
3801 #ifdef PERL_INC_VERSION_LIST
3802 /* Configure terminates PERL_INC_VERSION_LIST with a NULL */
3803 const char *incverlist[] = { PERL_INC_VERSION_LIST };
3804 const char **incver;
3811 if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) {
3813 while (unix[len-1] == '/') len--; /* Cosmetic */
3814 sv_usepvn(libdir,unix,len);
3817 PerlIO_printf(Perl_error_log,
3818 "Failed to unixify @INC element \"%s\"\n",
3822 #ifdef MACOS_TRADITIONAL
3823 #define PERL_AV_SUFFIX_FMT ""
3824 #define PERL_ARCH_FMT "%s:"
3825 #define PERL_ARCH_FMT_PATH PERL_FS_VER_FMT PERL_AV_SUFFIX_FMT
3827 #define PERL_AV_SUFFIX_FMT "/"
3828 #define PERL_ARCH_FMT "/%s"
3829 #define PERL_ARCH_FMT_PATH PERL_AV_SUFFIX_FMT PERL_FS_VER_FMT
3831 /* .../version/archname if -d .../version/archname */
3832 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH PERL_ARCH_FMT,
3834 (int)PERL_REVISION, (int)PERL_VERSION,
3835 (int)PERL_SUBVERSION, ARCHNAME);
3836 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3837 S_ISDIR(tmpstatbuf.st_mode))
3838 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3840 /* .../version if -d .../version */
3841 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH, libdir,
3842 (int)PERL_REVISION, (int)PERL_VERSION,
3843 (int)PERL_SUBVERSION);
3844 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3845 S_ISDIR(tmpstatbuf.st_mode))
3846 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3848 /* .../archname if -d .../archname */
3849 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, ARCHNAME);
3850 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3851 S_ISDIR(tmpstatbuf.st_mode))
3852 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3855 #ifdef PERL_INC_VERSION_LIST
3857 for (incver = incverlist; *incver; incver++) {
3858 /* .../xxx if -d .../xxx */
3859 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, *incver);
3860 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3861 S_ISDIR(tmpstatbuf.st_mode))
3862 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3868 /* finally push this lib directory on the end of @INC */
3869 av_push(GvAVn(PL_incgv), libdir);
3873 #ifdef USE_5005THREADS
3874 STATIC struct perl_thread *
3875 S_init_main_thread(pTHX)
3877 #if !defined(PERL_IMPLICIT_CONTEXT)
3878 struct perl_thread *thr;
3882 Newz(53, thr, 1, struct perl_thread);
3883 PL_curcop = &PL_compiling;
3884 thr->interp = PERL_GET_INTERP;
3885 thr->cvcache = newHV();
3886 thr->threadsv = newAV();
3887 /* thr->threadsvp is set when find_threadsv is called */
3888 thr->specific = newAV();
3889 thr->flags = THRf_R_JOINABLE;
3890 MUTEX_INIT(&thr->mutex);
3891 /* Handcraft thrsv similarly to mess_sv */
3892 New(53, PL_thrsv, 1, SV);
3893 Newz(53, xpv, 1, XPV);
3894 SvFLAGS(PL_thrsv) = SVt_PV;
3895 SvANY(PL_thrsv) = (void*)xpv;
3896 SvREFCNT(PL_thrsv) = 1 << 30; /* practically infinite */
3897 SvPVX(PL_thrsv) = (char*)thr;
3898 SvCUR_set(PL_thrsv, sizeof(thr));
3899 SvLEN_set(PL_thrsv, sizeof(thr));
3900 *SvEND(PL_thrsv) = '\0'; /* in the trailing_nul field */
3901 thr->oursv = PL_thrsv;
3902 PL_chopset = " \n-";
3905 MUTEX_LOCK(&PL_threads_mutex);
3911 MUTEX_UNLOCK(&PL_threads_mutex);
3913 #ifdef HAVE_THREAD_INTERN
3914 Perl_init_thread_intern(thr);
3917 #ifdef SET_THREAD_SELF
3918 SET_THREAD_SELF(thr);
3920 thr->self = pthread_self();
3921 #endif /* SET_THREAD_SELF */
3925 * These must come after the thread self setting
3926 * because sv_setpvn does SvTAINT and the taint
3927 * fields thread selfness being set.
3929 PL_toptarget = NEWSV(0,0);
3930 sv_upgrade(PL_toptarget, SVt_PVFM);
3931 sv_setpvn(PL_toptarget, "", 0);
3932 PL_bodytarget = NEWSV(0,0);
3933 sv_upgrade(PL_bodytarget, SVt_PVFM);
3934 sv_setpvn(PL_bodytarget, "", 0);
3935 PL_formtarget = PL_bodytarget;
3936 thr->errsv = newSVpvn("", 0);
3937 (void) find_threadsv("@"); /* Ensure $@ is initialised early */
3940 PL_peepp = MEMBER_TO_FPTR(Perl_peep);
3941 PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
3942 PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
3943 PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
3944 PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
3945 PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
3947 PL_reginterp_cnt = 0;
3951 #endif /* USE_5005THREADS */
3954 Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
3957 line_t oldline = CopLINE(PL_curcop);
3963 while (AvFILL(paramList) >= 0) {
3964 cv = (CV*)av_shift(paramList);
3965 if (PL_savebegin && (paramList == PL_beginav)) {
3966 /* save PL_beginav for compiler */
3967 if (! PL_beginav_save)
3968 PL_beginav_save = newAV();
3969 av_push(PL_beginav_save, (SV*)cv);
3973 #ifdef PERL_FLEXIBLE_EXCEPTIONS
3974 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_list_body), cv);
3980 #ifndef PERL_FLEXIBLE_EXCEPTIONS
3984 (void)SvPV(atsv, len);
3987 PL_curcop = &PL_compiling;
3988 CopLINE_set(PL_curcop, oldline);
3989 if (paramList == PL_beginav)
3990 sv_catpv(atsv, "BEGIN failed--compilation aborted");
3992 Perl_sv_catpvf(aTHX_ atsv,
3993 "%s failed--call queue aborted",
3994 paramList == PL_checkav ? "CHECK"
3995 : paramList == PL_initav ? "INIT"
3997 while (PL_scopestack_ix > oldscope)
4000 Perl_croak(aTHX_ "%s", SvPVx(atsv, n_a));
4007 /* my_exit() was called */
4008 while (PL_scopestack_ix > oldscope)
4011 PL_curstash = PL_defstash;
4012 PL_curcop = &PL_compiling;
4013 CopLINE_set(PL_curcop, oldline);
4015 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) {
4016 if (paramList == PL_beginav)
4017 Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
4019 Perl_croak(aTHX_ "%s failed--call queue aborted",
4020 paramList == PL_checkav ? "CHECK"
4021 : paramList == PL_initav ? "INIT"
4028 PL_curcop = &PL_compiling;
4029 CopLINE_set(PL_curcop, oldline);
4032 PerlIO_printf(Perl_error_log, "panic: restartop\n");
4040 #ifdef PERL_FLEXIBLE_EXCEPTIONS
4042 S_vcall_list_body(pTHX_ va_list args)
4044 CV *cv = va_arg(args, CV*);
4045 return call_list_body(cv);
4050 S_call_list_body(pTHX_ CV *cv)
4052 PUSHMARK(PL_stack_sp);
4053 call_sv((SV*)cv, G_EVAL|G_DISCARD);
4058 Perl_my_exit(pTHX_ U32 status)
4060 DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
4061 thr, (unsigned long) status));
4070 STATUS_NATIVE_SET(status);
4077 Perl_my_failure_exit(pTHX)
4080 if (vaxc$errno & 1) {
4081 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
4082 STATUS_NATIVE_SET(44);
4085 if (!vaxc$errno && errno) /* unlikely */
4086 STATUS_NATIVE_SET(44);
4088 STATUS_NATIVE_SET(vaxc$errno);
4093 STATUS_POSIX_SET(errno);
4095 exitstatus = STATUS_POSIX >> 8;
4096 if (exitstatus & 255)
4097 STATUS_POSIX_SET(exitstatus);
4099 STATUS_POSIX_SET(255);
4106 S_my_exit_jump(pTHX)
4108 register PERL_CONTEXT *cx;
4113 SvREFCNT_dec(PL_e_script);
4114 PL_e_script = Nullsv;
4117 POPSTACK_TO(PL_mainstack);
4118 if (cxstack_ix >= 0) {
4121 POPBLOCK(cx,PL_curpm);
4129 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen)
4132 p = SvPVX(PL_e_script);
4133 nl = strchr(p, '\n');
4134 nl = (nl) ? nl+1 : SvEND(PL_e_script);
4136 filter_del(read_e_script);
4139 sv_catpvn(buf_sv, p, nl-p);
4140 sv_chop(PL_e_script, nl);