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%s syntax OK\n",
1652 (gMacPerl_ErrorFormat ? "# " : ""),
1653 MacPerl_MPWFileName(PL_origfilename));
1655 PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
1659 if (PERLDB_SINGLE && PL_DBsingle)
1660 sv_setiv(PL_DBsingle, 1);
1662 call_list(oldscope, PL_initav);
1668 PL_op = PL_restartop;
1672 else if (PL_main_start) {
1673 CvDEPTH(PL_main_cv) = 1;
1674 PL_op = PL_main_start;
1684 =head1 SV Manipulation Functions
1686 =for apidoc p||get_sv
1688 Returns the SV of the specified Perl scalar. If C<create> is set and the
1689 Perl variable does not exist then it will be created. If C<create> is not
1690 set and the variable does not exist then NULL is returned.
1696 Perl_get_sv(pTHX_ const char *name, I32 create)
1699 #ifdef USE_5005THREADS
1700 if (name[1] == '\0' && !isALPHA(name[0])) {
1701 PADOFFSET tmp = find_threadsv(name);
1702 if (tmp != NOT_IN_PAD)
1703 return THREADSV(tmp);
1705 #endif /* USE_5005THREADS */
1706 gv = gv_fetchpv(name, create, SVt_PV);
1713 =head1 Array Manipulation Functions
1715 =for apidoc p||get_av
1717 Returns the AV of the specified Perl array. If C<create> is set and the
1718 Perl variable does not exist then it will be created. If C<create> is not
1719 set and the variable does not exist then NULL is returned.
1725 Perl_get_av(pTHX_ const char *name, I32 create)
1727 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1736 =head1 Hash Manipulation Functions
1738 =for apidoc p||get_hv
1740 Returns the HV of the specified Perl hash. If C<create> is set and the
1741 Perl variable does not exist then it will be created. If C<create> is not
1742 set and the variable does not exist then NULL is returned.
1748 Perl_get_hv(pTHX_ const char *name, I32 create)
1750 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1759 =head1 CV Manipulation Functions
1761 =for apidoc p||get_cv
1763 Returns the CV of the specified Perl subroutine. If C<create> is set and
1764 the Perl subroutine does not exist then it will be declared (which has the
1765 same effect as saying C<sub name;>). If C<create> is not set and the
1766 subroutine does not exist then NULL is returned.
1772 Perl_get_cv(pTHX_ const char *name, I32 create)
1774 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
1775 /* XXX unsafe for threads if eval_owner isn't held */
1776 /* XXX this is probably not what they think they're getting.
1777 * It has the same effect as "sub name;", i.e. just a forward
1779 if (create && !GvCVu(gv))
1780 return newSUB(start_subparse(FALSE, 0),
1781 newSVOP(OP_CONST, 0, newSVpv(name,0)),
1789 /* Be sure to refetch the stack pointer after calling these routines. */
1793 =head1 Callback Functions
1795 =for apidoc p||call_argv
1797 Performs a callback to the specified Perl sub. See L<perlcall>.
1803 Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv)
1805 /* See G_* flags in cop.h */
1806 /* null terminated arg list */
1813 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
1818 return call_pv(sub_name, flags);
1822 =for apidoc p||call_pv
1824 Performs a callback to the specified Perl sub. See L<perlcall>.
1830 Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
1831 /* name of the subroutine */
1832 /* See G_* flags in cop.h */
1834 return call_sv((SV*)get_cv(sub_name, TRUE), flags);
1838 =for apidoc p||call_method
1840 Performs a callback to the specified Perl method. The blessed object must
1841 be on the stack. See L<perlcall>.
1847 Perl_call_method(pTHX_ const char *methname, I32 flags)
1848 /* name of the subroutine */
1849 /* See G_* flags in cop.h */
1851 return call_sv(sv_2mortal(newSVpv(methname,0)), flags | G_METHOD);
1854 /* May be called with any of a CV, a GV, or an SV containing the name. */
1856 =for apidoc p||call_sv
1858 Performs a callback to the Perl sub whose name is in the SV. See
1865 Perl_call_sv(pTHX_ SV *sv, I32 flags)
1866 /* See G_* flags in cop.h */
1869 LOGOP myop; /* fake syntax tree node */
1872 volatile I32 retval = 0;
1874 bool oldcatch = CATCH_GET;
1879 if (flags & G_DISCARD) {
1884 Zero(&myop, 1, LOGOP);
1885 myop.op_next = Nullop;
1886 if (!(flags & G_NOARGS))
1887 myop.op_flags |= OPf_STACKED;
1888 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1889 (flags & G_ARRAY) ? OPf_WANT_LIST :
1894 EXTEND(PL_stack_sp, 1);
1895 *++PL_stack_sp = sv;
1897 oldscope = PL_scopestack_ix;
1899 if (PERLDB_SUB && PL_curstash != PL_debstash
1900 /* Handle first BEGIN of -d. */
1901 && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
1902 /* Try harder, since this may have been a sighandler, thus
1903 * curstash may be meaningless. */
1904 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != PL_debstash)
1905 && !(flags & G_NODEBUG))
1906 PL_op->op_private |= OPpENTERSUB_DB;
1908 if (flags & G_METHOD) {
1909 Zero(&method_op, 1, UNOP);
1910 method_op.op_next = PL_op;
1911 method_op.op_ppaddr = PL_ppaddr[OP_METHOD];
1912 myop.op_ppaddr = PL_ppaddr[OP_ENTERSUB];
1913 PL_op = (OP*)&method_op;
1916 if (!(flags & G_EVAL)) {
1918 call_body((OP*)&myop, FALSE);
1919 retval = PL_stack_sp - (PL_stack_base + oldmark);
1920 CATCH_SET(oldcatch);
1923 myop.op_other = (OP*)&myop;
1925 /* we're trying to emulate pp_entertry() here */
1927 register PERL_CONTEXT *cx;
1928 I32 gimme = GIMME_V;
1933 push_return(Nullop);
1934 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
1936 PL_eval_root = PL_op; /* Only needed so that goto works right. */
1938 PL_in_eval = EVAL_INEVAL;
1939 if (flags & G_KEEPERR)
1940 PL_in_eval |= EVAL_KEEPERR;
1946 #ifdef PERL_FLEXIBLE_EXCEPTIONS
1948 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_body),
1955 #ifndef PERL_FLEXIBLE_EXCEPTIONS
1957 call_body((OP*)&myop, FALSE);
1959 retval = PL_stack_sp - (PL_stack_base + oldmark);
1960 if (!(flags & G_KEEPERR))
1967 /* my_exit() was called */
1968 PL_curstash = PL_defstash;
1971 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
1972 Perl_croak(aTHX_ "Callback called exit");
1977 PL_op = PL_restartop;
1981 PL_stack_sp = PL_stack_base + oldmark;
1982 if (flags & G_ARRAY)
1986 *++PL_stack_sp = &PL_sv_undef;
1991 if (PL_scopestack_ix > oldscope) {
1995 register PERL_CONTEXT *cx;
2007 if (flags & G_DISCARD) {
2008 PL_stack_sp = PL_stack_base + oldmark;
2017 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2019 S_vcall_body(pTHX_ va_list args)
2021 OP *myop = va_arg(args, OP*);
2022 int is_eval = va_arg(args, int);
2024 call_body(myop, is_eval);
2030 S_call_body(pTHX_ OP *myop, int is_eval)
2032 if (PL_op == myop) {
2034 PL_op = Perl_pp_entereval(aTHX); /* this doesn't do a POPMARK */
2036 PL_op = Perl_pp_entersub(aTHX); /* this does */
2042 /* Eval a string. The G_EVAL flag is always assumed. */
2045 =for apidoc p||eval_sv
2047 Tells Perl to C<eval> the string in the SV.
2053 Perl_eval_sv(pTHX_ SV *sv, I32 flags)
2055 /* See G_* flags in cop.h */
2058 UNOP myop; /* fake syntax tree node */
2059 volatile I32 oldmark = SP - PL_stack_base;
2060 volatile I32 retval = 0;
2066 if (flags & G_DISCARD) {
2073 Zero(PL_op, 1, UNOP);
2074 EXTEND(PL_stack_sp, 1);
2075 *++PL_stack_sp = sv;
2076 oldscope = PL_scopestack_ix;
2078 if (!(flags & G_NOARGS))
2079 myop.op_flags = OPf_STACKED;
2080 myop.op_next = Nullop;
2081 myop.op_type = OP_ENTEREVAL;
2082 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
2083 (flags & G_ARRAY) ? OPf_WANT_LIST :
2085 if (flags & G_KEEPERR)
2086 myop.op_flags |= OPf_SPECIAL;
2088 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2090 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_body),
2097 #ifndef PERL_FLEXIBLE_EXCEPTIONS
2099 call_body((OP*)&myop,TRUE);
2101 retval = PL_stack_sp - (PL_stack_base + oldmark);
2102 if (!(flags & G_KEEPERR))
2109 /* my_exit() was called */
2110 PL_curstash = PL_defstash;
2113 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
2114 Perl_croak(aTHX_ "Callback called exit");
2119 PL_op = PL_restartop;
2123 PL_stack_sp = PL_stack_base + oldmark;
2124 if (flags & G_ARRAY)
2128 *++PL_stack_sp = &PL_sv_undef;
2134 if (flags & G_DISCARD) {
2135 PL_stack_sp = PL_stack_base + oldmark;
2145 =for apidoc p||eval_pv
2147 Tells Perl to C<eval> the given string and return an SV* result.
2153 Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
2156 SV* sv = newSVpv(p, 0);
2158 eval_sv(sv, G_SCALAR);
2165 if (croak_on_error && SvTRUE(ERRSV)) {
2167 Perl_croak(aTHX_ SvPVx(ERRSV, n_a));
2173 /* Require a module. */
2176 =head1 Embedding Functions
2178 =for apidoc p||require_pv
2180 Tells Perl to C<require> the file named by the string argument. It is
2181 analogous to the Perl code C<eval "require '$file'">. It's even
2182 implemented that way; consider using Perl_load_module instead.
2187 Perl_require_pv(pTHX_ const char *pv)
2191 PUSHSTACKi(PERLSI_REQUIRE);
2193 sv = sv_newmortal();
2194 sv_setpv(sv, "require '");
2197 eval_sv(sv, G_DISCARD);
2203 Perl_magicname(pTHX_ char *sym, char *name, I32 namlen)
2207 if ((gv = gv_fetchpv(sym,TRUE, SVt_PV)))
2208 sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, namlen);
2212 S_usage(pTHX_ char *name) /* XXX move this out into a module ? */
2214 /* This message really ought to be max 23 lines.
2215 * Removed -h because the user already knows that option. Others? */
2217 static char *usage_msg[] = {
2218 "-0[octal] specify record separator (\\0, if no argument)",
2219 "-a autosplit mode with -n or -p (splits $_ into @F)",
2220 "-C enable native wide character system interfaces",
2221 "-c check syntax only (runs BEGIN and CHECK blocks)",
2222 "-d[:debugger] run program under debugger",
2223 "-D[number/list] set debugging flags (argument is a bit mask or alphabets)",
2224 "-e 'command' one line of program (several -e's allowed, omit programfile)",
2225 "-F/pattern/ split() pattern for -a switch (//'s are optional)",
2226 "-i[extension] edit <> files in place (makes backup if extension supplied)",
2227 "-Idirectory specify @INC/#include directory (several -I's allowed)",
2228 "-l[octal] enable line ending processing, specifies line terminator",
2229 "-[mM][-]module execute `use/no module...' before executing program",
2230 "-n assume 'while (<>) { ... }' loop around program",
2231 "-p assume loop like -n but print line also, like sed",
2232 "-P run program through C preprocessor before compilation",
2233 "-s enable rudimentary parsing for switches after programfile",
2234 "-S look for programfile using PATH environment variable",
2235 "-T enable tainting checks",
2236 "-t enable tainting warnings",
2237 "-u dump core after parsing program",
2238 "-U allow unsafe operations",
2239 "-v print version, subversion (includes VERY IMPORTANT perl info)",
2240 "-V[:variable] print configuration summary (or a single Config.pm variable)",
2241 "-w enable many useful warnings (RECOMMENDED)",
2242 "-W enable all warnings",
2243 "-X disable all warnings",
2244 "-x[directory] strip off text before #!perl line and perhaps cd to directory",
2248 char **p = usage_msg;
2250 PerlIO_printf(PerlIO_stdout(),
2251 "\nUsage: %s [switches] [--] [programfile] [arguments]",
2254 PerlIO_printf(PerlIO_stdout(), "\n %s", *p++);
2257 /* This routine handles any switches that can be given during run */
2260 Perl_moreswitches(pTHX_ char *s)
2270 rschar = (U32)grok_oct(s, &numlen, &flags, NULL);
2271 SvREFCNT_dec(PL_rs);
2272 if (rschar & ~((U8)~0))
2273 PL_rs = &PL_sv_undef;
2274 else if (!rschar && numlen >= 2)
2275 PL_rs = newSVpvn("", 0);
2277 char ch = (char)rschar;
2278 PL_rs = newSVpvn(&ch, 1);
2283 PL_widesyscalls = TRUE;
2289 while (*s && !isSPACE(*s)) ++s;
2291 PL_splitstr = savepv(PL_splitstr);
2304 /* The following permits -d:Mod to accepts arguments following an =
2305 in the fashion that -MSome::Mod does. */
2306 if (*s == ':' || *s == '=') {
2309 sv = newSVpv("use Devel::", 0);
2311 /* We now allow -d:Module=Foo,Bar */
2312 while(isALNUM(*s) || *s==':') ++s;
2314 sv_catpv(sv, start);
2316 sv_catpvn(sv, start, s-start);
2317 sv_catpv(sv, " split(/,/,q{");
2322 my_setenv("PERL5DB", SvPV(sv, PL_na));
2325 PL_perldb = PERLDB_ALL;
2333 if (isALPHA(s[1])) {
2334 /* if adding extra options, remember to update DEBUG_MASK */
2335 static char debopts[] = "psltocPmfrxuLHXDSTRJ";
2338 for (s++; *s && (d = strchr(debopts,*s)); s++)
2339 PL_debug |= 1 << (d - debopts);
2342 PL_debug = atoi(s+1);
2343 for (s++; isDIGIT(*s); s++) ;
2346 if (DEBUG_p_TEST_ && ckWARN_d(WARN_DEBUGGING))
2347 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
2348 "-Dp not implemented on this platform\n");
2350 PL_debug |= DEBUG_TOP_FLAG;
2351 #else /* !DEBUGGING */
2352 if (ckWARN_d(WARN_DEBUGGING))
2353 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
2354 "Recompile perl with -DDEBUGGING to use -D switch\n");
2355 for (s++; isALNUM(*s); s++) ;
2361 usage(PL_origargv[0]);
2365 Safefree(PL_inplace);
2366 #if defined(__CYGWIN__) /* do backup extension automagically */
2367 if (*(s+1) == '\0') {
2368 PL_inplace = savepv(".bak");
2371 #endif /* __CYGWIN__ */
2372 PL_inplace = savepv(s+1);
2374 for (s = PL_inplace; *s && !isSPACE(*s); s++) ;
2377 if (*s == '-') /* Additional switches on #! line. */
2381 case 'I': /* -I handled both here and in parse_body() */
2384 while (*s && isSPACE(*s))
2389 /* ignore trailing spaces (possibly followed by other switches) */
2391 for (e = p; *e && !isSPACE(*e); e++) ;
2395 } while (*p && *p != '-');
2396 e = savepvn(s, e-s);
2397 incpush(e, TRUE, TRUE);
2404 Perl_croak(aTHX_ "No directory specified for -I");
2410 SvREFCNT_dec(PL_ors_sv);
2415 PL_ors_sv = newSVpvn("\n",1);
2416 numlen = 3 + (*s == '0');
2417 *SvPVX(PL_ors_sv) = (char)grok_oct(s, &numlen, &flags, NULL);
2421 if (RsPARA(PL_rs)) {
2422 PL_ors_sv = newSVpvn("\n\n",2);
2425 PL_ors_sv = newSVsv(PL_rs);
2430 forbid_setid("-M"); /* XXX ? */
2433 forbid_setid("-m"); /* XXX ? */
2438 /* -M-foo == 'no foo' */
2439 if (*s == '-') { use = "no "; ++s; }
2440 sv = newSVpv(use,0);
2442 /* We allow -M'Module qw(Foo Bar)' */
2443 while(isALNUM(*s) || *s==':') ++s;
2445 sv_catpv(sv, start);
2446 if (*(start-1) == 'm') {
2448 Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
2449 sv_catpv( sv, " ()");
2453 Perl_croak(aTHX_ "Module name required with -%c option",
2455 sv_catpvn(sv, start, s-start);
2456 sv_catpv(sv, " split(/,/,q{");
2462 PL_preambleav = newAV();
2463 av_push(PL_preambleav, sv);
2466 Perl_croak(aTHX_ "No space allowed after -%c", *(s-1));
2478 PL_doswitches = TRUE;
2483 Perl_croak(aTHX_ "Too late for \"-t\" option");
2488 Perl_croak(aTHX_ "Too late for \"-T\" option");
2492 #ifdef MACOS_TRADITIONAL
2493 Perl_croak(aTHX_ "Believe me, you don't want to use \"-u\" on a Macintosh");
2495 PL_do_undump = TRUE;
2504 PerlIO_printf(PerlIO_stdout(),
2505 Perl_form(aTHX_ "\nThis is perl, v%"VDf" built for %s",
2506 PL_patchlevel, ARCHNAME));
2508 /* Adjust verbose output as in the perl that ships with the DG/UX OS from EMC */
2509 PerlIO_printf(PerlIO_stdout(),
2510 Perl_form(aTHX_ "\nThis is perl, version %vd\n", PL_patchlevel));
2511 PerlIO_printf(PerlIO_stdout(),
2512 Perl_form(aTHX_ " built under %s at %s %s\n",
2513 OSNAME, __DATE__, __TIME__));
2514 PerlIO_printf(PerlIO_stdout(),
2515 Perl_form(aTHX_ " OS Specific Release: %s\n",
2519 #if defined(LOCAL_PATCH_COUNT)
2520 if (LOCAL_PATCH_COUNT > 0)
2521 PerlIO_printf(PerlIO_stdout(),
2522 "\n(with %d registered patch%s, "
2523 "see perl -V for more detail)",
2524 (int)LOCAL_PATCH_COUNT,
2525 (LOCAL_PATCH_COUNT!=1) ? "es" : "");
2528 PerlIO_printf(PerlIO_stdout(),
2529 "\n\nCopyright 1987-2002, Larry Wall\n");
2530 #ifdef MACOS_TRADITIONAL
2531 PerlIO_printf(PerlIO_stdout(),
2532 "\nMac OS port Copyright 1991-2002, Matthias Neeracher;\n"
2533 "maintained by Chris Nandor\n");
2536 PerlIO_printf(PerlIO_stdout(),
2537 "\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
2540 PerlIO_printf(PerlIO_stdout(),
2541 "djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n"
2542 "djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
2545 PerlIO_printf(PerlIO_stdout(),
2546 "\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
2547 "Version 5 port Copyright (c) 1994-2002, Andreas Kaiser, Ilya Zakharevich\n");
2550 PerlIO_printf(PerlIO_stdout(),
2551 "atariST series port, ++jrb bammi@cadence.com\n");
2554 PerlIO_printf(PerlIO_stdout(),
2555 "BeOS port Copyright Tom Spindler, 1997-1999\n");
2558 PerlIO_printf(PerlIO_stdout(),
2559 "MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-2002\n");
2562 PerlIO_printf(PerlIO_stdout(),
2563 "MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
2566 PerlIO_printf(PerlIO_stdout(),
2567 "Stratus VOS port by Paul.Green@stratus.com, 1997-2002\n");
2570 PerlIO_printf(PerlIO_stdout(),
2571 "VM/ESA port by Neale Ferguson, 1998-1999\n");
2574 PerlIO_printf(PerlIO_stdout(),
2575 "BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
2578 PerlIO_printf(PerlIO_stdout(),
2579 "MiNT port by Guido Flohr, 1997-1999\n");
2582 PerlIO_printf(PerlIO_stdout(),
2583 "EPOC port by Olaf Flebbe, 1999-2002\n");
2586 printf("WINCE port by Rainer Keuchel, 2001-2002\n");
2587 printf("Built on " __DATE__ " " __TIME__ "\n\n");
2590 #ifdef BINARY_BUILD_NOTICE
2591 BINARY_BUILD_NOTICE;
2593 PerlIO_printf(PerlIO_stdout(),
2595 Perl may be copied only under the terms of either the Artistic License or the\n\
2596 GNU General Public License, which may be found in the Perl 5 source kit.\n\n\
2597 Complete documentation for Perl, including FAQ lists, should be found on\n\
2598 this system using `man perl' or `perldoc perl'. If you have access to the\n\
2599 Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
2602 if (! (PL_dowarn & G_WARN_ALL_MASK))
2603 PL_dowarn |= G_WARN_ON;
2607 PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
2608 if (!specialWARN(PL_compiling.cop_warnings))
2609 SvREFCNT_dec(PL_compiling.cop_warnings);
2610 PL_compiling.cop_warnings = pWARN_ALL ;
2614 PL_dowarn = G_WARN_ALL_OFF;
2615 if (!specialWARN(PL_compiling.cop_warnings))
2616 SvREFCNT_dec(PL_compiling.cop_warnings);
2617 PL_compiling.cop_warnings = pWARN_NONE ;
2622 if (s[1] == '-') /* Additional switches on #! line. */
2627 #if defined(WIN32) || !defined(PERL_STRICT_CR)
2633 #ifdef ALTERNATE_SHEBANG
2634 case 'S': /* OS/2 needs -S on "extproc" line. */
2642 Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
2647 /* compliments of Tom Christiansen */
2649 /* unexec() can be found in the Gnu emacs distribution */
2650 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
2653 Perl_my_unexec(pTHX)
2661 prog = newSVpv(BIN_EXP, 0);
2662 sv_catpv(prog, "/perl");
2663 file = newSVpv(PL_origfilename, 0);
2664 sv_catpv(file, ".perldump");
2666 unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
2667 /* unexec prints msg to stderr in case of failure */
2668 PerlProc_exit(status);
2671 # include <lib$routines.h>
2672 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
2674 ABORT(); /* for use with undump */
2679 /* initialize curinterp */
2685 # define PERLVAR(var,type)
2686 # define PERLVARA(var,n,type)
2687 # if defined(PERL_IMPLICIT_CONTEXT)
2688 # if defined(USE_5005THREADS)
2689 # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
2690 # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
2691 # else /* !USE_5005THREADS */
2692 # define PERLVARI(var,type,init) aTHX->var = init;
2693 # define PERLVARIC(var,type,init) aTHX->var = init;
2694 # endif /* USE_5005THREADS */
2696 # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
2697 # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
2699 # include "intrpvar.h"
2700 # ifndef USE_5005THREADS
2701 # include "thrdvar.h"
2708 # define PERLVAR(var,type)
2709 # define PERLVARA(var,n,type)
2710 # define PERLVARI(var,type,init) PL_##var = init;
2711 # define PERLVARIC(var,type,init) PL_##var = init;
2712 # include "intrpvar.h"
2713 # ifndef USE_5005THREADS
2714 # include "thrdvar.h"
2725 S_init_main_stash(pTHX)
2729 PL_curstash = PL_defstash = newHV();
2730 PL_curstname = newSVpvn("main",4);
2731 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
2732 SvREFCNT_dec(GvHV(gv));
2733 GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
2735 HvNAME(PL_defstash) = savepv("main");
2736 PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
2737 GvMULTI_on(PL_incgv);
2738 PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
2739 GvMULTI_on(PL_hintgv);
2740 PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
2741 PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
2742 GvMULTI_on(PL_errgv);
2743 PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
2744 GvMULTI_on(PL_replgv);
2745 (void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */
2746 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
2747 sv_setpvn(ERRSV, "", 0);
2748 PL_curstash = PL_defstash;
2749 CopSTASH_set(&PL_compiling, PL_defstash);
2750 PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
2751 PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
2752 PL_nullstash = GvHV(gv_fetchpv("<none>::", GV_ADDMULTI, SVt_PVHV));
2753 /* We must init $/ before switches are processed. */
2754 sv_setpvn(get_sv("/", TRUE), "\n", 1);
2758 S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
2762 char *cpp_discard_flag;
2768 PL_origfilename = savepv("-e");
2771 /* if find_script() returns, it returns a malloc()-ed value */
2772 PL_origfilename = scriptname = find_script(scriptname, dosearch, NULL, 1);
2774 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
2775 char *s = scriptname + 8;
2776 *fdscript = atoi(s);
2780 scriptname = savepv(s + 1);
2781 Safefree(PL_origfilename);
2782 PL_origfilename = scriptname;
2787 CopFILE_free(PL_curcop);
2788 CopFILE_set(PL_curcop, PL_origfilename);
2789 if (strEQ(PL_origfilename,"-"))
2791 if (*fdscript >= 0) {
2792 PL_rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE);
2793 # if defined(HAS_FCNTL) && defined(F_SETFD)
2795 /* ensure close-on-exec */
2796 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
2799 else if (PL_preprocess) {
2800 char *cpp_cfg = CPPSTDIN;
2801 SV *cpp = newSVpvn("",0);
2802 SV *cmd = NEWSV(0,0);
2804 if (strEQ(cpp_cfg, "cppstdin"))
2805 Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
2806 sv_catpv(cpp, cpp_cfg);
2809 sv_catpvn(sv, "-I", 2);
2810 sv_catpv(sv,PRIVLIB_EXP);
2813 DEBUG_P(PerlIO_printf(Perl_debug_log,
2814 "PL_preprocess: scriptname=\"%s\", cpp=\"%s\", sv=\"%s\", CPPMINUS=\"%s\"\n",
2815 scriptname, SvPVX (cpp), SvPVX (sv), CPPMINUS));
2817 # if defined(MSDOS) || defined(WIN32) || defined(VMS)
2824 cpp_discard_flag = "";
2826 cpp_discard_flag = "-C";
2830 perl = os2_execname(aTHX);
2832 perl = PL_origargv[0];
2836 /* This strips off Perl comments which might interfere with
2837 the C pre-processor, including #!. #line directives are
2838 deliberately stripped to avoid confusion with Perl's version
2839 of #line. FWP played some golf with it so it will fit
2840 into VMS's 255 character buffer.
2843 code = "(1../^#!.*perl/i)|/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print";
2845 code = "/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print";
2847 Perl_sv_setpvf(aTHX_ cmd, "\
2848 %s -ne%s%s%s %s | %"SVf" %s %"SVf" %s",
2849 perl, quote, code, quote, scriptname, cpp,
2850 cpp_discard_flag, sv, CPPMINUS);
2852 PL_doextract = FALSE;
2853 # ifdef IAMSUID /* actually, this is caught earlier */
2854 if (PL_euid != PL_uid && !PL_euid) { /* if running suidperl */
2856 (void)seteuid(PL_uid); /* musn't stay setuid root */
2858 # ifdef HAS_SETREUID
2859 (void)setreuid((Uid_t)-1, PL_uid);
2861 # ifdef HAS_SETRESUID
2862 (void)setresuid((Uid_t)-1, PL_uid, (Uid_t)-1);
2864 PerlProc_setuid(PL_uid);
2868 if (PerlProc_geteuid() != PL_uid)
2869 Perl_croak(aTHX_ "Can't do seteuid!\n");
2871 # endif /* IAMSUID */
2873 DEBUG_P(PerlIO_printf(Perl_debug_log,
2874 "PL_preprocess: cmd=\"%s\"\n",
2877 PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
2881 else if (!*scriptname) {
2882 forbid_setid("program input from stdin");
2883 PL_rsfp = PerlIO_stdin();
2886 PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
2887 # if defined(HAS_FCNTL) && defined(F_SETFD)
2889 /* ensure close-on-exec */
2890 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
2895 # ifndef IAMSUID /* in case script is not readable before setuid */
2897 PerlLIO_stat(CopFILE(PL_curcop),&PL_statbuf) >= 0 &&
2898 PL_statbuf.st_mode & (S_ISUID|S_ISGID))
2901 PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT,
2902 BIN_EXP, (int)PERL_REVISION,
2904 (int)PERL_SUBVERSION), PL_origargv);
2905 Perl_croak(aTHX_ "Can't do setuid\n");
2911 Perl_croak(aTHX_ "Can't open perl script: %s\n",
2914 Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
2915 CopFILE(PL_curcop), Strerror(errno));
2921 * I_SYSSTATVFS HAS_FSTATVFS
2923 * I_STATFS HAS_FSTATFS HAS_GETFSSTAT
2924 * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT
2925 * here so that metaconfig picks them up. */
2929 S_fd_on_nosuid_fs(pTHX_ int fd)
2931 int check_okay = 0; /* able to do all the required sys/libcalls */
2932 int on_nosuid = 0; /* the fd is on a nosuid fs */
2934 * Preferred order: fstatvfs(), fstatfs(), ustat()+getmnt(), getmntent().
2935 * fstatvfs() is UNIX98.
2936 * fstatfs() is 4.3 BSD.
2937 * ustat()+getmnt() is pre-4.3 BSD.
2938 * getmntent() is O(number-of-mounted-filesystems) and can hang on
2939 * an irrelevant filesystem while trying to reach the right one.
2942 #undef FD_ON_NOSUID_CHECK_OKAY /* found the syscalls to do the check? */
2944 # if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
2945 defined(HAS_FSTATVFS)
2946 # define FD_ON_NOSUID_CHECK_OKAY
2947 struct statvfs stfs;
2949 check_okay = fstatvfs(fd, &stfs) == 0;
2950 on_nosuid = check_okay && (stfs.f_flag & ST_NOSUID);
2951 # endif /* fstatvfs */
2953 # if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
2954 defined(PERL_MOUNT_NOSUID) && \
2955 defined(HAS_FSTATFS) && \
2956 defined(HAS_STRUCT_STATFS) && \
2957 defined(HAS_STRUCT_STATFS_F_FLAGS)
2958 # define FD_ON_NOSUID_CHECK_OKAY
2961 check_okay = fstatfs(fd, &stfs) == 0;
2962 on_nosuid = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
2963 # endif /* fstatfs */
2965 # if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
2966 defined(PERL_MOUNT_NOSUID) && \
2967 defined(HAS_FSTAT) && \
2968 defined(HAS_USTAT) && \
2969 defined(HAS_GETMNT) && \
2970 defined(HAS_STRUCT_FS_DATA) && \
2972 # define FD_ON_NOSUID_CHECK_OKAY
2975 if (fstat(fd, &fdst) == 0) {
2977 if (ustat(fdst.st_dev, &us) == 0) {
2979 /* NOSTAT_ONE here because we're not examining fields which
2980 * vary between that case and STAT_ONE. */
2981 if (getmnt((int*)0, &fsd, (int)0, NOSTAT_ONE, us.f_fname) == 0) {
2982 size_t cmplen = sizeof(us.f_fname);
2983 if (sizeof(fsd.fd_req.path) < cmplen)
2984 cmplen = sizeof(fsd.fd_req.path);
2985 if (strnEQ(fsd.fd_req.path, us.f_fname, cmplen) &&
2986 fdst.st_dev == fsd.fd_req.dev) {
2988 on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID;
2994 # endif /* fstat+ustat+getmnt */
2996 # if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
2997 defined(HAS_GETMNTENT) && \
2998 defined(HAS_HASMNTOPT) && \
2999 defined(MNTOPT_NOSUID)
3000 # define FD_ON_NOSUID_CHECK_OKAY
3001 FILE *mtab = fopen("/etc/mtab", "r");
3002 struct mntent *entry;
3005 if (mtab && (fstat(fd, &stb) == 0)) {
3006 while (entry = getmntent(mtab)) {
3007 if (stat(entry->mnt_dir, &fsb) == 0
3008 && fsb.st_dev == stb.st_dev)
3010 /* found the filesystem */
3012 if (hasmntopt(entry, MNTOPT_NOSUID))
3015 } /* A single fs may well fail its stat(). */
3020 # endif /* getmntent+hasmntopt */
3023 Perl_croak(aTHX_ "Can't check filesystem of script \"%s\" for nosuid", PL_origfilename);
3026 #endif /* IAMSUID */
3029 S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript)
3035 /* do we need to emulate setuid on scripts? */
3037 /* This code is for those BSD systems that have setuid #! scripts disabled
3038 * in the kernel because of a security problem. Merely defining DOSUID
3039 * in perl will not fix that problem, but if you have disabled setuid
3040 * scripts in the kernel, this will attempt to emulate setuid and setgid
3041 * on scripts that have those now-otherwise-useless bits set. The setuid
3042 * root version must be called suidperl or sperlN.NNN. If regular perl
3043 * discovers that it has opened a setuid script, it calls suidperl with
3044 * the same argv that it had. If suidperl finds that the script it has
3045 * just opened is NOT setuid root, it sets the effective uid back to the
3046 * uid. We don't just make perl setuid root because that loses the
3047 * effective uid we had before invoking perl, if it was different from the
3050 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
3051 * be defined in suidperl only. suidperl must be setuid root. The
3052 * Configure script will set this up for you if you want it.
3058 if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */
3059 Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
3060 if (fdscript < 0 && PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
3065 #ifndef HAS_SETREUID
3066 /* On this access check to make sure the directories are readable,
3067 * there is actually a small window that the user could use to make
3068 * filename point to an accessible directory. So there is a faint
3069 * chance that someone could execute a setuid script down in a
3070 * non-accessible directory. I don't know what to do about that.
3071 * But I don't think it's too important. The manual lies when
3072 * it says access() is useful in setuid programs.
3074 if (PerlLIO_access(CopFILE(PL_curcop),1)) /*double check*/
3075 Perl_croak(aTHX_ "Permission denied");
3077 /* If we can swap euid and uid, then we can determine access rights
3078 * with a simple stat of the file, and then compare device and
3079 * inode to make sure we did stat() on the same file we opened.
3080 * Then we just have to make sure he or she can execute it.
3087 setreuid(PL_euid,PL_uid) < 0
3090 setresuid(PL_euid,PL_uid,(Uid_t)-1) < 0
3093 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
3094 Perl_croak(aTHX_ "Can't swap uid and euid"); /* really paranoid */
3095 if (PerlLIO_stat(CopFILE(PL_curcop),&tmpstatbuf) < 0)
3096 Perl_croak(aTHX_ "Permission denied"); /* testing full pathname here */
3097 #if defined(IAMSUID) && !defined(NO_NOSUID_CHECK)
3098 if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp)))
3099 Perl_croak(aTHX_ "Permission denied");
3101 if (tmpstatbuf.st_dev != PL_statbuf.st_dev ||
3102 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
3103 (void)PerlIO_close(PL_rsfp);
3104 Perl_croak(aTHX_ "Permission denied\n");
3108 setreuid(PL_uid,PL_euid) < 0
3110 # if defined(HAS_SETRESUID)
3111 setresuid(PL_uid,PL_euid,(Uid_t)-1) < 0
3114 || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
3115 Perl_croak(aTHX_ "Can't reswap uid and euid");
3116 if (!cando(S_IXUSR,FALSE,&PL_statbuf)) /* can real uid exec? */
3117 Perl_croak(aTHX_ "Permission denied\n");
3119 #endif /* HAS_SETREUID */
3120 #endif /* IAMSUID */
3122 if (!S_ISREG(PL_statbuf.st_mode))
3123 Perl_croak(aTHX_ "Permission denied");
3124 if (PL_statbuf.st_mode & S_IWOTH)
3125 Perl_croak(aTHX_ "Setuid/gid script is writable by world");
3126 PL_doswitches = FALSE; /* -s is insecure in suid */
3127 CopLINE_inc(PL_curcop);
3128 if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
3129 strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */
3130 Perl_croak(aTHX_ "No #! line");
3131 s = SvPV(PL_linestr,n_a)+2;
3133 while (!isSPACE(*s)) s++;
3134 for (s2 = s; (s2 > SvPV(PL_linestr,n_a)+2 &&
3135 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
3136 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
3137 Perl_croak(aTHX_ "Not a perl script");
3138 while (*s == ' ' || *s == '\t') s++;
3140 * #! arg must be what we saw above. They can invoke it by
3141 * mentioning suidperl explicitly, but they may not add any strange
3142 * arguments beyond what #! says if they do invoke suidperl that way.
3144 len = strlen(validarg);
3145 if (strEQ(validarg," PHOOEY ") ||
3146 strnNE(s,validarg,len) || !isSPACE(s[len]))
3147 Perl_croak(aTHX_ "Args must match #! line");
3150 if (PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
3151 PL_euid == PL_statbuf.st_uid)
3153 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
3154 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
3155 #endif /* IAMSUID */
3157 if (PL_euid) { /* oops, we're not the setuid root perl */
3158 (void)PerlIO_close(PL_rsfp);
3161 PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
3162 (int)PERL_REVISION, (int)PERL_VERSION,
3163 (int)PERL_SUBVERSION), PL_origargv);
3165 Perl_croak(aTHX_ "Can't do setuid\n");
3168 if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
3170 (void)setegid(PL_statbuf.st_gid);
3173 (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
3175 #ifdef HAS_SETRESGID
3176 (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
3178 PerlProc_setgid(PL_statbuf.st_gid);
3182 if (PerlProc_getegid() != PL_statbuf.st_gid)
3183 Perl_croak(aTHX_ "Can't do setegid!\n");
3185 if (PL_statbuf.st_mode & S_ISUID) {
3186 if (PL_statbuf.st_uid != PL_euid)
3188 (void)seteuid(PL_statbuf.st_uid); /* all that for this */
3191 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
3193 #ifdef HAS_SETRESUID
3194 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
3196 PerlProc_setuid(PL_statbuf.st_uid);
3200 if (PerlProc_geteuid() != PL_statbuf.st_uid)
3201 Perl_croak(aTHX_ "Can't do seteuid!\n");
3203 else if (PL_uid) { /* oops, mustn't run as root */
3205 (void)seteuid((Uid_t)PL_uid);
3208 (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
3210 #ifdef HAS_SETRESUID
3211 (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
3213 PerlProc_setuid((Uid_t)PL_uid);
3217 if (PerlProc_geteuid() != PL_uid)
3218 Perl_croak(aTHX_ "Can't do seteuid!\n");
3221 if (!cando(S_IXUSR,TRUE,&PL_statbuf))
3222 Perl_croak(aTHX_ "Permission denied\n"); /* they can't do this */
3225 else if (PL_preprocess)
3226 Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
3227 else if (fdscript >= 0)
3228 Perl_croak(aTHX_ "fd script not allowed in suidperl\n");
3230 Perl_croak(aTHX_ "Script is not setuid/setgid in suidperl\n");
3232 /* We absolutely must clear out any saved ids here, so we */
3233 /* exec the real perl, substituting fd script for scriptname. */
3234 /* (We pass script name as "subdir" of fd, which perl will grok.) */
3235 PerlIO_rewind(PL_rsfp);
3236 PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0); /* just in case rewind didn't */
3237 for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
3238 if (!PL_origargv[which])
3239 Perl_croak(aTHX_ "Permission denied");
3240 PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
3241 PerlIO_fileno(PL_rsfp), PL_origargv[which]));
3242 #if defined(HAS_FCNTL) && defined(F_SETFD)
3243 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */
3245 PerlProc_execv(Perl_form(aTHX_ "%s/perl"PERL_FS_VER_FMT, BIN_EXP,
3246 (int)PERL_REVISION, (int)PERL_VERSION,
3247 (int)PERL_SUBVERSION), PL_origargv);/* try again */
3248 Perl_croak(aTHX_ "Can't do setuid\n");
3249 #endif /* IAMSUID */
3251 if (PL_euid != PL_uid || PL_egid != PL_gid) { /* (suidperl doesn't exist, in fact) */
3252 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
3253 PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf); /* may be either wrapped or real suid */
3254 if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
3256 (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
3259 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
3260 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
3261 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
3262 /* not set-id, must be wrapped */
3268 S_find_beginning(pTHX)
3270 register char *s, *s2;
3272 /* skip forward in input to the real script? */
3275 #ifdef MACOS_TRADITIONAL
3276 /* Since the Mac OS does not honor #! arguments for us, we do it ourselves */
3278 while (PL_doextract || gMacPerl_AlwaysExtract) {
3279 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
3280 if (!gMacPerl_AlwaysExtract)
3281 Perl_croak(aTHX_ "No Perl script found in input\n");
3283 if (PL_doextract) /* require explicit override ? */
3284 if (!OverrideExtract(PL_origfilename))
3285 Perl_croak(aTHX_ "User aborted script\n");
3287 PL_doextract = FALSE;
3289 /* Pater peccavi, file does not have #! */
3290 PerlIO_rewind(PL_rsfp);
3295 while (PL_doextract) {
3296 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
3297 Perl_croak(aTHX_ "No Perl script found in input\n");
3300 if (*s == '#' && s[1] == '!' && ((s = instr(s,"perl")) || (s = instr(s2,"PERL")))) {
3301 PerlIO_ungetc(PL_rsfp, '\n'); /* to keep line count right */
3302 PL_doextract = FALSE;
3303 while (*s && !(isSPACE (*s) || *s == '#')) s++;
3305 while (*s == ' ' || *s == '\t') s++;
3307 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
3308 if (strnEQ(s2-4,"perl",4))
3310 while ((s = moreswitches(s)))
3313 #ifdef MACOS_TRADITIONAL
3324 PL_uid = PerlProc_getuid();
3325 PL_euid = PerlProc_geteuid();
3326 PL_gid = PerlProc_getgid();
3327 PL_egid = PerlProc_getegid();
3329 PL_uid |= PL_gid << 16;
3330 PL_euid |= PL_egid << 16;
3332 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
3336 S_forbid_setid(pTHX_ char *s)
3338 if (PL_euid != PL_uid)
3339 Perl_croak(aTHX_ "No %s allowed while running setuid", s);
3340 if (PL_egid != PL_gid)
3341 Perl_croak(aTHX_ "No %s allowed while running setgid", s);
3345 Perl_init_debugger(pTHX)
3347 HV *ostash = PL_curstash;
3349 PL_curstash = PL_debstash;
3350 PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
3351 AvREAL_off(PL_dbargs);
3352 PL_DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
3353 PL_DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
3354 PL_DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
3355 sv_upgrade(GvSV(PL_DBsub), SVt_IV); /* IVX accessed if PERLDB_SUB_NN */
3356 PL_DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
3357 sv_setiv(PL_DBsingle, 0);
3358 PL_DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
3359 sv_setiv(PL_DBtrace, 0);
3360 PL_DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
3361 sv_setiv(PL_DBsignal, 0);
3362 PL_curstash = ostash;
3365 #ifndef STRESS_REALLOC
3366 #define REASONABLE(size) (size)
3368 #define REASONABLE(size) (1) /* unreasonable */
3372 Perl_init_stacks(pTHX)
3374 /* start with 128-item stack and 8K cxstack */
3375 PL_curstackinfo = new_stackinfo(REASONABLE(128),
3376 REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
3377 PL_curstackinfo->si_type = PERLSI_MAIN;
3378 PL_curstack = PL_curstackinfo->si_stack;
3379 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
3381 PL_stack_base = AvARRAY(PL_curstack);
3382 PL_stack_sp = PL_stack_base;
3383 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
3385 New(50,PL_tmps_stack,REASONABLE(128),SV*);
3388 PL_tmps_max = REASONABLE(128);
3390 New(54,PL_markstack,REASONABLE(32),I32);
3391 PL_markstack_ptr = PL_markstack;
3392 PL_markstack_max = PL_markstack + REASONABLE(32);
3396 New(54,PL_scopestack,REASONABLE(32),I32);
3397 PL_scopestack_ix = 0;
3398 PL_scopestack_max = REASONABLE(32);
3400 New(54,PL_savestack,REASONABLE(128),ANY);
3401 PL_savestack_ix = 0;
3402 PL_savestack_max = REASONABLE(128);
3404 New(54,PL_retstack,REASONABLE(16),OP*);
3406 PL_retstack_max = REASONABLE(16);
3414 while (PL_curstackinfo->si_next)
3415 PL_curstackinfo = PL_curstackinfo->si_next;
3416 while (PL_curstackinfo) {
3417 PERL_SI *p = PL_curstackinfo->si_prev;
3418 /* curstackinfo->si_stack got nuked by sv_free_arenas() */
3419 Safefree(PL_curstackinfo->si_cxstack);
3420 Safefree(PL_curstackinfo);
3421 PL_curstackinfo = p;
3423 Safefree(PL_tmps_stack);
3424 Safefree(PL_markstack);
3425 Safefree(PL_scopestack);
3426 Safefree(PL_savestack);
3427 Safefree(PL_retstack);
3436 lex_start(PL_linestr);
3438 PL_subname = newSVpvn("main",4);
3442 S_init_predump_symbols(pTHX)
3447 sv_setpvn(get_sv("\"", TRUE), " ", 1);
3448 PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
3449 GvMULTI_on(PL_stdingv);
3450 io = GvIOp(PL_stdingv);
3451 IoTYPE(io) = IoTYPE_RDONLY;
3452 IoIFP(io) = PerlIO_stdin();
3453 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
3455 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
3457 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
3460 IoTYPE(io) = IoTYPE_WRONLY;
3461 IoOFP(io) = IoIFP(io) = PerlIO_stdout();
3463 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
3465 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
3467 PL_stderrgv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
3468 GvMULTI_on(PL_stderrgv);
3469 io = GvIOp(PL_stderrgv);
3470 IoTYPE(io) = IoTYPE_WRONLY;
3471 IoOFP(io) = IoIFP(io) = PerlIO_stderr();
3472 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
3474 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
3476 PL_statname = NEWSV(66,0); /* last filename we did stat on */
3479 Safefree(PL_osname);
3480 PL_osname = savepv(OSNAME);
3484 Perl_init_argv_symbols(pTHX_ register int argc, register char **argv)
3487 argc--,argv++; /* skip name of script */
3488 if (PL_doswitches) {
3489 for (; argc > 0 && **argv == '-'; argc--,argv++) {
3492 if (argv[0][1] == '-' && !argv[0][2]) {
3496 if ((s = strchr(argv[0], '='))) {
3498 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
3501 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
3504 if ((PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV))) {
3505 GvMULTI_on(PL_argvgv);
3506 (void)gv_AVadd(PL_argvgv);
3507 av_clear(GvAVn(PL_argvgv));
3508 for (; argc > 0; argc--,argv++) {
3509 SV *sv = newSVpv(argv[0],0);
3510 av_push(GvAVn(PL_argvgv),sv);
3511 if (PL_widesyscalls)
3512 (void)sv_utf8_decode(sv);
3517 #ifdef HAS_PROCSELFEXE
3518 /* This is a function so that we don't hold on to MAXPATHLEN
3519 bytes of stack longer than necessary
3522 S_procself_val(pTHX_ SV *sv, char *arg0)
3524 char buf[MAXPATHLEN];
3525 int len = readlink(PROCSELFEXE_PATH, buf, sizeof(buf) - 1);
3526 /* FreeBSD's implementation is acknowledged to be imperfect, sometimes
3527 returning the text "unknown" from the readlink rather than the path
3528 to the executable (or returning an error from the readlink). Any valid
3529 path has a '/' in it somewhere, so use that to validate the result.
3530 See http://www.freebsd.org/cgi/query-pr.cgi?pr=35703
3532 if (len > 0 && memchr(buf, '/', len)) {
3533 sv_setpvn(sv,buf,len);
3539 #endif /* HAS_PROCSELFEXE */
3542 S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
3548 PL_toptarget = NEWSV(0,0);
3549 sv_upgrade(PL_toptarget, SVt_PVFM);
3550 sv_setpvn(PL_toptarget, "", 0);
3551 PL_bodytarget = NEWSV(0,0);
3552 sv_upgrade(PL_bodytarget, SVt_PVFM);
3553 sv_setpvn(PL_bodytarget, "", 0);
3554 PL_formtarget = PL_bodytarget;
3558 init_argv_symbols(argc,argv);
3560 if ((tmpgv = gv_fetchpv("0",TRUE, SVt_PV))) {
3561 #ifdef MACOS_TRADITIONAL
3562 /* $0 is not majick on a Mac */
3563 sv_setpv(GvSV(tmpgv),MacPerl_MPWFileName(PL_origfilename));
3565 sv_setpv(GvSV(tmpgv),PL_origfilename);
3566 magicname("0", "0", 1);
3569 if ((tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))) {/* $^X */
3570 #ifdef HAS_PROCSELFEXE
3571 S_procself_val(aTHX_ GvSV(tmpgv), PL_origargv[0]);
3574 sv_setpv(GvSV(tmpgv), os2_execname(aTHX));
3576 sv_setpv(GvSV(tmpgv),PL_origargv[0]);
3580 if ((PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV))) {
3582 GvMULTI_on(PL_envgv);
3583 hv = GvHVn(PL_envgv);
3584 hv_magic(hv, Nullgv, PERL_MAGIC_env);
3585 #ifdef USE_ENVIRON_ARRAY
3586 /* Note that if the supplied env parameter is actually a copy
3587 of the global environ then it may now point to free'd memory
3588 if the environment has been modified since. To avoid this
3589 problem we treat env==NULL as meaning 'use the default'
3594 # ifdef USE_ITHREADS
3595 && PL_curinterp == aTHX
3599 environ[0] = Nullch;
3602 for (; *env; env++) {
3603 if (!(s = strchr(*env,'=')))
3610 sv = newSVpv(s+1, 0);
3611 (void)hv_store(hv, *env, s - *env, sv, 0);
3615 #endif /* USE_ENVIRON_ARRAY */
3618 if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV))) {
3619 SvREADONLY_off(GvSV(tmpgv));
3620 sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
3621 SvREADONLY_on(GvSV(tmpgv));
3624 /* touch @F array to prevent spurious warnings 20020415 MJD */
3626 (void) get_av("main::F", TRUE | GV_ADDMULTI);
3628 /* touch @- and @+ arrays to prevent spurious warnings 20020415 MJD */
3629 (void) get_av("main::-", TRUE | GV_ADDMULTI);
3630 (void) get_av("main::+", TRUE | GV_ADDMULTI);
3634 S_init_perllib(pTHX)
3639 s = PerlEnv_getenv("PERL5LIB");
3641 incpush(s, TRUE, TRUE);
3643 incpush(PerlEnv_getenv("PERLLIB"), FALSE, FALSE);
3645 /* Treat PERL5?LIB as a possible search list logical name -- the
3646 * "natural" VMS idiom for a Unix path string. We allow each
3647 * element to be a set of |-separated directories for compatibility.
3651 if (my_trnlnm("PERL5LIB",buf,0))
3652 do { incpush(buf,TRUE,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
3654 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE,FALSE);
3658 /* Use the ~-expanded versions of APPLLIB (undocumented),
3659 ARCHLIB PRIVLIB SITEARCH SITELIB VENDORARCH and VENDORLIB
3662 incpush(APPLLIB_EXP, TRUE, TRUE);
3666 incpush(ARCHLIB_EXP, FALSE, FALSE);
3668 #ifdef MACOS_TRADITIONAL
3671 SV * privdir = NEWSV(55, 0);
3672 char * macperl = PerlEnv_getenv("MACPERL");
3677 Perl_sv_setpvf(aTHX_ privdir, "%slib:", macperl);
3678 if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
3679 incpush(SvPVX(privdir), TRUE, FALSE);
3680 Perl_sv_setpvf(aTHX_ privdir, "%ssite_perl:", macperl);
3681 if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
3682 incpush(SvPVX(privdir), TRUE, FALSE);
3684 SvREFCNT_dec(privdir);
3687 incpush(":", FALSE, FALSE);
3690 # define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
3693 incpush(PRIVLIB_EXP, TRUE, FALSE);
3695 incpush(PRIVLIB_EXP, FALSE, FALSE);
3699 /* sitearch is always relative to sitelib on Windows for
3700 * DLL-based path intuition to work correctly */
3701 # if !defined(WIN32)
3702 incpush(SITEARCH_EXP, FALSE, FALSE);
3708 incpush(SITELIB_EXP, TRUE, FALSE); /* this picks up sitearch as well */
3710 incpush(SITELIB_EXP, FALSE, FALSE);
3714 #ifdef SITELIB_STEM /* Search for version-specific dirs below here */
3715 incpush(SITELIB_STEM, FALSE, TRUE);
3718 #ifdef PERL_VENDORARCH_EXP
3719 /* vendorarch is always relative to vendorlib on Windows for
3720 * DLL-based path intuition to work correctly */
3721 # if !defined(WIN32)
3722 incpush(PERL_VENDORARCH_EXP, FALSE, FALSE);
3726 #ifdef PERL_VENDORLIB_EXP
3728 incpush(PERL_VENDORLIB_EXP, TRUE, FALSE); /* this picks up vendorarch as well */
3730 incpush(PERL_VENDORLIB_EXP, FALSE, FALSE);
3734 #ifdef PERL_VENDORLIB_STEM /* Search for version-specific dirs below here */
3735 incpush(PERL_VENDORLIB_STEM, FALSE, TRUE);
3738 #ifdef PERL_OTHERLIBDIRS
3739 incpush(PERL_OTHERLIBDIRS, TRUE, TRUE);
3743 incpush(".", FALSE, FALSE);
3744 #endif /* MACOS_TRADITIONAL */
3747 #if defined(DOSISH) || defined(EPOC)
3748 # define PERLLIB_SEP ';'
3751 # define PERLLIB_SEP '|'
3753 # if defined(MACOS_TRADITIONAL)
3754 # define PERLLIB_SEP ','
3756 # define PERLLIB_SEP ':'
3760 #ifndef PERLLIB_MANGLE
3761 # define PERLLIB_MANGLE(s,n) (s)
3765 S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers)
3767 SV *subdir = Nullsv;
3772 if (addsubdirs || addoldvers) {
3773 subdir = sv_newmortal();
3776 /* Break at all separators */
3778 SV *libdir = NEWSV(55,0);
3781 /* skip any consecutive separators */
3782 while ( *p == PERLLIB_SEP ) {
3783 /* Uncomment the next line for PATH semantics */
3784 /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */
3788 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
3789 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
3794 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
3795 p = Nullch; /* break out */
3797 #ifdef MACOS_TRADITIONAL
3798 if (!strchr(SvPVX(libdir), ':')) {
3801 sv_setpv(libdir, MacPerl_CanonDir(SvPVX(libdir), buf, 0));
3803 if (SvPVX(libdir)[SvCUR(libdir)-1] != ':')
3804 sv_catpv(libdir, ":");
3808 * BEFORE pushing libdir onto @INC we may first push version- and
3809 * archname-specific sub-directories.
3811 if (addsubdirs || addoldvers) {
3812 #ifdef PERL_INC_VERSION_LIST
3813 /* Configure terminates PERL_INC_VERSION_LIST with a NULL */
3814 const char *incverlist[] = { PERL_INC_VERSION_LIST };
3815 const char **incver;
3822 if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) {
3824 while (unix[len-1] == '/') len--; /* Cosmetic */
3825 sv_usepvn(libdir,unix,len);
3828 PerlIO_printf(Perl_error_log,
3829 "Failed to unixify @INC element \"%s\"\n",
3833 #ifdef MACOS_TRADITIONAL
3834 #define PERL_AV_SUFFIX_FMT ""
3835 #define PERL_ARCH_FMT "%s:"
3836 #define PERL_ARCH_FMT_PATH PERL_FS_VER_FMT PERL_AV_SUFFIX_FMT
3838 #define PERL_AV_SUFFIX_FMT "/"
3839 #define PERL_ARCH_FMT "/%s"
3840 #define PERL_ARCH_FMT_PATH PERL_AV_SUFFIX_FMT PERL_FS_VER_FMT
3842 /* .../version/archname if -d .../version/archname */
3843 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH PERL_ARCH_FMT,
3845 (int)PERL_REVISION, (int)PERL_VERSION,
3846 (int)PERL_SUBVERSION, ARCHNAME);
3847 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3848 S_ISDIR(tmpstatbuf.st_mode))
3849 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3851 /* .../version if -d .../version */
3852 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH, libdir,
3853 (int)PERL_REVISION, (int)PERL_VERSION,
3854 (int)PERL_SUBVERSION);
3855 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3856 S_ISDIR(tmpstatbuf.st_mode))
3857 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3859 /* .../archname if -d .../archname */
3860 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, ARCHNAME);
3861 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3862 S_ISDIR(tmpstatbuf.st_mode))
3863 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3866 #ifdef PERL_INC_VERSION_LIST
3868 for (incver = incverlist; *incver; incver++) {
3869 /* .../xxx if -d .../xxx */
3870 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, *incver);
3871 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3872 S_ISDIR(tmpstatbuf.st_mode))
3873 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3879 /* finally push this lib directory on the end of @INC */
3880 av_push(GvAVn(PL_incgv), libdir);
3884 #ifdef USE_5005THREADS
3885 STATIC struct perl_thread *
3886 S_init_main_thread(pTHX)
3888 #if !defined(PERL_IMPLICIT_CONTEXT)
3889 struct perl_thread *thr;
3893 Newz(53, thr, 1, struct perl_thread);
3894 PL_curcop = &PL_compiling;
3895 thr->interp = PERL_GET_INTERP;
3896 thr->cvcache = newHV();
3897 thr->threadsv = newAV();
3898 /* thr->threadsvp is set when find_threadsv is called */
3899 thr->specific = newAV();
3900 thr->flags = THRf_R_JOINABLE;
3901 MUTEX_INIT(&thr->mutex);
3902 /* Handcraft thrsv similarly to mess_sv */
3903 New(53, PL_thrsv, 1, SV);
3904 Newz(53, xpv, 1, XPV);
3905 SvFLAGS(PL_thrsv) = SVt_PV;
3906 SvANY(PL_thrsv) = (void*)xpv;
3907 SvREFCNT(PL_thrsv) = 1 << 30; /* practically infinite */
3908 SvPVX(PL_thrsv) = (char*)thr;
3909 SvCUR_set(PL_thrsv, sizeof(thr));
3910 SvLEN_set(PL_thrsv, sizeof(thr));
3911 *SvEND(PL_thrsv) = '\0'; /* in the trailing_nul field */
3912 thr->oursv = PL_thrsv;
3913 PL_chopset = " \n-";
3916 MUTEX_LOCK(&PL_threads_mutex);
3922 MUTEX_UNLOCK(&PL_threads_mutex);
3924 #ifdef HAVE_THREAD_INTERN
3925 Perl_init_thread_intern(thr);
3928 #ifdef SET_THREAD_SELF
3929 SET_THREAD_SELF(thr);
3931 thr->self = pthread_self();
3932 #endif /* SET_THREAD_SELF */
3936 * These must come after the thread self setting
3937 * because sv_setpvn does SvTAINT and the taint
3938 * fields thread selfness being set.
3940 PL_toptarget = NEWSV(0,0);
3941 sv_upgrade(PL_toptarget, SVt_PVFM);
3942 sv_setpvn(PL_toptarget, "", 0);
3943 PL_bodytarget = NEWSV(0,0);
3944 sv_upgrade(PL_bodytarget, SVt_PVFM);
3945 sv_setpvn(PL_bodytarget, "", 0);
3946 PL_formtarget = PL_bodytarget;
3947 thr->errsv = newSVpvn("", 0);
3948 (void) find_threadsv("@"); /* Ensure $@ is initialised early */
3951 PL_peepp = MEMBER_TO_FPTR(Perl_peep);
3952 PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
3953 PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
3954 PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
3955 PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
3956 PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
3958 PL_reginterp_cnt = 0;
3962 #endif /* USE_5005THREADS */
3965 Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
3968 line_t oldline = CopLINE(PL_curcop);
3974 while (AvFILL(paramList) >= 0) {
3975 cv = (CV*)av_shift(paramList);
3976 if (PL_savebegin && (paramList == PL_beginav)) {
3977 /* save PL_beginav for compiler */
3978 if (! PL_beginav_save)
3979 PL_beginav_save = newAV();
3980 av_push(PL_beginav_save, (SV*)cv);
3984 #ifdef PERL_FLEXIBLE_EXCEPTIONS
3985 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_list_body), cv);
3991 #ifndef PERL_FLEXIBLE_EXCEPTIONS
3995 (void)SvPV(atsv, len);
3998 PL_curcop = &PL_compiling;
3999 CopLINE_set(PL_curcop, oldline);
4000 if (paramList == PL_beginav)
4001 sv_catpv(atsv, "BEGIN failed--compilation aborted");
4003 Perl_sv_catpvf(aTHX_ atsv,
4004 "%s failed--call queue aborted",
4005 paramList == PL_checkav ? "CHECK"
4006 : paramList == PL_initav ? "INIT"
4008 while (PL_scopestack_ix > oldscope)
4011 Perl_croak(aTHX_ "%s", SvPVx(atsv, n_a));
4018 /* my_exit() was called */
4019 while (PL_scopestack_ix > oldscope)
4022 PL_curstash = PL_defstash;
4023 PL_curcop = &PL_compiling;
4024 CopLINE_set(PL_curcop, oldline);
4026 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) {
4027 if (paramList == PL_beginav)
4028 Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
4030 Perl_croak(aTHX_ "%s failed--call queue aborted",
4031 paramList == PL_checkav ? "CHECK"
4032 : paramList == PL_initav ? "INIT"
4039 PL_curcop = &PL_compiling;
4040 CopLINE_set(PL_curcop, oldline);
4043 PerlIO_printf(Perl_error_log, "panic: restartop\n");
4051 #ifdef PERL_FLEXIBLE_EXCEPTIONS
4053 S_vcall_list_body(pTHX_ va_list args)
4055 CV *cv = va_arg(args, CV*);
4056 return call_list_body(cv);
4061 S_call_list_body(pTHX_ CV *cv)
4063 PUSHMARK(PL_stack_sp);
4064 call_sv((SV*)cv, G_EVAL|G_DISCARD);
4069 Perl_my_exit(pTHX_ U32 status)
4071 DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
4072 thr, (unsigned long) status));
4081 STATUS_NATIVE_SET(status);
4088 Perl_my_failure_exit(pTHX)
4091 if (vaxc$errno & 1) {
4092 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
4093 STATUS_NATIVE_SET(44);
4096 if (!vaxc$errno && errno) /* unlikely */
4097 STATUS_NATIVE_SET(44);
4099 STATUS_NATIVE_SET(vaxc$errno);
4104 STATUS_POSIX_SET(errno);
4106 exitstatus = STATUS_POSIX >> 8;
4107 if (exitstatus & 255)
4108 STATUS_POSIX_SET(exitstatus);
4110 STATUS_POSIX_SET(255);
4117 S_my_exit_jump(pTHX)
4119 register PERL_CONTEXT *cx;
4124 SvREFCNT_dec(PL_e_script);
4125 PL_e_script = Nullsv;
4128 POPSTACK_TO(PL_mainstack);
4129 if (cxstack_ix >= 0) {
4132 POPBLOCK(cx,PL_curpm);
4140 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen)
4143 p = SvPVX(PL_e_script);
4144 nl = strchr(p, '\n');
4145 nl = (nl) ? nl+1 : SvEND(PL_e_script);
4147 filter_del(read_e_script);
4150 sv_catpvn(buf_sv, p, nl-p);
4151 sv_chop(PL_e_script, nl);