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 PL_inplace = savepv(s+1);
2368 for (s = PL_inplace; *s && !isSPACE(*s); s++) ;
2371 if (*s == '-') /* Additional switches on #! line. */
2375 case 'I': /* -I handled both here and in parse_body() */
2378 while (*s && isSPACE(*s))
2383 /* ignore trailing spaces (possibly followed by other switches) */
2385 for (e = p; *e && !isSPACE(*e); e++) ;
2389 } while (*p && *p != '-');
2390 e = savepvn(s, e-s);
2391 incpush(e, TRUE, TRUE);
2398 Perl_croak(aTHX_ "No directory specified for -I");
2404 SvREFCNT_dec(PL_ors_sv);
2409 PL_ors_sv = newSVpvn("\n",1);
2410 numlen = 3 + (*s == '0');
2411 *SvPVX(PL_ors_sv) = (char)grok_oct(s, &numlen, &flags, NULL);
2415 if (RsPARA(PL_rs)) {
2416 PL_ors_sv = newSVpvn("\n\n",2);
2419 PL_ors_sv = newSVsv(PL_rs);
2424 forbid_setid("-M"); /* XXX ? */
2427 forbid_setid("-m"); /* XXX ? */
2432 /* -M-foo == 'no foo' */
2433 if (*s == '-') { use = "no "; ++s; }
2434 sv = newSVpv(use,0);
2436 /* We allow -M'Module qw(Foo Bar)' */
2437 while(isALNUM(*s) || *s==':') ++s;
2439 sv_catpv(sv, start);
2440 if (*(start-1) == 'm') {
2442 Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
2443 sv_catpv( sv, " ()");
2447 Perl_croak(aTHX_ "Module name required with -%c option",
2449 sv_catpvn(sv, start, s-start);
2450 sv_catpv(sv, " split(/,/,q{");
2456 PL_preambleav = newAV();
2457 av_push(PL_preambleav, sv);
2460 Perl_croak(aTHX_ "No space allowed after -%c", *(s-1));
2472 PL_doswitches = TRUE;
2477 Perl_croak(aTHX_ "Too late for \"-t\" option");
2482 Perl_croak(aTHX_ "Too late for \"-T\" option");
2486 #ifdef MACOS_TRADITIONAL
2487 Perl_croak(aTHX_ "Believe me, you don't want to use \"-u\" on a Macintosh");
2489 PL_do_undump = TRUE;
2498 PerlIO_printf(PerlIO_stdout(),
2499 Perl_form(aTHX_ "\nThis is perl, v%"VDf" built for %s",
2500 PL_patchlevel, ARCHNAME));
2502 /* Adjust verbose output as in the perl that ships with the DG/UX OS from EMC */
2503 PerlIO_printf(PerlIO_stdout(),
2504 Perl_form(aTHX_ "\nThis is perl, version %vd\n", PL_patchlevel));
2505 PerlIO_printf(PerlIO_stdout(),
2506 Perl_form(aTHX_ " built under %s at %s %s\n",
2507 OSNAME, __DATE__, __TIME__));
2508 PerlIO_printf(PerlIO_stdout(),
2509 Perl_form(aTHX_ " OS Specific Release: %s\n",
2513 #if defined(LOCAL_PATCH_COUNT)
2514 if (LOCAL_PATCH_COUNT > 0)
2515 PerlIO_printf(PerlIO_stdout(),
2516 "\n(with %d registered patch%s, "
2517 "see perl -V for more detail)",
2518 (int)LOCAL_PATCH_COUNT,
2519 (LOCAL_PATCH_COUNT!=1) ? "es" : "");
2522 PerlIO_printf(PerlIO_stdout(),
2523 "\n\nCopyright 1987-2002, Larry Wall\n");
2524 #ifdef MACOS_TRADITIONAL
2525 PerlIO_printf(PerlIO_stdout(),
2526 "\nMac OS port Copyright 1991-2002, Matthias Neeracher;\n"
2527 "maintained by Chris Nandor\n");
2530 PerlIO_printf(PerlIO_stdout(),
2531 "\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
2534 PerlIO_printf(PerlIO_stdout(),
2535 "djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n"
2536 "djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
2539 PerlIO_printf(PerlIO_stdout(),
2540 "\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
2541 "Version 5 port Copyright (c) 1994-2002, Andreas Kaiser, Ilya Zakharevich\n");
2544 PerlIO_printf(PerlIO_stdout(),
2545 "atariST series port, ++jrb bammi@cadence.com\n");
2548 PerlIO_printf(PerlIO_stdout(),
2549 "BeOS port Copyright Tom Spindler, 1997-1999\n");
2552 PerlIO_printf(PerlIO_stdout(),
2553 "MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-2002\n");
2556 PerlIO_printf(PerlIO_stdout(),
2557 "MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
2560 PerlIO_printf(PerlIO_stdout(),
2561 "Stratus VOS port by Paul.Green@stratus.com, 1997-2002\n");
2564 PerlIO_printf(PerlIO_stdout(),
2565 "VM/ESA port by Neale Ferguson, 1998-1999\n");
2568 PerlIO_printf(PerlIO_stdout(),
2569 "BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
2572 PerlIO_printf(PerlIO_stdout(),
2573 "MiNT port by Guido Flohr, 1997-1999\n");
2576 PerlIO_printf(PerlIO_stdout(),
2577 "EPOC port by Olaf Flebbe, 1999-2002\n");
2580 printf("WINCE port by Rainer Keuchel, 2001-2002\n");
2581 printf("Built on " __DATE__ " " __TIME__ "\n\n");
2584 #ifdef BINARY_BUILD_NOTICE
2585 BINARY_BUILD_NOTICE;
2587 PerlIO_printf(PerlIO_stdout(),
2589 Perl may be copied only under the terms of either the Artistic License or the\n\
2590 GNU General Public License, which may be found in the Perl 5 source kit.\n\n\
2591 Complete documentation for Perl, including FAQ lists, should be found on\n\
2592 this system using `man perl' or `perldoc perl'. If you have access to the\n\
2593 Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
2596 if (! (PL_dowarn & G_WARN_ALL_MASK))
2597 PL_dowarn |= G_WARN_ON;
2601 PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
2602 if (!specialWARN(PL_compiling.cop_warnings))
2603 SvREFCNT_dec(PL_compiling.cop_warnings);
2604 PL_compiling.cop_warnings = pWARN_ALL ;
2608 PL_dowarn = G_WARN_ALL_OFF;
2609 if (!specialWARN(PL_compiling.cop_warnings))
2610 SvREFCNT_dec(PL_compiling.cop_warnings);
2611 PL_compiling.cop_warnings = pWARN_NONE ;
2616 if (s[1] == '-') /* Additional switches on #! line. */
2621 #if defined(WIN32) || !defined(PERL_STRICT_CR)
2627 #ifdef ALTERNATE_SHEBANG
2628 case 'S': /* OS/2 needs -S on "extproc" line. */
2636 Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
2641 /* compliments of Tom Christiansen */
2643 /* unexec() can be found in the Gnu emacs distribution */
2644 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
2647 Perl_my_unexec(pTHX)
2655 prog = newSVpv(BIN_EXP, 0);
2656 sv_catpv(prog, "/perl");
2657 file = newSVpv(PL_origfilename, 0);
2658 sv_catpv(file, ".perldump");
2660 unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
2661 /* unexec prints msg to stderr in case of failure */
2662 PerlProc_exit(status);
2665 # include <lib$routines.h>
2666 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
2668 ABORT(); /* for use with undump */
2673 /* initialize curinterp */
2679 # define PERLVAR(var,type)
2680 # define PERLVARA(var,n,type)
2681 # if defined(PERL_IMPLICIT_CONTEXT)
2682 # if defined(USE_5005THREADS)
2683 # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
2684 # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
2685 # else /* !USE_5005THREADS */
2686 # define PERLVARI(var,type,init) aTHX->var = init;
2687 # define PERLVARIC(var,type,init) aTHX->var = init;
2688 # endif /* USE_5005THREADS */
2690 # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
2691 # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
2693 # include "intrpvar.h"
2694 # ifndef USE_5005THREADS
2695 # include "thrdvar.h"
2702 # define PERLVAR(var,type)
2703 # define PERLVARA(var,n,type)
2704 # define PERLVARI(var,type,init) PL_##var = init;
2705 # define PERLVARIC(var,type,init) PL_##var = init;
2706 # include "intrpvar.h"
2707 # ifndef USE_5005THREADS
2708 # include "thrdvar.h"
2719 S_init_main_stash(pTHX)
2723 PL_curstash = PL_defstash = newHV();
2724 PL_curstname = newSVpvn("main",4);
2725 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
2726 SvREFCNT_dec(GvHV(gv));
2727 GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
2729 HvNAME(PL_defstash) = savepv("main");
2730 PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
2731 GvMULTI_on(PL_incgv);
2732 PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
2733 GvMULTI_on(PL_hintgv);
2734 PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
2735 PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
2736 GvMULTI_on(PL_errgv);
2737 PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
2738 GvMULTI_on(PL_replgv);
2739 (void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */
2740 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
2741 sv_setpvn(ERRSV, "", 0);
2742 PL_curstash = PL_defstash;
2743 CopSTASH_set(&PL_compiling, PL_defstash);
2744 PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
2745 PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
2746 PL_nullstash = GvHV(gv_fetchpv("<none>::", GV_ADDMULTI, SVt_PVHV));
2747 /* We must init $/ before switches are processed. */
2748 sv_setpvn(get_sv("/", TRUE), "\n", 1);
2752 S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
2756 char *cpp_discard_flag;
2762 PL_origfilename = savepv("-e");
2765 /* if find_script() returns, it returns a malloc()-ed value */
2766 PL_origfilename = scriptname = find_script(scriptname, dosearch, NULL, 1);
2768 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
2769 char *s = scriptname + 8;
2770 *fdscript = atoi(s);
2774 scriptname = savepv(s + 1);
2775 Safefree(PL_origfilename);
2776 PL_origfilename = scriptname;
2781 CopFILE_free(PL_curcop);
2782 CopFILE_set(PL_curcop, PL_origfilename);
2783 if (strEQ(PL_origfilename,"-"))
2785 if (*fdscript >= 0) {
2786 PL_rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE);
2787 # if defined(HAS_FCNTL) && defined(F_SETFD)
2789 /* ensure close-on-exec */
2790 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
2793 else if (PL_preprocess) {
2794 char *cpp_cfg = CPPSTDIN;
2795 SV *cpp = newSVpvn("",0);
2796 SV *cmd = NEWSV(0,0);
2798 if (strEQ(cpp_cfg, "cppstdin"))
2799 Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
2800 sv_catpv(cpp, cpp_cfg);
2803 sv_catpvn(sv, "-I", 2);
2804 sv_catpv(sv,PRIVLIB_EXP);
2807 DEBUG_P(PerlIO_printf(Perl_debug_log,
2808 "PL_preprocess: scriptname=\"%s\", cpp=\"%s\", sv=\"%s\", CPPMINUS=\"%s\"\n",
2809 scriptname, SvPVX (cpp), SvPVX (sv), CPPMINUS));
2811 # if defined(MSDOS) || defined(WIN32) || defined(VMS)
2818 cpp_discard_flag = "";
2820 cpp_discard_flag = "-C";
2824 perl = os2_execname(aTHX);
2826 perl = PL_origargv[0];
2830 /* This strips off Perl comments which might interfere with
2831 the C pre-processor, including #!. #line directives are
2832 deliberately stripped to avoid confusion with Perl's version
2833 of #line. FWP played some golf with it so it will fit
2834 into VMS's 255 character buffer.
2837 code = "(1../^#!.*perl/i)|/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print";
2839 code = "/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print";
2841 Perl_sv_setpvf(aTHX_ cmd, "\
2842 %s -ne%s%s%s %s | %"SVf" %s %"SVf" %s",
2843 perl, quote, code, quote, scriptname, cpp,
2844 cpp_discard_flag, sv, CPPMINUS);
2846 PL_doextract = FALSE;
2847 # ifdef IAMSUID /* actually, this is caught earlier */
2848 if (PL_euid != PL_uid && !PL_euid) { /* if running suidperl */
2850 (void)seteuid(PL_uid); /* musn't stay setuid root */
2852 # ifdef HAS_SETREUID
2853 (void)setreuid((Uid_t)-1, PL_uid);
2855 # ifdef HAS_SETRESUID
2856 (void)setresuid((Uid_t)-1, PL_uid, (Uid_t)-1);
2858 PerlProc_setuid(PL_uid);
2862 if (PerlProc_geteuid() != PL_uid)
2863 Perl_croak(aTHX_ "Can't do seteuid!\n");
2865 # endif /* IAMSUID */
2867 DEBUG_P(PerlIO_printf(Perl_debug_log,
2868 "PL_preprocess: cmd=\"%s\"\n",
2871 PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
2875 else if (!*scriptname) {
2876 forbid_setid("program input from stdin");
2877 PL_rsfp = PerlIO_stdin();
2880 PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
2881 # if defined(HAS_FCNTL) && defined(F_SETFD)
2883 /* ensure close-on-exec */
2884 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
2889 # ifndef IAMSUID /* in case script is not readable before setuid */
2891 PerlLIO_stat(CopFILE(PL_curcop),&PL_statbuf) >= 0 &&
2892 PL_statbuf.st_mode & (S_ISUID|S_ISGID))
2895 PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT,
2896 BIN_EXP, (int)PERL_REVISION,
2898 (int)PERL_SUBVERSION), PL_origargv);
2899 Perl_croak(aTHX_ "Can't do setuid\n");
2905 Perl_croak(aTHX_ "Can't open perl script: %s\n",
2908 Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
2909 CopFILE(PL_curcop), Strerror(errno));
2915 * I_SYSSTATVFS HAS_FSTATVFS
2917 * I_STATFS HAS_FSTATFS HAS_GETFSSTAT
2918 * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT
2919 * here so that metaconfig picks them up. */
2923 S_fd_on_nosuid_fs(pTHX_ int fd)
2925 int check_okay = 0; /* able to do all the required sys/libcalls */
2926 int on_nosuid = 0; /* the fd is on a nosuid fs */
2928 * Preferred order: fstatvfs(), fstatfs(), ustat()+getmnt(), getmntent().
2929 * fstatvfs() is UNIX98.
2930 * fstatfs() is 4.3 BSD.
2931 * ustat()+getmnt() is pre-4.3 BSD.
2932 * getmntent() is O(number-of-mounted-filesystems) and can hang on
2933 * an irrelevant filesystem while trying to reach the right one.
2936 #undef FD_ON_NOSUID_CHECK_OKAY /* found the syscalls to do the check? */
2938 # if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
2939 defined(HAS_FSTATVFS)
2940 # define FD_ON_NOSUID_CHECK_OKAY
2941 struct statvfs stfs;
2943 check_okay = fstatvfs(fd, &stfs) == 0;
2944 on_nosuid = check_okay && (stfs.f_flag & ST_NOSUID);
2945 # endif /* fstatvfs */
2947 # if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
2948 defined(PERL_MOUNT_NOSUID) && \
2949 defined(HAS_FSTATFS) && \
2950 defined(HAS_STRUCT_STATFS) && \
2951 defined(HAS_STRUCT_STATFS_F_FLAGS)
2952 # define FD_ON_NOSUID_CHECK_OKAY
2955 check_okay = fstatfs(fd, &stfs) == 0;
2956 on_nosuid = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
2957 # endif /* fstatfs */
2959 # if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
2960 defined(PERL_MOUNT_NOSUID) && \
2961 defined(HAS_FSTAT) && \
2962 defined(HAS_USTAT) && \
2963 defined(HAS_GETMNT) && \
2964 defined(HAS_STRUCT_FS_DATA) && \
2966 # define FD_ON_NOSUID_CHECK_OKAY
2969 if (fstat(fd, &fdst) == 0) {
2971 if (ustat(fdst.st_dev, &us) == 0) {
2973 /* NOSTAT_ONE here because we're not examining fields which
2974 * vary between that case and STAT_ONE. */
2975 if (getmnt((int*)0, &fsd, (int)0, NOSTAT_ONE, us.f_fname) == 0) {
2976 size_t cmplen = sizeof(us.f_fname);
2977 if (sizeof(fsd.fd_req.path) < cmplen)
2978 cmplen = sizeof(fsd.fd_req.path);
2979 if (strnEQ(fsd.fd_req.path, us.f_fname, cmplen) &&
2980 fdst.st_dev == fsd.fd_req.dev) {
2982 on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID;
2988 # endif /* fstat+ustat+getmnt */
2990 # if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
2991 defined(HAS_GETMNTENT) && \
2992 defined(HAS_HASMNTOPT) && \
2993 defined(MNTOPT_NOSUID)
2994 # define FD_ON_NOSUID_CHECK_OKAY
2995 FILE *mtab = fopen("/etc/mtab", "r");
2996 struct mntent *entry;
2999 if (mtab && (fstat(fd, &stb) == 0)) {
3000 while (entry = getmntent(mtab)) {
3001 if (stat(entry->mnt_dir, &fsb) == 0
3002 && fsb.st_dev == stb.st_dev)
3004 /* found the filesystem */
3006 if (hasmntopt(entry, MNTOPT_NOSUID))
3009 } /* A single fs may well fail its stat(). */
3014 # endif /* getmntent+hasmntopt */
3017 Perl_croak(aTHX_ "Can't check filesystem of script \"%s\" for nosuid", PL_origfilename);
3020 #endif /* IAMSUID */
3023 S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript)
3029 /* do we need to emulate setuid on scripts? */
3031 /* This code is for those BSD systems that have setuid #! scripts disabled
3032 * in the kernel because of a security problem. Merely defining DOSUID
3033 * in perl will not fix that problem, but if you have disabled setuid
3034 * scripts in the kernel, this will attempt to emulate setuid and setgid
3035 * on scripts that have those now-otherwise-useless bits set. The setuid
3036 * root version must be called suidperl or sperlN.NNN. If regular perl
3037 * discovers that it has opened a setuid script, it calls suidperl with
3038 * the same argv that it had. If suidperl finds that the script it has
3039 * just opened is NOT setuid root, it sets the effective uid back to the
3040 * uid. We don't just make perl setuid root because that loses the
3041 * effective uid we had before invoking perl, if it was different from the
3044 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
3045 * be defined in suidperl only. suidperl must be setuid root. The
3046 * Configure script will set this up for you if you want it.
3052 if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */
3053 Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
3054 if (fdscript < 0 && PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
3059 #ifndef HAS_SETREUID
3060 /* On this access check to make sure the directories are readable,
3061 * there is actually a small window that the user could use to make
3062 * filename point to an accessible directory. So there is a faint
3063 * chance that someone could execute a setuid script down in a
3064 * non-accessible directory. I don't know what to do about that.
3065 * But I don't think it's too important. The manual lies when
3066 * it says access() is useful in setuid programs.
3068 if (PerlLIO_access(CopFILE(PL_curcop),1)) /*double check*/
3069 Perl_croak(aTHX_ "Permission denied");
3071 /* If we can swap euid and uid, then we can determine access rights
3072 * with a simple stat of the file, and then compare device and
3073 * inode to make sure we did stat() on the same file we opened.
3074 * Then we just have to make sure he or she can execute it.
3081 setreuid(PL_euid,PL_uid) < 0
3084 setresuid(PL_euid,PL_uid,(Uid_t)-1) < 0
3087 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
3088 Perl_croak(aTHX_ "Can't swap uid and euid"); /* really paranoid */
3089 if (PerlLIO_stat(CopFILE(PL_curcop),&tmpstatbuf) < 0)
3090 Perl_croak(aTHX_ "Permission denied"); /* testing full pathname here */
3091 #if defined(IAMSUID) && !defined(NO_NOSUID_CHECK)
3092 if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp)))
3093 Perl_croak(aTHX_ "Permission denied");
3095 if (tmpstatbuf.st_dev != PL_statbuf.st_dev ||
3096 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
3097 (void)PerlIO_close(PL_rsfp);
3098 Perl_croak(aTHX_ "Permission denied\n");
3102 setreuid(PL_uid,PL_euid) < 0
3104 # if defined(HAS_SETRESUID)
3105 setresuid(PL_uid,PL_euid,(Uid_t)-1) < 0
3108 || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
3109 Perl_croak(aTHX_ "Can't reswap uid and euid");
3110 if (!cando(S_IXUSR,FALSE,&PL_statbuf)) /* can real uid exec? */
3111 Perl_croak(aTHX_ "Permission denied\n");
3113 #endif /* HAS_SETREUID */
3114 #endif /* IAMSUID */
3116 if (!S_ISREG(PL_statbuf.st_mode))
3117 Perl_croak(aTHX_ "Permission denied");
3118 if (PL_statbuf.st_mode & S_IWOTH)
3119 Perl_croak(aTHX_ "Setuid/gid script is writable by world");
3120 PL_doswitches = FALSE; /* -s is insecure in suid */
3121 CopLINE_inc(PL_curcop);
3122 if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
3123 strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */
3124 Perl_croak(aTHX_ "No #! line");
3125 s = SvPV(PL_linestr,n_a)+2;
3127 while (!isSPACE(*s)) s++;
3128 for (s2 = s; (s2 > SvPV(PL_linestr,n_a)+2 &&
3129 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
3130 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
3131 Perl_croak(aTHX_ "Not a perl script");
3132 while (*s == ' ' || *s == '\t') s++;
3134 * #! arg must be what we saw above. They can invoke it by
3135 * mentioning suidperl explicitly, but they may not add any strange
3136 * arguments beyond what #! says if they do invoke suidperl that way.
3138 len = strlen(validarg);
3139 if (strEQ(validarg," PHOOEY ") ||
3140 strnNE(s,validarg,len) || !isSPACE(s[len]))
3141 Perl_croak(aTHX_ "Args must match #! line");
3144 if (PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
3145 PL_euid == PL_statbuf.st_uid)
3147 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
3148 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
3149 #endif /* IAMSUID */
3151 if (PL_euid) { /* oops, we're not the setuid root perl */
3152 (void)PerlIO_close(PL_rsfp);
3155 PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
3156 (int)PERL_REVISION, (int)PERL_VERSION,
3157 (int)PERL_SUBVERSION), PL_origargv);
3159 Perl_croak(aTHX_ "Can't do setuid\n");
3162 if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
3164 (void)setegid(PL_statbuf.st_gid);
3167 (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
3169 #ifdef HAS_SETRESGID
3170 (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
3172 PerlProc_setgid(PL_statbuf.st_gid);
3176 if (PerlProc_getegid() != PL_statbuf.st_gid)
3177 Perl_croak(aTHX_ "Can't do setegid!\n");
3179 if (PL_statbuf.st_mode & S_ISUID) {
3180 if (PL_statbuf.st_uid != PL_euid)
3182 (void)seteuid(PL_statbuf.st_uid); /* all that for this */
3185 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
3187 #ifdef HAS_SETRESUID
3188 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
3190 PerlProc_setuid(PL_statbuf.st_uid);
3194 if (PerlProc_geteuid() != PL_statbuf.st_uid)
3195 Perl_croak(aTHX_ "Can't do seteuid!\n");
3197 else if (PL_uid) { /* oops, mustn't run as root */
3199 (void)seteuid((Uid_t)PL_uid);
3202 (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
3204 #ifdef HAS_SETRESUID
3205 (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
3207 PerlProc_setuid((Uid_t)PL_uid);
3211 if (PerlProc_geteuid() != PL_uid)
3212 Perl_croak(aTHX_ "Can't do seteuid!\n");
3215 if (!cando(S_IXUSR,TRUE,&PL_statbuf))
3216 Perl_croak(aTHX_ "Permission denied\n"); /* they can't do this */
3219 else if (PL_preprocess)
3220 Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
3221 else if (fdscript >= 0)
3222 Perl_croak(aTHX_ "fd script not allowed in suidperl\n");
3224 Perl_croak(aTHX_ "Script is not setuid/setgid in suidperl\n");
3226 /* We absolutely must clear out any saved ids here, so we */
3227 /* exec the real perl, substituting fd script for scriptname. */
3228 /* (We pass script name as "subdir" of fd, which perl will grok.) */
3229 PerlIO_rewind(PL_rsfp);
3230 PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0); /* just in case rewind didn't */
3231 for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
3232 if (!PL_origargv[which])
3233 Perl_croak(aTHX_ "Permission denied");
3234 PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
3235 PerlIO_fileno(PL_rsfp), PL_origargv[which]));
3236 #if defined(HAS_FCNTL) && defined(F_SETFD)
3237 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */
3239 PerlProc_execv(Perl_form(aTHX_ "%s/perl"PERL_FS_VER_FMT, BIN_EXP,
3240 (int)PERL_REVISION, (int)PERL_VERSION,
3241 (int)PERL_SUBVERSION), PL_origargv);/* try again */
3242 Perl_croak(aTHX_ "Can't do setuid\n");
3243 #endif /* IAMSUID */
3245 if (PL_euid != PL_uid || PL_egid != PL_gid) { /* (suidperl doesn't exist, in fact) */
3246 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
3247 PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf); /* may be either wrapped or real suid */
3248 if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
3250 (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
3253 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
3254 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
3255 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
3256 /* not set-id, must be wrapped */
3262 S_find_beginning(pTHX)
3264 register char *s, *s2;
3266 /* skip forward in input to the real script? */
3269 #ifdef MACOS_TRADITIONAL
3270 /* Since the Mac OS does not honor #! arguments for us, we do it ourselves */
3272 while (PL_doextract || gMacPerl_AlwaysExtract) {
3273 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
3274 if (!gMacPerl_AlwaysExtract)
3275 Perl_croak(aTHX_ "No Perl script found in input\n");
3277 if (PL_doextract) /* require explicit override ? */
3278 if (!OverrideExtract(PL_origfilename))
3279 Perl_croak(aTHX_ "User aborted script\n");
3281 PL_doextract = FALSE;
3283 /* Pater peccavi, file does not have #! */
3284 PerlIO_rewind(PL_rsfp);
3289 while (PL_doextract) {
3290 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
3291 Perl_croak(aTHX_ "No Perl script found in input\n");
3294 if (*s == '#' && s[1] == '!' && ((s = instr(s,"perl")) || (s = instr(s2,"PERL")))) {
3295 PerlIO_ungetc(PL_rsfp, '\n'); /* to keep line count right */
3296 PL_doextract = FALSE;
3297 while (*s && !(isSPACE (*s) || *s == '#')) s++;
3299 while (*s == ' ' || *s == '\t') s++;
3301 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
3302 if (strnEQ(s2-4,"perl",4))
3304 while ((s = moreswitches(s)))
3307 #ifdef MACOS_TRADITIONAL
3318 PL_uid = PerlProc_getuid();
3319 PL_euid = PerlProc_geteuid();
3320 PL_gid = PerlProc_getgid();
3321 PL_egid = PerlProc_getegid();
3323 PL_uid |= PL_gid << 16;
3324 PL_euid |= PL_egid << 16;
3326 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
3330 S_forbid_setid(pTHX_ char *s)
3332 if (PL_euid != PL_uid)
3333 Perl_croak(aTHX_ "No %s allowed while running setuid", s);
3334 if (PL_egid != PL_gid)
3335 Perl_croak(aTHX_ "No %s allowed while running setgid", s);
3339 Perl_init_debugger(pTHX)
3341 HV *ostash = PL_curstash;
3343 PL_curstash = PL_debstash;
3344 PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
3345 AvREAL_off(PL_dbargs);
3346 PL_DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
3347 PL_DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
3348 PL_DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
3349 sv_upgrade(GvSV(PL_DBsub), SVt_IV); /* IVX accessed if PERLDB_SUB_NN */
3350 PL_DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
3351 sv_setiv(PL_DBsingle, 0);
3352 PL_DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
3353 sv_setiv(PL_DBtrace, 0);
3354 PL_DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
3355 sv_setiv(PL_DBsignal, 0);
3356 PL_curstash = ostash;
3359 #ifndef STRESS_REALLOC
3360 #define REASONABLE(size) (size)
3362 #define REASONABLE(size) (1) /* unreasonable */
3366 Perl_init_stacks(pTHX)
3368 /* start with 128-item stack and 8K cxstack */
3369 PL_curstackinfo = new_stackinfo(REASONABLE(128),
3370 REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
3371 PL_curstackinfo->si_type = PERLSI_MAIN;
3372 PL_curstack = PL_curstackinfo->si_stack;
3373 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
3375 PL_stack_base = AvARRAY(PL_curstack);
3376 PL_stack_sp = PL_stack_base;
3377 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
3379 New(50,PL_tmps_stack,REASONABLE(128),SV*);
3382 PL_tmps_max = REASONABLE(128);
3384 New(54,PL_markstack,REASONABLE(32),I32);
3385 PL_markstack_ptr = PL_markstack;
3386 PL_markstack_max = PL_markstack + REASONABLE(32);
3390 New(54,PL_scopestack,REASONABLE(32),I32);
3391 PL_scopestack_ix = 0;
3392 PL_scopestack_max = REASONABLE(32);
3394 New(54,PL_savestack,REASONABLE(128),ANY);
3395 PL_savestack_ix = 0;
3396 PL_savestack_max = REASONABLE(128);
3398 New(54,PL_retstack,REASONABLE(16),OP*);
3400 PL_retstack_max = REASONABLE(16);
3408 while (PL_curstackinfo->si_next)
3409 PL_curstackinfo = PL_curstackinfo->si_next;
3410 while (PL_curstackinfo) {
3411 PERL_SI *p = PL_curstackinfo->si_prev;
3412 /* curstackinfo->si_stack got nuked by sv_free_arenas() */
3413 Safefree(PL_curstackinfo->si_cxstack);
3414 Safefree(PL_curstackinfo);
3415 PL_curstackinfo = p;
3417 Safefree(PL_tmps_stack);
3418 Safefree(PL_markstack);
3419 Safefree(PL_scopestack);
3420 Safefree(PL_savestack);
3421 Safefree(PL_retstack);
3430 lex_start(PL_linestr);
3432 PL_subname = newSVpvn("main",4);
3436 S_init_predump_symbols(pTHX)
3441 sv_setpvn(get_sv("\"", TRUE), " ", 1);
3442 PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
3443 GvMULTI_on(PL_stdingv);
3444 io = GvIOp(PL_stdingv);
3445 IoTYPE(io) = IoTYPE_RDONLY;
3446 IoIFP(io) = PerlIO_stdin();
3447 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
3449 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
3451 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
3454 IoTYPE(io) = IoTYPE_WRONLY;
3455 IoOFP(io) = IoIFP(io) = PerlIO_stdout();
3457 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
3459 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
3461 PL_stderrgv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
3462 GvMULTI_on(PL_stderrgv);
3463 io = GvIOp(PL_stderrgv);
3464 IoTYPE(io) = IoTYPE_WRONLY;
3465 IoOFP(io) = IoIFP(io) = PerlIO_stderr();
3466 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
3468 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
3470 PL_statname = NEWSV(66,0); /* last filename we did stat on */
3473 Safefree(PL_osname);
3474 PL_osname = savepv(OSNAME);
3478 Perl_init_argv_symbols(pTHX_ register int argc, register char **argv)
3481 argc--,argv++; /* skip name of script */
3482 if (PL_doswitches) {
3483 for (; argc > 0 && **argv == '-'; argc--,argv++) {
3486 if (argv[0][1] == '-' && !argv[0][2]) {
3490 if ((s = strchr(argv[0], '='))) {
3492 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
3495 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
3498 if ((PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV))) {
3499 GvMULTI_on(PL_argvgv);
3500 (void)gv_AVadd(PL_argvgv);
3501 av_clear(GvAVn(PL_argvgv));
3502 for (; argc > 0; argc--,argv++) {
3503 SV *sv = newSVpv(argv[0],0);
3504 av_push(GvAVn(PL_argvgv),sv);
3505 if (PL_widesyscalls)
3506 (void)sv_utf8_decode(sv);
3511 #ifdef HAS_PROCSELFEXE
3512 /* This is a function so that we don't hold on to MAXPATHLEN
3513 bytes of stack longer than necessary
3516 S_procself_val(pTHX_ SV *sv, char *arg0)
3518 char buf[MAXPATHLEN];
3519 int len = readlink(PROCSELFEXE_PATH, buf, sizeof(buf) - 1);
3520 /* FreeBSD's implementation is acknowledged to be imperfect, sometimes
3521 returning the text "unknown" from the readlink rather than the path
3522 to the executable (or returning an error from the readlink). Any valid
3523 path has a '/' in it somewhere, so use that to validate the result.
3524 See http://www.freebsd.org/cgi/query-pr.cgi?pr=35703
3526 if (len > 0 && memchr(buf, '/', len)) {
3527 sv_setpvn(sv,buf,len);
3533 #endif /* HAS_PROCSELFEXE */
3536 S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
3542 PL_toptarget = NEWSV(0,0);
3543 sv_upgrade(PL_toptarget, SVt_PVFM);
3544 sv_setpvn(PL_toptarget, "", 0);
3545 PL_bodytarget = NEWSV(0,0);
3546 sv_upgrade(PL_bodytarget, SVt_PVFM);
3547 sv_setpvn(PL_bodytarget, "", 0);
3548 PL_formtarget = PL_bodytarget;
3552 init_argv_symbols(argc,argv);
3554 if ((tmpgv = gv_fetchpv("0",TRUE, SVt_PV))) {
3555 #ifdef MACOS_TRADITIONAL
3556 /* $0 is not majick on a Mac */
3557 sv_setpv(GvSV(tmpgv),MacPerl_MPWFileName(PL_origfilename));
3559 sv_setpv(GvSV(tmpgv),PL_origfilename);
3560 magicname("0", "0", 1);
3563 if ((tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))) {/* $^X */
3564 #ifdef HAS_PROCSELFEXE
3565 S_procself_val(aTHX_ GvSV(tmpgv), PL_origargv[0]);
3568 sv_setpv(GvSV(tmpgv), os2_execname(aTHX));
3570 sv_setpv(GvSV(tmpgv),PL_origargv[0]);
3574 if ((PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV))) {
3576 GvMULTI_on(PL_envgv);
3577 hv = GvHVn(PL_envgv);
3578 hv_magic(hv, Nullgv, PERL_MAGIC_env);
3579 #ifdef USE_ENVIRON_ARRAY
3580 /* Note that if the supplied env parameter is actually a copy
3581 of the global environ then it may now point to free'd memory
3582 if the environment has been modified since. To avoid this
3583 problem we treat env==NULL as meaning 'use the default'
3588 # ifdef USE_ITHREADS
3589 && PL_curinterp == aTHX
3593 environ[0] = Nullch;
3596 for (; *env; env++) {
3597 if (!(s = strchr(*env,'=')))
3604 sv = newSVpv(s+1, 0);
3605 (void)hv_store(hv, *env, s - *env, sv, 0);
3609 #endif /* USE_ENVIRON_ARRAY */
3612 if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV))) {
3613 SvREADONLY_off(GvSV(tmpgv));
3614 sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
3615 SvREADONLY_on(GvSV(tmpgv));
3618 /* touch @F array to prevent spurious warnings 20020415 MJD */
3620 (void) get_av("main::F", TRUE | GV_ADDMULTI);
3622 /* touch @- and @+ arrays to prevent spurious warnings 20020415 MJD */
3623 (void) get_av("main::-", TRUE | GV_ADDMULTI);
3624 (void) get_av("main::+", TRUE | GV_ADDMULTI);
3628 S_init_perllib(pTHX)
3633 s = PerlEnv_getenv("PERL5LIB");
3635 incpush(s, TRUE, TRUE);
3637 incpush(PerlEnv_getenv("PERLLIB"), FALSE, FALSE);
3639 /* Treat PERL5?LIB as a possible search list logical name -- the
3640 * "natural" VMS idiom for a Unix path string. We allow each
3641 * element to be a set of |-separated directories for compatibility.
3645 if (my_trnlnm("PERL5LIB",buf,0))
3646 do { incpush(buf,TRUE,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
3648 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE,FALSE);
3652 /* Use the ~-expanded versions of APPLLIB (undocumented),
3653 ARCHLIB PRIVLIB SITEARCH SITELIB VENDORARCH and VENDORLIB
3656 incpush(APPLLIB_EXP, TRUE, TRUE);
3660 incpush(ARCHLIB_EXP, FALSE, FALSE);
3662 #ifdef MACOS_TRADITIONAL
3665 SV * privdir = NEWSV(55, 0);
3666 char * macperl = PerlEnv_getenv("MACPERL");
3671 Perl_sv_setpvf(aTHX_ privdir, "%slib:", macperl);
3672 if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
3673 incpush(SvPVX(privdir), TRUE, FALSE);
3674 Perl_sv_setpvf(aTHX_ privdir, "%ssite_perl:", macperl);
3675 if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
3676 incpush(SvPVX(privdir), TRUE, FALSE);
3678 SvREFCNT_dec(privdir);
3681 incpush(":", FALSE, FALSE);
3684 # define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
3687 incpush(PRIVLIB_EXP, TRUE, FALSE);
3689 incpush(PRIVLIB_EXP, FALSE, FALSE);
3693 /* sitearch is always relative to sitelib on Windows for
3694 * DLL-based path intuition to work correctly */
3695 # if !defined(WIN32)
3696 incpush(SITEARCH_EXP, FALSE, FALSE);
3702 incpush(SITELIB_EXP, TRUE, FALSE); /* this picks up sitearch as well */
3704 incpush(SITELIB_EXP, FALSE, FALSE);
3708 #ifdef SITELIB_STEM /* Search for version-specific dirs below here */
3709 incpush(SITELIB_STEM, FALSE, TRUE);
3712 #ifdef PERL_VENDORARCH_EXP
3713 /* vendorarch is always relative to vendorlib on Windows for
3714 * DLL-based path intuition to work correctly */
3715 # if !defined(WIN32)
3716 incpush(PERL_VENDORARCH_EXP, FALSE, FALSE);
3720 #ifdef PERL_VENDORLIB_EXP
3722 incpush(PERL_VENDORLIB_EXP, TRUE, FALSE); /* this picks up vendorarch as well */
3724 incpush(PERL_VENDORLIB_EXP, FALSE, FALSE);
3728 #ifdef PERL_VENDORLIB_STEM /* Search for version-specific dirs below here */
3729 incpush(PERL_VENDORLIB_STEM, FALSE, TRUE);
3732 #ifdef PERL_OTHERLIBDIRS
3733 incpush(PERL_OTHERLIBDIRS, TRUE, TRUE);
3737 incpush(".", FALSE, FALSE);
3738 #endif /* MACOS_TRADITIONAL */
3741 #if defined(DOSISH) || defined(EPOC)
3742 # define PERLLIB_SEP ';'
3745 # define PERLLIB_SEP '|'
3747 # if defined(MACOS_TRADITIONAL)
3748 # define PERLLIB_SEP ','
3750 # define PERLLIB_SEP ':'
3754 #ifndef PERLLIB_MANGLE
3755 # define PERLLIB_MANGLE(s,n) (s)
3759 S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers)
3761 SV *subdir = Nullsv;
3766 if (addsubdirs || addoldvers) {
3767 subdir = sv_newmortal();
3770 /* Break at all separators */
3772 SV *libdir = NEWSV(55,0);
3775 /* skip any consecutive separators */
3776 while ( *p == PERLLIB_SEP ) {
3777 /* Uncomment the next line for PATH semantics */
3778 /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */
3782 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
3783 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
3788 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
3789 p = Nullch; /* break out */
3791 #ifdef MACOS_TRADITIONAL
3792 if (!strchr(SvPVX(libdir), ':')) {
3795 sv_setpv(libdir, MacPerl_CanonDir(SvPVX(libdir), buf, 0));
3797 if (SvPVX(libdir)[SvCUR(libdir)-1] != ':')
3798 sv_catpv(libdir, ":");
3802 * BEFORE pushing libdir onto @INC we may first push version- and
3803 * archname-specific sub-directories.
3805 if (addsubdirs || addoldvers) {
3806 #ifdef PERL_INC_VERSION_LIST
3807 /* Configure terminates PERL_INC_VERSION_LIST with a NULL */
3808 const char *incverlist[] = { PERL_INC_VERSION_LIST };
3809 const char **incver;
3816 if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) {
3818 while (unix[len-1] == '/') len--; /* Cosmetic */
3819 sv_usepvn(libdir,unix,len);
3822 PerlIO_printf(Perl_error_log,
3823 "Failed to unixify @INC element \"%s\"\n",
3827 #ifdef MACOS_TRADITIONAL
3828 #define PERL_AV_SUFFIX_FMT ""
3829 #define PERL_ARCH_FMT "%s:"
3830 #define PERL_ARCH_FMT_PATH PERL_FS_VER_FMT PERL_AV_SUFFIX_FMT
3832 #define PERL_AV_SUFFIX_FMT "/"
3833 #define PERL_ARCH_FMT "/%s"
3834 #define PERL_ARCH_FMT_PATH PERL_AV_SUFFIX_FMT PERL_FS_VER_FMT
3836 /* .../version/archname if -d .../version/archname */
3837 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH PERL_ARCH_FMT,
3839 (int)PERL_REVISION, (int)PERL_VERSION,
3840 (int)PERL_SUBVERSION, ARCHNAME);
3841 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3842 S_ISDIR(tmpstatbuf.st_mode))
3843 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3845 /* .../version if -d .../version */
3846 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH, libdir,
3847 (int)PERL_REVISION, (int)PERL_VERSION,
3848 (int)PERL_SUBVERSION);
3849 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3850 S_ISDIR(tmpstatbuf.st_mode))
3851 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3853 /* .../archname if -d .../archname */
3854 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, ARCHNAME);
3855 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3856 S_ISDIR(tmpstatbuf.st_mode))
3857 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3860 #ifdef PERL_INC_VERSION_LIST
3862 for (incver = incverlist; *incver; incver++) {
3863 /* .../xxx if -d .../xxx */
3864 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, *incver);
3865 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3866 S_ISDIR(tmpstatbuf.st_mode))
3867 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3873 /* finally push this lib directory on the end of @INC */
3874 av_push(GvAVn(PL_incgv), libdir);
3878 #ifdef USE_5005THREADS
3879 STATIC struct perl_thread *
3880 S_init_main_thread(pTHX)
3882 #if !defined(PERL_IMPLICIT_CONTEXT)
3883 struct perl_thread *thr;
3887 Newz(53, thr, 1, struct perl_thread);
3888 PL_curcop = &PL_compiling;
3889 thr->interp = PERL_GET_INTERP;
3890 thr->cvcache = newHV();
3891 thr->threadsv = newAV();
3892 /* thr->threadsvp is set when find_threadsv is called */
3893 thr->specific = newAV();
3894 thr->flags = THRf_R_JOINABLE;
3895 MUTEX_INIT(&thr->mutex);
3896 /* Handcraft thrsv similarly to mess_sv */
3897 New(53, PL_thrsv, 1, SV);
3898 Newz(53, xpv, 1, XPV);
3899 SvFLAGS(PL_thrsv) = SVt_PV;
3900 SvANY(PL_thrsv) = (void*)xpv;
3901 SvREFCNT(PL_thrsv) = 1 << 30; /* practically infinite */
3902 SvPVX(PL_thrsv) = (char*)thr;
3903 SvCUR_set(PL_thrsv, sizeof(thr));
3904 SvLEN_set(PL_thrsv, sizeof(thr));
3905 *SvEND(PL_thrsv) = '\0'; /* in the trailing_nul field */
3906 thr->oursv = PL_thrsv;
3907 PL_chopset = " \n-";
3910 MUTEX_LOCK(&PL_threads_mutex);
3916 MUTEX_UNLOCK(&PL_threads_mutex);
3918 #ifdef HAVE_THREAD_INTERN
3919 Perl_init_thread_intern(thr);
3922 #ifdef SET_THREAD_SELF
3923 SET_THREAD_SELF(thr);
3925 thr->self = pthread_self();
3926 #endif /* SET_THREAD_SELF */
3930 * These must come after the thread self setting
3931 * because sv_setpvn does SvTAINT and the taint
3932 * fields thread selfness being set.
3934 PL_toptarget = NEWSV(0,0);
3935 sv_upgrade(PL_toptarget, SVt_PVFM);
3936 sv_setpvn(PL_toptarget, "", 0);
3937 PL_bodytarget = NEWSV(0,0);
3938 sv_upgrade(PL_bodytarget, SVt_PVFM);
3939 sv_setpvn(PL_bodytarget, "", 0);
3940 PL_formtarget = PL_bodytarget;
3941 thr->errsv = newSVpvn("", 0);
3942 (void) find_threadsv("@"); /* Ensure $@ is initialised early */
3945 PL_peepp = MEMBER_TO_FPTR(Perl_peep);
3946 PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
3947 PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
3948 PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
3949 PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
3950 PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
3952 PL_reginterp_cnt = 0;
3956 #endif /* USE_5005THREADS */
3959 Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
3962 line_t oldline = CopLINE(PL_curcop);
3968 while (AvFILL(paramList) >= 0) {
3969 cv = (CV*)av_shift(paramList);
3970 if (PL_savebegin && (paramList == PL_beginav)) {
3971 /* save PL_beginav for compiler */
3972 if (! PL_beginav_save)
3973 PL_beginav_save = newAV();
3974 av_push(PL_beginav_save, (SV*)cv);
3978 #ifdef PERL_FLEXIBLE_EXCEPTIONS
3979 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_list_body), cv);
3985 #ifndef PERL_FLEXIBLE_EXCEPTIONS
3989 (void)SvPV(atsv, len);
3992 PL_curcop = &PL_compiling;
3993 CopLINE_set(PL_curcop, oldline);
3994 if (paramList == PL_beginav)
3995 sv_catpv(atsv, "BEGIN failed--compilation aborted");
3997 Perl_sv_catpvf(aTHX_ atsv,
3998 "%s failed--call queue aborted",
3999 paramList == PL_checkav ? "CHECK"
4000 : paramList == PL_initav ? "INIT"
4002 while (PL_scopestack_ix > oldscope)
4005 Perl_croak(aTHX_ "%s", SvPVx(atsv, n_a));
4012 /* my_exit() was called */
4013 while (PL_scopestack_ix > oldscope)
4016 PL_curstash = PL_defstash;
4017 PL_curcop = &PL_compiling;
4018 CopLINE_set(PL_curcop, oldline);
4020 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) {
4021 if (paramList == PL_beginav)
4022 Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
4024 Perl_croak(aTHX_ "%s failed--call queue aborted",
4025 paramList == PL_checkav ? "CHECK"
4026 : paramList == PL_initav ? "INIT"
4033 PL_curcop = &PL_compiling;
4034 CopLINE_set(PL_curcop, oldline);
4037 PerlIO_printf(Perl_error_log, "panic: restartop\n");
4045 #ifdef PERL_FLEXIBLE_EXCEPTIONS
4047 S_vcall_list_body(pTHX_ va_list args)
4049 CV *cv = va_arg(args, CV*);
4050 return call_list_body(cv);
4055 S_call_list_body(pTHX_ CV *cv)
4057 PUSHMARK(PL_stack_sp);
4058 call_sv((SV*)cv, G_EVAL|G_DISCARD);
4063 Perl_my_exit(pTHX_ U32 status)
4065 DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
4066 thr, (unsigned long) status));
4075 STATUS_NATIVE_SET(status);
4082 Perl_my_failure_exit(pTHX)
4085 if (vaxc$errno & 1) {
4086 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
4087 STATUS_NATIVE_SET(44);
4090 if (!vaxc$errno && errno) /* unlikely */
4091 STATUS_NATIVE_SET(44);
4093 STATUS_NATIVE_SET(vaxc$errno);
4098 STATUS_POSIX_SET(errno);
4100 exitstatus = STATUS_POSIX >> 8;
4101 if (exitstatus & 255)
4102 STATUS_POSIX_SET(exitstatus);
4104 STATUS_POSIX_SET(255);
4111 S_my_exit_jump(pTHX)
4113 register PERL_CONTEXT *cx;
4118 SvREFCNT_dec(PL_e_script);
4119 PL_e_script = Nullsv;
4122 POPSTACK_TO(PL_mainstack);
4123 if (cxstack_ix >= 0) {
4126 POPBLOCK(cx,PL_curpm);
4134 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen)
4137 p = SvPVX(PL_e_script);
4138 nl = strchr(p, '\n');
4139 nl = (nl) ? nl+1 : SvEND(PL_e_script);
4141 filter_del(read_e_script);
4144 sv_catpvn(buf_sv, p, nl-p);
4145 sv_chop(PL_e_script, nl);