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);
262 sv_setpvn(PERL_DEBUG_PAD(0), "", 0); /* For regex debugging. */
263 sv_setpvn(PERL_DEBUG_PAD(1), "", 0);
264 sv_setpvn(PERL_DEBUG_PAD(2), "", 0);
267 PL_regex_padav = newAV();
268 av_push(PL_regex_padav,(SV*)newAV()); /* First entry is an array of empty elements */
269 PL_regex_pad = AvARRAY(PL_regex_padav);
271 #ifdef USE_REENTRANT_API
272 Perl_reentrant_init(aTHX);
275 /* Note that strtab is a rather special HV. Assumptions are made
276 about not iterating on it, and not adding tie magic to it.
277 It is properly deallocated in perl_destruct() */
280 #ifdef USE_5005THREADS
281 MUTEX_INIT(&PL_strtab_mutex);
283 HvSHAREKEYS_off(PL_strtab); /* mandatory */
284 hv_ksplit(PL_strtab, 512);
286 #if defined(__DYNAMIC__) && (defined(NeXT) || defined(__NeXT__))
287 _dyld_lookup_and_bind
288 ("__environ", (unsigned long *) &environ_pointer, NULL);
291 #ifdef USE_ENVIRON_ARRAY
292 PL_origenviron = environ;
299 =for apidoc perl_destruct
301 Shuts down a Perl interpreter. See L<perlembed>.
309 volatile int destruct_level; /* 0=none, 1=full, 2=full with checks */
311 #ifdef USE_5005THREADS
314 #endif /* USE_5005THREADS */
316 /* wait for all pseudo-forked children to finish */
317 PERL_WAIT_FOR_CHILDREN;
319 #ifdef USE_5005THREADS
321 /* Pass 1 on any remaining threads: detach joinables, join zombies */
323 MUTEX_LOCK(&PL_threads_mutex);
324 DEBUG_S(PerlIO_printf(Perl_debug_log,
325 "perl_destruct: waiting for %d threads...\n",
327 for (t = thr->next; t != thr; t = t->next) {
328 MUTEX_LOCK(&t->mutex);
329 switch (ThrSTATE(t)) {
332 DEBUG_S(PerlIO_printf(Perl_debug_log,
333 "perl_destruct: joining zombie %p\n", t));
334 ThrSETSTATE(t, THRf_DEAD);
335 MUTEX_UNLOCK(&t->mutex);
338 * The SvREFCNT_dec below may take a long time (e.g. av
339 * may contain an object scalar whose destructor gets
340 * called) so we have to unlock threads_mutex and start
343 MUTEX_UNLOCK(&PL_threads_mutex);
345 SvREFCNT_dec((SV*)av);
346 DEBUG_S(PerlIO_printf(Perl_debug_log,
347 "perl_destruct: joined zombie %p OK\n", t));
349 case THRf_R_JOINABLE:
350 DEBUG_S(PerlIO_printf(Perl_debug_log,
351 "perl_destruct: detaching thread %p\n", t));
352 ThrSETSTATE(t, THRf_R_DETACHED);
354 * We unlock threads_mutex and t->mutex in the opposite order
355 * from which we locked them just so that DETACH won't
356 * deadlock if it panics. It's only a breach of good style
357 * not a bug since they are unlocks not locks.
359 MUTEX_UNLOCK(&PL_threads_mutex);
361 MUTEX_UNLOCK(&t->mutex);
364 DEBUG_S(PerlIO_printf(Perl_debug_log,
365 "perl_destruct: ignoring %p (state %u)\n",
367 MUTEX_UNLOCK(&t->mutex);
368 /* fall through and out */
371 /* We leave the above "Pass 1" loop with threads_mutex still locked */
373 /* Pass 2 on remaining threads: wait for the thread count to drop to one */
374 while (PL_nthreads > 1)
376 DEBUG_S(PerlIO_printf(Perl_debug_log,
377 "perl_destruct: final wait for %d threads\n",
379 COND_WAIT(&PL_nthreads_cond, &PL_threads_mutex);
381 /* At this point, we're the last thread */
382 MUTEX_UNLOCK(&PL_threads_mutex);
383 DEBUG_S(PerlIO_printf(Perl_debug_log, "perl_destruct: armageddon has arrived\n"));
384 MUTEX_DESTROY(&PL_threads_mutex);
385 COND_DESTROY(&PL_nthreads_cond);
387 #endif /* !defined(FAKE_THREADS) */
388 #endif /* USE_5005THREADS */
390 destruct_level = PL_perl_destruct_level;
394 if ((s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL"))) {
396 if (destruct_level < i)
403 if(PL_exit_flags & PERL_EXIT_DESTRUCT_END) {
408 if (PL_endav && !PL_minus_c)
409 call_list(PL_scopestack_ix, PL_endav);
415 /* We must account for everything. */
417 /* Destroy the main CV and syntax tree */
419 PL_curpad = AvARRAY(PL_comppad);
420 op_free(PL_main_root);
421 PL_main_root = Nullop;
423 PL_curcop = &PL_compiling;
424 PL_main_start = Nullop;
425 SvREFCNT_dec(PL_main_cv);
429 /* Tell PerlIO we are about to tear things apart in case
430 we have layers which are using resources that should
434 PerlIO_destruct(aTHX);
436 if (PL_sv_objcount) {
438 * Try to destruct global references. We do this first so that the
439 * destructors and destructees still exist. Some sv's might remain.
440 * Non-referenced objects are on their own.
445 /* unhook hooks which will soon be, or use, destroyed data */
446 SvREFCNT_dec(PL_warnhook);
447 PL_warnhook = Nullsv;
448 SvREFCNT_dec(PL_diehook);
451 /* call exit list functions */
452 while (PL_exitlistlen-- > 0)
453 PL_exitlist[PL_exitlistlen].fn(aTHX_ PL_exitlist[PL_exitlistlen].ptr);
455 Safefree(PL_exitlist);
457 if (destruct_level == 0){
459 DEBUG_P(debprofdump());
461 #if defined(PERLIO_LAYERS)
462 /* No more IO - including error messages ! */
463 PerlIO_cleanup(aTHX);
466 /* The exit() function will do everything that needs doing. */
467 return STATUS_NATIVE_EXPORT;;
470 /* jettison our possibly duplicated environment */
471 /* if PERL_USE_SAFE_PUTENV is defined environ will not have been copied
472 * so we certainly shouldn't free it here
474 #if defined(USE_ENVIRON_ARRAY) && !defined(PERL_USE_SAFE_PUTENV)
475 if (environ != PL_origenviron) {
478 for (i = 0; environ[i]; i++)
479 safesysfree(environ[i]);
481 /* Must use safesysfree() when working with environ. */
482 safesysfree(environ);
484 environ = PL_origenviron;
489 /* the syntax tree is shared between clones
490 * so op_free(PL_main_root) only ReREFCNT_dec's
491 * REGEXPs in the parent interpreter
492 * we need to manually ReREFCNT_dec for the clones
495 I32 i = AvFILLp(PL_regex_padav) + 1;
496 SV **ary = AvARRAY(PL_regex_padav);
500 REGEXP *re = INT2PTR(REGEXP *,SvIVX(resv));
502 if (SvFLAGS(resv) & SVf_BREAK) {
503 /* this is PL_reg_curpm, already freed
504 * flag is set in regexec.c:S_regtry
506 SvFLAGS(resv) &= ~SVf_BREAK;
508 else if(SvREPADTMP(resv)) {
509 SvREPADTMP_off(resv);
516 SvREFCNT_dec(PL_regex_padav);
517 PL_regex_padav = Nullav;
521 /* loosen bonds of global variables */
524 (void)PerlIO_close(PL_rsfp);
528 /* Filters for program text */
529 SvREFCNT_dec(PL_rsfp_filters);
530 PL_rsfp_filters = Nullav;
533 PL_preprocess = FALSE;
539 PL_doswitches = FALSE;
540 PL_dowarn = G_WARN_OFF;
541 PL_doextract = FALSE;
542 PL_sawampersand = FALSE; /* must save all match strings */
545 Safefree(PL_inplace);
547 SvREFCNT_dec(PL_patchlevel);
550 SvREFCNT_dec(PL_e_script);
551 PL_e_script = Nullsv;
554 while (--PL_origargc >= 0) {
555 Safefree(PL_origargv[PL_origargc]);
557 Safefree(PL_origargv);
559 /* magical thingies */
561 SvREFCNT_dec(PL_ofs_sv); /* $, */
564 SvREFCNT_dec(PL_ors_sv); /* $\ */
567 SvREFCNT_dec(PL_rs); /* $/ */
570 PL_multiline = 0; /* $* */
571 Safefree(PL_osname); /* $^O */
574 SvREFCNT_dec(PL_statname);
575 PL_statname = Nullsv;
578 /* defgv, aka *_ should be taken care of elsewhere */
580 /* clean up after study() */
581 SvREFCNT_dec(PL_lastscream);
582 PL_lastscream = Nullsv;
583 Safefree(PL_screamfirst);
585 Safefree(PL_screamnext);
589 Safefree(PL_efloatbuf);
590 PL_efloatbuf = Nullch;
593 /* startup and shutdown function lists */
594 SvREFCNT_dec(PL_beginav);
595 SvREFCNT_dec(PL_beginav_save);
596 SvREFCNT_dec(PL_endav);
597 SvREFCNT_dec(PL_checkav);
598 SvREFCNT_dec(PL_initav);
600 PL_beginav_save = Nullav;
605 /* shortcuts just get cleared */
611 PL_argvoutgv = Nullgv;
613 PL_stderrgv = Nullgv;
614 PL_last_in_gv = Nullgv;
616 PL_debstash = Nullhv;
618 /* reset so print() ends up where we expect */
621 SvREFCNT_dec(PL_argvout_stack);
622 PL_argvout_stack = Nullav;
624 SvREFCNT_dec(PL_modglobal);
625 PL_modglobal = Nullhv;
626 SvREFCNT_dec(PL_preambleav);
627 PL_preambleav = Nullav;
628 SvREFCNT_dec(PL_subname);
630 SvREFCNT_dec(PL_linestr);
632 SvREFCNT_dec(PL_pidstatus);
633 PL_pidstatus = Nullhv;
634 SvREFCNT_dec(PL_toptarget);
635 PL_toptarget = Nullsv;
636 SvREFCNT_dec(PL_bodytarget);
637 PL_bodytarget = Nullsv;
638 PL_formtarget = Nullsv;
640 /* free locale stuff */
641 #ifdef USE_LOCALE_COLLATE
642 Safefree(PL_collation_name);
643 PL_collation_name = Nullch;
646 #ifdef USE_LOCALE_NUMERIC
647 Safefree(PL_numeric_name);
648 PL_numeric_name = Nullch;
649 SvREFCNT_dec(PL_numeric_radix_sv);
652 /* clear utf8 character classes */
653 SvREFCNT_dec(PL_utf8_alnum);
654 SvREFCNT_dec(PL_utf8_alnumc);
655 SvREFCNT_dec(PL_utf8_ascii);
656 SvREFCNT_dec(PL_utf8_alpha);
657 SvREFCNT_dec(PL_utf8_space);
658 SvREFCNT_dec(PL_utf8_cntrl);
659 SvREFCNT_dec(PL_utf8_graph);
660 SvREFCNT_dec(PL_utf8_digit);
661 SvREFCNT_dec(PL_utf8_upper);
662 SvREFCNT_dec(PL_utf8_lower);
663 SvREFCNT_dec(PL_utf8_print);
664 SvREFCNT_dec(PL_utf8_punct);
665 SvREFCNT_dec(PL_utf8_xdigit);
666 SvREFCNT_dec(PL_utf8_mark);
667 SvREFCNT_dec(PL_utf8_toupper);
668 SvREFCNT_dec(PL_utf8_totitle);
669 SvREFCNT_dec(PL_utf8_tolower);
670 SvREFCNT_dec(PL_utf8_tofold);
671 PL_utf8_alnum = Nullsv;
672 PL_utf8_alnumc = Nullsv;
673 PL_utf8_ascii = Nullsv;
674 PL_utf8_alpha = Nullsv;
675 PL_utf8_space = Nullsv;
676 PL_utf8_cntrl = Nullsv;
677 PL_utf8_graph = Nullsv;
678 PL_utf8_digit = Nullsv;
679 PL_utf8_upper = Nullsv;
680 PL_utf8_lower = Nullsv;
681 PL_utf8_print = Nullsv;
682 PL_utf8_punct = Nullsv;
683 PL_utf8_xdigit = Nullsv;
684 PL_utf8_mark = Nullsv;
685 PL_utf8_toupper = Nullsv;
686 PL_utf8_totitle = Nullsv;
687 PL_utf8_tolower = Nullsv;
688 PL_utf8_tofold = Nullsv;
690 if (!specialWARN(PL_compiling.cop_warnings))
691 SvREFCNT_dec(PL_compiling.cop_warnings);
692 PL_compiling.cop_warnings = Nullsv;
693 if (!specialCopIO(PL_compiling.cop_io))
694 SvREFCNT_dec(PL_compiling.cop_io);
695 PL_compiling.cop_io = Nullsv;
696 CopFILE_free(&PL_compiling);
697 CopSTASH_free(&PL_compiling);
699 /* Prepare to destruct main symbol table. */
704 SvREFCNT_dec(PL_curstname);
705 PL_curstname = Nullsv;
707 /* clear queued errors */
708 SvREFCNT_dec(PL_errors);
712 if (destruct_level >= 2 && ckWARN_d(WARN_INTERNAL)) {
713 if (PL_scopestack_ix != 0)
714 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
715 "Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
716 (long)PL_scopestack_ix);
717 if (PL_savestack_ix != 0)
718 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
719 "Unbalanced saves: %ld more saves than restores\n",
720 (long)PL_savestack_ix);
721 if (PL_tmps_floor != -1)
722 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced tmps: %ld more allocs than frees\n",
723 (long)PL_tmps_floor + 1);
724 if (cxstack_ix != -1)
725 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced context: %ld more PUSHes than POPs\n",
726 (long)cxstack_ix + 1);
729 /* Now absolutely destruct everything, somehow or other, loops or no. */
730 SvFLAGS(PL_fdpid) |= SVTYPEMASK; /* don't clean out pid table now */
731 SvFLAGS(PL_strtab) |= SVTYPEMASK; /* don't clean out strtab now */
733 /* the 2 is for PL_fdpid and PL_strtab */
734 while (PL_sv_count > 2 && sv_clean_all())
737 SvFLAGS(PL_fdpid) &= ~SVTYPEMASK;
738 SvFLAGS(PL_fdpid) |= SVt_PVAV;
739 SvFLAGS(PL_strtab) &= ~SVTYPEMASK;
740 SvFLAGS(PL_strtab) |= SVt_PVHV;
742 AvREAL_off(PL_fdpid); /* no surviving entries */
743 SvREFCNT_dec(PL_fdpid); /* needed in io_close() */
746 #ifdef HAVE_INTERP_INTERN
750 /* Destruct the global string table. */
752 /* Yell and reset the HeVAL() slots that are still holding refcounts,
753 * so that sv_free() won't fail on them.
761 max = HvMAX(PL_strtab);
762 array = HvARRAY(PL_strtab);
765 if (hent && ckWARN_d(WARN_INTERNAL)) {
766 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
767 "Unbalanced string table refcount: (%d) for \"%s\"",
768 HeVAL(hent) - Nullsv, HeKEY(hent));
769 HeVAL(hent) = Nullsv;
779 SvREFCNT_dec(PL_strtab);
782 /* free the pointer table used for cloning */
783 ptr_table_free(PL_ptr_table);
786 /* free special SVs */
788 SvREFCNT(&PL_sv_yes) = 0;
789 sv_clear(&PL_sv_yes);
790 SvANY(&PL_sv_yes) = NULL;
791 SvFLAGS(&PL_sv_yes) = 0;
793 SvREFCNT(&PL_sv_no) = 0;
795 SvANY(&PL_sv_no) = NULL;
796 SvFLAGS(&PL_sv_no) = 0;
798 SvREFCNT(&PL_sv_undef) = 0;
799 SvREADONLY_off(&PL_sv_undef);
801 if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL))
802 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Scalars leaked: %ld\n", (long)PL_sv_count);
804 #if defined(PERLIO_LAYERS)
805 /* No more IO - including error messages ! */
806 PerlIO_cleanup(aTHX);
809 Safefree(PL_origfilename);
810 Safefree(PL_reg_start_tmp);
812 Safefree(PL_reg_curpm);
813 Safefree(PL_reg_poscache);
814 Safefree(HeKEY_hek(&PL_hv_fetch_ent_mh));
815 Safefree(PL_op_mask);
816 Safefree(PL_psig_ptr);
817 Safefree(PL_psig_name);
818 Safefree(PL_bitcount);
819 Safefree(PL_psig_pend);
821 PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */
823 DEBUG_P(debprofdump());
824 #ifdef USE_5005THREADS
825 MUTEX_DESTROY(&PL_strtab_mutex);
826 MUTEX_DESTROY(&PL_sv_mutex);
827 MUTEX_DESTROY(&PL_eval_mutex);
828 MUTEX_DESTROY(&PL_cred_mutex);
829 MUTEX_DESTROY(&PL_fdpid_mutex);
830 COND_DESTROY(&PL_eval_cond);
831 #ifdef EMULATE_ATOMIC_REFCOUNTS
832 MUTEX_DESTROY(&PL_svref_mutex);
833 #endif /* EMULATE_ATOMIC_REFCOUNTS */
835 /* As the penultimate thing, free the non-arena SV for thrsv */
836 Safefree(SvPVX(PL_thrsv));
837 Safefree(SvANY(PL_thrsv));
840 #endif /* USE_5005THREADS */
842 #ifdef USE_REENTRANT_API
843 Perl_reentrant_free(aTHX);
848 /* As the absolutely last thing, free the non-arena SV for mess() */
851 /* it could have accumulated taint magic */
852 if (SvTYPE(PL_mess_sv) >= SVt_PVMG) {
855 for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) {
856 moremagic = mg->mg_moremagic;
857 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global
859 Safefree(mg->mg_ptr);
863 /* we know that type >= SVt_PV */
864 (void)SvOOK_off(PL_mess_sv);
865 Safefree(SvPVX(PL_mess_sv));
866 Safefree(SvANY(PL_mess_sv));
867 Safefree(PL_mess_sv);
870 return STATUS_NATIVE_EXPORT;
874 =for apidoc perl_free
876 Releases a Perl interpreter. See L<perlembed>.
884 #if defined(WIN32) || defined(NETWARE)
885 # if defined(PERL_IMPLICIT_SYS)
887 void *host = nw_internal_host;
889 void *host = w32_internal_host;
893 nw5_delete_internal_host(host);
895 win32_delete_internal_host(host);
906 Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
908 Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry);
909 PL_exitlist[PL_exitlistlen].fn = fn;
910 PL_exitlist[PL_exitlistlen].ptr = ptr;
915 =for apidoc perl_parse
917 Tells a Perl interpreter to parse a Perl script. See L<perlembed>.
923 perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
928 #ifdef USE_5005THREADS
932 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
935 Perl_croak(aTHX_ "suidperl is no longer needed since the kernel can now execute\n\
936 setuid perl scripts securely.\n");
942 /* we copy rather than point to argv
943 * since perl_clone will copy and perl_destruct
944 * has no way of knowing if we've made a copy or
948 New(0, PL_origargv, i+1, char*);
949 PL_origargv[i] = '\0';
951 PL_origargv[i] = savepv(argv[i]);
959 /* Come here if running an undumped a.out. */
961 PL_origfilename = savepv(argv[0]);
962 PL_do_undump = FALSE;
963 cxstack_ix = -1; /* start label stack again */
965 init_postdump_symbols(argc,argv,env);
970 PL_curpad = AvARRAY(PL_comppad);
971 op_free(PL_main_root);
972 PL_main_root = Nullop;
974 PL_main_start = Nullop;
975 SvREFCNT_dec(PL_main_cv);
979 oldscope = PL_scopestack_ix;
980 PL_dowarn = G_WARN_OFF;
982 #ifdef PERL_FLEXIBLE_EXCEPTIONS
983 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vparse_body), env, xsinit);
989 #ifndef PERL_FLEXIBLE_EXCEPTIONS
990 parse_body(env,xsinit);
993 call_list(oldscope, PL_checkav);
1000 /* my_exit() was called */
1001 while (PL_scopestack_ix > oldscope)
1004 PL_curstash = PL_defstash;
1006 call_list(oldscope, PL_checkav);
1007 ret = STATUS_NATIVE_EXPORT;
1010 PerlIO_printf(Perl_error_log, "panic: top_env\n");
1018 #ifdef PERL_FLEXIBLE_EXCEPTIONS
1020 S_vparse_body(pTHX_ va_list args)
1022 char **env = va_arg(args, char**);
1023 XSINIT_t xsinit = va_arg(args, XSINIT_t);
1025 return parse_body(env, xsinit);
1030 S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
1032 int argc = PL_origargc;
1033 char **argv = PL_origargv;
1034 char *scriptname = NULL;
1036 VOL bool dosearch = FALSE;
1037 char *validarg = "";
1041 char *cddir = Nullch;
1043 sv_setpvn(PL_linestr,"",0);
1044 sv = newSVpvn("",0); /* first used for -I flags */
1048 for (argc--,argv++; argc > 0; argc--,argv++) {
1049 if (argv[0][0] != '-' || !argv[0][1])
1053 validarg = " PHOOEY ";
1062 win32_argv2utf8(argc-1, argv+1);
1065 #ifndef PERL_STRICT_CR
1089 if ((s = moreswitches(s)))
1094 if( !PL_tainting ) {
1095 PL_taint_warn = TRUE;
1102 PL_taint_warn = FALSE;
1107 #ifdef MACOS_TRADITIONAL
1108 /* ignore -e for Dev:Pseudo argument */
1109 if (argv[1] && !strcmp(argv[1], "Dev:Pseudo"))
1112 if (PL_euid != PL_uid || PL_egid != PL_gid)
1113 Perl_croak(aTHX_ "No -e allowed in setuid scripts");
1115 PL_e_script = newSVpvn("",0);
1116 filter_add(read_e_script, NULL);
1119 sv_catpv(PL_e_script, s);
1121 sv_catpv(PL_e_script, argv[1]);
1125 Perl_croak(aTHX_ "No code specified for -e");
1126 sv_catpv(PL_e_script, "\n");
1129 case 'I': /* -I handled both here and in moreswitches() */
1131 if (!*++s && (s=argv[1]) != Nullch) {
1136 STRLEN len = strlen(s);
1137 p = savepvn(s, len);
1138 incpush(p, TRUE, TRUE);
1139 sv_catpvn(sv, "-I", 2);
1140 sv_catpvn(sv, p, len);
1141 sv_catpvn(sv, " ", 1);
1145 Perl_croak(aTHX_ "No directory specified for -I");
1149 PL_preprocess = TRUE;
1159 PL_preambleav = newAV();
1160 av_push(PL_preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
1162 PL_Sv = newSVpv("print myconfig();",0);
1164 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
1166 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
1168 sv_catpv(PL_Sv,"\" Compile-time options:");
1170 sv_catpv(PL_Sv," DEBUGGING");
1172 # ifdef MULTIPLICITY
1173 sv_catpv(PL_Sv," MULTIPLICITY");
1175 # ifdef USE_5005THREADS
1176 sv_catpv(PL_Sv," USE_5005THREADS");
1178 # ifdef USE_ITHREADS
1179 sv_catpv(PL_Sv," USE_ITHREADS");
1181 # ifdef USE_64_BIT_INT
1182 sv_catpv(PL_Sv," USE_64_BIT_INT");
1184 # ifdef USE_64_BIT_ALL
1185 sv_catpv(PL_Sv," USE_64_BIT_ALL");
1187 # ifdef USE_LONG_DOUBLE
1188 sv_catpv(PL_Sv," USE_LONG_DOUBLE");
1190 # ifdef USE_LARGE_FILES
1191 sv_catpv(PL_Sv," USE_LARGE_FILES");
1194 sv_catpv(PL_Sv," USE_SOCKS");
1196 # ifdef PERL_IMPLICIT_CONTEXT
1197 sv_catpv(PL_Sv," PERL_IMPLICIT_CONTEXT");
1199 # ifdef PERL_IMPLICIT_SYS
1200 sv_catpv(PL_Sv," PERL_IMPLICIT_SYS");
1202 sv_catpv(PL_Sv,"\\n\",");
1204 #if defined(LOCAL_PATCH_COUNT)
1205 if (LOCAL_PATCH_COUNT > 0) {
1207 sv_catpv(PL_Sv,"\" Locally applied patches:\\n\",");
1208 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
1209 if (PL_localpatches[i])
1210 Perl_sv_catpvf(aTHX_ PL_Sv,"q\" \t%s\n\",",PL_localpatches[i]);
1214 Perl_sv_catpvf(aTHX_ PL_Sv,"\" Built under %s\\n\"",OSNAME);
1217 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
1219 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled on %s\\n\"",__DATE__);
1222 sv_catpv(PL_Sv, "; \
1224 @env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; ");
1227 push @env, \"CYGWIN=\\\"$ENV{CYGWIN}\\\"\";");
1230 print \" \\%ENV:\\n @env\\n\" if @env; \
1231 print \" \\@INC:\\n @INC\\n\";");
1234 PL_Sv = newSVpv("config_vars(qw(",0);
1235 sv_catpv(PL_Sv, ++s);
1236 sv_catpv(PL_Sv, "))");
1239 av_push(PL_preambleav, PL_Sv);
1240 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
1243 PL_doextract = TRUE;
1251 if (!*++s || isSPACE(*s)) {
1255 /* catch use of gnu style long options */
1256 if (strEQ(s, "version")) {
1260 if (strEQ(s, "help")) {
1267 Perl_croak(aTHX_ "Unrecognized switch: -%s (-h will show valid options)",s);
1273 #ifndef SECURE_INTERNAL_GETENV
1276 (s = PerlEnv_getenv("PERL5OPT")))
1281 if (*s == '-' && *(s+1) == 'T') {
1283 PL_taint_warn = FALSE;
1286 char *popt_copy = Nullch;
1299 if (!strchr("DIMUdmtw", *s))
1300 Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
1304 popt_copy = SvPVX(sv_2mortal(newSVpv(popt,0)));
1305 s = popt_copy + (s - popt);
1306 d = popt_copy + (d - popt);
1313 if( !PL_tainting ) {
1314 PL_taint_warn = TRUE;
1324 if (PL_taint_warn && PL_dowarn != G_WARN_ALL_OFF) {
1325 PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
1329 scriptname = argv[0];
1332 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
1334 else if (scriptname == Nullch) {
1336 if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
1344 open_script(scriptname,dosearch,sv,&fdscript);
1346 validate_suid(validarg, scriptname,fdscript);
1349 #if defined(SIGCHLD) || defined(SIGCLD)
1352 # define SIGCHLD SIGCLD
1354 Sighandler_t sigstate = rsignal_state(SIGCHLD);
1355 if (sigstate == SIG_IGN) {
1356 if (ckWARN(WARN_SIGNAL))
1357 Perl_warner(aTHX_ packWARN(WARN_SIGNAL),
1358 "Can't ignore signal CHLD, forcing to default");
1359 (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL);
1365 #ifdef MACOS_TRADITIONAL
1366 if (PL_doextract || gMacPerl_AlwaysExtract) {
1371 if (cddir && PerlDir_chdir(cddir) < 0)
1372 Perl_croak(aTHX_ "Can't chdir to %s",cddir);
1376 PL_main_cv = PL_compcv = (CV*)NEWSV(1104,0);
1377 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
1378 CvUNIQUE_on(PL_compcv);
1380 PL_comppad = newAV();
1381 av_push(PL_comppad, Nullsv);
1382 PL_curpad = AvARRAY(PL_comppad);
1383 PL_comppad_name = newAV();
1384 PL_comppad_name_fill = 0;
1385 PL_min_intro_pending = 0;
1387 #ifdef USE_5005THREADS
1388 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
1389 PL_curpad[0] = (SV*)newAV();
1390 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
1391 CvOWNER(PL_compcv) = 0;
1392 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
1393 MUTEX_INIT(CvMUTEXP(PL_compcv));
1394 #endif /* USE_5005THREADS */
1396 comppadlist = newAV();
1397 AvREAL_off(comppadlist);
1398 av_store(comppadlist, 0, (SV*)PL_comppad_name);
1399 av_store(comppadlist, 1, (SV*)PL_comppad);
1400 CvPADLIST(PL_compcv) = comppadlist;
1403 boot_core_UNIVERSAL();
1405 boot_core_xsutils();
1409 (*xsinit)(aTHX); /* in case linked C routines want magical variables */
1411 #if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__) || defined(EPOC)
1417 # ifdef HAS_SOCKS5_INIT
1418 socks5_init(argv[0]);
1424 init_predump_symbols();
1425 /* init_postdump_symbols not currently designed to be called */
1426 /* more than once (ENV isn't cleared first, for example) */
1427 /* But running with -u leaves %ENV & @ARGV undefined! XXX */
1429 init_postdump_symbols(argc,argv,env);
1431 if (PL_wantutf8) { /* Requires init_predump_symbols(). */
1435 if (PL_stdingv && (io = GvIO(PL_stdingv)) && (fp = IoIFP(io)))
1436 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
1437 if (PL_defoutgv && (io = GvIO(PL_defoutgv)) && (fp = IoOFP(io)))
1438 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
1439 if (PL_stderrgv && (io = GvIO(PL_stderrgv)) && (fp = IoOFP(io)))
1440 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
1441 if ((sv = GvSV(gv_fetchpv("\017PEN", TRUE, SVt_PV)))) {
1442 sv_setpvn(sv, ":utf8\0:utf8", 11);
1449 /* now parse the script */
1451 SETERRNO(0,SS$_NORMAL);
1453 #ifdef MACOS_TRADITIONAL
1454 if (gMacPerl_SyntaxError = (yyparse() || PL_error_count)) {
1456 Perl_croak(aTHX_ "%s had compilation errors.\n", MacPerl_MPWFileName(PL_origfilename));
1458 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
1459 MacPerl_MPWFileName(PL_origfilename));
1463 if (yyparse() || PL_error_count) {
1465 Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
1467 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
1472 CopLINE_set(PL_curcop, 0);
1473 PL_curstash = PL_defstash;
1474 PL_preprocess = FALSE;
1476 SvREFCNT_dec(PL_e_script);
1477 PL_e_script = Nullsv;
1481 Not sure that this is still the right place to do this now that we
1482 no longer use PL_nrs. HVDS 2001/09/09
1484 sv_setsv(get_sv("/", TRUE), PL_rs);
1490 SAVECOPFILE(PL_curcop);
1491 SAVECOPLINE(PL_curcop);
1492 gv_check(PL_defstash);
1499 if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
1500 dump_mstats("after compilation:");
1509 =for apidoc perl_run
1511 Tells a Perl interpreter to run. See L<perlembed>.
1522 #ifdef USE_5005THREADS
1526 oldscope = PL_scopestack_ix;
1531 #ifdef PERL_FLEXIBLE_EXCEPTIONS
1533 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vrun_body), oldscope);
1539 cxstack_ix = -1; /* start context stack again */
1541 case 0: /* normal completion */
1542 #ifndef PERL_FLEXIBLE_EXCEPTIONS
1547 case 2: /* my_exit() */
1548 while (PL_scopestack_ix > oldscope)
1551 PL_curstash = PL_defstash;
1552 if (!(PL_exit_flags & PERL_EXIT_DESTRUCT_END) &&
1553 PL_endav && !PL_minus_c)
1554 call_list(oldscope, PL_endav);
1556 if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
1557 dump_mstats("after execution: ");
1559 ret = STATUS_NATIVE_EXPORT;
1563 POPSTACK_TO(PL_mainstack);
1566 PerlIO_printf(Perl_error_log, "panic: restartop\n");
1576 #ifdef PERL_FLEXIBLE_EXCEPTIONS
1578 S_vrun_body(pTHX_ va_list args)
1580 I32 oldscope = va_arg(args, I32);
1582 return run_body(oldscope);
1588 S_run_body(pTHX_ I32 oldscope)
1590 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
1591 PL_sawampersand ? "Enabling" : "Omitting"));
1593 if (!PL_restartop) {
1594 DEBUG_x(dump_all());
1595 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
1596 DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%"UVxf"\n",
1600 #ifdef MACOS_TRADITIONAL
1601 PerlIO_printf(Perl_error_log, "# %s syntax OK\n", MacPerl_MPWFileName(PL_origfilename));
1603 PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
1607 if (PERLDB_SINGLE && PL_DBsingle)
1608 sv_setiv(PL_DBsingle, 1);
1610 call_list(oldscope, PL_initav);
1616 PL_op = PL_restartop;
1620 else if (PL_main_start) {
1621 CvDEPTH(PL_main_cv) = 1;
1622 PL_op = PL_main_start;
1632 =head1 SV Manipulation Functions
1634 =for apidoc p||get_sv
1636 Returns the SV of the specified Perl scalar. If C<create> is set and the
1637 Perl variable does not exist then it will be created. If C<create> is not
1638 set and the variable does not exist then NULL is returned.
1644 Perl_get_sv(pTHX_ const char *name, I32 create)
1647 #ifdef USE_5005THREADS
1648 if (name[1] == '\0' && !isALPHA(name[0])) {
1649 PADOFFSET tmp = find_threadsv(name);
1650 if (tmp != NOT_IN_PAD)
1651 return THREADSV(tmp);
1653 #endif /* USE_5005THREADS */
1654 gv = gv_fetchpv(name, create, SVt_PV);
1661 =head1 Array Manipulation Functions
1663 =for apidoc p||get_av
1665 Returns the AV of the specified Perl array. If C<create> is set and the
1666 Perl variable does not exist then it will be created. If C<create> is not
1667 set and the variable does not exist then NULL is returned.
1673 Perl_get_av(pTHX_ const char *name, I32 create)
1675 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1684 =head1 Hash Manipulation Functions
1686 =for apidoc p||get_hv
1688 Returns the HV of the specified Perl hash. 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_hv(pTHX_ const char *name, I32 create)
1698 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1707 =head1 CV Manipulation Functions
1709 =for apidoc p||get_cv
1711 Returns the CV of the specified Perl subroutine. If C<create> is set and
1712 the Perl subroutine does not exist then it will be declared (which has the
1713 same effect as saying C<sub name;>). If C<create> is not set and the
1714 subroutine does not exist then NULL is returned.
1720 Perl_get_cv(pTHX_ const char *name, I32 create)
1722 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
1723 /* XXX unsafe for threads if eval_owner isn't held */
1724 /* XXX this is probably not what they think they're getting.
1725 * It has the same effect as "sub name;", i.e. just a forward
1727 if (create && !GvCVu(gv))
1728 return newSUB(start_subparse(FALSE, 0),
1729 newSVOP(OP_CONST, 0, newSVpv(name,0)),
1737 /* Be sure to refetch the stack pointer after calling these routines. */
1741 =head1 Callback Functions
1743 =for apidoc p||call_argv
1745 Performs a callback to the specified Perl sub. See L<perlcall>.
1751 Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv)
1753 /* See G_* flags in cop.h */
1754 /* null terminated arg list */
1761 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
1766 return call_pv(sub_name, flags);
1770 =for apidoc p||call_pv
1772 Performs a callback to the specified Perl sub. See L<perlcall>.
1778 Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
1779 /* name of the subroutine */
1780 /* See G_* flags in cop.h */
1782 return call_sv((SV*)get_cv(sub_name, TRUE), flags);
1786 =for apidoc p||call_method
1788 Performs a callback to the specified Perl method. The blessed object must
1789 be on the stack. See L<perlcall>.
1795 Perl_call_method(pTHX_ const char *methname, I32 flags)
1796 /* name of the subroutine */
1797 /* See G_* flags in cop.h */
1799 return call_sv(sv_2mortal(newSVpv(methname,0)), flags | G_METHOD);
1802 /* May be called with any of a CV, a GV, or an SV containing the name. */
1804 =for apidoc p||call_sv
1806 Performs a callback to the Perl sub whose name is in the SV. See
1813 Perl_call_sv(pTHX_ SV *sv, I32 flags)
1814 /* See G_* flags in cop.h */
1817 LOGOP myop; /* fake syntax tree node */
1820 volatile I32 retval = 0;
1822 bool oldcatch = CATCH_GET;
1827 if (flags & G_DISCARD) {
1832 Zero(&myop, 1, LOGOP);
1833 myop.op_next = Nullop;
1834 if (!(flags & G_NOARGS))
1835 myop.op_flags |= OPf_STACKED;
1836 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1837 (flags & G_ARRAY) ? OPf_WANT_LIST :
1842 EXTEND(PL_stack_sp, 1);
1843 *++PL_stack_sp = sv;
1845 oldscope = PL_scopestack_ix;
1847 if (PERLDB_SUB && PL_curstash != PL_debstash
1848 /* Handle first BEGIN of -d. */
1849 && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
1850 /* Try harder, since this may have been a sighandler, thus
1851 * curstash may be meaningless. */
1852 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != PL_debstash)
1853 && !(flags & G_NODEBUG))
1854 PL_op->op_private |= OPpENTERSUB_DB;
1856 if (flags & G_METHOD) {
1857 Zero(&method_op, 1, UNOP);
1858 method_op.op_next = PL_op;
1859 method_op.op_ppaddr = PL_ppaddr[OP_METHOD];
1860 myop.op_ppaddr = PL_ppaddr[OP_ENTERSUB];
1861 PL_op = (OP*)&method_op;
1864 if (!(flags & G_EVAL)) {
1866 call_body((OP*)&myop, FALSE);
1867 retval = PL_stack_sp - (PL_stack_base + oldmark);
1868 CATCH_SET(oldcatch);
1871 myop.op_other = (OP*)&myop;
1873 /* we're trying to emulate pp_entertry() here */
1875 register PERL_CONTEXT *cx;
1876 I32 gimme = GIMME_V;
1881 push_return(Nullop);
1882 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
1884 PL_eval_root = PL_op; /* Only needed so that goto works right. */
1886 PL_in_eval = EVAL_INEVAL;
1887 if (flags & G_KEEPERR)
1888 PL_in_eval |= EVAL_KEEPERR;
1894 #ifdef PERL_FLEXIBLE_EXCEPTIONS
1896 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_body),
1903 #ifndef PERL_FLEXIBLE_EXCEPTIONS
1905 call_body((OP*)&myop, FALSE);
1907 retval = PL_stack_sp - (PL_stack_base + oldmark);
1908 if (!(flags & G_KEEPERR))
1915 /* my_exit() was called */
1916 PL_curstash = PL_defstash;
1919 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
1920 Perl_croak(aTHX_ "Callback called exit");
1925 PL_op = PL_restartop;
1929 PL_stack_sp = PL_stack_base + oldmark;
1930 if (flags & G_ARRAY)
1934 *++PL_stack_sp = &PL_sv_undef;
1939 if (PL_scopestack_ix > oldscope) {
1943 register PERL_CONTEXT *cx;
1955 if (flags & G_DISCARD) {
1956 PL_stack_sp = PL_stack_base + oldmark;
1965 #ifdef PERL_FLEXIBLE_EXCEPTIONS
1967 S_vcall_body(pTHX_ va_list args)
1969 OP *myop = va_arg(args, OP*);
1970 int is_eval = va_arg(args, int);
1972 call_body(myop, is_eval);
1978 S_call_body(pTHX_ OP *myop, int is_eval)
1980 if (PL_op == myop) {
1982 PL_op = Perl_pp_entereval(aTHX); /* this doesn't do a POPMARK */
1984 PL_op = Perl_pp_entersub(aTHX); /* this does */
1990 /* Eval a string. The G_EVAL flag is always assumed. */
1993 =for apidoc p||eval_sv
1995 Tells Perl to C<eval> the string in the SV.
2001 Perl_eval_sv(pTHX_ SV *sv, I32 flags)
2003 /* See G_* flags in cop.h */
2006 UNOP myop; /* fake syntax tree node */
2007 volatile I32 oldmark = SP - PL_stack_base;
2008 volatile I32 retval = 0;
2014 if (flags & G_DISCARD) {
2021 Zero(PL_op, 1, UNOP);
2022 EXTEND(PL_stack_sp, 1);
2023 *++PL_stack_sp = sv;
2024 oldscope = PL_scopestack_ix;
2026 if (!(flags & G_NOARGS))
2027 myop.op_flags = OPf_STACKED;
2028 myop.op_next = Nullop;
2029 myop.op_type = OP_ENTEREVAL;
2030 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
2031 (flags & G_ARRAY) ? OPf_WANT_LIST :
2033 if (flags & G_KEEPERR)
2034 myop.op_flags |= OPf_SPECIAL;
2036 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2038 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_body),
2045 #ifndef PERL_FLEXIBLE_EXCEPTIONS
2047 call_body((OP*)&myop,TRUE);
2049 retval = PL_stack_sp - (PL_stack_base + oldmark);
2050 if (!(flags & G_KEEPERR))
2057 /* my_exit() was called */
2058 PL_curstash = PL_defstash;
2061 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
2062 Perl_croak(aTHX_ "Callback called exit");
2067 PL_op = PL_restartop;
2071 PL_stack_sp = PL_stack_base + oldmark;
2072 if (flags & G_ARRAY)
2076 *++PL_stack_sp = &PL_sv_undef;
2082 if (flags & G_DISCARD) {
2083 PL_stack_sp = PL_stack_base + oldmark;
2093 =for apidoc p||eval_pv
2095 Tells Perl to C<eval> the given string and return an SV* result.
2101 Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
2104 SV* sv = newSVpv(p, 0);
2106 eval_sv(sv, G_SCALAR);
2113 if (croak_on_error && SvTRUE(ERRSV)) {
2115 Perl_croak(aTHX_ SvPVx(ERRSV, n_a));
2121 /* Require a module. */
2124 =head1 Embedding Functions
2126 =for apidoc p||require_pv
2128 Tells Perl to C<require> the file named by the string argument. It is
2129 analogous to the Perl code C<eval "require '$file'">. It's even
2130 implemented that way; consider using Perl_load_module instead.
2135 Perl_require_pv(pTHX_ const char *pv)
2139 PUSHSTACKi(PERLSI_REQUIRE);
2141 sv = sv_newmortal();
2142 sv_setpv(sv, "require '");
2145 eval_sv(sv, G_DISCARD);
2151 Perl_magicname(pTHX_ char *sym, char *name, I32 namlen)
2155 if ((gv = gv_fetchpv(sym,TRUE, SVt_PV)))
2156 sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, namlen);
2160 S_usage(pTHX_ char *name) /* XXX move this out into a module ? */
2162 /* This message really ought to be max 23 lines.
2163 * Removed -h because the user already knows that option. Others? */
2165 static char *usage_msg[] = {
2166 "-0[octal] specify record separator (\\0, if no argument)",
2167 "-a autosplit mode with -n or -p (splits $_ into @F)",
2168 "-C enable native wide character system interfaces",
2169 "-c check syntax only (runs BEGIN and CHECK blocks)",
2170 "-d[:debugger] run program under debugger",
2171 "-D[number/list] set debugging flags (argument is a bit mask or alphabets)",
2172 "-e 'command' one line of program (several -e's allowed, omit programfile)",
2173 "-F/pattern/ split() pattern for -a switch (//'s are optional)",
2174 "-i[extension] edit <> files in place (makes backup if extension supplied)",
2175 "-Idirectory specify @INC/#include directory (several -I's allowed)",
2176 "-l[octal] enable line ending processing, specifies line terminator",
2177 "-[mM][-]module execute `use/no module...' before executing program",
2178 "-n assume 'while (<>) { ... }' loop around program",
2179 "-p assume loop like -n but print line also, like sed",
2180 "-P run program through C preprocessor before compilation",
2181 "-s enable rudimentary parsing for switches after programfile",
2182 "-S look for programfile using PATH environment variable",
2183 "-T enable tainting checks",
2184 "-t enable tainting warnings",
2185 "-u dump core after parsing program",
2186 "-U allow unsafe operations",
2187 "-v print version, subversion (includes VERY IMPORTANT perl info)",
2188 "-V[:variable] print configuration summary (or a single Config.pm variable)",
2189 "-w enable many useful warnings (RECOMMENDED)",
2190 "-W enable all warnings",
2191 "-X disable all warnings",
2192 "-x[directory] strip off text before #!perl line and perhaps cd to directory",
2196 char **p = usage_msg;
2198 PerlIO_printf(PerlIO_stdout(),
2199 "\nUsage: %s [switches] [--] [programfile] [arguments]",
2202 PerlIO_printf(PerlIO_stdout(), "\n %s", *p++);
2205 /* This routine handles any switches that can be given during run */
2208 Perl_moreswitches(pTHX_ char *s)
2218 rschar = (U32)grok_oct(s, &numlen, &flags, NULL);
2219 SvREFCNT_dec(PL_rs);
2220 if (rschar & ~((U8)~0))
2221 PL_rs = &PL_sv_undef;
2222 else if (!rschar && numlen >= 2)
2223 PL_rs = newSVpvn("", 0);
2226 PL_rs = newSVpvn(&ch, 1);
2231 PL_widesyscalls = TRUE;
2237 while (*s && !isSPACE(*s)) ++s;
2239 PL_splitstr = savepv(PL_splitstr);
2252 /* The following permits -d:Mod to accepts arguments following an =
2253 in the fashion that -MSome::Mod does. */
2254 if (*s == ':' || *s == '=') {
2257 sv = newSVpv("use Devel::", 0);
2259 /* We now allow -d:Module=Foo,Bar */
2260 while(isALNUM(*s) || *s==':') ++s;
2262 sv_catpv(sv, start);
2264 sv_catpvn(sv, start, s-start);
2265 sv_catpv(sv, " split(/,/,q{");
2270 my_setenv("PERL5DB", SvPV(sv, PL_na));
2273 PL_perldb = PERLDB_ALL;
2281 if (isALPHA(s[1])) {
2282 /* if adding extra options, remember to update DEBUG_MASK */
2283 static char debopts[] = "psltocPmfrxuLHXDSTRJ";
2286 for (s++; *s && (d = strchr(debopts,*s)); s++)
2287 PL_debug |= 1 << (d - debopts);
2290 PL_debug = atoi(s+1);
2291 for (s++; isDIGIT(*s); s++) ;
2293 PL_debug |= DEBUG_TOP_FLAG;
2295 if (ckWARN_d(WARN_DEBUGGING))
2296 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
2297 "Recompile perl with -DDEBUGGING to use -D switch\n");
2298 for (s++; isALNUM(*s); s++) ;
2304 usage(PL_origargv[0]);
2308 Safefree(PL_inplace);
2309 PL_inplace = savepv(s+1);
2311 for (s = PL_inplace; *s && !isSPACE(*s); s++) ;
2314 if (*s == '-') /* Additional switches on #! line. */
2318 case 'I': /* -I handled both here and in parse_body() */
2321 while (*s && isSPACE(*s))
2326 /* ignore trailing spaces (possibly followed by other switches) */
2328 for (e = p; *e && !isSPACE(*e); e++) ;
2332 } while (*p && *p != '-');
2333 e = savepvn(s, e-s);
2334 incpush(e, TRUE, TRUE);
2341 Perl_croak(aTHX_ "No directory specified for -I");
2347 SvREFCNT_dec(PL_ors_sv);
2352 PL_ors_sv = newSVpvn("\n",1);
2353 numlen = 3 + (*s == '0');
2354 *SvPVX(PL_ors_sv) = (char)grok_oct(s, &numlen, &flags, NULL);
2358 if (RsPARA(PL_rs)) {
2359 PL_ors_sv = newSVpvn("\n\n",2);
2362 PL_ors_sv = newSVsv(PL_rs);
2367 forbid_setid("-M"); /* XXX ? */
2370 forbid_setid("-m"); /* XXX ? */
2375 /* -M-foo == 'no foo' */
2376 if (*s == '-') { use = "no "; ++s; }
2377 sv = newSVpv(use,0);
2379 /* We allow -M'Module qw(Foo Bar)' */
2380 while(isALNUM(*s) || *s==':') ++s;
2382 sv_catpv(sv, start);
2383 if (*(start-1) == 'm') {
2385 Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
2386 sv_catpv( sv, " ()");
2390 Perl_croak(aTHX_ "Module name required with -%c option",
2392 sv_catpvn(sv, start, s-start);
2393 sv_catpv(sv, " split(/,/,q{");
2399 PL_preambleav = newAV();
2400 av_push(PL_preambleav, sv);
2403 Perl_croak(aTHX_ "No space allowed after -%c", *(s-1));
2415 PL_doswitches = TRUE;
2420 Perl_croak(aTHX_ "Too late for \"-t\" option");
2425 Perl_croak(aTHX_ "Too late for \"-T\" option");
2429 #ifdef MACOS_TRADITIONAL
2430 Perl_croak(aTHX_ "Believe me, you don't want to use \"-u\" on a Macintosh");
2432 PL_do_undump = TRUE;
2441 PerlIO_printf(PerlIO_stdout(),
2442 Perl_form(aTHX_ "\nThis is perl, v%"VDf" built for %s",
2443 PL_patchlevel, ARCHNAME));
2445 /* Adjust verbose output as in the perl that ships with the DG/UX OS from EMC */
2446 PerlIO_printf(PerlIO_stdout(),
2447 Perl_form(aTHX_ "\nThis is perl, version %vd\n", PL_patchlevel));
2448 PerlIO_printf(PerlIO_stdout(),
2449 Perl_form(aTHX_ " built under %s at %s %s\n",
2450 OSNAME, __DATE__, __TIME__));
2451 PerlIO_printf(PerlIO_stdout(),
2452 Perl_form(aTHX_ " OS Specific Release: %s\n",
2456 #if defined(LOCAL_PATCH_COUNT)
2457 if (LOCAL_PATCH_COUNT > 0)
2458 PerlIO_printf(PerlIO_stdout(),
2459 "\n(with %d registered patch%s, "
2460 "see perl -V for more detail)",
2461 (int)LOCAL_PATCH_COUNT,
2462 (LOCAL_PATCH_COUNT!=1) ? "es" : "");
2465 PerlIO_printf(PerlIO_stdout(),
2466 "\n\nCopyright 1987-2002, Larry Wall\n");
2467 #ifdef MACOS_TRADITIONAL
2468 PerlIO_printf(PerlIO_stdout(),
2469 "\nMac OS port Copyright 1991-2002, Matthias Neeracher;\n"
2470 "maintained by Chris Nandor\n");
2473 PerlIO_printf(PerlIO_stdout(),
2474 "\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
2477 PerlIO_printf(PerlIO_stdout(),
2478 "djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n"
2479 "djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
2482 PerlIO_printf(PerlIO_stdout(),
2483 "\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
2484 "Version 5 port Copyright (c) 1994-2002, Andreas Kaiser, Ilya Zakharevich\n");
2487 PerlIO_printf(PerlIO_stdout(),
2488 "atariST series port, ++jrb bammi@cadence.com\n");
2491 PerlIO_printf(PerlIO_stdout(),
2492 "BeOS port Copyright Tom Spindler, 1997-1999\n");
2495 PerlIO_printf(PerlIO_stdout(),
2496 "MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-2002\n");
2499 PerlIO_printf(PerlIO_stdout(),
2500 "MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
2503 PerlIO_printf(PerlIO_stdout(),
2504 "Stratus VOS port by Paul_Green@stratus.com, 1997-2002\n");
2507 PerlIO_printf(PerlIO_stdout(),
2508 "VM/ESA port by Neale Ferguson, 1998-1999\n");
2511 PerlIO_printf(PerlIO_stdout(),
2512 "BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
2515 PerlIO_printf(PerlIO_stdout(),
2516 "MiNT port by Guido Flohr, 1997-1999\n");
2519 PerlIO_printf(PerlIO_stdout(),
2520 "EPOC port by Olaf Flebbe, 1999-2002\n");
2523 printf("WINCE port by Rainer Keuchel, 2001-2002\n");
2524 printf("Built on " __DATE__ " " __TIME__ "\n\n");
2527 #ifdef BINARY_BUILD_NOTICE
2528 BINARY_BUILD_NOTICE;
2530 PerlIO_printf(PerlIO_stdout(),
2532 Perl may be copied only under the terms of either the Artistic License or the\n\
2533 GNU General Public License, which may be found in the Perl 5 source kit.\n\n\
2534 Complete documentation for Perl, including FAQ lists, should be found on\n\
2535 this system using `man perl' or `perldoc perl'. If you have access to the\n\
2536 Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
2539 if (! (PL_dowarn & G_WARN_ALL_MASK))
2540 PL_dowarn |= G_WARN_ON;
2544 PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
2545 if (!specialWARN(PL_compiling.cop_warnings))
2546 SvREFCNT_dec(PL_compiling.cop_warnings);
2547 PL_compiling.cop_warnings = pWARN_ALL ;
2551 PL_dowarn = G_WARN_ALL_OFF;
2552 if (!specialWARN(PL_compiling.cop_warnings))
2553 SvREFCNT_dec(PL_compiling.cop_warnings);
2554 PL_compiling.cop_warnings = pWARN_NONE ;
2559 if (s[1] == '-') /* Additional switches on #! line. */
2564 #if defined(WIN32) || !defined(PERL_STRICT_CR)
2570 #ifdef ALTERNATE_SHEBANG
2571 case 'S': /* OS/2 needs -S on "extproc" line. */
2579 Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
2584 /* compliments of Tom Christiansen */
2586 /* unexec() can be found in the Gnu emacs distribution */
2587 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
2590 Perl_my_unexec(pTHX)
2598 prog = newSVpv(BIN_EXP, 0);
2599 sv_catpv(prog, "/perl");
2600 file = newSVpv(PL_origfilename, 0);
2601 sv_catpv(file, ".perldump");
2603 unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
2604 /* unexec prints msg to stderr in case of failure */
2605 PerlProc_exit(status);
2608 # include <lib$routines.h>
2609 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
2611 ABORT(); /* for use with undump */
2616 /* initialize curinterp */
2622 # define PERLVAR(var,type)
2623 # define PERLVARA(var,n,type)
2624 # if defined(PERL_IMPLICIT_CONTEXT)
2625 # if defined(USE_5005THREADS)
2626 # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
2627 # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
2628 # else /* !USE_5005THREADS */
2629 # define PERLVARI(var,type,init) aTHX->var = init;
2630 # define PERLVARIC(var,type,init) aTHX->var = init;
2631 # endif /* USE_5005THREADS */
2633 # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
2634 # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
2636 # include "intrpvar.h"
2637 # ifndef USE_5005THREADS
2638 # include "thrdvar.h"
2645 # define PERLVAR(var,type)
2646 # define PERLVARA(var,n,type)
2647 # define PERLVARI(var,type,init) PL_##var = init;
2648 # define PERLVARIC(var,type,init) PL_##var = init;
2649 # include "intrpvar.h"
2650 # ifndef USE_5005THREADS
2651 # include "thrdvar.h"
2662 S_init_main_stash(pTHX)
2668 PL_curstash = PL_defstash = newHV();
2669 PL_curstname = newSVpvn("main",4);
2670 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
2671 SvREFCNT_dec(GvHV(gv));
2672 GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
2674 HvNAME(PL_defstash) = savepv("main");
2675 PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
2676 GvMULTI_on(PL_incgv);
2677 PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
2678 GvMULTI_on(PL_hintgv);
2679 PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
2680 PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
2681 GvMULTI_on(PL_errgv);
2682 PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
2683 GvMULTI_on(PL_replgv);
2684 (void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */
2685 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
2686 sv_setpvn(ERRSV, "", 0);
2687 PL_curstash = PL_defstash;
2688 CopSTASH_set(&PL_compiling, PL_defstash);
2689 PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
2690 PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
2691 PL_nullstash = GvHV(gv_fetchpv("<none>::", GV_ADDMULTI, SVt_PVHV));
2692 /* We must init $/ before switches are processed. */
2693 sv_setpvn(get_sv("/", TRUE), "\n", 1);
2697 S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
2701 char *cpp_discard_flag;
2707 PL_origfilename = savepv("-e");
2710 /* if find_script() returns, it returns a malloc()-ed value */
2711 PL_origfilename = scriptname = find_script(scriptname, dosearch, NULL, 1);
2713 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
2714 char *s = scriptname + 8;
2715 *fdscript = atoi(s);
2719 scriptname = savepv(s + 1);
2720 Safefree(PL_origfilename);
2721 PL_origfilename = scriptname;
2726 CopFILE_free(PL_curcop);
2727 CopFILE_set(PL_curcop, PL_origfilename);
2728 if (strEQ(PL_origfilename,"-"))
2730 if (*fdscript >= 0) {
2731 PL_rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE);
2732 # if defined(HAS_FCNTL) && defined(F_SETFD)
2734 /* ensure close-on-exec */
2735 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
2738 else if (PL_preprocess) {
2739 char *cpp_cfg = CPPSTDIN;
2740 SV *cpp = newSVpvn("",0);
2741 SV *cmd = NEWSV(0,0);
2743 if (strEQ(cpp_cfg, "cppstdin"))
2744 Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
2745 sv_catpv(cpp, cpp_cfg);
2748 sv_catpvn(sv, "-I", 2);
2749 sv_catpv(sv,PRIVLIB_EXP);
2752 DEBUG_P(PerlIO_printf(Perl_debug_log,
2753 "PL_preprocess: scriptname=\"%s\", cpp=\"%s\", sv=\"%s\", CPPMINUS=\"%s\"\n",
2754 scriptname, SvPVX (cpp), SvPVX (sv), CPPMINUS));
2756 # if defined(MSDOS) || defined(WIN32) || defined(VMS)
2763 cpp_discard_flag = "";
2765 cpp_discard_flag = "-C";
2769 perl = os2_execname(aTHX);
2771 perl = PL_origargv[0];
2775 /* This strips off Perl comments which might interfere with
2776 the C pre-processor, including #!. #line directives are
2777 deliberately stripped to avoid confusion with Perl's version
2778 of #line. FWP played some golf with it so it will fit
2779 into VMS's 255 character buffer.
2782 code = "(1../^#!.*perl/i)|/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print";
2784 code = "/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print";
2786 Perl_sv_setpvf(aTHX_ cmd, "\
2787 %s -ne%s%s%s %s | %"SVf" %s %"SVf" %s",
2788 perl, quote, code, quote, scriptname, cpp,
2789 cpp_discard_flag, sv, CPPMINUS);
2791 PL_doextract = FALSE;
2792 # ifdef IAMSUID /* actually, this is caught earlier */
2793 if (PL_euid != PL_uid && !PL_euid) { /* if running suidperl */
2795 (void)seteuid(PL_uid); /* musn't stay setuid root */
2797 # ifdef HAS_SETREUID
2798 (void)setreuid((Uid_t)-1, PL_uid);
2800 # ifdef HAS_SETRESUID
2801 (void)setresuid((Uid_t)-1, PL_uid, (Uid_t)-1);
2803 PerlProc_setuid(PL_uid);
2807 if (PerlProc_geteuid() != PL_uid)
2808 Perl_croak(aTHX_ "Can't do seteuid!\n");
2810 # endif /* IAMSUID */
2812 DEBUG_P(PerlIO_printf(Perl_debug_log,
2813 "PL_preprocess: cmd=\"%s\"\n",
2816 PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
2820 else if (!*scriptname) {
2821 forbid_setid("program input from stdin");
2822 PL_rsfp = PerlIO_stdin();
2825 PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
2826 # if defined(HAS_FCNTL) && defined(F_SETFD)
2828 /* ensure close-on-exec */
2829 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
2834 # ifndef IAMSUID /* in case script is not readable before setuid */
2836 PerlLIO_stat(CopFILE(PL_curcop),&PL_statbuf) >= 0 &&
2837 PL_statbuf.st_mode & (S_ISUID|S_ISGID))
2840 PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT,
2841 BIN_EXP, (int)PERL_REVISION,
2843 (int)PERL_SUBVERSION), PL_origargv);
2844 Perl_croak(aTHX_ "Can't do setuid\n");
2850 Perl_croak(aTHX_ "Can't open perl script: %s\n",
2853 Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
2854 CopFILE(PL_curcop), Strerror(errno));
2860 * I_SYSSTATVFS HAS_FSTATVFS
2862 * I_STATFS HAS_FSTATFS HAS_GETFSSTAT
2863 * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT
2864 * here so that metaconfig picks them up. */
2868 S_fd_on_nosuid_fs(pTHX_ int fd)
2870 int check_okay = 0; /* able to do all the required sys/libcalls */
2871 int on_nosuid = 0; /* the fd is on a nosuid fs */
2873 * Preferred order: fstatvfs(), fstatfs(), ustat()+getmnt(), getmntent().
2874 * fstatvfs() is UNIX98.
2875 * fstatfs() is 4.3 BSD.
2876 * ustat()+getmnt() is pre-4.3 BSD.
2877 * getmntent() is O(number-of-mounted-filesystems) and can hang on
2878 * an irrelevant filesystem while trying to reach the right one.
2881 #undef FD_ON_NOSUID_CHECK_OKAY /* found the syscalls to do the check? */
2883 # if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
2884 defined(HAS_FSTATVFS)
2885 # define FD_ON_NOSUID_CHECK_OKAY
2886 struct statvfs stfs;
2888 check_okay = fstatvfs(fd, &stfs) == 0;
2889 on_nosuid = check_okay && (stfs.f_flag & ST_NOSUID);
2890 # endif /* fstatvfs */
2892 # if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
2893 defined(PERL_MOUNT_NOSUID) && \
2894 defined(HAS_FSTATFS) && \
2895 defined(HAS_STRUCT_STATFS) && \
2896 defined(HAS_STRUCT_STATFS_F_FLAGS)
2897 # define FD_ON_NOSUID_CHECK_OKAY
2900 check_okay = fstatfs(fd, &stfs) == 0;
2901 on_nosuid = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
2902 # endif /* fstatfs */
2904 # if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
2905 defined(PERL_MOUNT_NOSUID) && \
2906 defined(HAS_FSTAT) && \
2907 defined(HAS_USTAT) && \
2908 defined(HAS_GETMNT) && \
2909 defined(HAS_STRUCT_FS_DATA) && \
2911 # define FD_ON_NOSUID_CHECK_OKAY
2914 if (fstat(fd, &fdst) == 0) {
2916 if (ustat(fdst.st_dev, &us) == 0) {
2918 /* NOSTAT_ONE here because we're not examining fields which
2919 * vary between that case and STAT_ONE. */
2920 if (getmnt((int*)0, &fsd, (int)0, NOSTAT_ONE, us.f_fname) == 0) {
2921 size_t cmplen = sizeof(us.f_fname);
2922 if (sizeof(fsd.fd_req.path) < cmplen)
2923 cmplen = sizeof(fsd.fd_req.path);
2924 if (strnEQ(fsd.fd_req.path, us.f_fname, cmplen) &&
2925 fdst.st_dev == fsd.fd_req.dev) {
2927 on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID;
2933 # endif /* fstat+ustat+getmnt */
2935 # if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
2936 defined(HAS_GETMNTENT) && \
2937 defined(HAS_HASMNTOPT) && \
2938 defined(MNTOPT_NOSUID)
2939 # define FD_ON_NOSUID_CHECK_OKAY
2940 FILE *mtab = fopen("/etc/mtab", "r");
2941 struct mntent *entry;
2942 struct stat stb, fsb;
2944 if (mtab && (fstat(fd, &stb) == 0)) {
2945 while (entry = getmntent(mtab)) {
2946 if (stat(entry->mnt_dir, &fsb) == 0
2947 && fsb.st_dev == stb.st_dev)
2949 /* found the filesystem */
2951 if (hasmntopt(entry, MNTOPT_NOSUID))
2954 } /* A single fs may well fail its stat(). */
2959 # endif /* getmntent+hasmntopt */
2962 Perl_croak(aTHX_ "Can't check filesystem of script \"%s\" for nosuid", PL_origfilename);
2965 #endif /* IAMSUID */
2968 S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript)
2974 /* do we need to emulate setuid on scripts? */
2976 /* This code is for those BSD systems that have setuid #! scripts disabled
2977 * in the kernel because of a security problem. Merely defining DOSUID
2978 * in perl will not fix that problem, but if you have disabled setuid
2979 * scripts in the kernel, this will attempt to emulate setuid and setgid
2980 * on scripts that have those now-otherwise-useless bits set. The setuid
2981 * root version must be called suidperl or sperlN.NNN. If regular perl
2982 * discovers that it has opened a setuid script, it calls suidperl with
2983 * the same argv that it had. If suidperl finds that the script it has
2984 * just opened is NOT setuid root, it sets the effective uid back to the
2985 * uid. We don't just make perl setuid root because that loses the
2986 * effective uid we had before invoking perl, if it was different from the
2989 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
2990 * be defined in suidperl only. suidperl must be setuid root. The
2991 * Configure script will set this up for you if you want it.
2997 if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */
2998 Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
2999 if (fdscript < 0 && PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
3004 #ifndef HAS_SETREUID
3005 /* On this access check to make sure the directories are readable,
3006 * there is actually a small window that the user could use to make
3007 * filename point to an accessible directory. So there is a faint
3008 * chance that someone could execute a setuid script down in a
3009 * non-accessible directory. I don't know what to do about that.
3010 * But I don't think it's too important. The manual lies when
3011 * it says access() is useful in setuid programs.
3013 if (PerlLIO_access(CopFILE(PL_curcop),1)) /*double check*/
3014 Perl_croak(aTHX_ "Permission denied");
3016 /* If we can swap euid and uid, then we can determine access rights
3017 * with a simple stat of the file, and then compare device and
3018 * inode to make sure we did stat() on the same file we opened.
3019 * Then we just have to make sure he or she can execute it.
3022 struct stat tmpstatbuf;
3026 setreuid(PL_euid,PL_uid) < 0
3029 setresuid(PL_euid,PL_uid,(Uid_t)-1) < 0
3032 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
3033 Perl_croak(aTHX_ "Can't swap uid and euid"); /* really paranoid */
3034 if (PerlLIO_stat(CopFILE(PL_curcop),&tmpstatbuf) < 0)
3035 Perl_croak(aTHX_ "Permission denied"); /* testing full pathname here */
3036 #if defined(IAMSUID) && !defined(NO_NOSUID_CHECK)
3037 if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp)))
3038 Perl_croak(aTHX_ "Permission denied");
3040 if (tmpstatbuf.st_dev != PL_statbuf.st_dev ||
3041 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
3042 (void)PerlIO_close(PL_rsfp);
3043 Perl_croak(aTHX_ "Permission denied\n");
3047 setreuid(PL_uid,PL_euid) < 0
3049 # if defined(HAS_SETRESUID)
3050 setresuid(PL_uid,PL_euid,(Uid_t)-1) < 0
3053 || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
3054 Perl_croak(aTHX_ "Can't reswap uid and euid");
3055 if (!cando(S_IXUSR,FALSE,&PL_statbuf)) /* can real uid exec? */
3056 Perl_croak(aTHX_ "Permission denied\n");
3058 #endif /* HAS_SETREUID */
3059 #endif /* IAMSUID */
3061 if (!S_ISREG(PL_statbuf.st_mode))
3062 Perl_croak(aTHX_ "Permission denied");
3063 if (PL_statbuf.st_mode & S_IWOTH)
3064 Perl_croak(aTHX_ "Setuid/gid script is writable by world");
3065 PL_doswitches = FALSE; /* -s is insecure in suid */
3066 CopLINE_inc(PL_curcop);
3067 if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
3068 strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */
3069 Perl_croak(aTHX_ "No #! line");
3070 s = SvPV(PL_linestr,n_a)+2;
3072 while (!isSPACE(*s)) s++;
3073 for (s2 = s; (s2 > SvPV(PL_linestr,n_a)+2 &&
3074 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
3075 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
3076 Perl_croak(aTHX_ "Not a perl script");
3077 while (*s == ' ' || *s == '\t') s++;
3079 * #! arg must be what we saw above. They can invoke it by
3080 * mentioning suidperl explicitly, but they may not add any strange
3081 * arguments beyond what #! says if they do invoke suidperl that way.
3083 len = strlen(validarg);
3084 if (strEQ(validarg," PHOOEY ") ||
3085 strnNE(s,validarg,len) || !isSPACE(s[len]))
3086 Perl_croak(aTHX_ "Args must match #! line");
3089 if (PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
3090 PL_euid == PL_statbuf.st_uid)
3092 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
3093 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
3094 #endif /* IAMSUID */
3096 if (PL_euid) { /* oops, we're not the setuid root perl */
3097 (void)PerlIO_close(PL_rsfp);
3100 PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
3101 (int)PERL_REVISION, (int)PERL_VERSION,
3102 (int)PERL_SUBVERSION), PL_origargv);
3104 Perl_croak(aTHX_ "Can't do setuid\n");
3107 if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
3109 (void)setegid(PL_statbuf.st_gid);
3112 (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
3114 #ifdef HAS_SETRESGID
3115 (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
3117 PerlProc_setgid(PL_statbuf.st_gid);
3121 if (PerlProc_getegid() != PL_statbuf.st_gid)
3122 Perl_croak(aTHX_ "Can't do setegid!\n");
3124 if (PL_statbuf.st_mode & S_ISUID) {
3125 if (PL_statbuf.st_uid != PL_euid)
3127 (void)seteuid(PL_statbuf.st_uid); /* all that for this */
3130 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
3132 #ifdef HAS_SETRESUID
3133 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
3135 PerlProc_setuid(PL_statbuf.st_uid);
3139 if (PerlProc_geteuid() != PL_statbuf.st_uid)
3140 Perl_croak(aTHX_ "Can't do seteuid!\n");
3142 else if (PL_uid) { /* oops, mustn't run as root */
3144 (void)seteuid((Uid_t)PL_uid);
3147 (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
3149 #ifdef HAS_SETRESUID
3150 (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
3152 PerlProc_setuid((Uid_t)PL_uid);
3156 if (PerlProc_geteuid() != PL_uid)
3157 Perl_croak(aTHX_ "Can't do seteuid!\n");
3160 if (!cando(S_IXUSR,TRUE,&PL_statbuf))
3161 Perl_croak(aTHX_ "Permission denied\n"); /* they can't do this */
3164 else if (PL_preprocess)
3165 Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
3166 else if (fdscript >= 0)
3167 Perl_croak(aTHX_ "fd script not allowed in suidperl\n");
3169 Perl_croak(aTHX_ "Script is not setuid/setgid in suidperl\n");
3171 /* We absolutely must clear out any saved ids here, so we */
3172 /* exec the real perl, substituting fd script for scriptname. */
3173 /* (We pass script name as "subdir" of fd, which perl will grok.) */
3174 PerlIO_rewind(PL_rsfp);
3175 PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0); /* just in case rewind didn't */
3176 for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
3177 if (!PL_origargv[which])
3178 Perl_croak(aTHX_ "Permission denied");
3179 PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
3180 PerlIO_fileno(PL_rsfp), PL_origargv[which]));
3181 #if defined(HAS_FCNTL) && defined(F_SETFD)
3182 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */
3184 PerlProc_execv(Perl_form(aTHX_ "%s/perl"PERL_FS_VER_FMT, BIN_EXP,
3185 (int)PERL_REVISION, (int)PERL_VERSION,
3186 (int)PERL_SUBVERSION), PL_origargv);/* try again */
3187 Perl_croak(aTHX_ "Can't do setuid\n");
3188 #endif /* IAMSUID */
3190 if (PL_euid != PL_uid || PL_egid != PL_gid) { /* (suidperl doesn't exist, in fact) */
3191 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
3192 PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf); /* may be either wrapped or real suid */
3193 if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
3195 (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
3198 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
3199 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
3200 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
3201 /* not set-id, must be wrapped */
3207 S_find_beginning(pTHX)
3209 register char *s, *s2;
3211 /* skip forward in input to the real script? */
3214 #ifdef MACOS_TRADITIONAL
3215 /* Since the Mac OS does not honor #! arguments for us, we do it ourselves */
3217 while (PL_doextract || gMacPerl_AlwaysExtract) {
3218 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
3219 if (!gMacPerl_AlwaysExtract)
3220 Perl_croak(aTHX_ "No Perl script found in input\n");
3222 if (PL_doextract) /* require explicit override ? */
3223 if (!OverrideExtract(PL_origfilename))
3224 Perl_croak(aTHX_ "User aborted script\n");
3226 PL_doextract = FALSE;
3228 /* Pater peccavi, file does not have #! */
3229 PerlIO_rewind(PL_rsfp);
3234 while (PL_doextract) {
3235 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
3236 Perl_croak(aTHX_ "No Perl script found in input\n");
3239 if (*s == '#' && s[1] == '!' && ((s = instr(s,"perl")) || (s = instr(s2,"PERL")))) {
3240 PerlIO_ungetc(PL_rsfp, '\n'); /* to keep line count right */
3241 PL_doextract = FALSE;
3242 while (*s && !(isSPACE (*s) || *s == '#')) s++;
3244 while (*s == ' ' || *s == '\t') s++;
3246 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
3247 if (strnEQ(s2-4,"perl",4))
3249 while ((s = moreswitches(s)))
3252 #ifdef MACOS_TRADITIONAL
3263 PL_uid = PerlProc_getuid();
3264 PL_euid = PerlProc_geteuid();
3265 PL_gid = PerlProc_getgid();
3266 PL_egid = PerlProc_getegid();
3268 PL_uid |= PL_gid << 16;
3269 PL_euid |= PL_egid << 16;
3271 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
3275 S_forbid_setid(pTHX_ char *s)
3277 if (PL_euid != PL_uid)
3278 Perl_croak(aTHX_ "No %s allowed while running setuid", s);
3279 if (PL_egid != PL_gid)
3280 Perl_croak(aTHX_ "No %s allowed while running setgid", s);
3284 Perl_init_debugger(pTHX)
3286 HV *ostash = PL_curstash;
3288 PL_curstash = PL_debstash;
3289 PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
3290 AvREAL_off(PL_dbargs);
3291 PL_DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
3292 PL_DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
3293 PL_DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
3294 sv_upgrade(GvSV(PL_DBsub), SVt_IV); /* IVX accessed if PERLDB_SUB_NN */
3295 PL_DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
3296 sv_setiv(PL_DBsingle, 0);
3297 PL_DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
3298 sv_setiv(PL_DBtrace, 0);
3299 PL_DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
3300 sv_setiv(PL_DBsignal, 0);
3301 PL_curstash = ostash;
3304 #ifndef STRESS_REALLOC
3305 #define REASONABLE(size) (size)
3307 #define REASONABLE(size) (1) /* unreasonable */
3311 Perl_init_stacks(pTHX)
3313 /* start with 128-item stack and 8K cxstack */
3314 PL_curstackinfo = new_stackinfo(REASONABLE(128),
3315 REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
3316 PL_curstackinfo->si_type = PERLSI_MAIN;
3317 PL_curstack = PL_curstackinfo->si_stack;
3318 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
3320 PL_stack_base = AvARRAY(PL_curstack);
3321 PL_stack_sp = PL_stack_base;
3322 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
3324 New(50,PL_tmps_stack,REASONABLE(128),SV*);
3327 PL_tmps_max = REASONABLE(128);
3329 New(54,PL_markstack,REASONABLE(32),I32);
3330 PL_markstack_ptr = PL_markstack;
3331 PL_markstack_max = PL_markstack + REASONABLE(32);
3335 New(54,PL_scopestack,REASONABLE(32),I32);
3336 PL_scopestack_ix = 0;
3337 PL_scopestack_max = REASONABLE(32);
3339 New(54,PL_savestack,REASONABLE(128),ANY);
3340 PL_savestack_ix = 0;
3341 PL_savestack_max = REASONABLE(128);
3343 New(54,PL_retstack,REASONABLE(16),OP*);
3345 PL_retstack_max = REASONABLE(16);
3353 while (PL_curstackinfo->si_next)
3354 PL_curstackinfo = PL_curstackinfo->si_next;
3355 while (PL_curstackinfo) {
3356 PERL_SI *p = PL_curstackinfo->si_prev;
3357 /* curstackinfo->si_stack got nuked by sv_free_arenas() */
3358 Safefree(PL_curstackinfo->si_cxstack);
3359 Safefree(PL_curstackinfo);
3360 PL_curstackinfo = p;
3362 Safefree(PL_tmps_stack);
3363 Safefree(PL_markstack);
3364 Safefree(PL_scopestack);
3365 Safefree(PL_savestack);
3366 Safefree(PL_retstack);
3375 lex_start(PL_linestr);
3377 PL_subname = newSVpvn("main",4);
3381 S_init_predump_symbols(pTHX)
3386 sv_setpvn(get_sv("\"", TRUE), " ", 1);
3387 PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
3388 GvMULTI_on(PL_stdingv);
3389 io = GvIOp(PL_stdingv);
3390 IoTYPE(io) = IoTYPE_RDONLY;
3391 IoIFP(io) = PerlIO_stdin();
3392 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
3394 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
3396 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
3399 IoTYPE(io) = IoTYPE_WRONLY;
3400 IoOFP(io) = IoIFP(io) = PerlIO_stdout();
3402 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
3404 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
3406 PL_stderrgv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
3407 GvMULTI_on(PL_stderrgv);
3408 io = GvIOp(PL_stderrgv);
3409 IoTYPE(io) = IoTYPE_WRONLY;
3410 IoOFP(io) = IoIFP(io) = PerlIO_stderr();
3411 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
3413 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
3415 PL_statname = NEWSV(66,0); /* last filename we did stat on */
3418 Safefree(PL_osname);
3419 PL_osname = savepv(OSNAME);
3423 Perl_init_argv_symbols(pTHX_ register int argc, register char **argv)
3426 argc--,argv++; /* skip name of script */
3427 if (PL_doswitches) {
3428 for (; argc > 0 && **argv == '-'; argc--,argv++) {
3431 if (argv[0][1] == '-' && !argv[0][2]) {
3435 if ((s = strchr(argv[0], '='))) {
3437 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
3440 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
3443 if ((PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV))) {
3444 GvMULTI_on(PL_argvgv);
3445 (void)gv_AVadd(PL_argvgv);
3446 av_clear(GvAVn(PL_argvgv));
3447 for (; argc > 0; argc--,argv++) {
3448 SV *sv = newSVpv(argv[0],0);
3449 av_push(GvAVn(PL_argvgv),sv);
3450 if (PL_widesyscalls)
3451 (void)sv_utf8_decode(sv);
3456 #ifdef HAS_PROCSELFEXE
3457 /* This is a function so that we don't hold on to MAXPATHLEN
3458 bytes of stack longer than necessary
3461 S_procself_val(pTHX_ SV *sv, char *arg0)
3463 char buf[MAXPATHLEN];
3464 int len = readlink(PROCSELFEXE_PATH, buf, sizeof(buf) - 1);
3465 /* FreeBSD's implementation is acknowledged to be imperfect, sometimes
3466 returning the text "unknown" from the readlink rather than the path
3467 to the executable (or returning an error from the readlink). Any valid
3468 path has a '/' in it somewhere, so use that to validate the result.
3469 See http://www.freebsd.org/cgi/query-pr.cgi?pr=35703
3471 if (len > 0 && memchr(buf, '/', len)) {
3472 sv_setpvn(sv,buf,len);
3478 #endif /* HAS_PROCSELFEXE */
3481 S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
3487 PL_toptarget = NEWSV(0,0);
3488 sv_upgrade(PL_toptarget, SVt_PVFM);
3489 sv_setpvn(PL_toptarget, "", 0);
3490 PL_bodytarget = NEWSV(0,0);
3491 sv_upgrade(PL_bodytarget, SVt_PVFM);
3492 sv_setpvn(PL_bodytarget, "", 0);
3493 PL_formtarget = PL_bodytarget;
3497 init_argv_symbols(argc,argv);
3499 if ((tmpgv = gv_fetchpv("0",TRUE, SVt_PV))) {
3500 #ifdef MACOS_TRADITIONAL
3501 /* $0 is not majick on a Mac */
3502 sv_setpv(GvSV(tmpgv),MacPerl_MPWFileName(PL_origfilename));
3504 sv_setpv(GvSV(tmpgv),PL_origfilename);
3505 magicname("0", "0", 1);
3508 if ((tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))) {/* $^X */
3509 #ifdef HAS_PROCSELFEXE
3510 S_procself_val(aTHX_ GvSV(tmpgv), PL_origargv[0]);
3513 sv_setpv(GvSV(tmpgv), os2_execname(aTHX));
3515 sv_setpv(GvSV(tmpgv),PL_origargv[0]);
3519 if ((PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV))) {
3521 GvMULTI_on(PL_envgv);
3522 hv = GvHVn(PL_envgv);
3523 hv_magic(hv, Nullgv, PERL_MAGIC_env);
3524 #ifdef USE_ENVIRON_ARRAY
3525 /* Note that if the supplied env parameter is actually a copy
3526 of the global environ then it may now point to free'd memory
3527 if the environment has been modified since. To avoid this
3528 problem we treat env==NULL as meaning 'use the default'
3533 environ[0] = Nullch;
3535 for (; *env; env++) {
3536 if (!(s = strchr(*env,'=')))
3543 sv = newSVpv(s+1, 0);
3544 (void)hv_store(hv, *env, s - *env, sv, 0);
3548 #endif /* USE_ENVIRON_ARRAY */
3551 if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV))) {
3552 SvREADONLY_off(GvSV(tmpgv));
3553 sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
3554 SvREADONLY_on(GvSV(tmpgv));
3559 S_init_perllib(pTHX)
3564 s = PerlEnv_getenv("PERL5LIB");
3566 incpush(s, TRUE, TRUE);
3568 incpush(PerlEnv_getenv("PERLLIB"), FALSE, FALSE);
3570 /* Treat PERL5?LIB as a possible search list logical name -- the
3571 * "natural" VMS idiom for a Unix path string. We allow each
3572 * element to be a set of |-separated directories for compatibility.
3576 if (my_trnlnm("PERL5LIB",buf,0))
3577 do { incpush(buf,TRUE,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
3579 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE,FALSE);
3583 /* Use the ~-expanded versions of APPLLIB (undocumented),
3584 ARCHLIB PRIVLIB SITEARCH SITELIB VENDORARCH and VENDORLIB
3587 incpush(APPLLIB_EXP, TRUE, TRUE);
3591 incpush(ARCHLIB_EXP, FALSE, FALSE);
3593 #ifdef MACOS_TRADITIONAL
3595 struct stat tmpstatbuf;
3596 SV * privdir = NEWSV(55, 0);
3597 char * macperl = PerlEnv_getenv("MACPERL");
3602 Perl_sv_setpvf(aTHX_ privdir, "%slib:", macperl);
3603 if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
3604 incpush(SvPVX(privdir), TRUE, FALSE);
3605 Perl_sv_setpvf(aTHX_ privdir, "%ssite_perl:", macperl);
3606 if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
3607 incpush(SvPVX(privdir), TRUE, FALSE);
3609 SvREFCNT_dec(privdir);
3612 incpush(":", FALSE, FALSE);
3615 # define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
3618 incpush(PRIVLIB_EXP, TRUE, FALSE);
3620 incpush(PRIVLIB_EXP, FALSE, FALSE);
3624 /* sitearch is always relative to sitelib on Windows for
3625 * DLL-based path intuition to work correctly */
3626 # if !defined(WIN32)
3627 incpush(SITEARCH_EXP, FALSE, FALSE);
3633 incpush(SITELIB_EXP, TRUE, FALSE); /* this picks up sitearch as well */
3635 incpush(SITELIB_EXP, FALSE, FALSE);
3639 #ifdef SITELIB_STEM /* Search for version-specific dirs below here */
3640 incpush(SITELIB_STEM, FALSE, TRUE);
3643 #ifdef PERL_VENDORARCH_EXP
3644 /* vendorarch is always relative to vendorlib on Windows for
3645 * DLL-based path intuition to work correctly */
3646 # if !defined(WIN32)
3647 incpush(PERL_VENDORARCH_EXP, FALSE, FALSE);
3651 #ifdef PERL_VENDORLIB_EXP
3653 incpush(PERL_VENDORLIB_EXP, TRUE, FALSE); /* this picks up vendorarch as well */
3655 incpush(PERL_VENDORLIB_EXP, FALSE, FALSE);
3659 #ifdef PERL_VENDORLIB_STEM /* Search for version-specific dirs below here */
3660 incpush(PERL_VENDORLIB_STEM, FALSE, TRUE);
3663 #ifdef PERL_OTHERLIBDIRS
3664 incpush(PERL_OTHERLIBDIRS, TRUE, TRUE);
3668 incpush(".", FALSE, FALSE);
3669 #endif /* MACOS_TRADITIONAL */
3672 #if defined(DOSISH) || defined(EPOC)
3673 # define PERLLIB_SEP ';'
3676 # define PERLLIB_SEP '|'
3678 # if defined(MACOS_TRADITIONAL)
3679 # define PERLLIB_SEP ','
3681 # define PERLLIB_SEP ':'
3685 #ifndef PERLLIB_MANGLE
3686 # define PERLLIB_MANGLE(s,n) (s)
3690 S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers)
3692 SV *subdir = Nullsv;
3697 if (addsubdirs || addoldvers) {
3698 subdir = sv_newmortal();
3701 /* Break at all separators */
3703 SV *libdir = NEWSV(55,0);
3706 /* skip any consecutive separators */
3707 while ( *p == PERLLIB_SEP ) {
3708 /* Uncomment the next line for PATH semantics */
3709 /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */
3713 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
3714 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
3719 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
3720 p = Nullch; /* break out */
3722 #ifdef MACOS_TRADITIONAL
3723 if (!strchr(SvPVX(libdir), ':'))
3724 sv_insert(libdir, 0, 0, ":", 1);
3725 if (SvPVX(libdir)[SvCUR(libdir)-1] != ':')
3726 sv_catpv(libdir, ":");
3730 * BEFORE pushing libdir onto @INC we may first push version- and
3731 * archname-specific sub-directories.
3733 if (addsubdirs || addoldvers) {
3734 #ifdef PERL_INC_VERSION_LIST
3735 /* Configure terminates PERL_INC_VERSION_LIST with a NULL */
3736 const char *incverlist[] = { PERL_INC_VERSION_LIST };
3737 const char **incver;
3739 struct stat tmpstatbuf;
3744 if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) {
3746 while (unix[len-1] == '/') len--; /* Cosmetic */
3747 sv_usepvn(libdir,unix,len);
3750 PerlIO_printf(Perl_error_log,
3751 "Failed to unixify @INC element \"%s\"\n",
3755 #ifdef MACOS_TRADITIONAL
3756 #define PERL_AV_SUFFIX_FMT ""
3757 #define PERL_ARCH_FMT "%s:"
3758 #define PERL_ARCH_FMT_PATH PERL_FS_VER_FMT PERL_AV_SUFFIX_FMT
3760 #define PERL_AV_SUFFIX_FMT "/"
3761 #define PERL_ARCH_FMT "/%s"
3762 #define PERL_ARCH_FMT_PATH PERL_AV_SUFFIX_FMT PERL_FS_VER_FMT
3764 /* .../version/archname if -d .../version/archname */
3765 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH PERL_ARCH_FMT,
3767 (int)PERL_REVISION, (int)PERL_VERSION,
3768 (int)PERL_SUBVERSION, ARCHNAME);
3769 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3770 S_ISDIR(tmpstatbuf.st_mode))
3771 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3773 /* .../version if -d .../version */
3774 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH, libdir,
3775 (int)PERL_REVISION, (int)PERL_VERSION,
3776 (int)PERL_SUBVERSION);
3777 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3778 S_ISDIR(tmpstatbuf.st_mode))
3779 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3781 /* .../archname if -d .../archname */
3782 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, ARCHNAME);
3783 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3784 S_ISDIR(tmpstatbuf.st_mode))
3785 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3788 #ifdef PERL_INC_VERSION_LIST
3790 for (incver = incverlist; *incver; incver++) {
3791 /* .../xxx if -d .../xxx */
3792 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, *incver);
3793 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3794 S_ISDIR(tmpstatbuf.st_mode))
3795 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3801 /* finally push this lib directory on the end of @INC */
3802 av_push(GvAVn(PL_incgv), libdir);
3806 #ifdef USE_5005THREADS
3807 STATIC struct perl_thread *
3808 S_init_main_thread(pTHX)
3810 #if !defined(PERL_IMPLICIT_CONTEXT)
3811 struct perl_thread *thr;
3815 Newz(53, thr, 1, struct perl_thread);
3816 PL_curcop = &PL_compiling;
3817 thr->interp = PERL_GET_INTERP;
3818 thr->cvcache = newHV();
3819 thr->threadsv = newAV();
3820 /* thr->threadsvp is set when find_threadsv is called */
3821 thr->specific = newAV();
3822 thr->flags = THRf_R_JOINABLE;
3823 MUTEX_INIT(&thr->mutex);
3824 /* Handcraft thrsv similarly to mess_sv */
3825 New(53, PL_thrsv, 1, SV);
3826 Newz(53, xpv, 1, XPV);
3827 SvFLAGS(PL_thrsv) = SVt_PV;
3828 SvANY(PL_thrsv) = (void*)xpv;
3829 SvREFCNT(PL_thrsv) = 1 << 30; /* practically infinite */
3830 SvPVX(PL_thrsv) = (char*)thr;
3831 SvCUR_set(PL_thrsv, sizeof(thr));
3832 SvLEN_set(PL_thrsv, sizeof(thr));
3833 *SvEND(PL_thrsv) = '\0'; /* in the trailing_nul field */
3834 thr->oursv = PL_thrsv;
3835 PL_chopset = " \n-";
3838 MUTEX_LOCK(&PL_threads_mutex);
3844 MUTEX_UNLOCK(&PL_threads_mutex);
3846 #ifdef HAVE_THREAD_INTERN
3847 Perl_init_thread_intern(thr);
3850 #ifdef SET_THREAD_SELF
3851 SET_THREAD_SELF(thr);
3853 thr->self = pthread_self();
3854 #endif /* SET_THREAD_SELF */
3858 * These must come after the thread self setting
3859 * because sv_setpvn does SvTAINT and the taint
3860 * fields thread selfness being set.
3862 PL_toptarget = NEWSV(0,0);
3863 sv_upgrade(PL_toptarget, SVt_PVFM);
3864 sv_setpvn(PL_toptarget, "", 0);
3865 PL_bodytarget = NEWSV(0,0);
3866 sv_upgrade(PL_bodytarget, SVt_PVFM);
3867 sv_setpvn(PL_bodytarget, "", 0);
3868 PL_formtarget = PL_bodytarget;
3869 thr->errsv = newSVpvn("", 0);
3870 (void) find_threadsv("@"); /* Ensure $@ is initialised early */
3873 PL_peepp = MEMBER_TO_FPTR(Perl_peep);
3874 PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
3875 PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
3876 PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
3877 PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
3878 PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
3880 PL_reginterp_cnt = 0;
3884 #endif /* USE_5005THREADS */
3887 Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
3890 line_t oldline = CopLINE(PL_curcop);
3896 while (AvFILL(paramList) >= 0) {
3897 cv = (CV*)av_shift(paramList);
3898 if (PL_savebegin && (paramList == PL_beginav)) {
3899 /* save PL_beginav for compiler */
3900 if (! PL_beginav_save)
3901 PL_beginav_save = newAV();
3902 av_push(PL_beginav_save, (SV*)cv);
3906 #ifdef PERL_FLEXIBLE_EXCEPTIONS
3907 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_list_body), cv);
3913 #ifndef PERL_FLEXIBLE_EXCEPTIONS
3917 (void)SvPV(atsv, len);
3920 PL_curcop = &PL_compiling;
3921 CopLINE_set(PL_curcop, oldline);
3922 if (paramList == PL_beginav)
3923 sv_catpv(atsv, "BEGIN failed--compilation aborted");
3925 Perl_sv_catpvf(aTHX_ atsv,
3926 "%s failed--call queue aborted",
3927 paramList == PL_checkav ? "CHECK"
3928 : paramList == PL_initav ? "INIT"
3930 while (PL_scopestack_ix > oldscope)
3933 Perl_croak(aTHX_ "%s", SvPVx(atsv, n_a));
3940 /* my_exit() was called */
3941 while (PL_scopestack_ix > oldscope)
3944 PL_curstash = PL_defstash;
3945 PL_curcop = &PL_compiling;
3946 CopLINE_set(PL_curcop, oldline);
3948 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) {
3949 if (paramList == PL_beginav)
3950 Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
3952 Perl_croak(aTHX_ "%s failed--call queue aborted",
3953 paramList == PL_checkav ? "CHECK"
3954 : paramList == PL_initav ? "INIT"
3961 PL_curcop = &PL_compiling;
3962 CopLINE_set(PL_curcop, oldline);
3965 PerlIO_printf(Perl_error_log, "panic: restartop\n");
3973 #ifdef PERL_FLEXIBLE_EXCEPTIONS
3975 S_vcall_list_body(pTHX_ va_list args)
3977 CV *cv = va_arg(args, CV*);
3978 return call_list_body(cv);
3983 S_call_list_body(pTHX_ CV *cv)
3985 PUSHMARK(PL_stack_sp);
3986 call_sv((SV*)cv, G_EVAL|G_DISCARD);
3991 Perl_my_exit(pTHX_ U32 status)
3993 DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
3994 thr, (unsigned long) status));
4003 STATUS_NATIVE_SET(status);
4010 Perl_my_failure_exit(pTHX)
4013 if (vaxc$errno & 1) {
4014 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
4015 STATUS_NATIVE_SET(44);
4018 if (!vaxc$errno && errno) /* unlikely */
4019 STATUS_NATIVE_SET(44);
4021 STATUS_NATIVE_SET(vaxc$errno);
4026 STATUS_POSIX_SET(errno);
4028 exitstatus = STATUS_POSIX >> 8;
4029 if (exitstatus & 255)
4030 STATUS_POSIX_SET(exitstatus);
4032 STATUS_POSIX_SET(255);
4039 S_my_exit_jump(pTHX)
4041 register PERL_CONTEXT *cx;
4046 SvREFCNT_dec(PL_e_script);
4047 PL_e_script = Nullsv;
4050 POPSTACK_TO(PL_mainstack);
4051 if (cxstack_ix >= 0) {
4054 POPBLOCK(cx,PL_curpm);
4062 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen)
4065 p = SvPVX(PL_e_script);
4066 nl = strchr(p, '\n');
4067 nl = (nl) ? nl+1 : SvEND(PL_e_script);
4069 filter_del(read_e_script);
4072 sv_catpvn(buf_sv, p, nl-p);
4073 sv_chop(PL_e_script, nl);