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 */
19 /* XXX If this causes problems, set i_unistd=undef in the hint file. */
24 #if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE) && !defined(PERL_MICRO)
25 char *getenv (char *); /* Usually in <stdlib.h> */
28 static I32 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen);
36 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
42 #if defined(USE_5005THREADS)
43 # define INIT_TLS_AND_INTERP \
45 if (!PL_curinterp) { \
46 PERL_SET_INTERP(my_perl); \
52 # if defined(USE_ITHREADS)
53 # define INIT_TLS_AND_INTERP \
55 if (!PL_curinterp) { \
56 PERL_SET_INTERP(my_perl); \
59 PERL_SET_THX(my_perl); \
63 PERL_SET_THX(my_perl); \
67 # define INIT_TLS_AND_INTERP \
69 if (!PL_curinterp) { \
70 PERL_SET_INTERP(my_perl); \
72 PERL_SET_THX(my_perl); \
77 #ifdef PERL_IMPLICIT_SYS
79 perl_alloc_using(struct IPerlMem* ipM, struct IPerlMem* ipMS,
80 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
81 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
82 struct IPerlDir* ipD, struct IPerlSock* ipS,
83 struct IPerlProc* ipP)
85 PerlInterpreter *my_perl;
86 /* New() needs interpreter, so call malloc() instead */
87 my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
89 Zero(my_perl, 1, PerlInterpreter);
105 =head1 Embedding Functions
107 =for apidoc perl_alloc
109 Allocates a new Perl interpreter. See L<perlembed>.
117 PerlInterpreter *my_perl;
118 #ifdef USE_5005THREADS
122 /* New() needs interpreter, so call malloc() instead */
123 my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
126 Zero(my_perl, 1, PerlInterpreter);
129 #endif /* PERL_IMPLICIT_SYS */
132 =for apidoc perl_construct
134 Initializes a new Perl interpreter. See L<perlembed>.
140 perl_construct(pTHXx)
142 #ifdef USE_5005THREADS
144 struct perl_thread *thr = NULL;
145 #endif /* FAKE_THREADS */
146 #endif /* USE_5005THREADS */
150 PL_perl_destruct_level = 1;
152 if (PL_perl_destruct_level > 0)
156 /* Init the real globals (and main thread)? */
158 #ifdef USE_5005THREADS
159 MUTEX_INIT(&PL_sv_mutex);
161 * Safe to use basic SV functions from now on (though
162 * not things like mortals or tainting yet).
164 MUTEX_INIT(&PL_eval_mutex);
165 COND_INIT(&PL_eval_cond);
166 MUTEX_INIT(&PL_threads_mutex);
167 COND_INIT(&PL_nthreads_cond);
168 # ifdef EMULATE_ATOMIC_REFCOUNTS
169 MUTEX_INIT(&PL_svref_mutex);
170 # endif /* EMULATE_ATOMIC_REFCOUNTS */
172 MUTEX_INIT(&PL_cred_mutex);
173 MUTEX_INIT(&PL_sv_lock_mutex);
174 MUTEX_INIT(&PL_fdpid_mutex);
176 thr = init_main_thread();
177 #endif /* USE_5005THREADS */
179 #ifdef PERL_FLEXIBLE_EXCEPTIONS
180 PL_protect = MEMBER_TO_FPTR(Perl_default_protect); /* for exceptions */
183 PL_curcop = &PL_compiling; /* needed by ckWARN, right away */
185 PL_linestr = NEWSV(65,79);
186 sv_upgrade(PL_linestr,SVt_PVIV);
188 if (!SvREADONLY(&PL_sv_undef)) {
189 /* set read-only and try to insure than we wont see REFCNT==0
192 SvREADONLY_on(&PL_sv_undef);
193 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
195 sv_setpv(&PL_sv_no,PL_No);
197 SvREADONLY_on(&PL_sv_no);
198 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
200 sv_setpv(&PL_sv_yes,PL_Yes);
202 SvREADONLY_on(&PL_sv_yes);
203 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
206 PL_sighandlerp = Perl_sighandler;
207 PL_pidstatus = newHV();
210 PL_rs = newSVpvn("\n", 1);
215 PL_lex_state = LEX_NOTPARSING;
221 SET_NUMERIC_STANDARD();
225 PL_patchlevel = NEWSV(0,4);
226 (void)SvUPGRADE(PL_patchlevel, SVt_PVNV);
227 if (PERL_REVISION > 127 || PERL_VERSION > 127 || PERL_SUBVERSION > 127)
228 SvGROW(PL_patchlevel, UTF8_MAXLEN*3+1);
229 s = (U8*)SvPVX(PL_patchlevel);
230 /* Build version strings using "native" characters */
231 s = uvchr_to_utf8(s, (UV)PERL_REVISION);
232 s = uvchr_to_utf8(s, (UV)PERL_VERSION);
233 s = uvchr_to_utf8(s, (UV)PERL_SUBVERSION);
235 SvCUR_set(PL_patchlevel, s - (U8*)SvPVX(PL_patchlevel));
236 SvPOK_on(PL_patchlevel);
237 SvNVX(PL_patchlevel) = (NV)PERL_REVISION
238 + ((NV)PERL_VERSION / (NV)1000)
239 #if defined(PERL_SUBVERSION) && PERL_SUBVERSION > 0
240 + ((NV)PERL_SUBVERSION / (NV)1000000)
243 SvNOK_on(PL_patchlevel); /* dual valued */
244 SvUTF8_on(PL_patchlevel);
245 SvREADONLY_on(PL_patchlevel);
248 #if defined(LOCAL_PATCH_COUNT)
249 PL_localpatches = local_patches; /* For possible -v */
252 #ifdef HAVE_INTERP_INTERN
256 PerlIO_init(aTHX); /* Hook to IO system */
258 PL_fdpid = newAV(); /* for remembering popen pids by fd */
259 PL_modglobal = newHV(); /* pointers to per-interpreter module globals */
260 PL_errors = newSVpvn("",0);
261 sv_setpvn(PERL_DEBUG_PAD(0), "", 0); /* For regex debugging. */
262 sv_setpvn(PERL_DEBUG_PAD(1), "", 0); /* ext/re needs these */
263 sv_setpvn(PERL_DEBUG_PAD(2), "", 0); /* even without DEBUGGING. */
265 PL_regex_padav = newAV();
266 av_push(PL_regex_padav,(SV*)newAV()); /* First entry is an array of empty elements */
267 PL_regex_pad = AvARRAY(PL_regex_padav);
269 #ifdef USE_REENTRANT_API
270 Perl_reentrant_init(aTHX);
273 /* Note that strtab is a rather special HV. Assumptions are made
274 about not iterating on it, and not adding tie magic to it.
275 It is properly deallocated in perl_destruct() */
278 #ifdef USE_5005THREADS
279 MUTEX_INIT(&PL_strtab_mutex);
281 HvSHAREKEYS_off(PL_strtab); /* mandatory */
282 hv_ksplit(PL_strtab, 512);
284 #if defined(__DYNAMIC__) && (defined(NeXT) || defined(__NeXT__))
285 _dyld_lookup_and_bind
286 ("__environ", (unsigned long *) &environ_pointer, NULL);
289 #ifdef USE_ENVIRON_ARRAY
290 PL_origenviron = environ;
297 =for apidoc nothreadhook
299 Stub that provides thread hook for perl_destruct when there are
306 Perl_nothreadhook(pTHX)
312 =for apidoc perl_destruct
314 Shuts down a Perl interpreter. See L<perlembed>.
322 volatile int destruct_level; /* 0=none, 1=full, 2=full with checks */
324 #ifdef USE_5005THREADS
327 #endif /* USE_5005THREADS */
329 /* wait for all pseudo-forked children to finish */
330 PERL_WAIT_FOR_CHILDREN;
332 #ifdef USE_5005THREADS
334 /* Pass 1 on any remaining threads: detach joinables, join zombies */
336 MUTEX_LOCK(&PL_threads_mutex);
337 DEBUG_S(PerlIO_printf(Perl_debug_log,
338 "perl_destruct: waiting for %d threads...\n",
340 for (t = thr->next; t != thr; t = t->next) {
341 MUTEX_LOCK(&t->mutex);
342 switch (ThrSTATE(t)) {
345 DEBUG_S(PerlIO_printf(Perl_debug_log,
346 "perl_destruct: joining zombie %p\n", t));
347 ThrSETSTATE(t, THRf_DEAD);
348 MUTEX_UNLOCK(&t->mutex);
351 * The SvREFCNT_dec below may take a long time (e.g. av
352 * may contain an object scalar whose destructor gets
353 * called) so we have to unlock threads_mutex and start
356 MUTEX_UNLOCK(&PL_threads_mutex);
358 SvREFCNT_dec((SV*)av);
359 DEBUG_S(PerlIO_printf(Perl_debug_log,
360 "perl_destruct: joined zombie %p OK\n", t));
362 case THRf_R_JOINABLE:
363 DEBUG_S(PerlIO_printf(Perl_debug_log,
364 "perl_destruct: detaching thread %p\n", t));
365 ThrSETSTATE(t, THRf_R_DETACHED);
367 * We unlock threads_mutex and t->mutex in the opposite order
368 * from which we locked them just so that DETACH won't
369 * deadlock if it panics. It's only a breach of good style
370 * not a bug since they are unlocks not locks.
372 MUTEX_UNLOCK(&PL_threads_mutex);
374 MUTEX_UNLOCK(&t->mutex);
377 DEBUG_S(PerlIO_printf(Perl_debug_log,
378 "perl_destruct: ignoring %p (state %u)\n",
380 MUTEX_UNLOCK(&t->mutex);
381 /* fall through and out */
384 /* We leave the above "Pass 1" loop with threads_mutex still locked */
386 /* Pass 2 on remaining threads: wait for the thread count to drop to one */
387 while (PL_nthreads > 1)
389 DEBUG_S(PerlIO_printf(Perl_debug_log,
390 "perl_destruct: final wait for %d threads\n",
392 COND_WAIT(&PL_nthreads_cond, &PL_threads_mutex);
394 /* At this point, we're the last thread */
395 MUTEX_UNLOCK(&PL_threads_mutex);
396 DEBUG_S(PerlIO_printf(Perl_debug_log, "perl_destruct: armageddon has arrived\n"));
397 MUTEX_DESTROY(&PL_threads_mutex);
398 COND_DESTROY(&PL_nthreads_cond);
400 #endif /* !defined(FAKE_THREADS) */
401 #endif /* USE_5005THREADS */
403 destruct_level = PL_perl_destruct_level;
407 if ((s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL"))) {
409 if (destruct_level < i)
416 if(PL_exit_flags & PERL_EXIT_DESTRUCT_END) {
421 if (PL_endav && !PL_minus_c)
422 call_list(PL_scopestack_ix, PL_endav);
428 /* Need to flush since END blocks can produce output */
429 PerlIO_flush((PerlIO*)NULL);
431 if (CALL_FPTR(PL_threadhook)(aTHX)) {
432 /* Threads hook has vetoed further cleanup */
433 return STATUS_NATIVE_EXPORT;;
436 /* We must account for everything. */
438 /* Destroy the main CV and syntax tree */
440 PL_curpad = AvARRAY(PL_comppad);
441 op_free(PL_main_root);
442 PL_main_root = Nullop;
444 PL_curcop = &PL_compiling;
445 PL_main_start = Nullop;
446 SvREFCNT_dec(PL_main_cv);
450 /* Tell PerlIO we are about to tear things apart in case
451 we have layers which are using resources that should
455 PerlIO_destruct(aTHX);
457 if (PL_sv_objcount) {
459 * Try to destruct global references. We do this first so that the
460 * destructors and destructees still exist. Some sv's might remain.
461 * Non-referenced objects are on their own.
466 /* unhook hooks which will soon be, or use, destroyed data */
467 SvREFCNT_dec(PL_warnhook);
468 PL_warnhook = Nullsv;
469 SvREFCNT_dec(PL_diehook);
472 /* call exit list functions */
473 while (PL_exitlistlen-- > 0)
474 PL_exitlist[PL_exitlistlen].fn(aTHX_ PL_exitlist[PL_exitlistlen].ptr);
476 Safefree(PL_exitlist);
478 if (destruct_level == 0){
480 DEBUG_P(debprofdump());
482 #if defined(PERLIO_LAYERS)
483 /* No more IO - including error messages ! */
484 PerlIO_cleanup(aTHX);
487 /* The exit() function will do everything that needs doing. */
488 return STATUS_NATIVE_EXPORT;;
491 /* jettison our possibly duplicated environment */
492 /* if PERL_USE_SAFE_PUTENV is defined environ will not have been copied
493 * so we certainly shouldn't free it here
495 #if defined(USE_ENVIRON_ARRAY) && !defined(PERL_USE_SAFE_PUTENV)
496 if (environ != PL_origenviron) {
499 for (i = 0; environ[i]; i++)
500 safesysfree(environ[i]);
502 /* Must use safesysfree() when working with environ. */
503 safesysfree(environ);
505 environ = PL_origenviron;
510 /* the syntax tree is shared between clones
511 * so op_free(PL_main_root) only ReREFCNT_dec's
512 * REGEXPs in the parent interpreter
513 * we need to manually ReREFCNT_dec for the clones
516 I32 i = AvFILLp(PL_regex_padav) + 1;
517 SV **ary = AvARRAY(PL_regex_padav);
521 REGEXP *re = INT2PTR(REGEXP *,SvIVX(resv));
523 if (SvFLAGS(resv) & SVf_BREAK) {
524 /* this is PL_reg_curpm, already freed
525 * flag is set in regexec.c:S_regtry
527 SvFLAGS(resv) &= ~SVf_BREAK;
529 else if(SvREPADTMP(resv)) {
530 SvREPADTMP_off(resv);
537 SvREFCNT_dec(PL_regex_padav);
538 PL_regex_padav = Nullav;
542 /* loosen bonds of global variables */
545 (void)PerlIO_close(PL_rsfp);
549 /* Filters for program text */
550 SvREFCNT_dec(PL_rsfp_filters);
551 PL_rsfp_filters = Nullav;
554 PL_preprocess = FALSE;
560 PL_doswitches = FALSE;
561 PL_dowarn = G_WARN_OFF;
562 PL_doextract = FALSE;
563 PL_sawampersand = FALSE; /* must save all match strings */
566 Safefree(PL_inplace);
568 SvREFCNT_dec(PL_patchlevel);
571 SvREFCNT_dec(PL_e_script);
572 PL_e_script = Nullsv;
575 while (--PL_origargc >= 0) {
576 Safefree(PL_origargv[PL_origargc]);
578 Safefree(PL_origargv);
580 /* magical thingies */
582 SvREFCNT_dec(PL_ofs_sv); /* $, */
585 SvREFCNT_dec(PL_ors_sv); /* $\ */
588 SvREFCNT_dec(PL_rs); /* $/ */
591 PL_multiline = 0; /* $* */
592 Safefree(PL_osname); /* $^O */
595 SvREFCNT_dec(PL_statname);
596 PL_statname = Nullsv;
599 /* defgv, aka *_ should be taken care of elsewhere */
601 /* clean up after study() */
602 SvREFCNT_dec(PL_lastscream);
603 PL_lastscream = Nullsv;
604 Safefree(PL_screamfirst);
606 Safefree(PL_screamnext);
610 Safefree(PL_efloatbuf);
611 PL_efloatbuf = Nullch;
614 /* startup and shutdown function lists */
615 SvREFCNT_dec(PL_beginav);
616 SvREFCNT_dec(PL_beginav_save);
617 SvREFCNT_dec(PL_endav);
618 SvREFCNT_dec(PL_checkav);
619 SvREFCNT_dec(PL_initav);
621 PL_beginav_save = Nullav;
626 /* shortcuts just get cleared */
632 PL_argvoutgv = Nullgv;
634 PL_stderrgv = Nullgv;
635 PL_last_in_gv = Nullgv;
637 PL_debstash = Nullhv;
639 /* reset so print() ends up where we expect */
642 SvREFCNT_dec(PL_argvout_stack);
643 PL_argvout_stack = Nullav;
645 SvREFCNT_dec(PL_modglobal);
646 PL_modglobal = Nullhv;
647 SvREFCNT_dec(PL_preambleav);
648 PL_preambleav = Nullav;
649 SvREFCNT_dec(PL_subname);
651 SvREFCNT_dec(PL_linestr);
653 SvREFCNT_dec(PL_pidstatus);
654 PL_pidstatus = Nullhv;
655 SvREFCNT_dec(PL_toptarget);
656 PL_toptarget = Nullsv;
657 SvREFCNT_dec(PL_bodytarget);
658 PL_bodytarget = Nullsv;
659 PL_formtarget = Nullsv;
661 /* free locale stuff */
662 #ifdef USE_LOCALE_COLLATE
663 Safefree(PL_collation_name);
664 PL_collation_name = Nullch;
667 #ifdef USE_LOCALE_NUMERIC
668 Safefree(PL_numeric_name);
669 PL_numeric_name = Nullch;
670 SvREFCNT_dec(PL_numeric_radix_sv);
673 /* clear utf8 character classes */
674 SvREFCNT_dec(PL_utf8_alnum);
675 SvREFCNT_dec(PL_utf8_alnumc);
676 SvREFCNT_dec(PL_utf8_ascii);
677 SvREFCNT_dec(PL_utf8_alpha);
678 SvREFCNT_dec(PL_utf8_space);
679 SvREFCNT_dec(PL_utf8_cntrl);
680 SvREFCNT_dec(PL_utf8_graph);
681 SvREFCNT_dec(PL_utf8_digit);
682 SvREFCNT_dec(PL_utf8_upper);
683 SvREFCNT_dec(PL_utf8_lower);
684 SvREFCNT_dec(PL_utf8_print);
685 SvREFCNT_dec(PL_utf8_punct);
686 SvREFCNT_dec(PL_utf8_xdigit);
687 SvREFCNT_dec(PL_utf8_mark);
688 SvREFCNT_dec(PL_utf8_toupper);
689 SvREFCNT_dec(PL_utf8_totitle);
690 SvREFCNT_dec(PL_utf8_tolower);
691 SvREFCNT_dec(PL_utf8_tofold);
692 SvREFCNT_dec(PL_utf8_idstart);
693 SvREFCNT_dec(PL_utf8_idcont);
694 PL_utf8_alnum = Nullsv;
695 PL_utf8_alnumc = Nullsv;
696 PL_utf8_ascii = Nullsv;
697 PL_utf8_alpha = Nullsv;
698 PL_utf8_space = Nullsv;
699 PL_utf8_cntrl = Nullsv;
700 PL_utf8_graph = Nullsv;
701 PL_utf8_digit = Nullsv;
702 PL_utf8_upper = Nullsv;
703 PL_utf8_lower = Nullsv;
704 PL_utf8_print = Nullsv;
705 PL_utf8_punct = Nullsv;
706 PL_utf8_xdigit = Nullsv;
707 PL_utf8_mark = Nullsv;
708 PL_utf8_toupper = Nullsv;
709 PL_utf8_totitle = Nullsv;
710 PL_utf8_tolower = Nullsv;
711 PL_utf8_tofold = Nullsv;
712 PL_utf8_idstart = Nullsv;
713 PL_utf8_idcont = Nullsv;
715 if (!specialWARN(PL_compiling.cop_warnings))
716 SvREFCNT_dec(PL_compiling.cop_warnings);
717 PL_compiling.cop_warnings = Nullsv;
718 if (!specialCopIO(PL_compiling.cop_io))
719 SvREFCNT_dec(PL_compiling.cop_io);
720 PL_compiling.cop_io = Nullsv;
721 CopFILE_free(&PL_compiling);
722 CopSTASH_free(&PL_compiling);
724 /* Prepare to destruct main symbol table. */
729 SvREFCNT_dec(PL_curstname);
730 PL_curstname = Nullsv;
732 /* clear queued errors */
733 SvREFCNT_dec(PL_errors);
737 if (destruct_level >= 2 && ckWARN_d(WARN_INTERNAL)) {
738 if (PL_scopestack_ix != 0)
739 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
740 "Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
741 (long)PL_scopestack_ix);
742 if (PL_savestack_ix != 0)
743 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
744 "Unbalanced saves: %ld more saves than restores\n",
745 (long)PL_savestack_ix);
746 if (PL_tmps_floor != -1)
747 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced tmps: %ld more allocs than frees\n",
748 (long)PL_tmps_floor + 1);
749 if (cxstack_ix != -1)
750 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced context: %ld more PUSHes than POPs\n",
751 (long)cxstack_ix + 1);
754 /* Now absolutely destruct everything, somehow or other, loops or no. */
755 SvFLAGS(PL_fdpid) |= SVTYPEMASK; /* don't clean out pid table now */
756 SvFLAGS(PL_strtab) |= SVTYPEMASK; /* don't clean out strtab now */
758 /* the 2 is for PL_fdpid and PL_strtab */
759 while (PL_sv_count > 2 && sv_clean_all())
762 SvFLAGS(PL_fdpid) &= ~SVTYPEMASK;
763 SvFLAGS(PL_fdpid) |= SVt_PVAV;
764 SvFLAGS(PL_strtab) &= ~SVTYPEMASK;
765 SvFLAGS(PL_strtab) |= SVt_PVHV;
767 AvREAL_off(PL_fdpid); /* no surviving entries */
768 SvREFCNT_dec(PL_fdpid); /* needed in io_close() */
771 #ifdef HAVE_INTERP_INTERN
775 /* Destruct the global string table. */
777 /* Yell and reset the HeVAL() slots that are still holding refcounts,
778 * so that sv_free() won't fail on them.
786 max = HvMAX(PL_strtab);
787 array = HvARRAY(PL_strtab);
790 if (hent && ckWARN_d(WARN_INTERNAL)) {
791 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
792 "Unbalanced string table refcount: (%d) for \"%s\"",
793 HeVAL(hent) - Nullsv, HeKEY(hent));
794 HeVAL(hent) = Nullsv;
804 SvREFCNT_dec(PL_strtab);
807 /* free the pointer table used for cloning */
808 ptr_table_free(PL_ptr_table);
811 /* free special SVs */
813 SvREFCNT(&PL_sv_yes) = 0;
814 sv_clear(&PL_sv_yes);
815 SvANY(&PL_sv_yes) = NULL;
816 SvFLAGS(&PL_sv_yes) = 0;
818 SvREFCNT(&PL_sv_no) = 0;
820 SvANY(&PL_sv_no) = NULL;
821 SvFLAGS(&PL_sv_no) = 0;
823 SvREFCNT(&PL_sv_undef) = 0;
824 SvREADONLY_off(&PL_sv_undef);
828 for (i=0; i<=2; i++) {
829 SvREFCNT(PERL_DEBUG_PAD(i)) = 0;
830 sv_clear(PERL_DEBUG_PAD(i));
831 SvANY(PERL_DEBUG_PAD(i)) = NULL;
832 SvFLAGS(PERL_DEBUG_PAD(i)) = 0;
836 if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL))
837 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Scalars leaked: %ld\n", (long)PL_sv_count);
839 #if defined(PERLIO_LAYERS)
840 /* No more IO - including error messages ! */
841 PerlIO_cleanup(aTHX);
844 Safefree(PL_origfilename);
845 Safefree(PL_reg_start_tmp);
847 Safefree(PL_reg_curpm);
848 Safefree(PL_reg_poscache);
849 Safefree(HeKEY_hek(&PL_hv_fetch_ent_mh));
850 Safefree(PL_op_mask);
851 Safefree(PL_psig_ptr);
852 Safefree(PL_psig_name);
853 Safefree(PL_bitcount);
854 Safefree(PL_psig_pend);
856 PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */
858 DEBUG_P(debprofdump());
859 #ifdef USE_5005THREADS
860 MUTEX_DESTROY(&PL_strtab_mutex);
861 MUTEX_DESTROY(&PL_sv_mutex);
862 MUTEX_DESTROY(&PL_eval_mutex);
863 MUTEX_DESTROY(&PL_cred_mutex);
864 MUTEX_DESTROY(&PL_fdpid_mutex);
865 COND_DESTROY(&PL_eval_cond);
866 #ifdef EMULATE_ATOMIC_REFCOUNTS
867 MUTEX_DESTROY(&PL_svref_mutex);
868 #endif /* EMULATE_ATOMIC_REFCOUNTS */
870 /* As the penultimate thing, free the non-arena SV for thrsv */
871 Safefree(SvPVX(PL_thrsv));
872 Safefree(SvANY(PL_thrsv));
875 #endif /* USE_5005THREADS */
877 #ifdef USE_REENTRANT_API
878 Perl_reentrant_free(aTHX);
883 /* As the absolutely last thing, free the non-arena SV for mess() */
886 /* it could have accumulated taint magic */
887 if (SvTYPE(PL_mess_sv) >= SVt_PVMG) {
890 for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) {
891 moremagic = mg->mg_moremagic;
892 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global
894 Safefree(mg->mg_ptr);
898 /* we know that type >= SVt_PV */
899 (void)SvOOK_off(PL_mess_sv);
900 Safefree(SvPVX(PL_mess_sv));
901 Safefree(SvANY(PL_mess_sv));
902 Safefree(PL_mess_sv);
905 return STATUS_NATIVE_EXPORT;
909 =for apidoc perl_free
911 Releases a Perl interpreter. See L<perlembed>.
919 #if defined(WIN32) || defined(NETWARE)
920 # if defined(PERL_IMPLICIT_SYS)
922 void *host = nw_internal_host;
924 void *host = w32_internal_host;
928 nw5_delete_internal_host(host);
930 win32_delete_internal_host(host);
941 Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
943 Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry);
944 PL_exitlist[PL_exitlistlen].fn = fn;
945 PL_exitlist[PL_exitlistlen].ptr = ptr;
950 =for apidoc perl_parse
952 Tells a Perl interpreter to parse a Perl script. See L<perlembed>.
958 perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
963 #ifdef USE_5005THREADS
967 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
970 Perl_croak(aTHX_ "suidperl is no longer needed since the kernel can now execute\n\
971 setuid perl scripts securely.\n");
977 /* we copy rather than point to argv
978 * since perl_clone will copy and perl_destruct
979 * has no way of knowing if we've made a copy or
983 New(0, PL_origargv, i+1, char*);
984 PL_origargv[i] = '\0';
986 PL_origargv[i] = savepv(argv[i]);
994 /* Come here if running an undumped a.out. */
996 PL_origfilename = savepv(argv[0]);
997 PL_do_undump = FALSE;
998 cxstack_ix = -1; /* start label stack again */
1000 init_postdump_symbols(argc,argv,env);
1005 PL_curpad = AvARRAY(PL_comppad);
1006 op_free(PL_main_root);
1007 PL_main_root = Nullop;
1009 PL_main_start = Nullop;
1010 SvREFCNT_dec(PL_main_cv);
1011 PL_main_cv = Nullcv;
1014 oldscope = PL_scopestack_ix;
1015 PL_dowarn = G_WARN_OFF;
1017 #ifdef PERL_FLEXIBLE_EXCEPTIONS
1018 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vparse_body), env, xsinit);
1024 #ifndef PERL_FLEXIBLE_EXCEPTIONS
1025 parse_body(env,xsinit);
1028 call_list(oldscope, PL_checkav);
1035 /* my_exit() was called */
1036 while (PL_scopestack_ix > oldscope)
1039 PL_curstash = PL_defstash;
1041 call_list(oldscope, PL_checkav);
1042 ret = STATUS_NATIVE_EXPORT;
1045 PerlIO_printf(Perl_error_log, "panic: top_env\n");
1053 #ifdef PERL_FLEXIBLE_EXCEPTIONS
1055 S_vparse_body(pTHX_ va_list args)
1057 char **env = va_arg(args, char**);
1058 XSINIT_t xsinit = va_arg(args, XSINIT_t);
1060 return parse_body(env, xsinit);
1065 S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
1067 int argc = PL_origargc;
1068 char **argv = PL_origargv;
1069 char *scriptname = NULL;
1071 VOL bool dosearch = FALSE;
1072 char *validarg = "";
1076 char *cddir = Nullch;
1078 sv_setpvn(PL_linestr,"",0);
1079 sv = newSVpvn("",0); /* first used for -I flags */
1083 for (argc--,argv++; argc > 0; argc--,argv++) {
1084 if (argv[0][0] != '-' || !argv[0][1])
1088 validarg = " PHOOEY ";
1097 win32_argv2utf8(argc-1, argv+1);
1100 #ifndef PERL_STRICT_CR
1124 if ((s = moreswitches(s)))
1129 if( !PL_tainting ) {
1130 PL_taint_warn = TRUE;
1137 PL_taint_warn = FALSE;
1142 #ifdef MACOS_TRADITIONAL
1143 /* ignore -e for Dev:Pseudo argument */
1144 if (argv[1] && !strcmp(argv[1], "Dev:Pseudo"))
1147 if (PL_euid != PL_uid || PL_egid != PL_gid)
1148 Perl_croak(aTHX_ "No -e allowed in setuid scripts");
1150 PL_e_script = newSVpvn("",0);
1151 filter_add(read_e_script, NULL);
1154 sv_catpv(PL_e_script, s);
1156 sv_catpv(PL_e_script, argv[1]);
1160 Perl_croak(aTHX_ "No code specified for -e");
1161 sv_catpv(PL_e_script, "\n");
1164 case 'I': /* -I handled both here and in moreswitches() */
1166 if (!*++s && (s=argv[1]) != Nullch) {
1171 STRLEN len = strlen(s);
1172 p = savepvn(s, len);
1173 incpush(p, TRUE, TRUE);
1174 sv_catpvn(sv, "-I", 2);
1175 sv_catpvn(sv, p, len);
1176 sv_catpvn(sv, " ", 1);
1180 Perl_croak(aTHX_ "No directory specified for -I");
1184 PL_preprocess = TRUE;
1194 PL_preambleav = newAV();
1195 av_push(PL_preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
1197 PL_Sv = newSVpv("print myconfig();",0);
1199 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
1201 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
1203 sv_catpv(PL_Sv,"\" Compile-time options:");
1205 sv_catpv(PL_Sv," DEBUGGING");
1207 # ifdef MULTIPLICITY
1208 sv_catpv(PL_Sv," MULTIPLICITY");
1210 # ifdef USE_5005THREADS
1211 sv_catpv(PL_Sv," USE_5005THREADS");
1213 # ifdef USE_ITHREADS
1214 sv_catpv(PL_Sv," USE_ITHREADS");
1216 # ifdef USE_64_BIT_INT
1217 sv_catpv(PL_Sv," USE_64_BIT_INT");
1219 # ifdef USE_64_BIT_ALL
1220 sv_catpv(PL_Sv," USE_64_BIT_ALL");
1222 # ifdef USE_LONG_DOUBLE
1223 sv_catpv(PL_Sv," USE_LONG_DOUBLE");
1225 # ifdef USE_LARGE_FILES
1226 sv_catpv(PL_Sv," USE_LARGE_FILES");
1229 sv_catpv(PL_Sv," USE_SOCKS");
1231 # ifdef PERL_IMPLICIT_CONTEXT
1232 sv_catpv(PL_Sv," PERL_IMPLICIT_CONTEXT");
1234 # ifdef PERL_IMPLICIT_SYS
1235 sv_catpv(PL_Sv," PERL_IMPLICIT_SYS");
1237 sv_catpv(PL_Sv,"\\n\",");
1239 #if defined(LOCAL_PATCH_COUNT)
1240 if (LOCAL_PATCH_COUNT > 0) {
1242 sv_catpv(PL_Sv,"\" Locally applied patches:\\n\",");
1243 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
1244 if (PL_localpatches[i])
1245 Perl_sv_catpvf(aTHX_ PL_Sv,"q\" \t%s\n\",",PL_localpatches[i]);
1249 Perl_sv_catpvf(aTHX_ PL_Sv,"\" Built under %s\\n\"",OSNAME);
1252 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
1254 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled on %s\\n\"",__DATE__);
1257 sv_catpv(PL_Sv, "; \
1259 @env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; ");
1262 push @env, \"CYGWIN=\\\"$ENV{CYGWIN}\\\"\";");
1265 print \" \\%ENV:\\n @env\\n\" if @env; \
1266 print \" \\@INC:\\n @INC\\n\";");
1269 PL_Sv = newSVpv("config_vars(qw(",0);
1270 sv_catpv(PL_Sv, ++s);
1271 sv_catpv(PL_Sv, "))");
1274 av_push(PL_preambleav, PL_Sv);
1275 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
1278 PL_doextract = TRUE;
1286 if (!*++s || isSPACE(*s)) {
1290 /* catch use of gnu style long options */
1291 if (strEQ(s, "version")) {
1295 if (strEQ(s, "help")) {
1302 Perl_croak(aTHX_ "Unrecognized switch: -%s (-h will show valid options)",s);
1308 #ifndef SECURE_INTERNAL_GETENV
1311 (s = PerlEnv_getenv("PERL5OPT")))
1316 if (*s == '-' && *(s+1) == 'T') {
1318 PL_taint_warn = FALSE;
1321 char *popt_copy = Nullch;
1334 if (!strchr("DIMUdmtw", *s))
1335 Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
1339 popt_copy = SvPVX(sv_2mortal(newSVpv(popt,0)));
1340 s = popt_copy + (s - popt);
1341 d = popt_copy + (d - popt);
1348 if( !PL_tainting ) {
1349 PL_taint_warn = TRUE;
1359 if (PL_taint_warn && PL_dowarn != G_WARN_ALL_OFF) {
1360 PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
1364 scriptname = argv[0];
1367 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
1369 else if (scriptname == Nullch) {
1371 if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
1379 open_script(scriptname,dosearch,sv,&fdscript);
1381 validate_suid(validarg, scriptname,fdscript);
1384 #if defined(SIGCHLD) || defined(SIGCLD)
1387 # define SIGCHLD SIGCLD
1389 Sighandler_t sigstate = rsignal_state(SIGCHLD);
1390 if (sigstate == SIG_IGN) {
1391 if (ckWARN(WARN_SIGNAL))
1392 Perl_warner(aTHX_ packWARN(WARN_SIGNAL),
1393 "Can't ignore signal CHLD, forcing to default");
1394 (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL);
1400 #ifdef MACOS_TRADITIONAL
1401 if (PL_doextract || gMacPerl_AlwaysExtract) {
1406 if (cddir && PerlDir_chdir(cddir) < 0)
1407 Perl_croak(aTHX_ "Can't chdir to %s",cddir);
1411 PL_main_cv = PL_compcv = (CV*)NEWSV(1104,0);
1412 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
1413 CvUNIQUE_on(PL_compcv);
1415 PL_comppad = newAV();
1416 av_push(PL_comppad, Nullsv);
1417 PL_curpad = AvARRAY(PL_comppad);
1418 PL_comppad_name = newAV();
1419 PL_comppad_name_fill = 0;
1420 PL_min_intro_pending = 0;
1422 #ifdef USE_5005THREADS
1423 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
1424 PL_curpad[0] = (SV*)newAV();
1425 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
1426 CvOWNER(PL_compcv) = 0;
1427 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
1428 MUTEX_INIT(CvMUTEXP(PL_compcv));
1429 #endif /* USE_5005THREADS */
1431 comppadlist = newAV();
1432 AvREAL_off(comppadlist);
1433 av_store(comppadlist, 0, (SV*)PL_comppad_name);
1434 av_store(comppadlist, 1, (SV*)PL_comppad);
1435 CvPADLIST(PL_compcv) = comppadlist;
1438 boot_core_UNIVERSAL();
1440 boot_core_xsutils();
1444 (*xsinit)(aTHX); /* in case linked C routines want magical variables */
1446 #if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__) || defined(EPOC)
1452 # ifdef HAS_SOCKS5_INIT
1453 socks5_init(argv[0]);
1459 init_predump_symbols();
1460 /* init_postdump_symbols not currently designed to be called */
1461 /* more than once (ENV isn't cleared first, for example) */
1462 /* But running with -u leaves %ENV & @ARGV undefined! XXX */
1464 init_postdump_symbols(argc,argv,env);
1466 if (PL_wantutf8) { /* Requires init_predump_symbols(). */
1470 if (PL_stdingv && (io = GvIO(PL_stdingv)) && (fp = IoIFP(io)))
1471 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
1472 if (PL_defoutgv && (io = GvIO(PL_defoutgv)) && (fp = IoOFP(io)))
1473 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
1474 if (PL_stderrgv && (io = GvIO(PL_stderrgv)) && (fp = IoOFP(io)))
1475 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
1476 if ((sv = GvSV(gv_fetchpv("\017PEN", TRUE, SVt_PV)))) {
1477 sv_setpvn(sv, ":utf8\0:utf8", 11);
1484 /* now parse the script */
1486 SETERRNO(0,SS$_NORMAL);
1488 #ifdef MACOS_TRADITIONAL
1489 if (gMacPerl_SyntaxError = (yyparse() || PL_error_count)) {
1491 Perl_croak(aTHX_ "%s had compilation errors.\n", MacPerl_MPWFileName(PL_origfilename));
1493 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
1494 MacPerl_MPWFileName(PL_origfilename));
1498 if (yyparse() || PL_error_count) {
1500 Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
1502 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
1507 CopLINE_set(PL_curcop, 0);
1508 PL_curstash = PL_defstash;
1509 PL_preprocess = FALSE;
1511 SvREFCNT_dec(PL_e_script);
1512 PL_e_script = Nullsv;
1516 Not sure that this is still the right place to do this now that we
1517 no longer use PL_nrs. HVDS 2001/09/09
1519 sv_setsv(get_sv("/", TRUE), PL_rs);
1525 SAVECOPFILE(PL_curcop);
1526 SAVECOPLINE(PL_curcop);
1527 gv_check(PL_defstash);
1534 if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
1535 dump_mstats("after compilation:");
1544 =for apidoc perl_run
1546 Tells a Perl interpreter to run. See L<perlembed>.
1557 #ifdef USE_5005THREADS
1561 oldscope = PL_scopestack_ix;
1566 #ifdef PERL_FLEXIBLE_EXCEPTIONS
1568 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vrun_body), oldscope);
1574 cxstack_ix = -1; /* start context stack again */
1576 case 0: /* normal completion */
1577 #ifndef PERL_FLEXIBLE_EXCEPTIONS
1582 case 2: /* my_exit() */
1583 while (PL_scopestack_ix > oldscope)
1586 PL_curstash = PL_defstash;
1587 if (!(PL_exit_flags & PERL_EXIT_DESTRUCT_END) &&
1588 PL_endav && !PL_minus_c)
1589 call_list(oldscope, PL_endav);
1591 if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
1592 dump_mstats("after execution: ");
1594 ret = STATUS_NATIVE_EXPORT;
1598 POPSTACK_TO(PL_mainstack);
1601 PerlIO_printf(Perl_error_log, "panic: restartop\n");
1611 #ifdef PERL_FLEXIBLE_EXCEPTIONS
1613 S_vrun_body(pTHX_ va_list args)
1615 I32 oldscope = va_arg(args, I32);
1617 return run_body(oldscope);
1623 S_run_body(pTHX_ I32 oldscope)
1625 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
1626 PL_sawampersand ? "Enabling" : "Omitting"));
1628 if (!PL_restartop) {
1629 DEBUG_x(dump_all());
1630 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
1631 DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%"UVxf"\n",
1635 #ifdef MACOS_TRADITIONAL
1636 PerlIO_printf(Perl_error_log, "# %s syntax OK\n", MacPerl_MPWFileName(PL_origfilename));
1638 PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
1642 if (PERLDB_SINGLE && PL_DBsingle)
1643 sv_setiv(PL_DBsingle, 1);
1645 call_list(oldscope, PL_initav);
1651 PL_op = PL_restartop;
1655 else if (PL_main_start) {
1656 CvDEPTH(PL_main_cv) = 1;
1657 PL_op = PL_main_start;
1667 =head1 SV Manipulation Functions
1669 =for apidoc p||get_sv
1671 Returns the SV of the specified Perl scalar. If C<create> is set and the
1672 Perl variable does not exist then it will be created. If C<create> is not
1673 set and the variable does not exist then NULL is returned.
1679 Perl_get_sv(pTHX_ const char *name, I32 create)
1682 #ifdef USE_5005THREADS
1683 if (name[1] == '\0' && !isALPHA(name[0])) {
1684 PADOFFSET tmp = find_threadsv(name);
1685 if (tmp != NOT_IN_PAD)
1686 return THREADSV(tmp);
1688 #endif /* USE_5005THREADS */
1689 gv = gv_fetchpv(name, create, SVt_PV);
1696 =head1 Array Manipulation Functions
1698 =for apidoc p||get_av
1700 Returns the AV of the specified Perl array. If C<create> is set and the
1701 Perl variable does not exist then it will be created. If C<create> is not
1702 set and the variable does not exist then NULL is returned.
1708 Perl_get_av(pTHX_ const char *name, I32 create)
1710 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1719 =head1 Hash Manipulation Functions
1721 =for apidoc p||get_hv
1723 Returns the HV of the specified Perl hash. If C<create> is set and the
1724 Perl variable does not exist then it will be created. If C<create> is not
1725 set and the variable does not exist then NULL is returned.
1731 Perl_get_hv(pTHX_ const char *name, I32 create)
1733 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1742 =head1 CV Manipulation Functions
1744 =for apidoc p||get_cv
1746 Returns the CV of the specified Perl subroutine. If C<create> is set and
1747 the Perl subroutine does not exist then it will be declared (which has the
1748 same effect as saying C<sub name;>). If C<create> is not set and the
1749 subroutine does not exist then NULL is returned.
1755 Perl_get_cv(pTHX_ const char *name, I32 create)
1757 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
1758 /* XXX unsafe for threads if eval_owner isn't held */
1759 /* XXX this is probably not what they think they're getting.
1760 * It has the same effect as "sub name;", i.e. just a forward
1762 if (create && !GvCVu(gv))
1763 return newSUB(start_subparse(FALSE, 0),
1764 newSVOP(OP_CONST, 0, newSVpv(name,0)),
1772 /* Be sure to refetch the stack pointer after calling these routines. */
1776 =head1 Callback Functions
1778 =for apidoc p||call_argv
1780 Performs a callback to the specified Perl sub. See L<perlcall>.
1786 Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv)
1788 /* See G_* flags in cop.h */
1789 /* null terminated arg list */
1796 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
1801 return call_pv(sub_name, flags);
1805 =for apidoc p||call_pv
1807 Performs a callback to the specified Perl sub. See L<perlcall>.
1813 Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
1814 /* name of the subroutine */
1815 /* See G_* flags in cop.h */
1817 return call_sv((SV*)get_cv(sub_name, TRUE), flags);
1821 =for apidoc p||call_method
1823 Performs a callback to the specified Perl method. The blessed object must
1824 be on the stack. See L<perlcall>.
1830 Perl_call_method(pTHX_ const char *methname, I32 flags)
1831 /* name of the subroutine */
1832 /* See G_* flags in cop.h */
1834 return call_sv(sv_2mortal(newSVpv(methname,0)), flags | G_METHOD);
1837 /* May be called with any of a CV, a GV, or an SV containing the name. */
1839 =for apidoc p||call_sv
1841 Performs a callback to the Perl sub whose name is in the SV. See
1848 Perl_call_sv(pTHX_ SV *sv, I32 flags)
1849 /* See G_* flags in cop.h */
1852 LOGOP myop; /* fake syntax tree node */
1855 volatile I32 retval = 0;
1857 bool oldcatch = CATCH_GET;
1862 if (flags & G_DISCARD) {
1867 Zero(&myop, 1, LOGOP);
1868 myop.op_next = Nullop;
1869 if (!(flags & G_NOARGS))
1870 myop.op_flags |= OPf_STACKED;
1871 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1872 (flags & G_ARRAY) ? OPf_WANT_LIST :
1877 EXTEND(PL_stack_sp, 1);
1878 *++PL_stack_sp = sv;
1880 oldscope = PL_scopestack_ix;
1882 if (PERLDB_SUB && PL_curstash != PL_debstash
1883 /* Handle first BEGIN of -d. */
1884 && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
1885 /* Try harder, since this may have been a sighandler, thus
1886 * curstash may be meaningless. */
1887 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != PL_debstash)
1888 && !(flags & G_NODEBUG))
1889 PL_op->op_private |= OPpENTERSUB_DB;
1891 if (flags & G_METHOD) {
1892 Zero(&method_op, 1, UNOP);
1893 method_op.op_next = PL_op;
1894 method_op.op_ppaddr = PL_ppaddr[OP_METHOD];
1895 myop.op_ppaddr = PL_ppaddr[OP_ENTERSUB];
1896 PL_op = (OP*)&method_op;
1899 if (!(flags & G_EVAL)) {
1901 call_body((OP*)&myop, FALSE);
1902 retval = PL_stack_sp - (PL_stack_base + oldmark);
1903 CATCH_SET(oldcatch);
1906 myop.op_other = (OP*)&myop;
1908 /* we're trying to emulate pp_entertry() here */
1910 register PERL_CONTEXT *cx;
1911 I32 gimme = GIMME_V;
1916 push_return(Nullop);
1917 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
1919 PL_eval_root = PL_op; /* Only needed so that goto works right. */
1921 PL_in_eval = EVAL_INEVAL;
1922 if (flags & G_KEEPERR)
1923 PL_in_eval |= EVAL_KEEPERR;
1929 #ifdef PERL_FLEXIBLE_EXCEPTIONS
1931 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_body),
1938 #ifndef PERL_FLEXIBLE_EXCEPTIONS
1940 call_body((OP*)&myop, FALSE);
1942 retval = PL_stack_sp - (PL_stack_base + oldmark);
1943 if (!(flags & G_KEEPERR))
1950 /* my_exit() was called */
1951 PL_curstash = PL_defstash;
1954 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
1955 Perl_croak(aTHX_ "Callback called exit");
1960 PL_op = PL_restartop;
1964 PL_stack_sp = PL_stack_base + oldmark;
1965 if (flags & G_ARRAY)
1969 *++PL_stack_sp = &PL_sv_undef;
1974 if (PL_scopestack_ix > oldscope) {
1978 register PERL_CONTEXT *cx;
1990 if (flags & G_DISCARD) {
1991 PL_stack_sp = PL_stack_base + oldmark;
2000 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2002 S_vcall_body(pTHX_ va_list args)
2004 OP *myop = va_arg(args, OP*);
2005 int is_eval = va_arg(args, int);
2007 call_body(myop, is_eval);
2013 S_call_body(pTHX_ OP *myop, int is_eval)
2015 if (PL_op == myop) {
2017 PL_op = Perl_pp_entereval(aTHX); /* this doesn't do a POPMARK */
2019 PL_op = Perl_pp_entersub(aTHX); /* this does */
2025 /* Eval a string. The G_EVAL flag is always assumed. */
2028 =for apidoc p||eval_sv
2030 Tells Perl to C<eval> the string in the SV.
2036 Perl_eval_sv(pTHX_ SV *sv, I32 flags)
2038 /* See G_* flags in cop.h */
2041 UNOP myop; /* fake syntax tree node */
2042 volatile I32 oldmark = SP - PL_stack_base;
2043 volatile I32 retval = 0;
2049 if (flags & G_DISCARD) {
2056 Zero(PL_op, 1, UNOP);
2057 EXTEND(PL_stack_sp, 1);
2058 *++PL_stack_sp = sv;
2059 oldscope = PL_scopestack_ix;
2061 if (!(flags & G_NOARGS))
2062 myop.op_flags = OPf_STACKED;
2063 myop.op_next = Nullop;
2064 myop.op_type = OP_ENTEREVAL;
2065 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
2066 (flags & G_ARRAY) ? OPf_WANT_LIST :
2068 if (flags & G_KEEPERR)
2069 myop.op_flags |= OPf_SPECIAL;
2071 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2073 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_body),
2080 #ifndef PERL_FLEXIBLE_EXCEPTIONS
2082 call_body((OP*)&myop,TRUE);
2084 retval = PL_stack_sp - (PL_stack_base + oldmark);
2085 if (!(flags & G_KEEPERR))
2092 /* my_exit() was called */
2093 PL_curstash = PL_defstash;
2096 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
2097 Perl_croak(aTHX_ "Callback called exit");
2102 PL_op = PL_restartop;
2106 PL_stack_sp = PL_stack_base + oldmark;
2107 if (flags & G_ARRAY)
2111 *++PL_stack_sp = &PL_sv_undef;
2117 if (flags & G_DISCARD) {
2118 PL_stack_sp = PL_stack_base + oldmark;
2128 =for apidoc p||eval_pv
2130 Tells Perl to C<eval> the given string and return an SV* result.
2136 Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
2139 SV* sv = newSVpv(p, 0);
2141 eval_sv(sv, G_SCALAR);
2148 if (croak_on_error && SvTRUE(ERRSV)) {
2150 Perl_croak(aTHX_ SvPVx(ERRSV, n_a));
2156 /* Require a module. */
2159 =head1 Embedding Functions
2161 =for apidoc p||require_pv
2163 Tells Perl to C<require> the file named by the string argument. It is
2164 analogous to the Perl code C<eval "require '$file'">. It's even
2165 implemented that way; consider using Perl_load_module instead.
2170 Perl_require_pv(pTHX_ const char *pv)
2174 PUSHSTACKi(PERLSI_REQUIRE);
2176 sv = sv_newmortal();
2177 sv_setpv(sv, "require '");
2180 eval_sv(sv, G_DISCARD);
2186 Perl_magicname(pTHX_ char *sym, char *name, I32 namlen)
2190 if ((gv = gv_fetchpv(sym,TRUE, SVt_PV)))
2191 sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, namlen);
2195 S_usage(pTHX_ char *name) /* XXX move this out into a module ? */
2197 /* This message really ought to be max 23 lines.
2198 * Removed -h because the user already knows that option. Others? */
2200 static char *usage_msg[] = {
2201 "-0[octal] specify record separator (\\0, if no argument)",
2202 "-a autosplit mode with -n or -p (splits $_ into @F)",
2203 "-C enable native wide character system interfaces",
2204 "-c check syntax only (runs BEGIN and CHECK blocks)",
2205 "-d[:debugger] run program under debugger",
2206 "-D[number/list] set debugging flags (argument is a bit mask or alphabets)",
2207 "-e 'command' one line of program (several -e's allowed, omit programfile)",
2208 "-F/pattern/ split() pattern for -a switch (//'s are optional)",
2209 "-i[extension] edit <> files in place (makes backup if extension supplied)",
2210 "-Idirectory specify @INC/#include directory (several -I's allowed)",
2211 "-l[octal] enable line ending processing, specifies line terminator",
2212 "-[mM][-]module execute `use/no module...' before executing program",
2213 "-n assume 'while (<>) { ... }' loop around program",
2214 "-p assume loop like -n but print line also, like sed",
2215 "-P run program through C preprocessor before compilation",
2216 "-s enable rudimentary parsing for switches after programfile",
2217 "-S look for programfile using PATH environment variable",
2218 "-T enable tainting checks",
2219 "-t enable tainting warnings",
2220 "-u dump core after parsing program",
2221 "-U allow unsafe operations",
2222 "-v print version, subversion (includes VERY IMPORTANT perl info)",
2223 "-V[:variable] print configuration summary (or a single Config.pm variable)",
2224 "-w enable many useful warnings (RECOMMENDED)",
2225 "-W enable all warnings",
2226 "-X disable all warnings",
2227 "-x[directory] strip off text before #!perl line and perhaps cd to directory",
2231 char **p = usage_msg;
2233 PerlIO_printf(PerlIO_stdout(),
2234 "\nUsage: %s [switches] [--] [programfile] [arguments]",
2237 PerlIO_printf(PerlIO_stdout(), "\n %s", *p++);
2240 /* This routine handles any switches that can be given during run */
2243 Perl_moreswitches(pTHX_ char *s)
2253 rschar = (U32)grok_oct(s, &numlen, &flags, NULL);
2254 SvREFCNT_dec(PL_rs);
2255 if (rschar & ~((U8)~0))
2256 PL_rs = &PL_sv_undef;
2257 else if (!rschar && numlen >= 2)
2258 PL_rs = newSVpvn("", 0);
2261 PL_rs = newSVpvn(&ch, 1);
2266 PL_widesyscalls = TRUE;
2272 while (*s && !isSPACE(*s)) ++s;
2274 PL_splitstr = savepv(PL_splitstr);
2287 /* The following permits -d:Mod to accepts arguments following an =
2288 in the fashion that -MSome::Mod does. */
2289 if (*s == ':' || *s == '=') {
2292 sv = newSVpv("use Devel::", 0);
2294 /* We now allow -d:Module=Foo,Bar */
2295 while(isALNUM(*s) || *s==':') ++s;
2297 sv_catpv(sv, start);
2299 sv_catpvn(sv, start, s-start);
2300 sv_catpv(sv, " split(/,/,q{");
2305 my_setenv("PERL5DB", SvPV(sv, PL_na));
2308 PL_perldb = PERLDB_ALL;
2316 if (isALPHA(s[1])) {
2317 /* if adding extra options, remember to update DEBUG_MASK */
2318 static char debopts[] = "psltocPmfrxuLHXDSTRJ";
2321 for (s++; *s && (d = strchr(debopts,*s)); s++)
2322 PL_debug |= 1 << (d - debopts);
2325 PL_debug = atoi(s+1);
2326 for (s++; isDIGIT(*s); s++) ;
2329 if (DEBUG_p_TEST_ && ckWARN_d(WARN_DEBUGGING))
2330 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
2331 "-Dp not implemented on this platform\n");
2333 PL_debug |= DEBUG_TOP_FLAG;
2334 #else /* !DEBUGGING */
2335 if (ckWARN_d(WARN_DEBUGGING))
2336 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
2337 "Recompile perl with -DDEBUGGING to use -D switch\n");
2338 for (s++; isALNUM(*s); s++) ;
2344 usage(PL_origargv[0]);
2348 Safefree(PL_inplace);
2349 PL_inplace = savepv(s+1);
2351 for (s = PL_inplace; *s && !isSPACE(*s); s++) ;
2354 if (*s == '-') /* Additional switches on #! line. */
2358 case 'I': /* -I handled both here and in parse_body() */
2361 while (*s && isSPACE(*s))
2366 /* ignore trailing spaces (possibly followed by other switches) */
2368 for (e = p; *e && !isSPACE(*e); e++) ;
2372 } while (*p && *p != '-');
2373 e = savepvn(s, e-s);
2374 incpush(e, TRUE, TRUE);
2381 Perl_croak(aTHX_ "No directory specified for -I");
2387 SvREFCNT_dec(PL_ors_sv);
2392 PL_ors_sv = newSVpvn("\n",1);
2393 numlen = 3 + (*s == '0');
2394 *SvPVX(PL_ors_sv) = (char)grok_oct(s, &numlen, &flags, NULL);
2398 if (RsPARA(PL_rs)) {
2399 PL_ors_sv = newSVpvn("\n\n",2);
2402 PL_ors_sv = newSVsv(PL_rs);
2407 forbid_setid("-M"); /* XXX ? */
2410 forbid_setid("-m"); /* XXX ? */
2415 /* -M-foo == 'no foo' */
2416 if (*s == '-') { use = "no "; ++s; }
2417 sv = newSVpv(use,0);
2419 /* We allow -M'Module qw(Foo Bar)' */
2420 while(isALNUM(*s) || *s==':') ++s;
2422 sv_catpv(sv, start);
2423 if (*(start-1) == 'm') {
2425 Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
2426 sv_catpv( sv, " ()");
2430 Perl_croak(aTHX_ "Module name required with -%c option",
2432 sv_catpvn(sv, start, s-start);
2433 sv_catpv(sv, " split(/,/,q{");
2439 PL_preambleav = newAV();
2440 av_push(PL_preambleav, sv);
2443 Perl_croak(aTHX_ "No space allowed after -%c", *(s-1));
2455 PL_doswitches = TRUE;
2460 Perl_croak(aTHX_ "Too late for \"-t\" option");
2465 Perl_croak(aTHX_ "Too late for \"-T\" option");
2469 #ifdef MACOS_TRADITIONAL
2470 Perl_croak(aTHX_ "Believe me, you don't want to use \"-u\" on a Macintosh");
2472 PL_do_undump = TRUE;
2481 PerlIO_printf(PerlIO_stdout(),
2482 Perl_form(aTHX_ "\nThis is perl, v%"VDf" built for %s",
2483 PL_patchlevel, ARCHNAME));
2485 /* Adjust verbose output as in the perl that ships with the DG/UX OS from EMC */
2486 PerlIO_printf(PerlIO_stdout(),
2487 Perl_form(aTHX_ "\nThis is perl, version %vd\n", PL_patchlevel));
2488 PerlIO_printf(PerlIO_stdout(),
2489 Perl_form(aTHX_ " built under %s at %s %s\n",
2490 OSNAME, __DATE__, __TIME__));
2491 PerlIO_printf(PerlIO_stdout(),
2492 Perl_form(aTHX_ " OS Specific Release: %s\n",
2496 #if defined(LOCAL_PATCH_COUNT)
2497 if (LOCAL_PATCH_COUNT > 0)
2498 PerlIO_printf(PerlIO_stdout(),
2499 "\n(with %d registered patch%s, "
2500 "see perl -V for more detail)",
2501 (int)LOCAL_PATCH_COUNT,
2502 (LOCAL_PATCH_COUNT!=1) ? "es" : "");
2505 PerlIO_printf(PerlIO_stdout(),
2506 "\n\nCopyright 1987-2002, Larry Wall\n");
2507 #ifdef MACOS_TRADITIONAL
2508 PerlIO_printf(PerlIO_stdout(),
2509 "\nMac OS port Copyright 1991-2002, Matthias Neeracher;\n"
2510 "maintained by Chris Nandor\n");
2513 PerlIO_printf(PerlIO_stdout(),
2514 "\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
2517 PerlIO_printf(PerlIO_stdout(),
2518 "djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n"
2519 "djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
2522 PerlIO_printf(PerlIO_stdout(),
2523 "\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
2524 "Version 5 port Copyright (c) 1994-2002, Andreas Kaiser, Ilya Zakharevich\n");
2527 PerlIO_printf(PerlIO_stdout(),
2528 "atariST series port, ++jrb bammi@cadence.com\n");
2531 PerlIO_printf(PerlIO_stdout(),
2532 "BeOS port Copyright Tom Spindler, 1997-1999\n");
2535 PerlIO_printf(PerlIO_stdout(),
2536 "MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-2002\n");
2539 PerlIO_printf(PerlIO_stdout(),
2540 "MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
2543 PerlIO_printf(PerlIO_stdout(),
2544 "Stratus VOS port by Paul.Green@stratus.com, 1997-2002\n");
2547 PerlIO_printf(PerlIO_stdout(),
2548 "VM/ESA port by Neale Ferguson, 1998-1999\n");
2551 PerlIO_printf(PerlIO_stdout(),
2552 "BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
2555 PerlIO_printf(PerlIO_stdout(),
2556 "MiNT port by Guido Flohr, 1997-1999\n");
2559 PerlIO_printf(PerlIO_stdout(),
2560 "EPOC port by Olaf Flebbe, 1999-2002\n");
2563 printf("WINCE port by Rainer Keuchel, 2001-2002\n");
2564 printf("Built on " __DATE__ " " __TIME__ "\n\n");
2567 #ifdef BINARY_BUILD_NOTICE
2568 BINARY_BUILD_NOTICE;
2570 PerlIO_printf(PerlIO_stdout(),
2572 Perl may be copied only under the terms of either the Artistic License or the\n\
2573 GNU General Public License, which may be found in the Perl 5 source kit.\n\n\
2574 Complete documentation for Perl, including FAQ lists, should be found on\n\
2575 this system using `man perl' or `perldoc perl'. If you have access to the\n\
2576 Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
2579 if (! (PL_dowarn & G_WARN_ALL_MASK))
2580 PL_dowarn |= G_WARN_ON;
2584 PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
2585 if (!specialWARN(PL_compiling.cop_warnings))
2586 SvREFCNT_dec(PL_compiling.cop_warnings);
2587 PL_compiling.cop_warnings = pWARN_ALL ;
2591 PL_dowarn = G_WARN_ALL_OFF;
2592 if (!specialWARN(PL_compiling.cop_warnings))
2593 SvREFCNT_dec(PL_compiling.cop_warnings);
2594 PL_compiling.cop_warnings = pWARN_NONE ;
2599 if (s[1] == '-') /* Additional switches on #! line. */
2604 #if defined(WIN32) || !defined(PERL_STRICT_CR)
2610 #ifdef ALTERNATE_SHEBANG
2611 case 'S': /* OS/2 needs -S on "extproc" line. */
2619 Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
2624 /* compliments of Tom Christiansen */
2626 /* unexec() can be found in the Gnu emacs distribution */
2627 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
2630 Perl_my_unexec(pTHX)
2638 prog = newSVpv(BIN_EXP, 0);
2639 sv_catpv(prog, "/perl");
2640 file = newSVpv(PL_origfilename, 0);
2641 sv_catpv(file, ".perldump");
2643 unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
2644 /* unexec prints msg to stderr in case of failure */
2645 PerlProc_exit(status);
2648 # include <lib$routines.h>
2649 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
2651 ABORT(); /* for use with undump */
2656 /* initialize curinterp */
2662 # define PERLVAR(var,type)
2663 # define PERLVARA(var,n,type)
2664 # if defined(PERL_IMPLICIT_CONTEXT)
2665 # if defined(USE_5005THREADS)
2666 # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
2667 # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
2668 # else /* !USE_5005THREADS */
2669 # define PERLVARI(var,type,init) aTHX->var = init;
2670 # define PERLVARIC(var,type,init) aTHX->var = init;
2671 # endif /* USE_5005THREADS */
2673 # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
2674 # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
2676 # include "intrpvar.h"
2677 # ifndef USE_5005THREADS
2678 # include "thrdvar.h"
2685 # define PERLVAR(var,type)
2686 # define PERLVARA(var,n,type)
2687 # define PERLVARI(var,type,init) PL_##var = init;
2688 # define PERLVARIC(var,type,init) PL_##var = init;
2689 # include "intrpvar.h"
2690 # ifndef USE_5005THREADS
2691 # include "thrdvar.h"
2702 S_init_main_stash(pTHX)
2706 PL_curstash = PL_defstash = newHV();
2707 PL_curstname = newSVpvn("main",4);
2708 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
2709 SvREFCNT_dec(GvHV(gv));
2710 GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
2712 HvNAME(PL_defstash) = savepv("main");
2713 PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
2714 GvMULTI_on(PL_incgv);
2715 PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
2716 GvMULTI_on(PL_hintgv);
2717 PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
2718 PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
2719 GvMULTI_on(PL_errgv);
2720 PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
2721 GvMULTI_on(PL_replgv);
2722 (void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */
2723 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
2724 sv_setpvn(ERRSV, "", 0);
2725 PL_curstash = PL_defstash;
2726 CopSTASH_set(&PL_compiling, PL_defstash);
2727 PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
2728 PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
2729 PL_nullstash = GvHV(gv_fetchpv("<none>::", GV_ADDMULTI, SVt_PVHV));
2730 /* We must init $/ before switches are processed. */
2731 sv_setpvn(get_sv("/", TRUE), "\n", 1);
2735 S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
2739 char *cpp_discard_flag;
2745 PL_origfilename = savepv("-e");
2748 /* if find_script() returns, it returns a malloc()-ed value */
2749 PL_origfilename = scriptname = find_script(scriptname, dosearch, NULL, 1);
2751 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
2752 char *s = scriptname + 8;
2753 *fdscript = atoi(s);
2757 scriptname = savepv(s + 1);
2758 Safefree(PL_origfilename);
2759 PL_origfilename = scriptname;
2764 CopFILE_free(PL_curcop);
2765 CopFILE_set(PL_curcop, PL_origfilename);
2766 if (strEQ(PL_origfilename,"-"))
2768 if (*fdscript >= 0) {
2769 PL_rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE);
2770 # if defined(HAS_FCNTL) && defined(F_SETFD)
2772 /* ensure close-on-exec */
2773 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
2776 else if (PL_preprocess) {
2777 char *cpp_cfg = CPPSTDIN;
2778 SV *cpp = newSVpvn("",0);
2779 SV *cmd = NEWSV(0,0);
2781 if (strEQ(cpp_cfg, "cppstdin"))
2782 Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
2783 sv_catpv(cpp, cpp_cfg);
2786 sv_catpvn(sv, "-I", 2);
2787 sv_catpv(sv,PRIVLIB_EXP);
2790 DEBUG_P(PerlIO_printf(Perl_debug_log,
2791 "PL_preprocess: scriptname=\"%s\", cpp=\"%s\", sv=\"%s\", CPPMINUS=\"%s\"\n",
2792 scriptname, SvPVX (cpp), SvPVX (sv), CPPMINUS));
2794 # if defined(MSDOS) || defined(WIN32) || defined(VMS)
2801 cpp_discard_flag = "";
2803 cpp_discard_flag = "-C";
2807 perl = os2_execname(aTHX);
2809 perl = PL_origargv[0];
2813 /* This strips off Perl comments which might interfere with
2814 the C pre-processor, including #!. #line directives are
2815 deliberately stripped to avoid confusion with Perl's version
2816 of #line. FWP played some golf with it so it will fit
2817 into VMS's 255 character buffer.
2820 code = "(1../^#!.*perl/i)|/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print";
2822 code = "/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print";
2824 Perl_sv_setpvf(aTHX_ cmd, "\
2825 %s -ne%s%s%s %s | %"SVf" %s %"SVf" %s",
2826 perl, quote, code, quote, scriptname, cpp,
2827 cpp_discard_flag, sv, CPPMINUS);
2829 PL_doextract = FALSE;
2830 # ifdef IAMSUID /* actually, this is caught earlier */
2831 if (PL_euid != PL_uid && !PL_euid) { /* if running suidperl */
2833 (void)seteuid(PL_uid); /* musn't stay setuid root */
2835 # ifdef HAS_SETREUID
2836 (void)setreuid((Uid_t)-1, PL_uid);
2838 # ifdef HAS_SETRESUID
2839 (void)setresuid((Uid_t)-1, PL_uid, (Uid_t)-1);
2841 PerlProc_setuid(PL_uid);
2845 if (PerlProc_geteuid() != PL_uid)
2846 Perl_croak(aTHX_ "Can't do seteuid!\n");
2848 # endif /* IAMSUID */
2850 DEBUG_P(PerlIO_printf(Perl_debug_log,
2851 "PL_preprocess: cmd=\"%s\"\n",
2854 PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
2858 else if (!*scriptname) {
2859 forbid_setid("program input from stdin");
2860 PL_rsfp = PerlIO_stdin();
2863 PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
2864 # if defined(HAS_FCNTL) && defined(F_SETFD)
2866 /* ensure close-on-exec */
2867 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
2872 # ifndef IAMSUID /* in case script is not readable before setuid */
2874 PerlLIO_stat(CopFILE(PL_curcop),&PL_statbuf) >= 0 &&
2875 PL_statbuf.st_mode & (S_ISUID|S_ISGID))
2878 PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT,
2879 BIN_EXP, (int)PERL_REVISION,
2881 (int)PERL_SUBVERSION), PL_origargv);
2882 Perl_croak(aTHX_ "Can't do setuid\n");
2888 Perl_croak(aTHX_ "Can't open perl script: %s\n",
2891 Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
2892 CopFILE(PL_curcop), Strerror(errno));
2898 * I_SYSSTATVFS HAS_FSTATVFS
2900 * I_STATFS HAS_FSTATFS HAS_GETFSSTAT
2901 * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT
2902 * here so that metaconfig picks them up. */
2906 S_fd_on_nosuid_fs(pTHX_ int fd)
2908 int check_okay = 0; /* able to do all the required sys/libcalls */
2909 int on_nosuid = 0; /* the fd is on a nosuid fs */
2911 * Preferred order: fstatvfs(), fstatfs(), ustat()+getmnt(), getmntent().
2912 * fstatvfs() is UNIX98.
2913 * fstatfs() is 4.3 BSD.
2914 * ustat()+getmnt() is pre-4.3 BSD.
2915 * getmntent() is O(number-of-mounted-filesystems) and can hang on
2916 * an irrelevant filesystem while trying to reach the right one.
2919 #undef FD_ON_NOSUID_CHECK_OKAY /* found the syscalls to do the check? */
2921 # if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
2922 defined(HAS_FSTATVFS)
2923 # define FD_ON_NOSUID_CHECK_OKAY
2924 struct statvfs stfs;
2926 check_okay = fstatvfs(fd, &stfs) == 0;
2927 on_nosuid = check_okay && (stfs.f_flag & ST_NOSUID);
2928 # endif /* fstatvfs */
2930 # if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
2931 defined(PERL_MOUNT_NOSUID) && \
2932 defined(HAS_FSTATFS) && \
2933 defined(HAS_STRUCT_STATFS) && \
2934 defined(HAS_STRUCT_STATFS_F_FLAGS)
2935 # define FD_ON_NOSUID_CHECK_OKAY
2938 check_okay = fstatfs(fd, &stfs) == 0;
2939 on_nosuid = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
2940 # endif /* fstatfs */
2942 # if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
2943 defined(PERL_MOUNT_NOSUID) && \
2944 defined(HAS_FSTAT) && \
2945 defined(HAS_USTAT) && \
2946 defined(HAS_GETMNT) && \
2947 defined(HAS_STRUCT_FS_DATA) && \
2949 # define FD_ON_NOSUID_CHECK_OKAY
2952 if (fstat(fd, &fdst) == 0) {
2954 if (ustat(fdst.st_dev, &us) == 0) {
2956 /* NOSTAT_ONE here because we're not examining fields which
2957 * vary between that case and STAT_ONE. */
2958 if (getmnt((int*)0, &fsd, (int)0, NOSTAT_ONE, us.f_fname) == 0) {
2959 size_t cmplen = sizeof(us.f_fname);
2960 if (sizeof(fsd.fd_req.path) < cmplen)
2961 cmplen = sizeof(fsd.fd_req.path);
2962 if (strnEQ(fsd.fd_req.path, us.f_fname, cmplen) &&
2963 fdst.st_dev == fsd.fd_req.dev) {
2965 on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID;
2971 # endif /* fstat+ustat+getmnt */
2973 # if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
2974 defined(HAS_GETMNTENT) && \
2975 defined(HAS_HASMNTOPT) && \
2976 defined(MNTOPT_NOSUID)
2977 # define FD_ON_NOSUID_CHECK_OKAY
2978 FILE *mtab = fopen("/etc/mtab", "r");
2979 struct mntent *entry;
2982 if (mtab && (fstat(fd, &stb) == 0)) {
2983 while (entry = getmntent(mtab)) {
2984 if (stat(entry->mnt_dir, &fsb) == 0
2985 && fsb.st_dev == stb.st_dev)
2987 /* found the filesystem */
2989 if (hasmntopt(entry, MNTOPT_NOSUID))
2992 } /* A single fs may well fail its stat(). */
2997 # endif /* getmntent+hasmntopt */
3000 Perl_croak(aTHX_ "Can't check filesystem of script \"%s\" for nosuid", PL_origfilename);
3003 #endif /* IAMSUID */
3006 S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript)
3012 /* do we need to emulate setuid on scripts? */
3014 /* This code is for those BSD systems that have setuid #! scripts disabled
3015 * in the kernel because of a security problem. Merely defining DOSUID
3016 * in perl will not fix that problem, but if you have disabled setuid
3017 * scripts in the kernel, this will attempt to emulate setuid and setgid
3018 * on scripts that have those now-otherwise-useless bits set. The setuid
3019 * root version must be called suidperl or sperlN.NNN. If regular perl
3020 * discovers that it has opened a setuid script, it calls suidperl with
3021 * the same argv that it had. If suidperl finds that the script it has
3022 * just opened is NOT setuid root, it sets the effective uid back to the
3023 * uid. We don't just make perl setuid root because that loses the
3024 * effective uid we had before invoking perl, if it was different from the
3027 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
3028 * be defined in suidperl only. suidperl must be setuid root. The
3029 * Configure script will set this up for you if you want it.
3035 if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */
3036 Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
3037 if (fdscript < 0 && PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
3042 #ifndef HAS_SETREUID
3043 /* On this access check to make sure the directories are readable,
3044 * there is actually a small window that the user could use to make
3045 * filename point to an accessible directory. So there is a faint
3046 * chance that someone could execute a setuid script down in a
3047 * non-accessible directory. I don't know what to do about that.
3048 * But I don't think it's too important. The manual lies when
3049 * it says access() is useful in setuid programs.
3051 if (PerlLIO_access(CopFILE(PL_curcop),1)) /*double check*/
3052 Perl_croak(aTHX_ "Permission denied");
3054 /* If we can swap euid and uid, then we can determine access rights
3055 * with a simple stat of the file, and then compare device and
3056 * inode to make sure we did stat() on the same file we opened.
3057 * Then we just have to make sure he or she can execute it.
3064 setreuid(PL_euid,PL_uid) < 0
3067 setresuid(PL_euid,PL_uid,(Uid_t)-1) < 0
3070 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
3071 Perl_croak(aTHX_ "Can't swap uid and euid"); /* really paranoid */
3072 if (PerlLIO_stat(CopFILE(PL_curcop),&tmpstatbuf) < 0)
3073 Perl_croak(aTHX_ "Permission denied"); /* testing full pathname here */
3074 #if defined(IAMSUID) && !defined(NO_NOSUID_CHECK)
3075 if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp)))
3076 Perl_croak(aTHX_ "Permission denied");
3078 if (tmpstatbuf.st_dev != PL_statbuf.st_dev ||
3079 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
3080 (void)PerlIO_close(PL_rsfp);
3081 Perl_croak(aTHX_ "Permission denied\n");
3085 setreuid(PL_uid,PL_euid) < 0
3087 # if defined(HAS_SETRESUID)
3088 setresuid(PL_uid,PL_euid,(Uid_t)-1) < 0
3091 || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
3092 Perl_croak(aTHX_ "Can't reswap uid and euid");
3093 if (!cando(S_IXUSR,FALSE,&PL_statbuf)) /* can real uid exec? */
3094 Perl_croak(aTHX_ "Permission denied\n");
3096 #endif /* HAS_SETREUID */
3097 #endif /* IAMSUID */
3099 if (!S_ISREG(PL_statbuf.st_mode))
3100 Perl_croak(aTHX_ "Permission denied");
3101 if (PL_statbuf.st_mode & S_IWOTH)
3102 Perl_croak(aTHX_ "Setuid/gid script is writable by world");
3103 PL_doswitches = FALSE; /* -s is insecure in suid */
3104 CopLINE_inc(PL_curcop);
3105 if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
3106 strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */
3107 Perl_croak(aTHX_ "No #! line");
3108 s = SvPV(PL_linestr,n_a)+2;
3110 while (!isSPACE(*s)) s++;
3111 for (s2 = s; (s2 > SvPV(PL_linestr,n_a)+2 &&
3112 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
3113 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
3114 Perl_croak(aTHX_ "Not a perl script");
3115 while (*s == ' ' || *s == '\t') s++;
3117 * #! arg must be what we saw above. They can invoke it by
3118 * mentioning suidperl explicitly, but they may not add any strange
3119 * arguments beyond what #! says if they do invoke suidperl that way.
3121 len = strlen(validarg);
3122 if (strEQ(validarg," PHOOEY ") ||
3123 strnNE(s,validarg,len) || !isSPACE(s[len]))
3124 Perl_croak(aTHX_ "Args must match #! line");
3127 if (PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
3128 PL_euid == PL_statbuf.st_uid)
3130 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
3131 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
3132 #endif /* IAMSUID */
3134 if (PL_euid) { /* oops, we're not the setuid root perl */
3135 (void)PerlIO_close(PL_rsfp);
3138 PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
3139 (int)PERL_REVISION, (int)PERL_VERSION,
3140 (int)PERL_SUBVERSION), PL_origargv);
3142 Perl_croak(aTHX_ "Can't do setuid\n");
3145 if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
3147 (void)setegid(PL_statbuf.st_gid);
3150 (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
3152 #ifdef HAS_SETRESGID
3153 (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
3155 PerlProc_setgid(PL_statbuf.st_gid);
3159 if (PerlProc_getegid() != PL_statbuf.st_gid)
3160 Perl_croak(aTHX_ "Can't do setegid!\n");
3162 if (PL_statbuf.st_mode & S_ISUID) {
3163 if (PL_statbuf.st_uid != PL_euid)
3165 (void)seteuid(PL_statbuf.st_uid); /* all that for this */
3168 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
3170 #ifdef HAS_SETRESUID
3171 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
3173 PerlProc_setuid(PL_statbuf.st_uid);
3177 if (PerlProc_geteuid() != PL_statbuf.st_uid)
3178 Perl_croak(aTHX_ "Can't do seteuid!\n");
3180 else if (PL_uid) { /* oops, mustn't run as root */
3182 (void)seteuid((Uid_t)PL_uid);
3185 (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
3187 #ifdef HAS_SETRESUID
3188 (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
3190 PerlProc_setuid((Uid_t)PL_uid);
3194 if (PerlProc_geteuid() != PL_uid)
3195 Perl_croak(aTHX_ "Can't do seteuid!\n");
3198 if (!cando(S_IXUSR,TRUE,&PL_statbuf))
3199 Perl_croak(aTHX_ "Permission denied\n"); /* they can't do this */
3202 else if (PL_preprocess)
3203 Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
3204 else if (fdscript >= 0)
3205 Perl_croak(aTHX_ "fd script not allowed in suidperl\n");
3207 Perl_croak(aTHX_ "Script is not setuid/setgid in suidperl\n");
3209 /* We absolutely must clear out any saved ids here, so we */
3210 /* exec the real perl, substituting fd script for scriptname. */
3211 /* (We pass script name as "subdir" of fd, which perl will grok.) */
3212 PerlIO_rewind(PL_rsfp);
3213 PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0); /* just in case rewind didn't */
3214 for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
3215 if (!PL_origargv[which])
3216 Perl_croak(aTHX_ "Permission denied");
3217 PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
3218 PerlIO_fileno(PL_rsfp), PL_origargv[which]));
3219 #if defined(HAS_FCNTL) && defined(F_SETFD)
3220 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */
3222 PerlProc_execv(Perl_form(aTHX_ "%s/perl"PERL_FS_VER_FMT, BIN_EXP,
3223 (int)PERL_REVISION, (int)PERL_VERSION,
3224 (int)PERL_SUBVERSION), PL_origargv);/* try again */
3225 Perl_croak(aTHX_ "Can't do setuid\n");
3226 #endif /* IAMSUID */
3228 if (PL_euid != PL_uid || PL_egid != PL_gid) { /* (suidperl doesn't exist, in fact) */
3229 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
3230 PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf); /* may be either wrapped or real suid */
3231 if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
3233 (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
3236 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
3237 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
3238 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
3239 /* not set-id, must be wrapped */
3245 S_find_beginning(pTHX)
3247 register char *s, *s2;
3249 /* skip forward in input to the real script? */
3252 #ifdef MACOS_TRADITIONAL
3253 /* Since the Mac OS does not honor #! arguments for us, we do it ourselves */
3255 while (PL_doextract || gMacPerl_AlwaysExtract) {
3256 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
3257 if (!gMacPerl_AlwaysExtract)
3258 Perl_croak(aTHX_ "No Perl script found in input\n");
3260 if (PL_doextract) /* require explicit override ? */
3261 if (!OverrideExtract(PL_origfilename))
3262 Perl_croak(aTHX_ "User aborted script\n");
3264 PL_doextract = FALSE;
3266 /* Pater peccavi, file does not have #! */
3267 PerlIO_rewind(PL_rsfp);
3272 while (PL_doextract) {
3273 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
3274 Perl_croak(aTHX_ "No Perl script found in input\n");
3277 if (*s == '#' && s[1] == '!' && ((s = instr(s,"perl")) || (s = instr(s2,"PERL")))) {
3278 PerlIO_ungetc(PL_rsfp, '\n'); /* to keep line count right */
3279 PL_doextract = FALSE;
3280 while (*s && !(isSPACE (*s) || *s == '#')) s++;
3282 while (*s == ' ' || *s == '\t') s++;
3284 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
3285 if (strnEQ(s2-4,"perl",4))
3287 while ((s = moreswitches(s)))
3290 #ifdef MACOS_TRADITIONAL
3301 PL_uid = PerlProc_getuid();
3302 PL_euid = PerlProc_geteuid();
3303 PL_gid = PerlProc_getgid();
3304 PL_egid = PerlProc_getegid();
3306 PL_uid |= PL_gid << 16;
3307 PL_euid |= PL_egid << 16;
3309 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
3313 S_forbid_setid(pTHX_ char *s)
3315 if (PL_euid != PL_uid)
3316 Perl_croak(aTHX_ "No %s allowed while running setuid", s);
3317 if (PL_egid != PL_gid)
3318 Perl_croak(aTHX_ "No %s allowed while running setgid", s);
3322 Perl_init_debugger(pTHX)
3324 HV *ostash = PL_curstash;
3326 PL_curstash = PL_debstash;
3327 PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
3328 AvREAL_off(PL_dbargs);
3329 PL_DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
3330 PL_DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
3331 PL_DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
3332 sv_upgrade(GvSV(PL_DBsub), SVt_IV); /* IVX accessed if PERLDB_SUB_NN */
3333 PL_DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
3334 sv_setiv(PL_DBsingle, 0);
3335 PL_DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
3336 sv_setiv(PL_DBtrace, 0);
3337 PL_DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
3338 sv_setiv(PL_DBsignal, 0);
3339 PL_curstash = ostash;
3342 #ifndef STRESS_REALLOC
3343 #define REASONABLE(size) (size)
3345 #define REASONABLE(size) (1) /* unreasonable */
3349 Perl_init_stacks(pTHX)
3351 /* start with 128-item stack and 8K cxstack */
3352 PL_curstackinfo = new_stackinfo(REASONABLE(128),
3353 REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
3354 PL_curstackinfo->si_type = PERLSI_MAIN;
3355 PL_curstack = PL_curstackinfo->si_stack;
3356 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
3358 PL_stack_base = AvARRAY(PL_curstack);
3359 PL_stack_sp = PL_stack_base;
3360 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
3362 New(50,PL_tmps_stack,REASONABLE(128),SV*);
3365 PL_tmps_max = REASONABLE(128);
3367 New(54,PL_markstack,REASONABLE(32),I32);
3368 PL_markstack_ptr = PL_markstack;
3369 PL_markstack_max = PL_markstack + REASONABLE(32);
3373 New(54,PL_scopestack,REASONABLE(32),I32);
3374 PL_scopestack_ix = 0;
3375 PL_scopestack_max = REASONABLE(32);
3377 New(54,PL_savestack,REASONABLE(128),ANY);
3378 PL_savestack_ix = 0;
3379 PL_savestack_max = REASONABLE(128);
3381 New(54,PL_retstack,REASONABLE(16),OP*);
3383 PL_retstack_max = REASONABLE(16);
3391 while (PL_curstackinfo->si_next)
3392 PL_curstackinfo = PL_curstackinfo->si_next;
3393 while (PL_curstackinfo) {
3394 PERL_SI *p = PL_curstackinfo->si_prev;
3395 /* curstackinfo->si_stack got nuked by sv_free_arenas() */
3396 Safefree(PL_curstackinfo->si_cxstack);
3397 Safefree(PL_curstackinfo);
3398 PL_curstackinfo = p;
3400 Safefree(PL_tmps_stack);
3401 Safefree(PL_markstack);
3402 Safefree(PL_scopestack);
3403 Safefree(PL_savestack);
3404 Safefree(PL_retstack);
3413 lex_start(PL_linestr);
3415 PL_subname = newSVpvn("main",4);
3419 S_init_predump_symbols(pTHX)
3424 sv_setpvn(get_sv("\"", TRUE), " ", 1);
3425 PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
3426 GvMULTI_on(PL_stdingv);
3427 io = GvIOp(PL_stdingv);
3428 IoTYPE(io) = IoTYPE_RDONLY;
3429 IoIFP(io) = PerlIO_stdin();
3430 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
3432 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
3434 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
3437 IoTYPE(io) = IoTYPE_WRONLY;
3438 IoOFP(io) = IoIFP(io) = PerlIO_stdout();
3440 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
3442 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
3444 PL_stderrgv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
3445 GvMULTI_on(PL_stderrgv);
3446 io = GvIOp(PL_stderrgv);
3447 IoTYPE(io) = IoTYPE_WRONLY;
3448 IoOFP(io) = IoIFP(io) = PerlIO_stderr();
3449 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
3451 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
3453 PL_statname = NEWSV(66,0); /* last filename we did stat on */
3456 Safefree(PL_osname);
3457 PL_osname = savepv(OSNAME);
3461 Perl_init_argv_symbols(pTHX_ register int argc, register char **argv)
3464 argc--,argv++; /* skip name of script */
3465 if (PL_doswitches) {
3466 for (; argc > 0 && **argv == '-'; argc--,argv++) {
3469 if (argv[0][1] == '-' && !argv[0][2]) {
3473 if ((s = strchr(argv[0], '='))) {
3475 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
3478 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
3481 if ((PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV))) {
3482 GvMULTI_on(PL_argvgv);
3483 (void)gv_AVadd(PL_argvgv);
3484 av_clear(GvAVn(PL_argvgv));
3485 for (; argc > 0; argc--,argv++) {
3486 SV *sv = newSVpv(argv[0],0);
3487 av_push(GvAVn(PL_argvgv),sv);
3488 if (PL_widesyscalls)
3489 (void)sv_utf8_decode(sv);
3494 #ifdef HAS_PROCSELFEXE
3495 /* This is a function so that we don't hold on to MAXPATHLEN
3496 bytes of stack longer than necessary
3499 S_procself_val(pTHX_ SV *sv, char *arg0)
3501 char buf[MAXPATHLEN];
3502 int len = readlink(PROCSELFEXE_PATH, buf, sizeof(buf) - 1);
3503 /* FreeBSD's implementation is acknowledged to be imperfect, sometimes
3504 returning the text "unknown" from the readlink rather than the path
3505 to the executable (or returning an error from the readlink). Any valid
3506 path has a '/' in it somewhere, so use that to validate the result.
3507 See http://www.freebsd.org/cgi/query-pr.cgi?pr=35703
3509 if (len > 0 && memchr(buf, '/', len)) {
3510 sv_setpvn(sv,buf,len);
3516 #endif /* HAS_PROCSELFEXE */
3519 S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
3525 PL_toptarget = NEWSV(0,0);
3526 sv_upgrade(PL_toptarget, SVt_PVFM);
3527 sv_setpvn(PL_toptarget, "", 0);
3528 PL_bodytarget = NEWSV(0,0);
3529 sv_upgrade(PL_bodytarget, SVt_PVFM);
3530 sv_setpvn(PL_bodytarget, "", 0);
3531 PL_formtarget = PL_bodytarget;
3535 init_argv_symbols(argc,argv);
3537 if ((tmpgv = gv_fetchpv("0",TRUE, SVt_PV))) {
3538 #ifdef MACOS_TRADITIONAL
3539 /* $0 is not majick on a Mac */
3540 sv_setpv(GvSV(tmpgv),MacPerl_MPWFileName(PL_origfilename));
3542 sv_setpv(GvSV(tmpgv),PL_origfilename);
3543 magicname("0", "0", 1);
3546 if ((tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))) {/* $^X */
3547 #ifdef HAS_PROCSELFEXE
3548 S_procself_val(aTHX_ GvSV(tmpgv), PL_origargv[0]);
3551 sv_setpv(GvSV(tmpgv), os2_execname(aTHX));
3553 sv_setpv(GvSV(tmpgv),PL_origargv[0]);
3557 if ((PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV))) {
3559 GvMULTI_on(PL_envgv);
3560 hv = GvHVn(PL_envgv);
3561 hv_magic(hv, Nullgv, PERL_MAGIC_env);
3562 #ifdef USE_ENVIRON_ARRAY
3563 /* Note that if the supplied env parameter is actually a copy
3564 of the global environ then it may now point to free'd memory
3565 if the environment has been modified since. To avoid this
3566 problem we treat env==NULL as meaning 'use the default'
3571 environ[0] = Nullch;
3573 for (; *env; env++) {
3574 if (!(s = strchr(*env,'=')))
3581 sv = newSVpv(s+1, 0);
3582 (void)hv_store(hv, *env, s - *env, sv, 0);
3586 #endif /* USE_ENVIRON_ARRAY */
3589 if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV))) {
3590 SvREADONLY_off(GvSV(tmpgv));
3591 sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
3592 SvREADONLY_on(GvSV(tmpgv));
3595 /* touch @F array to prevent spurious warnings 20020415 MJD */
3597 (void) get_av("main::F", TRUE | GV_ADDMULTI);
3599 /* touch @- and @+ arrays to prevent spurious warnings 20020415 MJD */
3600 (void) get_av("main::-", TRUE | GV_ADDMULTI);
3601 (void) get_av("main::+", TRUE | GV_ADDMULTI);
3605 S_init_perllib(pTHX)
3610 s = PerlEnv_getenv("PERL5LIB");
3612 incpush(s, TRUE, TRUE);
3614 incpush(PerlEnv_getenv("PERLLIB"), FALSE, FALSE);
3616 /* Treat PERL5?LIB as a possible search list logical name -- the
3617 * "natural" VMS idiom for a Unix path string. We allow each
3618 * element to be a set of |-separated directories for compatibility.
3622 if (my_trnlnm("PERL5LIB",buf,0))
3623 do { incpush(buf,TRUE,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
3625 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE,FALSE);
3629 /* Use the ~-expanded versions of APPLLIB (undocumented),
3630 ARCHLIB PRIVLIB SITEARCH SITELIB VENDORARCH and VENDORLIB
3633 incpush(APPLLIB_EXP, TRUE, TRUE);
3637 incpush(ARCHLIB_EXP, FALSE, FALSE);
3639 #ifdef MACOS_TRADITIONAL
3642 SV * privdir = NEWSV(55, 0);
3643 char * macperl = PerlEnv_getenv("MACPERL");
3648 Perl_sv_setpvf(aTHX_ privdir, "%slib:", macperl);
3649 if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
3650 incpush(SvPVX(privdir), TRUE, FALSE);
3651 Perl_sv_setpvf(aTHX_ privdir, "%ssite_perl:", macperl);
3652 if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
3653 incpush(SvPVX(privdir), TRUE, FALSE);
3655 SvREFCNT_dec(privdir);
3658 incpush(":", FALSE, FALSE);
3661 # define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
3664 incpush(PRIVLIB_EXP, TRUE, FALSE);
3666 incpush(PRIVLIB_EXP, FALSE, FALSE);
3670 /* sitearch is always relative to sitelib on Windows for
3671 * DLL-based path intuition to work correctly */
3672 # if !defined(WIN32)
3673 incpush(SITEARCH_EXP, FALSE, FALSE);
3679 incpush(SITELIB_EXP, TRUE, FALSE); /* this picks up sitearch as well */
3681 incpush(SITELIB_EXP, FALSE, FALSE);
3685 #ifdef SITELIB_STEM /* Search for version-specific dirs below here */
3686 incpush(SITELIB_STEM, FALSE, TRUE);
3689 #ifdef PERL_VENDORARCH_EXP
3690 /* vendorarch is always relative to vendorlib on Windows for
3691 * DLL-based path intuition to work correctly */
3692 # if !defined(WIN32)
3693 incpush(PERL_VENDORARCH_EXP, FALSE, FALSE);
3697 #ifdef PERL_VENDORLIB_EXP
3699 incpush(PERL_VENDORLIB_EXP, TRUE, FALSE); /* this picks up vendorarch as well */
3701 incpush(PERL_VENDORLIB_EXP, FALSE, FALSE);
3705 #ifdef PERL_VENDORLIB_STEM /* Search for version-specific dirs below here */
3706 incpush(PERL_VENDORLIB_STEM, FALSE, TRUE);
3709 #ifdef PERL_OTHERLIBDIRS
3710 incpush(PERL_OTHERLIBDIRS, TRUE, TRUE);
3714 incpush(".", FALSE, FALSE);
3715 #endif /* MACOS_TRADITIONAL */
3718 #if defined(DOSISH) || defined(EPOC)
3719 # define PERLLIB_SEP ';'
3722 # define PERLLIB_SEP '|'
3724 # if defined(MACOS_TRADITIONAL)
3725 # define PERLLIB_SEP ','
3727 # define PERLLIB_SEP ':'
3731 #ifndef PERLLIB_MANGLE
3732 # define PERLLIB_MANGLE(s,n) (s)
3736 S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers)
3738 SV *subdir = Nullsv;
3743 if (addsubdirs || addoldvers) {
3744 subdir = sv_newmortal();
3747 /* Break at all separators */
3749 SV *libdir = NEWSV(55,0);
3752 /* skip any consecutive separators */
3753 while ( *p == PERLLIB_SEP ) {
3754 /* Uncomment the next line for PATH semantics */
3755 /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */
3759 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
3760 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
3765 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
3766 p = Nullch; /* break out */
3768 #ifdef MACOS_TRADITIONAL
3769 if (!strchr(SvPVX(libdir), ':'))
3770 sv_insert(libdir, 0, 0, ":", 1);
3771 if (SvPVX(libdir)[SvCUR(libdir)-1] != ':')
3772 sv_catpv(libdir, ":");
3776 * BEFORE pushing libdir onto @INC we may first push version- and
3777 * archname-specific sub-directories.
3779 if (addsubdirs || addoldvers) {
3780 #ifdef PERL_INC_VERSION_LIST
3781 /* Configure terminates PERL_INC_VERSION_LIST with a NULL */
3782 const char *incverlist[] = { PERL_INC_VERSION_LIST };
3783 const char **incver;
3790 if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) {
3792 while (unix[len-1] == '/') len--; /* Cosmetic */
3793 sv_usepvn(libdir,unix,len);
3796 PerlIO_printf(Perl_error_log,
3797 "Failed to unixify @INC element \"%s\"\n",
3801 #ifdef MACOS_TRADITIONAL
3802 #define PERL_AV_SUFFIX_FMT ""
3803 #define PERL_ARCH_FMT "%s:"
3804 #define PERL_ARCH_FMT_PATH PERL_FS_VER_FMT PERL_AV_SUFFIX_FMT
3806 #define PERL_AV_SUFFIX_FMT "/"
3807 #define PERL_ARCH_FMT "/%s"
3808 #define PERL_ARCH_FMT_PATH PERL_AV_SUFFIX_FMT PERL_FS_VER_FMT
3810 /* .../version/archname if -d .../version/archname */
3811 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH PERL_ARCH_FMT,
3813 (int)PERL_REVISION, (int)PERL_VERSION,
3814 (int)PERL_SUBVERSION, ARCHNAME);
3815 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3816 S_ISDIR(tmpstatbuf.st_mode))
3817 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3819 /* .../version if -d .../version */
3820 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH, libdir,
3821 (int)PERL_REVISION, (int)PERL_VERSION,
3822 (int)PERL_SUBVERSION);
3823 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3824 S_ISDIR(tmpstatbuf.st_mode))
3825 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3827 /* .../archname if -d .../archname */
3828 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, ARCHNAME);
3829 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3830 S_ISDIR(tmpstatbuf.st_mode))
3831 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3834 #ifdef PERL_INC_VERSION_LIST
3836 for (incver = incverlist; *incver; incver++) {
3837 /* .../xxx if -d .../xxx */
3838 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, *incver);
3839 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3840 S_ISDIR(tmpstatbuf.st_mode))
3841 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3847 /* finally push this lib directory on the end of @INC */
3848 av_push(GvAVn(PL_incgv), libdir);
3852 #ifdef USE_5005THREADS
3853 STATIC struct perl_thread *
3854 S_init_main_thread(pTHX)
3856 #if !defined(PERL_IMPLICIT_CONTEXT)
3857 struct perl_thread *thr;
3861 Newz(53, thr, 1, struct perl_thread);
3862 PL_curcop = &PL_compiling;
3863 thr->interp = PERL_GET_INTERP;
3864 thr->cvcache = newHV();
3865 thr->threadsv = newAV();
3866 /* thr->threadsvp is set when find_threadsv is called */
3867 thr->specific = newAV();
3868 thr->flags = THRf_R_JOINABLE;
3869 MUTEX_INIT(&thr->mutex);
3870 /* Handcraft thrsv similarly to mess_sv */
3871 New(53, PL_thrsv, 1, SV);
3872 Newz(53, xpv, 1, XPV);
3873 SvFLAGS(PL_thrsv) = SVt_PV;
3874 SvANY(PL_thrsv) = (void*)xpv;
3875 SvREFCNT(PL_thrsv) = 1 << 30; /* practically infinite */
3876 SvPVX(PL_thrsv) = (char*)thr;
3877 SvCUR_set(PL_thrsv, sizeof(thr));
3878 SvLEN_set(PL_thrsv, sizeof(thr));
3879 *SvEND(PL_thrsv) = '\0'; /* in the trailing_nul field */
3880 thr->oursv = PL_thrsv;
3881 PL_chopset = " \n-";
3884 MUTEX_LOCK(&PL_threads_mutex);
3890 MUTEX_UNLOCK(&PL_threads_mutex);
3892 #ifdef HAVE_THREAD_INTERN
3893 Perl_init_thread_intern(thr);
3896 #ifdef SET_THREAD_SELF
3897 SET_THREAD_SELF(thr);
3899 thr->self = pthread_self();
3900 #endif /* SET_THREAD_SELF */
3904 * These must come after the thread self setting
3905 * because sv_setpvn does SvTAINT and the taint
3906 * fields thread selfness being set.
3908 PL_toptarget = NEWSV(0,0);
3909 sv_upgrade(PL_toptarget, SVt_PVFM);
3910 sv_setpvn(PL_toptarget, "", 0);
3911 PL_bodytarget = NEWSV(0,0);
3912 sv_upgrade(PL_bodytarget, SVt_PVFM);
3913 sv_setpvn(PL_bodytarget, "", 0);
3914 PL_formtarget = PL_bodytarget;
3915 thr->errsv = newSVpvn("", 0);
3916 (void) find_threadsv("@"); /* Ensure $@ is initialised early */
3919 PL_peepp = MEMBER_TO_FPTR(Perl_peep);
3920 PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
3921 PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
3922 PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
3923 PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
3924 PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
3926 PL_reginterp_cnt = 0;
3930 #endif /* USE_5005THREADS */
3933 Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
3936 line_t oldline = CopLINE(PL_curcop);
3942 while (AvFILL(paramList) >= 0) {
3943 cv = (CV*)av_shift(paramList);
3944 if (PL_savebegin && (paramList == PL_beginav)) {
3945 /* save PL_beginav for compiler */
3946 if (! PL_beginav_save)
3947 PL_beginav_save = newAV();
3948 av_push(PL_beginav_save, (SV*)cv);
3952 #ifdef PERL_FLEXIBLE_EXCEPTIONS
3953 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_list_body), cv);
3959 #ifndef PERL_FLEXIBLE_EXCEPTIONS
3963 (void)SvPV(atsv, len);
3966 PL_curcop = &PL_compiling;
3967 CopLINE_set(PL_curcop, oldline);
3968 if (paramList == PL_beginav)
3969 sv_catpv(atsv, "BEGIN failed--compilation aborted");
3971 Perl_sv_catpvf(aTHX_ atsv,
3972 "%s failed--call queue aborted",
3973 paramList == PL_checkav ? "CHECK"
3974 : paramList == PL_initav ? "INIT"
3976 while (PL_scopestack_ix > oldscope)
3979 Perl_croak(aTHX_ "%s", SvPVx(atsv, n_a));
3986 /* my_exit() was called */
3987 while (PL_scopestack_ix > oldscope)
3990 PL_curstash = PL_defstash;
3991 PL_curcop = &PL_compiling;
3992 CopLINE_set(PL_curcop, oldline);
3994 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) {
3995 if (paramList == PL_beginav)
3996 Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
3998 Perl_croak(aTHX_ "%s failed--call queue aborted",
3999 paramList == PL_checkav ? "CHECK"
4000 : paramList == PL_initav ? "INIT"
4007 PL_curcop = &PL_compiling;
4008 CopLINE_set(PL_curcop, oldline);
4011 PerlIO_printf(Perl_error_log, "panic: restartop\n");
4019 #ifdef PERL_FLEXIBLE_EXCEPTIONS
4021 S_vcall_list_body(pTHX_ va_list args)
4023 CV *cv = va_arg(args, CV*);
4024 return call_list_body(cv);
4029 S_call_list_body(pTHX_ CV *cv)
4031 PUSHMARK(PL_stack_sp);
4032 call_sv((SV*)cv, G_EVAL|G_DISCARD);
4037 Perl_my_exit(pTHX_ U32 status)
4039 DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
4040 thr, (unsigned long) status));
4049 STATUS_NATIVE_SET(status);
4056 Perl_my_failure_exit(pTHX)
4059 if (vaxc$errno & 1) {
4060 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
4061 STATUS_NATIVE_SET(44);
4064 if (!vaxc$errno && errno) /* unlikely */
4065 STATUS_NATIVE_SET(44);
4067 STATUS_NATIVE_SET(vaxc$errno);
4072 STATUS_POSIX_SET(errno);
4074 exitstatus = STATUS_POSIX >> 8;
4075 if (exitstatus & 255)
4076 STATUS_POSIX_SET(exitstatus);
4078 STATUS_POSIX_SET(255);
4085 S_my_exit_jump(pTHX)
4087 register PERL_CONTEXT *cx;
4092 SvREFCNT_dec(PL_e_script);
4093 PL_e_script = Nullsv;
4096 POPSTACK_TO(PL_mainstack);
4097 if (cxstack_ix >= 0) {
4100 POPBLOCK(cx,PL_curpm);
4108 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen)
4111 p = SvPVX(PL_e_script);
4112 nl = strchr(p, '\n');
4113 nl = (nl) ? nl+1 : SvEND(PL_e_script);
4115 filter_del(read_e_script);
4118 sv_catpvn(buf_sv, p, nl-p);
4119 sv_chop(PL_e_script, nl);