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) {
504 for (i = 0; environ[i]; i++)
505 safesysfree(environ[i]);
507 /* Must use safesysfree() when working with environ. */
508 safesysfree(environ);
510 environ = PL_origenviron;
515 /* the syntax tree is shared between clones
516 * so op_free(PL_main_root) only ReREFCNT_dec's
517 * REGEXPs in the parent interpreter
518 * we need to manually ReREFCNT_dec for the clones
521 I32 i = AvFILLp(PL_regex_padav) + 1;
522 SV **ary = AvARRAY(PL_regex_padav);
526 REGEXP *re = INT2PTR(REGEXP *,SvIVX(resv));
528 if (SvFLAGS(resv) & SVf_BREAK) {
529 /* this is PL_reg_curpm, already freed
530 * flag is set in regexec.c:S_regtry
532 SvFLAGS(resv) &= ~SVf_BREAK;
534 else if(SvREPADTMP(resv)) {
535 SvREPADTMP_off(resv);
542 SvREFCNT_dec(PL_regex_padav);
543 PL_regex_padav = Nullav;
547 /* loosen bonds of global variables */
550 (void)PerlIO_close(PL_rsfp);
554 /* Filters for program text */
555 SvREFCNT_dec(PL_rsfp_filters);
556 PL_rsfp_filters = Nullav;
559 PL_preprocess = FALSE;
565 PL_doswitches = FALSE;
566 PL_dowarn = G_WARN_OFF;
567 PL_doextract = FALSE;
568 PL_sawampersand = FALSE; /* must save all match strings */
571 Safefree(PL_inplace);
573 SvREFCNT_dec(PL_patchlevel);
576 SvREFCNT_dec(PL_e_script);
577 PL_e_script = Nullsv;
580 while (--PL_origargc >= 0) {
581 Safefree(PL_origargv[PL_origargc]);
583 Safefree(PL_origargv);
585 /* magical thingies */
587 SvREFCNT_dec(PL_ofs_sv); /* $, */
590 SvREFCNT_dec(PL_ors_sv); /* $\ */
593 SvREFCNT_dec(PL_rs); /* $/ */
596 PL_multiline = 0; /* $* */
597 Safefree(PL_osname); /* $^O */
600 SvREFCNT_dec(PL_statname);
601 PL_statname = Nullsv;
604 /* defgv, aka *_ should be taken care of elsewhere */
606 /* clean up after study() */
607 SvREFCNT_dec(PL_lastscream);
608 PL_lastscream = Nullsv;
609 Safefree(PL_screamfirst);
611 Safefree(PL_screamnext);
615 Safefree(PL_efloatbuf);
616 PL_efloatbuf = Nullch;
619 /* startup and shutdown function lists */
620 SvREFCNT_dec(PL_beginav);
621 SvREFCNT_dec(PL_beginav_save);
622 SvREFCNT_dec(PL_endav);
623 SvREFCNT_dec(PL_checkav);
624 SvREFCNT_dec(PL_initav);
626 PL_beginav_save = Nullav;
631 /* shortcuts just get cleared */
637 PL_argvoutgv = Nullgv;
639 PL_stderrgv = Nullgv;
640 PL_last_in_gv = Nullgv;
642 PL_debstash = Nullhv;
644 /* reset so print() ends up where we expect */
647 SvREFCNT_dec(PL_argvout_stack);
648 PL_argvout_stack = Nullav;
650 SvREFCNT_dec(PL_modglobal);
651 PL_modglobal = Nullhv;
652 SvREFCNT_dec(PL_preambleav);
653 PL_preambleav = Nullav;
654 SvREFCNT_dec(PL_subname);
656 SvREFCNT_dec(PL_linestr);
658 SvREFCNT_dec(PL_pidstatus);
659 PL_pidstatus = Nullhv;
660 SvREFCNT_dec(PL_toptarget);
661 PL_toptarget = Nullsv;
662 SvREFCNT_dec(PL_bodytarget);
663 PL_bodytarget = Nullsv;
664 PL_formtarget = Nullsv;
666 /* free locale stuff */
667 #ifdef USE_LOCALE_COLLATE
668 Safefree(PL_collation_name);
669 PL_collation_name = Nullch;
672 #ifdef USE_LOCALE_NUMERIC
673 Safefree(PL_numeric_name);
674 PL_numeric_name = Nullch;
675 SvREFCNT_dec(PL_numeric_radix_sv);
678 /* clear utf8 character classes */
679 SvREFCNT_dec(PL_utf8_alnum);
680 SvREFCNT_dec(PL_utf8_alnumc);
681 SvREFCNT_dec(PL_utf8_ascii);
682 SvREFCNT_dec(PL_utf8_alpha);
683 SvREFCNT_dec(PL_utf8_space);
684 SvREFCNT_dec(PL_utf8_cntrl);
685 SvREFCNT_dec(PL_utf8_graph);
686 SvREFCNT_dec(PL_utf8_digit);
687 SvREFCNT_dec(PL_utf8_upper);
688 SvREFCNT_dec(PL_utf8_lower);
689 SvREFCNT_dec(PL_utf8_print);
690 SvREFCNT_dec(PL_utf8_punct);
691 SvREFCNT_dec(PL_utf8_xdigit);
692 SvREFCNT_dec(PL_utf8_mark);
693 SvREFCNT_dec(PL_utf8_toupper);
694 SvREFCNT_dec(PL_utf8_totitle);
695 SvREFCNT_dec(PL_utf8_tolower);
696 SvREFCNT_dec(PL_utf8_tofold);
697 SvREFCNT_dec(PL_utf8_idstart);
698 SvREFCNT_dec(PL_utf8_idcont);
699 PL_utf8_alnum = Nullsv;
700 PL_utf8_alnumc = Nullsv;
701 PL_utf8_ascii = Nullsv;
702 PL_utf8_alpha = Nullsv;
703 PL_utf8_space = Nullsv;
704 PL_utf8_cntrl = Nullsv;
705 PL_utf8_graph = Nullsv;
706 PL_utf8_digit = Nullsv;
707 PL_utf8_upper = Nullsv;
708 PL_utf8_lower = Nullsv;
709 PL_utf8_print = Nullsv;
710 PL_utf8_punct = Nullsv;
711 PL_utf8_xdigit = Nullsv;
712 PL_utf8_mark = Nullsv;
713 PL_utf8_toupper = Nullsv;
714 PL_utf8_totitle = Nullsv;
715 PL_utf8_tolower = Nullsv;
716 PL_utf8_tofold = Nullsv;
717 PL_utf8_idstart = Nullsv;
718 PL_utf8_idcont = Nullsv;
720 if (!specialWARN(PL_compiling.cop_warnings))
721 SvREFCNT_dec(PL_compiling.cop_warnings);
722 PL_compiling.cop_warnings = Nullsv;
723 if (!specialCopIO(PL_compiling.cop_io))
724 SvREFCNT_dec(PL_compiling.cop_io);
725 PL_compiling.cop_io = Nullsv;
726 CopFILE_free(&PL_compiling);
727 CopSTASH_free(&PL_compiling);
729 /* Prepare to destruct main symbol table. */
734 SvREFCNT_dec(PL_curstname);
735 PL_curstname = Nullsv;
737 /* clear queued errors */
738 SvREFCNT_dec(PL_errors);
742 if (destruct_level >= 2 && ckWARN_d(WARN_INTERNAL)) {
743 if (PL_scopestack_ix != 0)
744 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
745 "Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
746 (long)PL_scopestack_ix);
747 if (PL_savestack_ix != 0)
748 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
749 "Unbalanced saves: %ld more saves than restores\n",
750 (long)PL_savestack_ix);
751 if (PL_tmps_floor != -1)
752 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced tmps: %ld more allocs than frees\n",
753 (long)PL_tmps_floor + 1);
754 if (cxstack_ix != -1)
755 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced context: %ld more PUSHes than POPs\n",
756 (long)cxstack_ix + 1);
759 /* Now absolutely destruct everything, somehow or other, loops or no. */
760 SvFLAGS(PL_fdpid) |= SVTYPEMASK; /* don't clean out pid table now */
761 SvFLAGS(PL_strtab) |= SVTYPEMASK; /* don't clean out strtab now */
763 /* the 2 is for PL_fdpid and PL_strtab */
764 while (PL_sv_count > 2 && sv_clean_all())
767 SvFLAGS(PL_fdpid) &= ~SVTYPEMASK;
768 SvFLAGS(PL_fdpid) |= SVt_PVAV;
769 SvFLAGS(PL_strtab) &= ~SVTYPEMASK;
770 SvFLAGS(PL_strtab) |= SVt_PVHV;
772 AvREAL_off(PL_fdpid); /* no surviving entries */
773 SvREFCNT_dec(PL_fdpid); /* needed in io_close() */
776 #ifdef HAVE_INTERP_INTERN
780 /* Destruct the global string table. */
782 /* Yell and reset the HeVAL() slots that are still holding refcounts,
783 * so that sv_free() won't fail on them.
791 max = HvMAX(PL_strtab);
792 array = HvARRAY(PL_strtab);
795 if (hent && ckWARN_d(WARN_INTERNAL)) {
796 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
797 "Unbalanced string table refcount: (%d) for \"%s\"",
798 HeVAL(hent) - Nullsv, HeKEY(hent));
799 HeVAL(hent) = Nullsv;
809 SvREFCNT_dec(PL_strtab);
812 /* free the pointer table used for cloning */
813 ptr_table_free(PL_ptr_table);
816 /* free special SVs */
818 SvREFCNT(&PL_sv_yes) = 0;
819 sv_clear(&PL_sv_yes);
820 SvANY(&PL_sv_yes) = NULL;
821 SvFLAGS(&PL_sv_yes) = 0;
823 SvREFCNT(&PL_sv_no) = 0;
825 SvANY(&PL_sv_no) = NULL;
826 SvFLAGS(&PL_sv_no) = 0;
828 SvREFCNT(&PL_sv_undef) = 0;
829 SvREADONLY_off(&PL_sv_undef);
833 for (i=0; i<=2; i++) {
834 SvREFCNT(PERL_DEBUG_PAD(i)) = 0;
835 sv_clear(PERL_DEBUG_PAD(i));
836 SvANY(PERL_DEBUG_PAD(i)) = NULL;
837 SvFLAGS(PERL_DEBUG_PAD(i)) = 0;
841 if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL))
842 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Scalars leaked: %ld\n", (long)PL_sv_count);
844 #if defined(PERLIO_LAYERS)
845 /* No more IO - including error messages ! */
846 PerlIO_cleanup(aTHX);
849 Safefree(PL_origfilename);
850 Safefree(PL_reg_start_tmp);
852 Safefree(PL_reg_curpm);
853 Safefree(PL_reg_poscache);
854 Safefree(HeKEY_hek(&PL_hv_fetch_ent_mh));
855 Safefree(PL_op_mask);
856 Safefree(PL_psig_ptr);
857 Safefree(PL_psig_name);
858 Safefree(PL_bitcount);
859 Safefree(PL_psig_pend);
861 PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */
863 DEBUG_P(debprofdump());
864 #ifdef USE_5005THREADS
865 MUTEX_DESTROY(&PL_strtab_mutex);
866 MUTEX_DESTROY(&PL_sv_mutex);
867 MUTEX_DESTROY(&PL_eval_mutex);
868 MUTEX_DESTROY(&PL_cred_mutex);
869 MUTEX_DESTROY(&PL_fdpid_mutex);
870 COND_DESTROY(&PL_eval_cond);
871 #ifdef EMULATE_ATOMIC_REFCOUNTS
872 MUTEX_DESTROY(&PL_svref_mutex);
873 #endif /* EMULATE_ATOMIC_REFCOUNTS */
875 /* As the penultimate thing, free the non-arena SV for thrsv */
876 Safefree(SvPVX(PL_thrsv));
877 Safefree(SvANY(PL_thrsv));
880 #endif /* USE_5005THREADS */
882 #ifdef USE_REENTRANT_API
883 Perl_reentrant_free(aTHX);
888 /* As the absolutely last thing, free the non-arena SV for mess() */
891 /* it could have accumulated taint magic */
892 if (SvTYPE(PL_mess_sv) >= SVt_PVMG) {
895 for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) {
896 moremagic = mg->mg_moremagic;
897 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global
899 Safefree(mg->mg_ptr);
903 /* we know that type >= SVt_PV */
904 (void)SvOOK_off(PL_mess_sv);
905 Safefree(SvPVX(PL_mess_sv));
906 Safefree(SvANY(PL_mess_sv));
907 Safefree(PL_mess_sv);
910 return STATUS_NATIVE_EXPORT;
914 =for apidoc perl_free
916 Releases a Perl interpreter. See L<perlembed>.
924 #if defined(WIN32) || defined(NETWARE)
925 # if defined(PERL_IMPLICIT_SYS)
927 void *host = nw_internal_host;
929 void *host = w32_internal_host;
933 nw_delete_internal_host(host);
935 win32_delete_internal_host(host);
946 Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
948 Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry);
949 PL_exitlist[PL_exitlistlen].fn = fn;
950 PL_exitlist[PL_exitlistlen].ptr = ptr;
955 =for apidoc perl_parse
957 Tells a Perl interpreter to parse a Perl script. See L<perlembed>.
963 perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
968 #ifdef USE_5005THREADS
972 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
975 Perl_croak(aTHX_ "suidperl is no longer needed since the kernel can now execute\n\
976 setuid perl scripts securely.\n");
982 /* we copy rather than point to argv
983 * since perl_clone will copy and perl_destruct
984 * has no way of knowing if we've made a copy or
988 New(0, PL_origargv, i+1, char*);
989 PL_origargv[i] = '\0';
991 PL_origargv[i] = savepv(argv[i]);
999 /* Come here if running an undumped a.out. */
1001 PL_origfilename = savepv(argv[0]);
1002 PL_do_undump = FALSE;
1003 cxstack_ix = -1; /* start label stack again */
1005 init_postdump_symbols(argc,argv,env);
1010 PL_curpad = AvARRAY(PL_comppad);
1011 op_free(PL_main_root);
1012 PL_main_root = Nullop;
1014 PL_main_start = Nullop;
1015 SvREFCNT_dec(PL_main_cv);
1016 PL_main_cv = Nullcv;
1019 oldscope = PL_scopestack_ix;
1020 PL_dowarn = G_WARN_OFF;
1022 #ifdef PERL_FLEXIBLE_EXCEPTIONS
1023 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vparse_body), env, xsinit);
1029 #ifndef PERL_FLEXIBLE_EXCEPTIONS
1030 parse_body(env,xsinit);
1033 call_list(oldscope, PL_checkav);
1040 /* my_exit() was called */
1041 while (PL_scopestack_ix > oldscope)
1044 PL_curstash = PL_defstash;
1046 call_list(oldscope, PL_checkav);
1047 ret = STATUS_NATIVE_EXPORT;
1050 PerlIO_printf(Perl_error_log, "panic: top_env\n");
1058 #ifdef PERL_FLEXIBLE_EXCEPTIONS
1060 S_vparse_body(pTHX_ va_list args)
1062 char **env = va_arg(args, char**);
1063 XSINIT_t xsinit = va_arg(args, XSINIT_t);
1065 return parse_body(env, xsinit);
1070 S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
1072 int argc = PL_origargc;
1073 char **argv = PL_origargv;
1074 char *scriptname = NULL;
1076 VOL bool dosearch = FALSE;
1077 char *validarg = "";
1081 char *cddir = Nullch;
1083 sv_setpvn(PL_linestr,"",0);
1084 sv = newSVpvn("",0); /* first used for -I flags */
1088 for (argc--,argv++; argc > 0; argc--,argv++) {
1089 if (argv[0][0] != '-' || !argv[0][1])
1093 validarg = " PHOOEY ";
1102 win32_argv2utf8(argc-1, argv+1);
1105 #ifndef PERL_STRICT_CR
1129 if ((s = moreswitches(s)))
1134 if( !PL_tainting ) {
1135 PL_taint_warn = TRUE;
1142 PL_taint_warn = FALSE;
1147 #ifdef MACOS_TRADITIONAL
1148 /* ignore -e for Dev:Pseudo argument */
1149 if (argv[1] && !strcmp(argv[1], "Dev:Pseudo"))
1152 if (PL_euid != PL_uid || PL_egid != PL_gid)
1153 Perl_croak(aTHX_ "No -e allowed in setuid scripts");
1155 PL_e_script = newSVpvn("",0);
1156 filter_add(read_e_script, NULL);
1159 sv_catpv(PL_e_script, s);
1161 sv_catpv(PL_e_script, argv[1]);
1165 Perl_croak(aTHX_ "No code specified for -e");
1166 sv_catpv(PL_e_script, "\n");
1169 case 'I': /* -I handled both here and in moreswitches() */
1171 if (!*++s && (s=argv[1]) != Nullch) {
1176 STRLEN len = strlen(s);
1177 p = savepvn(s, len);
1178 incpush(p, TRUE, TRUE);
1179 sv_catpvn(sv, "-I", 2);
1180 sv_catpvn(sv, p, len);
1181 sv_catpvn(sv, " ", 1);
1185 Perl_croak(aTHX_ "No directory specified for -I");
1189 PL_preprocess = TRUE;
1199 PL_preambleav = newAV();
1200 av_push(PL_preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
1202 PL_Sv = newSVpv("print myconfig();",0);
1204 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
1206 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
1208 sv_catpv(PL_Sv,"\" Compile-time options:");
1210 sv_catpv(PL_Sv," DEBUGGING");
1212 # ifdef MULTIPLICITY
1213 sv_catpv(PL_Sv," MULTIPLICITY");
1215 # ifdef USE_5005THREADS
1216 sv_catpv(PL_Sv," USE_5005THREADS");
1218 # ifdef USE_ITHREADS
1219 sv_catpv(PL_Sv," USE_ITHREADS");
1221 # ifdef USE_64_BIT_INT
1222 sv_catpv(PL_Sv," USE_64_BIT_INT");
1224 # ifdef USE_64_BIT_ALL
1225 sv_catpv(PL_Sv," USE_64_BIT_ALL");
1227 # ifdef USE_LONG_DOUBLE
1228 sv_catpv(PL_Sv," USE_LONG_DOUBLE");
1230 # ifdef USE_LARGE_FILES
1231 sv_catpv(PL_Sv," USE_LARGE_FILES");
1234 sv_catpv(PL_Sv," USE_SOCKS");
1236 # ifdef PERL_IMPLICIT_CONTEXT
1237 sv_catpv(PL_Sv," PERL_IMPLICIT_CONTEXT");
1239 # ifdef PERL_IMPLICIT_SYS
1240 sv_catpv(PL_Sv," PERL_IMPLICIT_SYS");
1242 sv_catpv(PL_Sv,"\\n\",");
1244 #if defined(LOCAL_PATCH_COUNT)
1245 if (LOCAL_PATCH_COUNT > 0) {
1247 sv_catpv(PL_Sv,"\" Locally applied patches:\\n\",");
1248 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
1249 if (PL_localpatches[i])
1250 Perl_sv_catpvf(aTHX_ PL_Sv,"q\" \t%s\n\",",PL_localpatches[i]);
1254 Perl_sv_catpvf(aTHX_ PL_Sv,"\" Built under %s\\n\"",OSNAME);
1257 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
1259 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled on %s\\n\"",__DATE__);
1262 sv_catpv(PL_Sv, "; \
1264 @env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; ");
1267 push @env, \"CYGWIN=\\\"$ENV{CYGWIN}\\\"\";");
1270 print \" \\%ENV:\\n @env\\n\" if @env; \
1271 print \" \\@INC:\\n @INC\\n\";");
1274 PL_Sv = newSVpv("config_vars(qw(",0);
1275 sv_catpv(PL_Sv, ++s);
1276 sv_catpv(PL_Sv, "))");
1279 av_push(PL_preambleav, PL_Sv);
1280 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
1283 PL_doextract = TRUE;
1291 if (!*++s || isSPACE(*s)) {
1295 /* catch use of gnu style long options */
1296 if (strEQ(s, "version")) {
1300 if (strEQ(s, "help")) {
1307 Perl_croak(aTHX_ "Unrecognized switch: -%s (-h will show valid options)",s);
1313 #ifndef SECURE_INTERNAL_GETENV
1316 (s = PerlEnv_getenv("PERL5OPT")))
1321 if (*s == '-' && *(s+1) == 'T') {
1323 PL_taint_warn = FALSE;
1326 char *popt_copy = Nullch;
1339 if (!strchr("DIMUdmtw", *s))
1340 Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
1344 popt_copy = SvPVX(sv_2mortal(newSVpv(popt,0)));
1345 s = popt_copy + (s - popt);
1346 d = popt_copy + (d - popt);
1353 if( !PL_tainting ) {
1354 PL_taint_warn = TRUE;
1364 if (PL_taint_warn && PL_dowarn != G_WARN_ALL_OFF) {
1365 PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
1369 scriptname = argv[0];
1372 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
1374 else if (scriptname == Nullch) {
1376 if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
1384 open_script(scriptname,dosearch,sv,&fdscript);
1386 validate_suid(validarg, scriptname,fdscript);
1389 #if defined(SIGCHLD) || defined(SIGCLD)
1392 # define SIGCHLD SIGCLD
1394 Sighandler_t sigstate = rsignal_state(SIGCHLD);
1395 if (sigstate == SIG_IGN) {
1396 if (ckWARN(WARN_SIGNAL))
1397 Perl_warner(aTHX_ packWARN(WARN_SIGNAL),
1398 "Can't ignore signal CHLD, forcing to default");
1399 (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL);
1405 #ifdef MACOS_TRADITIONAL
1406 if (PL_doextract || gMacPerl_AlwaysExtract) {
1411 if (cddir && PerlDir_chdir(cddir) < 0)
1412 Perl_croak(aTHX_ "Can't chdir to %s",cddir);
1416 PL_main_cv = PL_compcv = (CV*)NEWSV(1104,0);
1417 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
1418 CvUNIQUE_on(PL_compcv);
1420 PL_comppad = newAV();
1421 av_push(PL_comppad, Nullsv);
1422 PL_curpad = AvARRAY(PL_comppad);
1423 PL_comppad_name = newAV();
1424 PL_comppad_name_fill = 0;
1425 PL_min_intro_pending = 0;
1427 #ifdef USE_5005THREADS
1428 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
1429 PL_curpad[0] = (SV*)newAV();
1430 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
1431 CvOWNER(PL_compcv) = 0;
1432 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
1433 MUTEX_INIT(CvMUTEXP(PL_compcv));
1434 #endif /* USE_5005THREADS */
1436 comppadlist = newAV();
1437 AvREAL_off(comppadlist);
1438 av_store(comppadlist, 0, (SV*)PL_comppad_name);
1439 av_store(comppadlist, 1, (SV*)PL_comppad);
1440 CvPADLIST(PL_compcv) = comppadlist;
1443 boot_core_UNIVERSAL();
1445 boot_core_xsutils();
1449 (*xsinit)(aTHX); /* in case linked C routines want magical variables */
1451 #if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__) || defined(EPOC)
1457 # ifdef HAS_SOCKS5_INIT
1458 socks5_init(argv[0]);
1464 init_predump_symbols();
1465 /* init_postdump_symbols not currently designed to be called */
1466 /* more than once (ENV isn't cleared first, for example) */
1467 /* But running with -u leaves %ENV & @ARGV undefined! XXX */
1469 init_postdump_symbols(argc,argv,env);
1471 if (PL_wantutf8) { /* Requires init_predump_symbols(). */
1475 if (PL_stdingv && (io = GvIO(PL_stdingv)) && (fp = IoIFP(io)))
1476 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
1477 if (PL_defoutgv && (io = GvIO(PL_defoutgv)) && (fp = IoOFP(io)))
1478 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
1479 if (PL_stderrgv && (io = GvIO(PL_stderrgv)) && (fp = IoOFP(io)))
1480 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
1481 if ((sv = GvSV(gv_fetchpv("\017PEN", TRUE, SVt_PV)))) {
1482 sv_setpvn(sv, ":utf8\0:utf8", 11);
1489 /* now parse the script */
1491 SETERRNO(0,SS$_NORMAL);
1493 #ifdef MACOS_TRADITIONAL
1494 if (gMacPerl_SyntaxError = (yyparse() || PL_error_count)) {
1496 Perl_croak(aTHX_ "%s had compilation errors.\n", MacPerl_MPWFileName(PL_origfilename));
1498 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
1499 MacPerl_MPWFileName(PL_origfilename));
1503 if (yyparse() || PL_error_count) {
1505 Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
1507 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
1512 CopLINE_set(PL_curcop, 0);
1513 PL_curstash = PL_defstash;
1514 PL_preprocess = FALSE;
1516 SvREFCNT_dec(PL_e_script);
1517 PL_e_script = Nullsv;
1521 Not sure that this is still the right place to do this now that we
1522 no longer use PL_nrs. HVDS 2001/09/09
1524 sv_setsv(get_sv("/", TRUE), PL_rs);
1530 SAVECOPFILE(PL_curcop);
1531 SAVECOPLINE(PL_curcop);
1532 gv_check(PL_defstash);
1539 if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
1540 dump_mstats("after compilation:");
1549 =for apidoc perl_run
1551 Tells a Perl interpreter to run. See L<perlembed>.
1562 #ifdef USE_5005THREADS
1566 oldscope = PL_scopestack_ix;
1571 #ifdef PERL_FLEXIBLE_EXCEPTIONS
1573 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vrun_body), oldscope);
1579 cxstack_ix = -1; /* start context stack again */
1581 case 0: /* normal completion */
1582 #ifndef PERL_FLEXIBLE_EXCEPTIONS
1587 case 2: /* my_exit() */
1588 while (PL_scopestack_ix > oldscope)
1591 PL_curstash = PL_defstash;
1592 if (!(PL_exit_flags & PERL_EXIT_DESTRUCT_END) &&
1593 PL_endav && !PL_minus_c)
1594 call_list(oldscope, PL_endav);
1596 if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
1597 dump_mstats("after execution: ");
1599 ret = STATUS_NATIVE_EXPORT;
1603 POPSTACK_TO(PL_mainstack);
1606 PerlIO_printf(Perl_error_log, "panic: restartop\n");
1616 #ifdef PERL_FLEXIBLE_EXCEPTIONS
1618 S_vrun_body(pTHX_ va_list args)
1620 I32 oldscope = va_arg(args, I32);
1622 return run_body(oldscope);
1628 S_run_body(pTHX_ I32 oldscope)
1630 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
1631 PL_sawampersand ? "Enabling" : "Omitting"));
1633 if (!PL_restartop) {
1634 DEBUG_x(dump_all());
1635 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
1636 DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%"UVxf"\n",
1640 #ifdef MACOS_TRADITIONAL
1641 PerlIO_printf(Perl_error_log, "# %s syntax OK\n", MacPerl_MPWFileName(PL_origfilename));
1643 PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
1647 if (PERLDB_SINGLE && PL_DBsingle)
1648 sv_setiv(PL_DBsingle, 1);
1650 call_list(oldscope, PL_initav);
1656 PL_op = PL_restartop;
1660 else if (PL_main_start) {
1661 CvDEPTH(PL_main_cv) = 1;
1662 PL_op = PL_main_start;
1672 =head1 SV Manipulation Functions
1674 =for apidoc p||get_sv
1676 Returns the SV of the specified Perl scalar. If C<create> is set and the
1677 Perl variable does not exist then it will be created. If C<create> is not
1678 set and the variable does not exist then NULL is returned.
1684 Perl_get_sv(pTHX_ const char *name, I32 create)
1687 #ifdef USE_5005THREADS
1688 if (name[1] == '\0' && !isALPHA(name[0])) {
1689 PADOFFSET tmp = find_threadsv(name);
1690 if (tmp != NOT_IN_PAD)
1691 return THREADSV(tmp);
1693 #endif /* USE_5005THREADS */
1694 gv = gv_fetchpv(name, create, SVt_PV);
1701 =head1 Array Manipulation Functions
1703 =for apidoc p||get_av
1705 Returns the AV of the specified Perl array. If C<create> is set and the
1706 Perl variable does not exist then it will be created. If C<create> is not
1707 set and the variable does not exist then NULL is returned.
1713 Perl_get_av(pTHX_ const char *name, I32 create)
1715 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1724 =head1 Hash Manipulation Functions
1726 =for apidoc p||get_hv
1728 Returns the HV of the specified Perl hash. If C<create> is set and the
1729 Perl variable does not exist then it will be created. If C<create> is not
1730 set and the variable does not exist then NULL is returned.
1736 Perl_get_hv(pTHX_ const char *name, I32 create)
1738 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1747 =head1 CV Manipulation Functions
1749 =for apidoc p||get_cv
1751 Returns the CV of the specified Perl subroutine. If C<create> is set and
1752 the Perl subroutine does not exist then it will be declared (which has the
1753 same effect as saying C<sub name;>). If C<create> is not set and the
1754 subroutine does not exist then NULL is returned.
1760 Perl_get_cv(pTHX_ const char *name, I32 create)
1762 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
1763 /* XXX unsafe for threads if eval_owner isn't held */
1764 /* XXX this is probably not what they think they're getting.
1765 * It has the same effect as "sub name;", i.e. just a forward
1767 if (create && !GvCVu(gv))
1768 return newSUB(start_subparse(FALSE, 0),
1769 newSVOP(OP_CONST, 0, newSVpv(name,0)),
1777 /* Be sure to refetch the stack pointer after calling these routines. */
1781 =head1 Callback Functions
1783 =for apidoc p||call_argv
1785 Performs a callback to the specified Perl sub. See L<perlcall>.
1791 Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv)
1793 /* See G_* flags in cop.h */
1794 /* null terminated arg list */
1801 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
1806 return call_pv(sub_name, flags);
1810 =for apidoc p||call_pv
1812 Performs a callback to the specified Perl sub. See L<perlcall>.
1818 Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
1819 /* name of the subroutine */
1820 /* See G_* flags in cop.h */
1822 return call_sv((SV*)get_cv(sub_name, TRUE), flags);
1826 =for apidoc p||call_method
1828 Performs a callback to the specified Perl method. The blessed object must
1829 be on the stack. See L<perlcall>.
1835 Perl_call_method(pTHX_ const char *methname, I32 flags)
1836 /* name of the subroutine */
1837 /* See G_* flags in cop.h */
1839 return call_sv(sv_2mortal(newSVpv(methname,0)), flags | G_METHOD);
1842 /* May be called with any of a CV, a GV, or an SV containing the name. */
1844 =for apidoc p||call_sv
1846 Performs a callback to the Perl sub whose name is in the SV. See
1853 Perl_call_sv(pTHX_ SV *sv, I32 flags)
1854 /* See G_* flags in cop.h */
1857 LOGOP myop; /* fake syntax tree node */
1860 volatile I32 retval = 0;
1862 bool oldcatch = CATCH_GET;
1867 if (flags & G_DISCARD) {
1872 Zero(&myop, 1, LOGOP);
1873 myop.op_next = Nullop;
1874 if (!(flags & G_NOARGS))
1875 myop.op_flags |= OPf_STACKED;
1876 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1877 (flags & G_ARRAY) ? OPf_WANT_LIST :
1882 EXTEND(PL_stack_sp, 1);
1883 *++PL_stack_sp = sv;
1885 oldscope = PL_scopestack_ix;
1887 if (PERLDB_SUB && PL_curstash != PL_debstash
1888 /* Handle first BEGIN of -d. */
1889 && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
1890 /* Try harder, since this may have been a sighandler, thus
1891 * curstash may be meaningless. */
1892 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != PL_debstash)
1893 && !(flags & G_NODEBUG))
1894 PL_op->op_private |= OPpENTERSUB_DB;
1896 if (flags & G_METHOD) {
1897 Zero(&method_op, 1, UNOP);
1898 method_op.op_next = PL_op;
1899 method_op.op_ppaddr = PL_ppaddr[OP_METHOD];
1900 myop.op_ppaddr = PL_ppaddr[OP_ENTERSUB];
1901 PL_op = (OP*)&method_op;
1904 if (!(flags & G_EVAL)) {
1906 call_body((OP*)&myop, FALSE);
1907 retval = PL_stack_sp - (PL_stack_base + oldmark);
1908 CATCH_SET(oldcatch);
1911 myop.op_other = (OP*)&myop;
1913 /* we're trying to emulate pp_entertry() here */
1915 register PERL_CONTEXT *cx;
1916 I32 gimme = GIMME_V;
1921 push_return(Nullop);
1922 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
1924 PL_eval_root = PL_op; /* Only needed so that goto works right. */
1926 PL_in_eval = EVAL_INEVAL;
1927 if (flags & G_KEEPERR)
1928 PL_in_eval |= EVAL_KEEPERR;
1934 #ifdef PERL_FLEXIBLE_EXCEPTIONS
1936 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_body),
1943 #ifndef PERL_FLEXIBLE_EXCEPTIONS
1945 call_body((OP*)&myop, FALSE);
1947 retval = PL_stack_sp - (PL_stack_base + oldmark);
1948 if (!(flags & G_KEEPERR))
1955 /* my_exit() was called */
1956 PL_curstash = PL_defstash;
1959 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
1960 Perl_croak(aTHX_ "Callback called exit");
1965 PL_op = PL_restartop;
1969 PL_stack_sp = PL_stack_base + oldmark;
1970 if (flags & G_ARRAY)
1974 *++PL_stack_sp = &PL_sv_undef;
1979 if (PL_scopestack_ix > oldscope) {
1983 register PERL_CONTEXT *cx;
1995 if (flags & G_DISCARD) {
1996 PL_stack_sp = PL_stack_base + oldmark;
2005 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2007 S_vcall_body(pTHX_ va_list args)
2009 OP *myop = va_arg(args, OP*);
2010 int is_eval = va_arg(args, int);
2012 call_body(myop, is_eval);
2018 S_call_body(pTHX_ OP *myop, int is_eval)
2020 if (PL_op == myop) {
2022 PL_op = Perl_pp_entereval(aTHX); /* this doesn't do a POPMARK */
2024 PL_op = Perl_pp_entersub(aTHX); /* this does */
2030 /* Eval a string. The G_EVAL flag is always assumed. */
2033 =for apidoc p||eval_sv
2035 Tells Perl to C<eval> the string in the SV.
2041 Perl_eval_sv(pTHX_ SV *sv, I32 flags)
2043 /* See G_* flags in cop.h */
2046 UNOP myop; /* fake syntax tree node */
2047 volatile I32 oldmark = SP - PL_stack_base;
2048 volatile I32 retval = 0;
2054 if (flags & G_DISCARD) {
2061 Zero(PL_op, 1, UNOP);
2062 EXTEND(PL_stack_sp, 1);
2063 *++PL_stack_sp = sv;
2064 oldscope = PL_scopestack_ix;
2066 if (!(flags & G_NOARGS))
2067 myop.op_flags = OPf_STACKED;
2068 myop.op_next = Nullop;
2069 myop.op_type = OP_ENTEREVAL;
2070 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
2071 (flags & G_ARRAY) ? OPf_WANT_LIST :
2073 if (flags & G_KEEPERR)
2074 myop.op_flags |= OPf_SPECIAL;
2076 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2078 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_body),
2085 #ifndef PERL_FLEXIBLE_EXCEPTIONS
2087 call_body((OP*)&myop,TRUE);
2089 retval = PL_stack_sp - (PL_stack_base + oldmark);
2090 if (!(flags & G_KEEPERR))
2097 /* my_exit() was called */
2098 PL_curstash = PL_defstash;
2101 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
2102 Perl_croak(aTHX_ "Callback called exit");
2107 PL_op = PL_restartop;
2111 PL_stack_sp = PL_stack_base + oldmark;
2112 if (flags & G_ARRAY)
2116 *++PL_stack_sp = &PL_sv_undef;
2122 if (flags & G_DISCARD) {
2123 PL_stack_sp = PL_stack_base + oldmark;
2133 =for apidoc p||eval_pv
2135 Tells Perl to C<eval> the given string and return an SV* result.
2141 Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
2144 SV* sv = newSVpv(p, 0);
2146 eval_sv(sv, G_SCALAR);
2153 if (croak_on_error && SvTRUE(ERRSV)) {
2155 Perl_croak(aTHX_ SvPVx(ERRSV, n_a));
2161 /* Require a module. */
2164 =head1 Embedding Functions
2166 =for apidoc p||require_pv
2168 Tells Perl to C<require> the file named by the string argument. It is
2169 analogous to the Perl code C<eval "require '$file'">. It's even
2170 implemented that way; consider using Perl_load_module instead.
2175 Perl_require_pv(pTHX_ const char *pv)
2179 PUSHSTACKi(PERLSI_REQUIRE);
2181 sv = sv_newmortal();
2182 sv_setpv(sv, "require '");
2185 eval_sv(sv, G_DISCARD);
2191 Perl_magicname(pTHX_ char *sym, char *name, I32 namlen)
2195 if ((gv = gv_fetchpv(sym,TRUE, SVt_PV)))
2196 sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, namlen);
2200 S_usage(pTHX_ char *name) /* XXX move this out into a module ? */
2202 /* This message really ought to be max 23 lines.
2203 * Removed -h because the user already knows that option. Others? */
2205 static char *usage_msg[] = {
2206 "-0[octal] specify record separator (\\0, if no argument)",
2207 "-a autosplit mode with -n or -p (splits $_ into @F)",
2208 "-C enable native wide character system interfaces",
2209 "-c check syntax only (runs BEGIN and CHECK blocks)",
2210 "-d[:debugger] run program under debugger",
2211 "-D[number/list] set debugging flags (argument is a bit mask or alphabets)",
2212 "-e 'command' one line of program (several -e's allowed, omit programfile)",
2213 "-F/pattern/ split() pattern for -a switch (//'s are optional)",
2214 "-i[extension] edit <> files in place (makes backup if extension supplied)",
2215 "-Idirectory specify @INC/#include directory (several -I's allowed)",
2216 "-l[octal] enable line ending processing, specifies line terminator",
2217 "-[mM][-]module execute `use/no module...' before executing program",
2218 "-n assume 'while (<>) { ... }' loop around program",
2219 "-p assume loop like -n but print line also, like sed",
2220 "-P run program through C preprocessor before compilation",
2221 "-s enable rudimentary parsing for switches after programfile",
2222 "-S look for programfile using PATH environment variable",
2223 "-T enable tainting checks",
2224 "-t enable tainting warnings",
2225 "-u dump core after parsing program",
2226 "-U allow unsafe operations",
2227 "-v print version, subversion (includes VERY IMPORTANT perl info)",
2228 "-V[:variable] print configuration summary (or a single Config.pm variable)",
2229 "-w enable many useful warnings (RECOMMENDED)",
2230 "-W enable all warnings",
2231 "-X disable all warnings",
2232 "-x[directory] strip off text before #!perl line and perhaps cd to directory",
2236 char **p = usage_msg;
2238 PerlIO_printf(PerlIO_stdout(),
2239 "\nUsage: %s [switches] [--] [programfile] [arguments]",
2242 PerlIO_printf(PerlIO_stdout(), "\n %s", *p++);
2245 /* This routine handles any switches that can be given during run */
2248 Perl_moreswitches(pTHX_ char *s)
2258 rschar = (U32)grok_oct(s, &numlen, &flags, NULL);
2259 SvREFCNT_dec(PL_rs);
2260 if (rschar & ~((U8)~0))
2261 PL_rs = &PL_sv_undef;
2262 else if (!rschar && numlen >= 2)
2263 PL_rs = newSVpvn("", 0);
2265 char ch = (char)rschar;
2266 PL_rs = newSVpvn(&ch, 1);
2271 PL_widesyscalls = TRUE;
2277 while (*s && !isSPACE(*s)) ++s;
2279 PL_splitstr = savepv(PL_splitstr);
2292 /* The following permits -d:Mod to accepts arguments following an =
2293 in the fashion that -MSome::Mod does. */
2294 if (*s == ':' || *s == '=') {
2297 sv = newSVpv("use Devel::", 0);
2299 /* We now allow -d:Module=Foo,Bar */
2300 while(isALNUM(*s) || *s==':') ++s;
2302 sv_catpv(sv, start);
2304 sv_catpvn(sv, start, s-start);
2305 sv_catpv(sv, " split(/,/,q{");
2310 my_setenv("PERL5DB", SvPV(sv, PL_na));
2313 PL_perldb = PERLDB_ALL;
2321 if (isALPHA(s[1])) {
2322 /* if adding extra options, remember to update DEBUG_MASK */
2323 static char debopts[] = "psltocPmfrxuLHXDSTRJ";
2326 for (s++; *s && (d = strchr(debopts,*s)); s++)
2327 PL_debug |= 1 << (d - debopts);
2330 PL_debug = atoi(s+1);
2331 for (s++; isDIGIT(*s); s++) ;
2334 if (DEBUG_p_TEST_ && ckWARN_d(WARN_DEBUGGING))
2335 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
2336 "-Dp not implemented on this platform\n");
2338 PL_debug |= DEBUG_TOP_FLAG;
2339 #else /* !DEBUGGING */
2340 if (ckWARN_d(WARN_DEBUGGING))
2341 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
2342 "Recompile perl with -DDEBUGGING to use -D switch\n");
2343 for (s++; isALNUM(*s); s++) ;
2349 usage(PL_origargv[0]);
2353 Safefree(PL_inplace);
2354 PL_inplace = savepv(s+1);
2356 for (s = PL_inplace; *s && !isSPACE(*s); s++) ;
2359 if (*s == '-') /* Additional switches on #! line. */
2363 case 'I': /* -I handled both here and in parse_body() */
2366 while (*s && isSPACE(*s))
2371 /* ignore trailing spaces (possibly followed by other switches) */
2373 for (e = p; *e && !isSPACE(*e); e++) ;
2377 } while (*p && *p != '-');
2378 e = savepvn(s, e-s);
2379 incpush(e, TRUE, TRUE);
2386 Perl_croak(aTHX_ "No directory specified for -I");
2392 SvREFCNT_dec(PL_ors_sv);
2397 PL_ors_sv = newSVpvn("\n",1);
2398 numlen = 3 + (*s == '0');
2399 *SvPVX(PL_ors_sv) = (char)grok_oct(s, &numlen, &flags, NULL);
2403 if (RsPARA(PL_rs)) {
2404 PL_ors_sv = newSVpvn("\n\n",2);
2407 PL_ors_sv = newSVsv(PL_rs);
2412 forbid_setid("-M"); /* XXX ? */
2415 forbid_setid("-m"); /* XXX ? */
2420 /* -M-foo == 'no foo' */
2421 if (*s == '-') { use = "no "; ++s; }
2422 sv = newSVpv(use,0);
2424 /* We allow -M'Module qw(Foo Bar)' */
2425 while(isALNUM(*s) || *s==':') ++s;
2427 sv_catpv(sv, start);
2428 if (*(start-1) == 'm') {
2430 Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
2431 sv_catpv( sv, " ()");
2435 Perl_croak(aTHX_ "Module name required with -%c option",
2437 sv_catpvn(sv, start, s-start);
2438 sv_catpv(sv, " split(/,/,q{");
2444 PL_preambleav = newAV();
2445 av_push(PL_preambleav, sv);
2448 Perl_croak(aTHX_ "No space allowed after -%c", *(s-1));
2460 PL_doswitches = TRUE;
2465 Perl_croak(aTHX_ "Too late for \"-t\" option");
2470 Perl_croak(aTHX_ "Too late for \"-T\" option");
2474 #ifdef MACOS_TRADITIONAL
2475 Perl_croak(aTHX_ "Believe me, you don't want to use \"-u\" on a Macintosh");
2477 PL_do_undump = TRUE;
2486 PerlIO_printf(PerlIO_stdout(),
2487 Perl_form(aTHX_ "\nThis is perl, v%"VDf" built for %s",
2488 PL_patchlevel, ARCHNAME));
2490 /* Adjust verbose output as in the perl that ships with the DG/UX OS from EMC */
2491 PerlIO_printf(PerlIO_stdout(),
2492 Perl_form(aTHX_ "\nThis is perl, version %vd\n", PL_patchlevel));
2493 PerlIO_printf(PerlIO_stdout(),
2494 Perl_form(aTHX_ " built under %s at %s %s\n",
2495 OSNAME, __DATE__, __TIME__));
2496 PerlIO_printf(PerlIO_stdout(),
2497 Perl_form(aTHX_ " OS Specific Release: %s\n",
2501 #if defined(LOCAL_PATCH_COUNT)
2502 if (LOCAL_PATCH_COUNT > 0)
2503 PerlIO_printf(PerlIO_stdout(),
2504 "\n(with %d registered patch%s, "
2505 "see perl -V for more detail)",
2506 (int)LOCAL_PATCH_COUNT,
2507 (LOCAL_PATCH_COUNT!=1) ? "es" : "");
2510 PerlIO_printf(PerlIO_stdout(),
2511 "\n\nCopyright 1987-2002, Larry Wall\n");
2512 #ifdef MACOS_TRADITIONAL
2513 PerlIO_printf(PerlIO_stdout(),
2514 "\nMac OS port Copyright 1991-2002, Matthias Neeracher;\n"
2515 "maintained by Chris Nandor\n");
2518 PerlIO_printf(PerlIO_stdout(),
2519 "\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
2522 PerlIO_printf(PerlIO_stdout(),
2523 "djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n"
2524 "djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
2527 PerlIO_printf(PerlIO_stdout(),
2528 "\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
2529 "Version 5 port Copyright (c) 1994-2002, Andreas Kaiser, Ilya Zakharevich\n");
2532 PerlIO_printf(PerlIO_stdout(),
2533 "atariST series port, ++jrb bammi@cadence.com\n");
2536 PerlIO_printf(PerlIO_stdout(),
2537 "BeOS port Copyright Tom Spindler, 1997-1999\n");
2540 PerlIO_printf(PerlIO_stdout(),
2541 "MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-2002\n");
2544 PerlIO_printf(PerlIO_stdout(),
2545 "MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
2548 PerlIO_printf(PerlIO_stdout(),
2549 "Stratus VOS port by Paul.Green@stratus.com, 1997-2002\n");
2552 PerlIO_printf(PerlIO_stdout(),
2553 "VM/ESA port by Neale Ferguson, 1998-1999\n");
2556 PerlIO_printf(PerlIO_stdout(),
2557 "BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
2560 PerlIO_printf(PerlIO_stdout(),
2561 "MiNT port by Guido Flohr, 1997-1999\n");
2564 PerlIO_printf(PerlIO_stdout(),
2565 "EPOC port by Olaf Flebbe, 1999-2002\n");
2568 printf("WINCE port by Rainer Keuchel, 2001-2002\n");
2569 printf("Built on " __DATE__ " " __TIME__ "\n\n");
2572 #ifdef BINARY_BUILD_NOTICE
2573 BINARY_BUILD_NOTICE;
2575 PerlIO_printf(PerlIO_stdout(),
2577 Perl may be copied only under the terms of either the Artistic License or the\n\
2578 GNU General Public License, which may be found in the Perl 5 source kit.\n\n\
2579 Complete documentation for Perl, including FAQ lists, should be found on\n\
2580 this system using `man perl' or `perldoc perl'. If you have access to the\n\
2581 Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
2584 if (! (PL_dowarn & G_WARN_ALL_MASK))
2585 PL_dowarn |= G_WARN_ON;
2589 PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
2590 if (!specialWARN(PL_compiling.cop_warnings))
2591 SvREFCNT_dec(PL_compiling.cop_warnings);
2592 PL_compiling.cop_warnings = pWARN_ALL ;
2596 PL_dowarn = G_WARN_ALL_OFF;
2597 if (!specialWARN(PL_compiling.cop_warnings))
2598 SvREFCNT_dec(PL_compiling.cop_warnings);
2599 PL_compiling.cop_warnings = pWARN_NONE ;
2604 if (s[1] == '-') /* Additional switches on #! line. */
2609 #if defined(WIN32) || !defined(PERL_STRICT_CR)
2615 #ifdef ALTERNATE_SHEBANG
2616 case 'S': /* OS/2 needs -S on "extproc" line. */
2624 Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
2629 /* compliments of Tom Christiansen */
2631 /* unexec() can be found in the Gnu emacs distribution */
2632 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
2635 Perl_my_unexec(pTHX)
2643 prog = newSVpv(BIN_EXP, 0);
2644 sv_catpv(prog, "/perl");
2645 file = newSVpv(PL_origfilename, 0);
2646 sv_catpv(file, ".perldump");
2648 unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
2649 /* unexec prints msg to stderr in case of failure */
2650 PerlProc_exit(status);
2653 # include <lib$routines.h>
2654 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
2656 ABORT(); /* for use with undump */
2661 /* initialize curinterp */
2667 # define PERLVAR(var,type)
2668 # define PERLVARA(var,n,type)
2669 # if defined(PERL_IMPLICIT_CONTEXT)
2670 # if defined(USE_5005THREADS)
2671 # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
2672 # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
2673 # else /* !USE_5005THREADS */
2674 # define PERLVARI(var,type,init) aTHX->var = init;
2675 # define PERLVARIC(var,type,init) aTHX->var = init;
2676 # endif /* USE_5005THREADS */
2678 # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
2679 # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
2681 # include "intrpvar.h"
2682 # ifndef USE_5005THREADS
2683 # include "thrdvar.h"
2690 # define PERLVAR(var,type)
2691 # define PERLVARA(var,n,type)
2692 # define PERLVARI(var,type,init) PL_##var = init;
2693 # define PERLVARIC(var,type,init) PL_##var = init;
2694 # include "intrpvar.h"
2695 # ifndef USE_5005THREADS
2696 # include "thrdvar.h"
2707 S_init_main_stash(pTHX)
2711 PL_curstash = PL_defstash = newHV();
2712 PL_curstname = newSVpvn("main",4);
2713 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
2714 SvREFCNT_dec(GvHV(gv));
2715 GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
2717 HvNAME(PL_defstash) = savepv("main");
2718 PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
2719 GvMULTI_on(PL_incgv);
2720 PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
2721 GvMULTI_on(PL_hintgv);
2722 PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
2723 PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
2724 GvMULTI_on(PL_errgv);
2725 PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
2726 GvMULTI_on(PL_replgv);
2727 (void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */
2728 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
2729 sv_setpvn(ERRSV, "", 0);
2730 PL_curstash = PL_defstash;
2731 CopSTASH_set(&PL_compiling, PL_defstash);
2732 PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
2733 PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
2734 PL_nullstash = GvHV(gv_fetchpv("<none>::", GV_ADDMULTI, SVt_PVHV));
2735 /* We must init $/ before switches are processed. */
2736 sv_setpvn(get_sv("/", TRUE), "\n", 1);
2740 S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
2744 char *cpp_discard_flag;
2750 PL_origfilename = savepv("-e");
2753 /* if find_script() returns, it returns a malloc()-ed value */
2754 PL_origfilename = scriptname = find_script(scriptname, dosearch, NULL, 1);
2756 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
2757 char *s = scriptname + 8;
2758 *fdscript = atoi(s);
2762 scriptname = savepv(s + 1);
2763 Safefree(PL_origfilename);
2764 PL_origfilename = scriptname;
2769 CopFILE_free(PL_curcop);
2770 CopFILE_set(PL_curcop, PL_origfilename);
2771 if (strEQ(PL_origfilename,"-"))
2773 if (*fdscript >= 0) {
2774 PL_rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE);
2775 # if defined(HAS_FCNTL) && defined(F_SETFD)
2777 /* ensure close-on-exec */
2778 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
2781 else if (PL_preprocess) {
2782 char *cpp_cfg = CPPSTDIN;
2783 SV *cpp = newSVpvn("",0);
2784 SV *cmd = NEWSV(0,0);
2786 if (strEQ(cpp_cfg, "cppstdin"))
2787 Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
2788 sv_catpv(cpp, cpp_cfg);
2791 sv_catpvn(sv, "-I", 2);
2792 sv_catpv(sv,PRIVLIB_EXP);
2795 DEBUG_P(PerlIO_printf(Perl_debug_log,
2796 "PL_preprocess: scriptname=\"%s\", cpp=\"%s\", sv=\"%s\", CPPMINUS=\"%s\"\n",
2797 scriptname, SvPVX (cpp), SvPVX (sv), CPPMINUS));
2799 # if defined(MSDOS) || defined(WIN32) || defined(VMS)
2806 cpp_discard_flag = "";
2808 cpp_discard_flag = "-C";
2812 perl = os2_execname(aTHX);
2814 perl = PL_origargv[0];
2818 /* This strips off Perl comments which might interfere with
2819 the C pre-processor, including #!. #line directives are
2820 deliberately stripped to avoid confusion with Perl's version
2821 of #line. FWP played some golf with it so it will fit
2822 into VMS's 255 character buffer.
2825 code = "(1../^#!.*perl/i)|/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print";
2827 code = "/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print";
2829 Perl_sv_setpvf(aTHX_ cmd, "\
2830 %s -ne%s%s%s %s | %"SVf" %s %"SVf" %s",
2831 perl, quote, code, quote, scriptname, cpp,
2832 cpp_discard_flag, sv, CPPMINUS);
2834 PL_doextract = FALSE;
2835 # ifdef IAMSUID /* actually, this is caught earlier */
2836 if (PL_euid != PL_uid && !PL_euid) { /* if running suidperl */
2838 (void)seteuid(PL_uid); /* musn't stay setuid root */
2840 # ifdef HAS_SETREUID
2841 (void)setreuid((Uid_t)-1, PL_uid);
2843 # ifdef HAS_SETRESUID
2844 (void)setresuid((Uid_t)-1, PL_uid, (Uid_t)-1);
2846 PerlProc_setuid(PL_uid);
2850 if (PerlProc_geteuid() != PL_uid)
2851 Perl_croak(aTHX_ "Can't do seteuid!\n");
2853 # endif /* IAMSUID */
2855 DEBUG_P(PerlIO_printf(Perl_debug_log,
2856 "PL_preprocess: cmd=\"%s\"\n",
2859 PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
2863 else if (!*scriptname) {
2864 forbid_setid("program input from stdin");
2865 PL_rsfp = PerlIO_stdin();
2868 PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
2869 # if defined(HAS_FCNTL) && defined(F_SETFD)
2871 /* ensure close-on-exec */
2872 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
2877 # ifndef IAMSUID /* in case script is not readable before setuid */
2879 PerlLIO_stat(CopFILE(PL_curcop),&PL_statbuf) >= 0 &&
2880 PL_statbuf.st_mode & (S_ISUID|S_ISGID))
2883 PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT,
2884 BIN_EXP, (int)PERL_REVISION,
2886 (int)PERL_SUBVERSION), PL_origargv);
2887 Perl_croak(aTHX_ "Can't do setuid\n");
2893 Perl_croak(aTHX_ "Can't open perl script: %s\n",
2896 Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
2897 CopFILE(PL_curcop), Strerror(errno));
2903 * I_SYSSTATVFS HAS_FSTATVFS
2905 * I_STATFS HAS_FSTATFS HAS_GETFSSTAT
2906 * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT
2907 * here so that metaconfig picks them up. */
2911 S_fd_on_nosuid_fs(pTHX_ int fd)
2913 int check_okay = 0; /* able to do all the required sys/libcalls */
2914 int on_nosuid = 0; /* the fd is on a nosuid fs */
2916 * Preferred order: fstatvfs(), fstatfs(), ustat()+getmnt(), getmntent().
2917 * fstatvfs() is UNIX98.
2918 * fstatfs() is 4.3 BSD.
2919 * ustat()+getmnt() is pre-4.3 BSD.
2920 * getmntent() is O(number-of-mounted-filesystems) and can hang on
2921 * an irrelevant filesystem while trying to reach the right one.
2924 #undef FD_ON_NOSUID_CHECK_OKAY /* found the syscalls to do the check? */
2926 # if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
2927 defined(HAS_FSTATVFS)
2928 # define FD_ON_NOSUID_CHECK_OKAY
2929 struct statvfs stfs;
2931 check_okay = fstatvfs(fd, &stfs) == 0;
2932 on_nosuid = check_okay && (stfs.f_flag & ST_NOSUID);
2933 # endif /* fstatvfs */
2935 # if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
2936 defined(PERL_MOUNT_NOSUID) && \
2937 defined(HAS_FSTATFS) && \
2938 defined(HAS_STRUCT_STATFS) && \
2939 defined(HAS_STRUCT_STATFS_F_FLAGS)
2940 # define FD_ON_NOSUID_CHECK_OKAY
2943 check_okay = fstatfs(fd, &stfs) == 0;
2944 on_nosuid = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
2945 # endif /* fstatfs */
2947 # if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
2948 defined(PERL_MOUNT_NOSUID) && \
2949 defined(HAS_FSTAT) && \
2950 defined(HAS_USTAT) && \
2951 defined(HAS_GETMNT) && \
2952 defined(HAS_STRUCT_FS_DATA) && \
2954 # define FD_ON_NOSUID_CHECK_OKAY
2957 if (fstat(fd, &fdst) == 0) {
2959 if (ustat(fdst.st_dev, &us) == 0) {
2961 /* NOSTAT_ONE here because we're not examining fields which
2962 * vary between that case and STAT_ONE. */
2963 if (getmnt((int*)0, &fsd, (int)0, NOSTAT_ONE, us.f_fname) == 0) {
2964 size_t cmplen = sizeof(us.f_fname);
2965 if (sizeof(fsd.fd_req.path) < cmplen)
2966 cmplen = sizeof(fsd.fd_req.path);
2967 if (strnEQ(fsd.fd_req.path, us.f_fname, cmplen) &&
2968 fdst.st_dev == fsd.fd_req.dev) {
2970 on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID;
2976 # endif /* fstat+ustat+getmnt */
2978 # if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
2979 defined(HAS_GETMNTENT) && \
2980 defined(HAS_HASMNTOPT) && \
2981 defined(MNTOPT_NOSUID)
2982 # define FD_ON_NOSUID_CHECK_OKAY
2983 FILE *mtab = fopen("/etc/mtab", "r");
2984 struct mntent *entry;
2987 if (mtab && (fstat(fd, &stb) == 0)) {
2988 while (entry = getmntent(mtab)) {
2989 if (stat(entry->mnt_dir, &fsb) == 0
2990 && fsb.st_dev == stb.st_dev)
2992 /* found the filesystem */
2994 if (hasmntopt(entry, MNTOPT_NOSUID))
2997 } /* A single fs may well fail its stat(). */
3002 # endif /* getmntent+hasmntopt */
3005 Perl_croak(aTHX_ "Can't check filesystem of script \"%s\" for nosuid", PL_origfilename);
3008 #endif /* IAMSUID */
3011 S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript)
3017 /* do we need to emulate setuid on scripts? */
3019 /* This code is for those BSD systems that have setuid #! scripts disabled
3020 * in the kernel because of a security problem. Merely defining DOSUID
3021 * in perl will not fix that problem, but if you have disabled setuid
3022 * scripts in the kernel, this will attempt to emulate setuid and setgid
3023 * on scripts that have those now-otherwise-useless bits set. The setuid
3024 * root version must be called suidperl or sperlN.NNN. If regular perl
3025 * discovers that it has opened a setuid script, it calls suidperl with
3026 * the same argv that it had. If suidperl finds that the script it has
3027 * just opened is NOT setuid root, it sets the effective uid back to the
3028 * uid. We don't just make perl setuid root because that loses the
3029 * effective uid we had before invoking perl, if it was different from the
3032 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
3033 * be defined in suidperl only. suidperl must be setuid root. The
3034 * Configure script will set this up for you if you want it.
3040 if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */
3041 Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
3042 if (fdscript < 0 && PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
3047 #ifndef HAS_SETREUID
3048 /* On this access check to make sure the directories are readable,
3049 * there is actually a small window that the user could use to make
3050 * filename point to an accessible directory. So there is a faint
3051 * chance that someone could execute a setuid script down in a
3052 * non-accessible directory. I don't know what to do about that.
3053 * But I don't think it's too important. The manual lies when
3054 * it says access() is useful in setuid programs.
3056 if (PerlLIO_access(CopFILE(PL_curcop),1)) /*double check*/
3057 Perl_croak(aTHX_ "Permission denied");
3059 /* If we can swap euid and uid, then we can determine access rights
3060 * with a simple stat of the file, and then compare device and
3061 * inode to make sure we did stat() on the same file we opened.
3062 * Then we just have to make sure he or she can execute it.
3069 setreuid(PL_euid,PL_uid) < 0
3072 setresuid(PL_euid,PL_uid,(Uid_t)-1) < 0
3075 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
3076 Perl_croak(aTHX_ "Can't swap uid and euid"); /* really paranoid */
3077 if (PerlLIO_stat(CopFILE(PL_curcop),&tmpstatbuf) < 0)
3078 Perl_croak(aTHX_ "Permission denied"); /* testing full pathname here */
3079 #if defined(IAMSUID) && !defined(NO_NOSUID_CHECK)
3080 if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp)))
3081 Perl_croak(aTHX_ "Permission denied");
3083 if (tmpstatbuf.st_dev != PL_statbuf.st_dev ||
3084 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
3085 (void)PerlIO_close(PL_rsfp);
3086 Perl_croak(aTHX_ "Permission denied\n");
3090 setreuid(PL_uid,PL_euid) < 0
3092 # if defined(HAS_SETRESUID)
3093 setresuid(PL_uid,PL_euid,(Uid_t)-1) < 0
3096 || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
3097 Perl_croak(aTHX_ "Can't reswap uid and euid");
3098 if (!cando(S_IXUSR,FALSE,&PL_statbuf)) /* can real uid exec? */
3099 Perl_croak(aTHX_ "Permission denied\n");
3101 #endif /* HAS_SETREUID */
3102 #endif /* IAMSUID */
3104 if (!S_ISREG(PL_statbuf.st_mode))
3105 Perl_croak(aTHX_ "Permission denied");
3106 if (PL_statbuf.st_mode & S_IWOTH)
3107 Perl_croak(aTHX_ "Setuid/gid script is writable by world");
3108 PL_doswitches = FALSE; /* -s is insecure in suid */
3109 CopLINE_inc(PL_curcop);
3110 if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
3111 strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */
3112 Perl_croak(aTHX_ "No #! line");
3113 s = SvPV(PL_linestr,n_a)+2;
3115 while (!isSPACE(*s)) s++;
3116 for (s2 = s; (s2 > SvPV(PL_linestr,n_a)+2 &&
3117 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
3118 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
3119 Perl_croak(aTHX_ "Not a perl script");
3120 while (*s == ' ' || *s == '\t') s++;
3122 * #! arg must be what we saw above. They can invoke it by
3123 * mentioning suidperl explicitly, but they may not add any strange
3124 * arguments beyond what #! says if they do invoke suidperl that way.
3126 len = strlen(validarg);
3127 if (strEQ(validarg," PHOOEY ") ||
3128 strnNE(s,validarg,len) || !isSPACE(s[len]))
3129 Perl_croak(aTHX_ "Args must match #! line");
3132 if (PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
3133 PL_euid == PL_statbuf.st_uid)
3135 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
3136 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
3137 #endif /* IAMSUID */
3139 if (PL_euid) { /* oops, we're not the setuid root perl */
3140 (void)PerlIO_close(PL_rsfp);
3143 PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
3144 (int)PERL_REVISION, (int)PERL_VERSION,
3145 (int)PERL_SUBVERSION), PL_origargv);
3147 Perl_croak(aTHX_ "Can't do setuid\n");
3150 if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
3152 (void)setegid(PL_statbuf.st_gid);
3155 (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
3157 #ifdef HAS_SETRESGID
3158 (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
3160 PerlProc_setgid(PL_statbuf.st_gid);
3164 if (PerlProc_getegid() != PL_statbuf.st_gid)
3165 Perl_croak(aTHX_ "Can't do setegid!\n");
3167 if (PL_statbuf.st_mode & S_ISUID) {
3168 if (PL_statbuf.st_uid != PL_euid)
3170 (void)seteuid(PL_statbuf.st_uid); /* all that for this */
3173 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
3175 #ifdef HAS_SETRESUID
3176 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
3178 PerlProc_setuid(PL_statbuf.st_uid);
3182 if (PerlProc_geteuid() != PL_statbuf.st_uid)
3183 Perl_croak(aTHX_ "Can't do seteuid!\n");
3185 else if (PL_uid) { /* oops, mustn't run as root */
3187 (void)seteuid((Uid_t)PL_uid);
3190 (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
3192 #ifdef HAS_SETRESUID
3193 (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
3195 PerlProc_setuid((Uid_t)PL_uid);
3199 if (PerlProc_geteuid() != PL_uid)
3200 Perl_croak(aTHX_ "Can't do seteuid!\n");
3203 if (!cando(S_IXUSR,TRUE,&PL_statbuf))
3204 Perl_croak(aTHX_ "Permission denied\n"); /* they can't do this */
3207 else if (PL_preprocess)
3208 Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
3209 else if (fdscript >= 0)
3210 Perl_croak(aTHX_ "fd script not allowed in suidperl\n");
3212 Perl_croak(aTHX_ "Script is not setuid/setgid in suidperl\n");
3214 /* We absolutely must clear out any saved ids here, so we */
3215 /* exec the real perl, substituting fd script for scriptname. */
3216 /* (We pass script name as "subdir" of fd, which perl will grok.) */
3217 PerlIO_rewind(PL_rsfp);
3218 PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0); /* just in case rewind didn't */
3219 for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
3220 if (!PL_origargv[which])
3221 Perl_croak(aTHX_ "Permission denied");
3222 PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
3223 PerlIO_fileno(PL_rsfp), PL_origargv[which]));
3224 #if defined(HAS_FCNTL) && defined(F_SETFD)
3225 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */
3227 PerlProc_execv(Perl_form(aTHX_ "%s/perl"PERL_FS_VER_FMT, BIN_EXP,
3228 (int)PERL_REVISION, (int)PERL_VERSION,
3229 (int)PERL_SUBVERSION), PL_origargv);/* try again */
3230 Perl_croak(aTHX_ "Can't do setuid\n");
3231 #endif /* IAMSUID */
3233 if (PL_euid != PL_uid || PL_egid != PL_gid) { /* (suidperl doesn't exist, in fact) */
3234 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
3235 PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf); /* may be either wrapped or real suid */
3236 if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
3238 (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
3241 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
3242 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
3243 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
3244 /* not set-id, must be wrapped */
3250 S_find_beginning(pTHX)
3252 register char *s, *s2;
3254 /* skip forward in input to the real script? */
3257 #ifdef MACOS_TRADITIONAL
3258 /* Since the Mac OS does not honor #! arguments for us, we do it ourselves */
3260 while (PL_doextract || gMacPerl_AlwaysExtract) {
3261 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
3262 if (!gMacPerl_AlwaysExtract)
3263 Perl_croak(aTHX_ "No Perl script found in input\n");
3265 if (PL_doextract) /* require explicit override ? */
3266 if (!OverrideExtract(PL_origfilename))
3267 Perl_croak(aTHX_ "User aborted script\n");
3269 PL_doextract = FALSE;
3271 /* Pater peccavi, file does not have #! */
3272 PerlIO_rewind(PL_rsfp);
3277 while (PL_doextract) {
3278 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
3279 Perl_croak(aTHX_ "No Perl script found in input\n");
3282 if (*s == '#' && s[1] == '!' && ((s = instr(s,"perl")) || (s = instr(s2,"PERL")))) {
3283 PerlIO_ungetc(PL_rsfp, '\n'); /* to keep line count right */
3284 PL_doextract = FALSE;
3285 while (*s && !(isSPACE (*s) || *s == '#')) s++;
3287 while (*s == ' ' || *s == '\t') s++;
3289 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
3290 if (strnEQ(s2-4,"perl",4))
3292 while ((s = moreswitches(s)))
3295 #ifdef MACOS_TRADITIONAL
3306 PL_uid = PerlProc_getuid();
3307 PL_euid = PerlProc_geteuid();
3308 PL_gid = PerlProc_getgid();
3309 PL_egid = PerlProc_getegid();
3311 PL_uid |= PL_gid << 16;
3312 PL_euid |= PL_egid << 16;
3314 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
3318 S_forbid_setid(pTHX_ char *s)
3320 if (PL_euid != PL_uid)
3321 Perl_croak(aTHX_ "No %s allowed while running setuid", s);
3322 if (PL_egid != PL_gid)
3323 Perl_croak(aTHX_ "No %s allowed while running setgid", s);
3327 Perl_init_debugger(pTHX)
3329 HV *ostash = PL_curstash;
3331 PL_curstash = PL_debstash;
3332 PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
3333 AvREAL_off(PL_dbargs);
3334 PL_DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
3335 PL_DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
3336 PL_DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
3337 sv_upgrade(GvSV(PL_DBsub), SVt_IV); /* IVX accessed if PERLDB_SUB_NN */
3338 PL_DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
3339 sv_setiv(PL_DBsingle, 0);
3340 PL_DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
3341 sv_setiv(PL_DBtrace, 0);
3342 PL_DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
3343 sv_setiv(PL_DBsignal, 0);
3344 PL_curstash = ostash;
3347 #ifndef STRESS_REALLOC
3348 #define REASONABLE(size) (size)
3350 #define REASONABLE(size) (1) /* unreasonable */
3354 Perl_init_stacks(pTHX)
3356 /* start with 128-item stack and 8K cxstack */
3357 PL_curstackinfo = new_stackinfo(REASONABLE(128),
3358 REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
3359 PL_curstackinfo->si_type = PERLSI_MAIN;
3360 PL_curstack = PL_curstackinfo->si_stack;
3361 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
3363 PL_stack_base = AvARRAY(PL_curstack);
3364 PL_stack_sp = PL_stack_base;
3365 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
3367 New(50,PL_tmps_stack,REASONABLE(128),SV*);
3370 PL_tmps_max = REASONABLE(128);
3372 New(54,PL_markstack,REASONABLE(32),I32);
3373 PL_markstack_ptr = PL_markstack;
3374 PL_markstack_max = PL_markstack + REASONABLE(32);
3378 New(54,PL_scopestack,REASONABLE(32),I32);
3379 PL_scopestack_ix = 0;
3380 PL_scopestack_max = REASONABLE(32);
3382 New(54,PL_savestack,REASONABLE(128),ANY);
3383 PL_savestack_ix = 0;
3384 PL_savestack_max = REASONABLE(128);
3386 New(54,PL_retstack,REASONABLE(16),OP*);
3388 PL_retstack_max = REASONABLE(16);
3396 while (PL_curstackinfo->si_next)
3397 PL_curstackinfo = PL_curstackinfo->si_next;
3398 while (PL_curstackinfo) {
3399 PERL_SI *p = PL_curstackinfo->si_prev;
3400 /* curstackinfo->si_stack got nuked by sv_free_arenas() */
3401 Safefree(PL_curstackinfo->si_cxstack);
3402 Safefree(PL_curstackinfo);
3403 PL_curstackinfo = p;
3405 Safefree(PL_tmps_stack);
3406 Safefree(PL_markstack);
3407 Safefree(PL_scopestack);
3408 Safefree(PL_savestack);
3409 Safefree(PL_retstack);
3418 lex_start(PL_linestr);
3420 PL_subname = newSVpvn("main",4);
3424 S_init_predump_symbols(pTHX)
3429 sv_setpvn(get_sv("\"", TRUE), " ", 1);
3430 PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
3431 GvMULTI_on(PL_stdingv);
3432 io = GvIOp(PL_stdingv);
3433 IoTYPE(io) = IoTYPE_RDONLY;
3434 IoIFP(io) = PerlIO_stdin();
3435 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
3437 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
3439 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
3442 IoTYPE(io) = IoTYPE_WRONLY;
3443 IoOFP(io) = IoIFP(io) = PerlIO_stdout();
3445 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
3447 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
3449 PL_stderrgv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
3450 GvMULTI_on(PL_stderrgv);
3451 io = GvIOp(PL_stderrgv);
3452 IoTYPE(io) = IoTYPE_WRONLY;
3453 IoOFP(io) = IoIFP(io) = PerlIO_stderr();
3454 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
3456 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
3458 PL_statname = NEWSV(66,0); /* last filename we did stat on */
3461 Safefree(PL_osname);
3462 PL_osname = savepv(OSNAME);
3466 Perl_init_argv_symbols(pTHX_ register int argc, register char **argv)
3469 argc--,argv++; /* skip name of script */
3470 if (PL_doswitches) {
3471 for (; argc > 0 && **argv == '-'; argc--,argv++) {
3474 if (argv[0][1] == '-' && !argv[0][2]) {
3478 if ((s = strchr(argv[0], '='))) {
3480 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
3483 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
3486 if ((PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV))) {
3487 GvMULTI_on(PL_argvgv);
3488 (void)gv_AVadd(PL_argvgv);
3489 av_clear(GvAVn(PL_argvgv));
3490 for (; argc > 0; argc--,argv++) {
3491 SV *sv = newSVpv(argv[0],0);
3492 av_push(GvAVn(PL_argvgv),sv);
3493 if (PL_widesyscalls)
3494 (void)sv_utf8_decode(sv);
3499 #ifdef HAS_PROCSELFEXE
3500 /* This is a function so that we don't hold on to MAXPATHLEN
3501 bytes of stack longer than necessary
3504 S_procself_val(pTHX_ SV *sv, char *arg0)
3506 char buf[MAXPATHLEN];
3507 int len = readlink(PROCSELFEXE_PATH, buf, sizeof(buf) - 1);
3508 /* FreeBSD's implementation is acknowledged to be imperfect, sometimes
3509 returning the text "unknown" from the readlink rather than the path
3510 to the executable (or returning an error from the readlink). Any valid
3511 path has a '/' in it somewhere, so use that to validate the result.
3512 See http://www.freebsd.org/cgi/query-pr.cgi?pr=35703
3514 if (len > 0 && memchr(buf, '/', len)) {
3515 sv_setpvn(sv,buf,len);
3521 #endif /* HAS_PROCSELFEXE */
3524 S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
3530 PL_toptarget = NEWSV(0,0);
3531 sv_upgrade(PL_toptarget, SVt_PVFM);
3532 sv_setpvn(PL_toptarget, "", 0);
3533 PL_bodytarget = NEWSV(0,0);
3534 sv_upgrade(PL_bodytarget, SVt_PVFM);
3535 sv_setpvn(PL_bodytarget, "", 0);
3536 PL_formtarget = PL_bodytarget;
3540 init_argv_symbols(argc,argv);
3542 if ((tmpgv = gv_fetchpv("0",TRUE, SVt_PV))) {
3543 #ifdef MACOS_TRADITIONAL
3544 /* $0 is not majick on a Mac */
3545 sv_setpv(GvSV(tmpgv),MacPerl_MPWFileName(PL_origfilename));
3547 sv_setpv(GvSV(tmpgv),PL_origfilename);
3548 magicname("0", "0", 1);
3551 if ((tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))) {/* $^X */
3552 #ifdef HAS_PROCSELFEXE
3553 S_procself_val(aTHX_ GvSV(tmpgv), PL_origargv[0]);
3556 sv_setpv(GvSV(tmpgv), os2_execname(aTHX));
3558 sv_setpv(GvSV(tmpgv),PL_origargv[0]);
3562 if ((PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV))) {
3564 GvMULTI_on(PL_envgv);
3565 hv = GvHVn(PL_envgv);
3566 hv_magic(hv, Nullgv, PERL_MAGIC_env);
3567 #ifdef USE_ENVIRON_ARRAY
3568 /* Note that if the supplied env parameter is actually a copy
3569 of the global environ then it may now point to free'd memory
3570 if the environment has been modified since. To avoid this
3571 problem we treat env==NULL as meaning 'use the default'
3576 environ[0] = Nullch;
3578 for (; *env; env++) {
3579 if (!(s = strchr(*env,'=')))
3586 sv = newSVpv(s+1, 0);
3587 (void)hv_store(hv, *env, s - *env, sv, 0);
3591 #endif /* USE_ENVIRON_ARRAY */
3594 if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV))) {
3595 SvREADONLY_off(GvSV(tmpgv));
3596 sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
3597 SvREADONLY_on(GvSV(tmpgv));
3600 /* touch @F array to prevent spurious warnings 20020415 MJD */
3602 (void) get_av("main::F", TRUE | GV_ADDMULTI);
3604 /* touch @- and @+ arrays to prevent spurious warnings 20020415 MJD */
3605 (void) get_av("main::-", TRUE | GV_ADDMULTI);
3606 (void) get_av("main::+", TRUE | GV_ADDMULTI);
3610 S_init_perllib(pTHX)
3615 s = PerlEnv_getenv("PERL5LIB");
3617 incpush(s, TRUE, TRUE);
3619 incpush(PerlEnv_getenv("PERLLIB"), FALSE, FALSE);
3621 /* Treat PERL5?LIB as a possible search list logical name -- the
3622 * "natural" VMS idiom for a Unix path string. We allow each
3623 * element to be a set of |-separated directories for compatibility.
3627 if (my_trnlnm("PERL5LIB",buf,0))
3628 do { incpush(buf,TRUE,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
3630 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE,FALSE);
3634 /* Use the ~-expanded versions of APPLLIB (undocumented),
3635 ARCHLIB PRIVLIB SITEARCH SITELIB VENDORARCH and VENDORLIB
3638 incpush(APPLLIB_EXP, TRUE, TRUE);
3642 incpush(ARCHLIB_EXP, FALSE, FALSE);
3644 #ifdef MACOS_TRADITIONAL
3647 SV * privdir = NEWSV(55, 0);
3648 char * macperl = PerlEnv_getenv("MACPERL");
3653 Perl_sv_setpvf(aTHX_ privdir, "%slib:", macperl);
3654 if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
3655 incpush(SvPVX(privdir), TRUE, FALSE);
3656 Perl_sv_setpvf(aTHX_ privdir, "%ssite_perl:", macperl);
3657 if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
3658 incpush(SvPVX(privdir), TRUE, FALSE);
3660 SvREFCNT_dec(privdir);
3663 incpush(":", FALSE, FALSE);
3666 # define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
3669 incpush(PRIVLIB_EXP, TRUE, FALSE);
3671 incpush(PRIVLIB_EXP, FALSE, FALSE);
3675 /* sitearch is always relative to sitelib on Windows for
3676 * DLL-based path intuition to work correctly */
3677 # if !defined(WIN32)
3678 incpush(SITEARCH_EXP, FALSE, FALSE);
3684 incpush(SITELIB_EXP, TRUE, FALSE); /* this picks up sitearch as well */
3686 incpush(SITELIB_EXP, FALSE, FALSE);
3690 #ifdef SITELIB_STEM /* Search for version-specific dirs below here */
3691 incpush(SITELIB_STEM, FALSE, TRUE);
3694 #ifdef PERL_VENDORARCH_EXP
3695 /* vendorarch is always relative to vendorlib on Windows for
3696 * DLL-based path intuition to work correctly */
3697 # if !defined(WIN32)
3698 incpush(PERL_VENDORARCH_EXP, FALSE, FALSE);
3702 #ifdef PERL_VENDORLIB_EXP
3704 incpush(PERL_VENDORLIB_EXP, TRUE, FALSE); /* this picks up vendorarch as well */
3706 incpush(PERL_VENDORLIB_EXP, FALSE, FALSE);
3710 #ifdef PERL_VENDORLIB_STEM /* Search for version-specific dirs below here */
3711 incpush(PERL_VENDORLIB_STEM, FALSE, TRUE);
3714 #ifdef PERL_OTHERLIBDIRS
3715 incpush(PERL_OTHERLIBDIRS, TRUE, TRUE);
3719 incpush(".", FALSE, FALSE);
3720 #endif /* MACOS_TRADITIONAL */
3723 #if defined(DOSISH) || defined(EPOC)
3724 # define PERLLIB_SEP ';'
3727 # define PERLLIB_SEP '|'
3729 # if defined(MACOS_TRADITIONAL)
3730 # define PERLLIB_SEP ','
3732 # define PERLLIB_SEP ':'
3736 #ifndef PERLLIB_MANGLE
3737 # define PERLLIB_MANGLE(s,n) (s)
3741 S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers)
3743 SV *subdir = Nullsv;
3748 if (addsubdirs || addoldvers) {
3749 subdir = sv_newmortal();
3752 /* Break at all separators */
3754 SV *libdir = NEWSV(55,0);
3757 /* skip any consecutive separators */
3758 while ( *p == PERLLIB_SEP ) {
3759 /* Uncomment the next line for PATH semantics */
3760 /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */
3764 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
3765 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
3770 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
3771 p = Nullch; /* break out */
3773 #ifdef MACOS_TRADITIONAL
3774 if (!strchr(SvPVX(libdir), ':'))
3775 sv_insert(libdir, 0, 0, ":", 1);
3776 if (SvPVX(libdir)[SvCUR(libdir)-1] != ':')
3777 sv_catpv(libdir, ":");
3781 * BEFORE pushing libdir onto @INC we may first push version- and
3782 * archname-specific sub-directories.
3784 if (addsubdirs || addoldvers) {
3785 #ifdef PERL_INC_VERSION_LIST
3786 /* Configure terminates PERL_INC_VERSION_LIST with a NULL */
3787 const char *incverlist[] = { PERL_INC_VERSION_LIST };
3788 const char **incver;
3795 if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) {
3797 while (unix[len-1] == '/') len--; /* Cosmetic */
3798 sv_usepvn(libdir,unix,len);
3801 PerlIO_printf(Perl_error_log,
3802 "Failed to unixify @INC element \"%s\"\n",
3806 #ifdef MACOS_TRADITIONAL
3807 #define PERL_AV_SUFFIX_FMT ""
3808 #define PERL_ARCH_FMT "%s:"
3809 #define PERL_ARCH_FMT_PATH PERL_FS_VER_FMT PERL_AV_SUFFIX_FMT
3811 #define PERL_AV_SUFFIX_FMT "/"
3812 #define PERL_ARCH_FMT "/%s"
3813 #define PERL_ARCH_FMT_PATH PERL_AV_SUFFIX_FMT PERL_FS_VER_FMT
3815 /* .../version/archname if -d .../version/archname */
3816 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH PERL_ARCH_FMT,
3818 (int)PERL_REVISION, (int)PERL_VERSION,
3819 (int)PERL_SUBVERSION, ARCHNAME);
3820 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3821 S_ISDIR(tmpstatbuf.st_mode))
3822 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3824 /* .../version if -d .../version */
3825 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH, libdir,
3826 (int)PERL_REVISION, (int)PERL_VERSION,
3827 (int)PERL_SUBVERSION);
3828 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3829 S_ISDIR(tmpstatbuf.st_mode))
3830 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3832 /* .../archname if -d .../archname */
3833 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, ARCHNAME);
3834 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3835 S_ISDIR(tmpstatbuf.st_mode))
3836 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3839 #ifdef PERL_INC_VERSION_LIST
3841 for (incver = incverlist; *incver; incver++) {
3842 /* .../xxx if -d .../xxx */
3843 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, *incver);
3844 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3845 S_ISDIR(tmpstatbuf.st_mode))
3846 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3852 /* finally push this lib directory on the end of @INC */
3853 av_push(GvAVn(PL_incgv), libdir);
3857 #ifdef USE_5005THREADS
3858 STATIC struct perl_thread *
3859 S_init_main_thread(pTHX)
3861 #if !defined(PERL_IMPLICIT_CONTEXT)
3862 struct perl_thread *thr;
3866 Newz(53, thr, 1, struct perl_thread);
3867 PL_curcop = &PL_compiling;
3868 thr->interp = PERL_GET_INTERP;
3869 thr->cvcache = newHV();
3870 thr->threadsv = newAV();
3871 /* thr->threadsvp is set when find_threadsv is called */
3872 thr->specific = newAV();
3873 thr->flags = THRf_R_JOINABLE;
3874 MUTEX_INIT(&thr->mutex);
3875 /* Handcraft thrsv similarly to mess_sv */
3876 New(53, PL_thrsv, 1, SV);
3877 Newz(53, xpv, 1, XPV);
3878 SvFLAGS(PL_thrsv) = SVt_PV;
3879 SvANY(PL_thrsv) = (void*)xpv;
3880 SvREFCNT(PL_thrsv) = 1 << 30; /* practically infinite */
3881 SvPVX(PL_thrsv) = (char*)thr;
3882 SvCUR_set(PL_thrsv, sizeof(thr));
3883 SvLEN_set(PL_thrsv, sizeof(thr));
3884 *SvEND(PL_thrsv) = '\0'; /* in the trailing_nul field */
3885 thr->oursv = PL_thrsv;
3886 PL_chopset = " \n-";
3889 MUTEX_LOCK(&PL_threads_mutex);
3895 MUTEX_UNLOCK(&PL_threads_mutex);
3897 #ifdef HAVE_THREAD_INTERN
3898 Perl_init_thread_intern(thr);
3901 #ifdef SET_THREAD_SELF
3902 SET_THREAD_SELF(thr);
3904 thr->self = pthread_self();
3905 #endif /* SET_THREAD_SELF */
3909 * These must come after the thread self setting
3910 * because sv_setpvn does SvTAINT and the taint
3911 * fields thread selfness being set.
3913 PL_toptarget = NEWSV(0,0);
3914 sv_upgrade(PL_toptarget, SVt_PVFM);
3915 sv_setpvn(PL_toptarget, "", 0);
3916 PL_bodytarget = NEWSV(0,0);
3917 sv_upgrade(PL_bodytarget, SVt_PVFM);
3918 sv_setpvn(PL_bodytarget, "", 0);
3919 PL_formtarget = PL_bodytarget;
3920 thr->errsv = newSVpvn("", 0);
3921 (void) find_threadsv("@"); /* Ensure $@ is initialised early */
3924 PL_peepp = MEMBER_TO_FPTR(Perl_peep);
3925 PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
3926 PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
3927 PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
3928 PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
3929 PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
3931 PL_reginterp_cnt = 0;
3935 #endif /* USE_5005THREADS */
3938 Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
3941 line_t oldline = CopLINE(PL_curcop);
3947 while (AvFILL(paramList) >= 0) {
3948 cv = (CV*)av_shift(paramList);
3949 if (PL_savebegin && (paramList == PL_beginav)) {
3950 /* save PL_beginav for compiler */
3951 if (! PL_beginav_save)
3952 PL_beginav_save = newAV();
3953 av_push(PL_beginav_save, (SV*)cv);
3957 #ifdef PERL_FLEXIBLE_EXCEPTIONS
3958 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_list_body), cv);
3964 #ifndef PERL_FLEXIBLE_EXCEPTIONS
3968 (void)SvPV(atsv, len);
3971 PL_curcop = &PL_compiling;
3972 CopLINE_set(PL_curcop, oldline);
3973 if (paramList == PL_beginav)
3974 sv_catpv(atsv, "BEGIN failed--compilation aborted");
3976 Perl_sv_catpvf(aTHX_ atsv,
3977 "%s failed--call queue aborted",
3978 paramList == PL_checkav ? "CHECK"
3979 : paramList == PL_initav ? "INIT"
3981 while (PL_scopestack_ix > oldscope)
3984 Perl_croak(aTHX_ "%s", SvPVx(atsv, n_a));
3991 /* my_exit() was called */
3992 while (PL_scopestack_ix > oldscope)
3995 PL_curstash = PL_defstash;
3996 PL_curcop = &PL_compiling;
3997 CopLINE_set(PL_curcop, oldline);
3999 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) {
4000 if (paramList == PL_beginav)
4001 Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
4003 Perl_croak(aTHX_ "%s failed--call queue aborted",
4004 paramList == PL_checkav ? "CHECK"
4005 : paramList == PL_initav ? "INIT"
4012 PL_curcop = &PL_compiling;
4013 CopLINE_set(PL_curcop, oldline);
4016 PerlIO_printf(Perl_error_log, "panic: restartop\n");
4024 #ifdef PERL_FLEXIBLE_EXCEPTIONS
4026 S_vcall_list_body(pTHX_ va_list args)
4028 CV *cv = va_arg(args, CV*);
4029 return call_list_body(cv);
4034 S_call_list_body(pTHX_ CV *cv)
4036 PUSHMARK(PL_stack_sp);
4037 call_sv((SV*)cv, G_EVAL|G_DISCARD);
4042 Perl_my_exit(pTHX_ U32 status)
4044 DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
4045 thr, (unsigned long) status));
4054 STATUS_NATIVE_SET(status);
4061 Perl_my_failure_exit(pTHX)
4064 if (vaxc$errno & 1) {
4065 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
4066 STATUS_NATIVE_SET(44);
4069 if (!vaxc$errno && errno) /* unlikely */
4070 STATUS_NATIVE_SET(44);
4072 STATUS_NATIVE_SET(vaxc$errno);
4077 STATUS_POSIX_SET(errno);
4079 exitstatus = STATUS_POSIX >> 8;
4080 if (exitstatus & 255)
4081 STATUS_POSIX_SET(exitstatus);
4083 STATUS_POSIX_SET(255);
4090 S_my_exit_jump(pTHX)
4092 register PERL_CONTEXT *cx;
4097 SvREFCNT_dec(PL_e_script);
4098 PL_e_script = Nullsv;
4101 POPSTACK_TO(PL_mainstack);
4102 if (cxstack_ix >= 0) {
4105 POPBLOCK(cx,PL_curpm);
4113 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen)
4116 p = SvPVX(PL_e_script);
4117 nl = strchr(p, '\n');
4118 nl = (nl) ? nl+1 : SvEND(PL_e_script);
4120 filter_del(read_e_script);
4123 sv_catpvn(buf_sv, p, nl-p);
4124 sv_chop(PL_e_script, nl);