3 * Copyright (c) 1987-2000 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)
25 char *getenv (char *); /* Usually in <stdlib.h> */
28 static I32 read_e_script(pTHXo_ int idx, SV *buf_sv, int maxlen);
36 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
43 #define perl_construct Perl_construct
44 #define perl_parse Perl_parse
45 #define perl_run Perl_run
46 #define perl_destruct Perl_destruct
47 #define perl_free Perl_free
50 #if defined(USE_THREADS)
51 # define INIT_TLS_AND_INTERP \
53 if (!PL_curinterp) { \
54 PERL_SET_INTERP(my_perl); \
60 # if defined(USE_ITHREADS)
61 # define INIT_TLS_AND_INTERP \
63 if (!PL_curinterp) { \
64 PERL_SET_INTERP(my_perl); \
67 PERL_SET_THX(my_perl); \
71 PERL_SET_THX(my_perl); \
75 # define INIT_TLS_AND_INTERP \
77 if (!PL_curinterp) { \
78 PERL_SET_INTERP(my_perl); \
80 PERL_SET_THX(my_perl); \
85 #ifdef PERL_IMPLICIT_SYS
87 perl_alloc_using(struct IPerlMem* ipM, struct IPerlMem* ipMS,
88 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
89 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
90 struct IPerlDir* ipD, struct IPerlSock* ipS,
91 struct IPerlProc* ipP)
93 PerlInterpreter *my_perl;
95 my_perl = (PerlInterpreter*)new(ipM) CPerlObj(ipM, ipMS, ipMP, ipE, ipStd,
96 ipLIO, ipD, ipS, ipP);
99 /* New() needs interpreter, so call malloc() instead */
100 my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
102 Zero(my_perl, 1, PerlInterpreter);
119 =for apidoc perl_alloc
121 Allocates a new Perl interpreter. See L<perlembed>.
129 PerlInterpreter *my_perl;
131 /* New() needs interpreter, so call malloc() instead */
132 my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
135 Zero(my_perl, 1, PerlInterpreter);
138 #endif /* PERL_IMPLICIT_SYS */
141 =for apidoc perl_construct
143 Initializes a new Perl interpreter. See L<perlembed>.
149 perl_construct(pTHXx)
154 struct perl_thread *thr = NULL;
155 #endif /* FAKE_THREADS */
156 #endif /* USE_THREADS */
160 PL_perl_destruct_level = 1;
162 if (PL_perl_destruct_level > 0)
166 /* Init the real globals (and main thread)? */
169 MUTEX_INIT(&PL_sv_mutex);
171 * Safe to use basic SV functions from now on (though
172 * not things like mortals or tainting yet).
174 MUTEX_INIT(&PL_eval_mutex);
175 COND_INIT(&PL_eval_cond);
176 MUTEX_INIT(&PL_threads_mutex);
177 COND_INIT(&PL_nthreads_cond);
178 # ifdef EMULATE_ATOMIC_REFCOUNTS
179 MUTEX_INIT(&PL_svref_mutex);
180 # endif /* EMULATE_ATOMIC_REFCOUNTS */
182 MUTEX_INIT(&PL_cred_mutex);
183 MUTEX_INIT(&PL_sv_lock_mutex);
184 MUTEX_INIT(&PL_fdpid_mutex);
186 thr = init_main_thread();
187 #endif /* USE_THREADS */
189 #ifdef PERL_FLEXIBLE_EXCEPTIONS
190 PL_protect = MEMBER_TO_FPTR(Perl_default_protect); /* for exceptions */
193 PL_curcop = &PL_compiling; /* needed by ckWARN, right away */
195 PL_linestr = NEWSV(65,79);
196 sv_upgrade(PL_linestr,SVt_PVIV);
198 if (!SvREADONLY(&PL_sv_undef)) {
199 /* set read-only and try to insure than we wont see REFCNT==0
202 SvREADONLY_on(&PL_sv_undef);
203 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
205 sv_setpv(&PL_sv_no,PL_No);
207 SvREADONLY_on(&PL_sv_no);
208 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
210 sv_setpv(&PL_sv_yes,PL_Yes);
212 SvREADONLY_on(&PL_sv_yes);
213 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
218 /* PL_sighandlerp = sighandler; */
220 PL_sighandlerp = Perl_sighandler;
222 PL_pidstatus = newHV();
226 * There is no way we can refer to them from Perl so close them to save
227 * space. The other alternative would be to provide STDAUX and STDPRN
230 (void)fclose(stdaux);
231 (void)fclose(stdprn);
235 PL_nrs = newSVpvn("\n", 1);
236 PL_rs = SvREFCNT_inc(PL_nrs);
241 PL_lex_state = LEX_NOTPARSING;
247 SET_NUMERIC_STANDARD();
251 PL_patchlevel = NEWSV(0,4);
252 (void)SvUPGRADE(PL_patchlevel, SVt_PVNV);
253 if (PERL_REVISION > 127 || PERL_VERSION > 127 || PERL_SUBVERSION > 127)
254 SvGROW(PL_patchlevel, UTF8_MAXLEN*3+1);
255 s = (U8*)SvPVX(PL_patchlevel);
256 s = uv_to_utf8(s, (UV)PERL_REVISION);
257 s = uv_to_utf8(s, (UV)PERL_VERSION);
258 s = uv_to_utf8(s, (UV)PERL_SUBVERSION);
260 SvCUR_set(PL_patchlevel, s - (U8*)SvPVX(PL_patchlevel));
261 SvPOK_on(PL_patchlevel);
262 SvNVX(PL_patchlevel) = (NV)PERL_REVISION
263 + ((NV)PERL_VERSION / (NV)1000)
264 #if defined(PERL_SUBVERSION) && PERL_SUBVERSION > 0
265 + ((NV)PERL_SUBVERSION / (NV)1000000)
268 SvNOK_on(PL_patchlevel); /* dual valued */
269 SvUTF8_on(PL_patchlevel);
270 SvREADONLY_on(PL_patchlevel);
273 #if defined(LOCAL_PATCH_COUNT)
274 PL_localpatches = local_patches; /* For possible -v */
277 #ifdef HAVE_INTERP_INTERN
281 PerlIO_init(); /* Hook to IO system */
283 PL_fdpid = newAV(); /* for remembering popen pids by fd */
284 PL_modglobal = newHV(); /* pointers to per-interpreter module globals */
285 PL_errors = newSVpvn("",0);
291 =for apidoc perl_destruct
293 Shuts down a Perl interpreter. See L<perlembed>.
302 int destruct_level; /* 0=none, 1=full, 2=full with checks */
308 #endif /* USE_THREADS */
310 /* wait for all pseudo-forked children to finish */
311 PERL_WAIT_FOR_CHILDREN;
315 /* Pass 1 on any remaining threads: detach joinables, join zombies */
317 MUTEX_LOCK(&PL_threads_mutex);
318 DEBUG_S(PerlIO_printf(Perl_debug_log,
319 "perl_destruct: waiting for %d threads...\n",
321 for (t = thr->next; t != thr; t = t->next) {
322 MUTEX_LOCK(&t->mutex);
323 switch (ThrSTATE(t)) {
326 DEBUG_S(PerlIO_printf(Perl_debug_log,
327 "perl_destruct: joining zombie %p\n", t));
328 ThrSETSTATE(t, THRf_DEAD);
329 MUTEX_UNLOCK(&t->mutex);
332 * The SvREFCNT_dec below may take a long time (e.g. av
333 * may contain an object scalar whose destructor gets
334 * called) so we have to unlock threads_mutex and start
337 MUTEX_UNLOCK(&PL_threads_mutex);
339 SvREFCNT_dec((SV*)av);
340 DEBUG_S(PerlIO_printf(Perl_debug_log,
341 "perl_destruct: joined zombie %p OK\n", t));
343 case THRf_R_JOINABLE:
344 DEBUG_S(PerlIO_printf(Perl_debug_log,
345 "perl_destruct: detaching thread %p\n", t));
346 ThrSETSTATE(t, THRf_R_DETACHED);
348 * We unlock threads_mutex and t->mutex in the opposite order
349 * from which we locked them just so that DETACH won't
350 * deadlock if it panics. It's only a breach of good style
351 * not a bug since they are unlocks not locks.
353 MUTEX_UNLOCK(&PL_threads_mutex);
355 MUTEX_UNLOCK(&t->mutex);
358 DEBUG_S(PerlIO_printf(Perl_debug_log,
359 "perl_destruct: ignoring %p (state %u)\n",
361 MUTEX_UNLOCK(&t->mutex);
362 /* fall through and out */
365 /* We leave the above "Pass 1" loop with threads_mutex still locked */
367 /* Pass 2 on remaining threads: wait for the thread count to drop to one */
368 while (PL_nthreads > 1)
370 DEBUG_S(PerlIO_printf(Perl_debug_log,
371 "perl_destruct: final wait for %d threads\n",
373 COND_WAIT(&PL_nthreads_cond, &PL_threads_mutex);
375 /* At this point, we're the last thread */
376 MUTEX_UNLOCK(&PL_threads_mutex);
377 DEBUG_S(PerlIO_printf(Perl_debug_log, "perl_destruct: armageddon has arrived\n"));
378 MUTEX_DESTROY(&PL_threads_mutex);
379 COND_DESTROY(&PL_nthreads_cond);
380 #endif /* !defined(FAKE_THREADS) */
381 #endif /* USE_THREADS */
383 destruct_level = PL_perl_destruct_level;
387 if ((s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL"))) {
389 if (destruct_level < i)
398 /* We must account for everything. */
400 /* Destroy the main CV and syntax tree */
402 PL_curpad = AvARRAY(PL_comppad);
403 op_free(PL_main_root);
404 PL_main_root = Nullop;
406 PL_curcop = &PL_compiling;
407 PL_main_start = Nullop;
408 SvREFCNT_dec(PL_main_cv);
412 if (PL_sv_objcount) {
414 * Try to destruct global references. We do this first so that the
415 * destructors and destructees still exist. Some sv's might remain.
416 * Non-referenced objects are on their own.
421 /* unhook hooks which will soon be, or use, destroyed data */
422 SvREFCNT_dec(PL_warnhook);
423 PL_warnhook = Nullsv;
424 SvREFCNT_dec(PL_diehook);
427 /* call exit list functions */
428 while (PL_exitlistlen-- > 0)
429 PL_exitlist[PL_exitlistlen].fn(aTHXo_ PL_exitlist[PL_exitlistlen].ptr);
431 Safefree(PL_exitlist);
433 if (destruct_level == 0){
435 DEBUG_P(debprofdump());
437 /* The exit() function will do everything that needs doing. */
441 /* loosen bonds of global variables */
444 (void)PerlIO_close(PL_rsfp);
448 /* Filters for program text */
449 SvREFCNT_dec(PL_rsfp_filters);
450 PL_rsfp_filters = Nullav;
453 PL_preprocess = FALSE;
459 PL_doswitches = FALSE;
460 PL_dowarn = G_WARN_OFF;
461 PL_doextract = FALSE;
462 PL_sawampersand = FALSE; /* must save all match strings */
465 Safefree(PL_inplace);
467 SvREFCNT_dec(PL_patchlevel);
470 SvREFCNT_dec(PL_e_script);
471 PL_e_script = Nullsv;
474 /* magical thingies */
476 Safefree(PL_ofs); /* $, */
479 Safefree(PL_ors); /* $\ */
482 SvREFCNT_dec(PL_rs); /* $/ */
485 SvREFCNT_dec(PL_nrs); /* $/ helper */
488 PL_multiline = 0; /* $* */
489 Safefree(PL_osname); /* $^O */
492 SvREFCNT_dec(PL_statname);
493 PL_statname = Nullsv;
496 /* defgv, aka *_ should be taken care of elsewhere */
498 /* clean up after study() */
499 SvREFCNT_dec(PL_lastscream);
500 PL_lastscream = Nullsv;
501 Safefree(PL_screamfirst);
503 Safefree(PL_screamnext);
507 Safefree(PL_efloatbuf);
508 PL_efloatbuf = Nullch;
511 /* startup and shutdown function lists */
512 SvREFCNT_dec(PL_beginav);
513 SvREFCNT_dec(PL_endav);
514 SvREFCNT_dec(PL_checkav);
515 SvREFCNT_dec(PL_initav);
521 /* shortcuts just get cleared */
527 PL_argvoutgv = Nullgv;
529 PL_stderrgv = Nullgv;
530 PL_last_in_gv = Nullgv;
532 PL_debstash = Nullhv;
534 /* reset so print() ends up where we expect */
537 SvREFCNT_dec(PL_argvout_stack);
538 PL_argvout_stack = Nullav;
540 SvREFCNT_dec(PL_modglobal);
541 PL_modglobal = Nullhv;
542 SvREFCNT_dec(PL_preambleav);
543 PL_preambleav = Nullav;
544 SvREFCNT_dec(PL_subname);
546 SvREFCNT_dec(PL_linestr);
548 SvREFCNT_dec(PL_pidstatus);
549 PL_pidstatus = Nullhv;
550 SvREFCNT_dec(PL_toptarget);
551 PL_toptarget = Nullsv;
552 SvREFCNT_dec(PL_bodytarget);
553 PL_bodytarget = Nullsv;
554 PL_formtarget = Nullsv;
556 /* free locale stuff */
557 #ifdef USE_LOCALE_COLLATE
558 Safefree(PL_collation_name);
559 PL_collation_name = Nullch;
562 #ifdef USE_LOCALE_NUMERIC
563 Safefree(PL_numeric_name);
564 PL_numeric_name = Nullch;
567 /* clear utf8 character classes */
568 SvREFCNT_dec(PL_utf8_alnum);
569 SvREFCNT_dec(PL_utf8_alnumc);
570 SvREFCNT_dec(PL_utf8_ascii);
571 SvREFCNT_dec(PL_utf8_alpha);
572 SvREFCNT_dec(PL_utf8_space);
573 SvREFCNT_dec(PL_utf8_cntrl);
574 SvREFCNT_dec(PL_utf8_graph);
575 SvREFCNT_dec(PL_utf8_digit);
576 SvREFCNT_dec(PL_utf8_upper);
577 SvREFCNT_dec(PL_utf8_lower);
578 SvREFCNT_dec(PL_utf8_print);
579 SvREFCNT_dec(PL_utf8_punct);
580 SvREFCNT_dec(PL_utf8_xdigit);
581 SvREFCNT_dec(PL_utf8_mark);
582 SvREFCNT_dec(PL_utf8_toupper);
583 SvREFCNT_dec(PL_utf8_tolower);
584 PL_utf8_alnum = Nullsv;
585 PL_utf8_alnumc = Nullsv;
586 PL_utf8_ascii = Nullsv;
587 PL_utf8_alpha = Nullsv;
588 PL_utf8_space = Nullsv;
589 PL_utf8_cntrl = Nullsv;
590 PL_utf8_graph = Nullsv;
591 PL_utf8_digit = Nullsv;
592 PL_utf8_upper = Nullsv;
593 PL_utf8_lower = Nullsv;
594 PL_utf8_print = Nullsv;
595 PL_utf8_punct = Nullsv;
596 PL_utf8_xdigit = Nullsv;
597 PL_utf8_mark = Nullsv;
598 PL_utf8_toupper = Nullsv;
599 PL_utf8_totitle = Nullsv;
600 PL_utf8_tolower = Nullsv;
602 if (!specialWARN(PL_compiling.cop_warnings))
603 SvREFCNT_dec(PL_compiling.cop_warnings);
604 PL_compiling.cop_warnings = Nullsv;
606 Safefree(CopFILE(&PL_compiling));
607 CopFILE(&PL_compiling) = Nullch;
608 Safefree(CopSTASHPV(&PL_compiling));
610 SvREFCNT_dec(CopFILEGV(&PL_compiling));
611 CopFILEGV(&PL_compiling) = Nullgv;
612 /* cop_stash is not refcounted */
615 /* Prepare to destruct main symbol table. */
620 SvREFCNT_dec(PL_curstname);
621 PL_curstname = Nullsv;
623 /* clear queued errors */
624 SvREFCNT_dec(PL_errors);
628 if (destruct_level >= 2 && ckWARN_d(WARN_INTERNAL)) {
629 if (PL_scopestack_ix != 0)
630 Perl_warner(aTHX_ WARN_INTERNAL,
631 "Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
632 (long)PL_scopestack_ix);
633 if (PL_savestack_ix != 0)
634 Perl_warner(aTHX_ WARN_INTERNAL,
635 "Unbalanced saves: %ld more saves than restores\n",
636 (long)PL_savestack_ix);
637 if (PL_tmps_floor != -1)
638 Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced tmps: %ld more allocs than frees\n",
639 (long)PL_tmps_floor + 1);
640 if (cxstack_ix != -1)
641 Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced context: %ld more PUSHes than POPs\n",
642 (long)cxstack_ix + 1);
645 /* Now absolutely destruct everything, somehow or other, loops or no. */
647 SvFLAGS(PL_fdpid) |= SVTYPEMASK; /* don't clean out pid table now */
648 SvFLAGS(PL_strtab) |= SVTYPEMASK; /* don't clean out strtab now */
649 while (PL_sv_count != 0 && PL_sv_count != last_sv_count) {
650 last_sv_count = PL_sv_count;
653 SvFLAGS(PL_fdpid) &= ~SVTYPEMASK;
654 SvFLAGS(PL_fdpid) |= SVt_PVAV;
655 SvFLAGS(PL_strtab) &= ~SVTYPEMASK;
656 SvFLAGS(PL_strtab) |= SVt_PVHV;
658 AvREAL_off(PL_fdpid); /* no surviving entries */
659 SvREFCNT_dec(PL_fdpid); /* needed in io_close() */
662 /* Destruct the global string table. */
664 /* Yell and reset the HeVAL() slots that are still holding refcounts,
665 * so that sv_free() won't fail on them.
673 max = HvMAX(PL_strtab);
674 array = HvARRAY(PL_strtab);
677 if (hent && ckWARN_d(WARN_INTERNAL)) {
678 Perl_warner(aTHX_ WARN_INTERNAL,
679 "Unbalanced string table refcount: (%d) for \"%s\"",
680 HeVAL(hent) - Nullsv, HeKEY(hent));
681 HeVAL(hent) = Nullsv;
691 SvREFCNT_dec(PL_strtab);
693 /* free special SVs */
695 SvREFCNT(&PL_sv_yes) = 0;
696 sv_clear(&PL_sv_yes);
697 SvANY(&PL_sv_yes) = NULL;
698 SvFLAGS(&PL_sv_yes) = 0;
700 SvREFCNT(&PL_sv_no) = 0;
702 SvANY(&PL_sv_no) = NULL;
703 SvFLAGS(&PL_sv_no) = 0;
705 SvREFCNT(&PL_sv_undef) = 0;
706 SvREADONLY_off(&PL_sv_undef);
708 if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL))
709 Perl_warner(aTHX_ WARN_INTERNAL,"Scalars leaked: %ld\n", (long)PL_sv_count);
713 /* No SVs have survived, need to clean out */
714 Safefree(PL_origfilename);
715 Safefree(PL_reg_start_tmp);
717 Safefree(PL_reg_curpm);
718 Safefree(PL_reg_poscache);
719 Safefree(HeKEY_hek(&PL_hv_fetch_ent_mh));
720 Safefree(PL_op_mask);
722 PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */
724 DEBUG_P(debprofdump());
726 MUTEX_DESTROY(&PL_strtab_mutex);
727 MUTEX_DESTROY(&PL_sv_mutex);
728 MUTEX_DESTROY(&PL_eval_mutex);
729 MUTEX_DESTROY(&PL_cred_mutex);
730 MUTEX_DESTROY(&PL_fdpid_mutex);
731 COND_DESTROY(&PL_eval_cond);
732 #ifdef EMULATE_ATOMIC_REFCOUNTS
733 MUTEX_DESTROY(&PL_svref_mutex);
734 #endif /* EMULATE_ATOMIC_REFCOUNTS */
736 /* As the penultimate thing, free the non-arena SV for thrsv */
737 Safefree(SvPVX(PL_thrsv));
738 Safefree(SvANY(PL_thrsv));
741 #endif /* USE_THREADS */
743 /* As the absolutely last thing, free the non-arena SV for mess() */
746 /* it could have accumulated taint magic */
747 if (SvTYPE(PL_mess_sv) >= SVt_PVMG) {
750 for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) {
751 moremagic = mg->mg_moremagic;
752 if (mg->mg_ptr && mg->mg_type != 'g' && mg->mg_len >= 0)
753 Safefree(mg->mg_ptr);
757 /* we know that type >= SVt_PV */
758 (void)SvOOK_off(PL_mess_sv);
759 Safefree(SvPVX(PL_mess_sv));
760 Safefree(SvANY(PL_mess_sv));
761 Safefree(PL_mess_sv);
767 =for apidoc perl_free
769 Releases a Perl interpreter. See L<perlembed>.
777 #if defined(PERL_OBJECT)
780 # if defined(PERL_IMPLICIT_SYS) && defined(WIN32)
781 void *host = w32_internal_host;
783 win32_delete_internal_host(host);
791 Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
793 Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry);
794 PL_exitlist[PL_exitlistlen].fn = fn;
795 PL_exitlist[PL_exitlistlen].ptr = ptr;
800 =for apidoc perl_parse
802 Tells a Perl interpreter to parse a Perl script. See L<perlembed>.
808 perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
818 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
821 Perl_croak(aTHX_ "suidperl is no longer needed since the kernel can now execute\n\
822 setuid perl scripts securely.\n");
826 #if defined(__DYNAMIC__) && (defined(NeXT) || defined(__NeXT__))
827 _dyld_lookup_and_bind
828 ("__environ", (unsigned long *) &environ_pointer, NULL);
833 #ifndef VMS /* VMS doesn't have environ array */
834 PL_origenviron = environ;
839 /* Come here if running an undumped a.out. */
841 PL_origfilename = savepv(argv[0]);
842 PL_do_undump = FALSE;
843 cxstack_ix = -1; /* start label stack again */
845 init_postdump_symbols(argc,argv,env);
850 PL_curpad = AvARRAY(PL_comppad);
851 op_free(PL_main_root);
852 PL_main_root = Nullop;
854 PL_main_start = Nullop;
855 SvREFCNT_dec(PL_main_cv);
859 oldscope = PL_scopestack_ix;
860 PL_dowarn = G_WARN_OFF;
862 #ifdef PERL_FLEXIBLE_EXCEPTIONS
863 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vparse_body), env, xsinit);
869 #ifndef PERL_FLEXIBLE_EXCEPTIONS
870 parse_body(env,xsinit);
873 call_list(oldscope, PL_checkav);
880 /* my_exit() was called */
881 while (PL_scopestack_ix > oldscope)
884 PL_curstash = PL_defstash;
886 call_list(oldscope, PL_checkav);
887 ret = STATUS_NATIVE_EXPORT;
890 PerlIO_printf(Perl_error_log, "panic: top_env\n");
898 #ifdef PERL_FLEXIBLE_EXCEPTIONS
900 S_vparse_body(pTHX_ va_list args)
902 char **env = va_arg(args, char**);
903 XSINIT_t xsinit = va_arg(args, XSINIT_t);
905 return parse_body(env, xsinit);
910 S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
913 int argc = PL_origargc;
914 char **argv = PL_origargv;
915 char *scriptname = NULL;
917 VOL bool dosearch = FALSE;
922 char *cddir = Nullch;
924 sv_setpvn(PL_linestr,"",0);
925 sv = newSVpvn("",0); /* first used for -I flags */
929 for (argc--,argv++; argc > 0; argc--,argv++) {
930 if (argv[0][0] != '-' || !argv[0][1])
934 validarg = " PHOOEY ";
943 win32_argv2utf8(argc-1, argv+1);
946 #ifndef PERL_STRICT_CR
970 if ((s = moreswitches(s)))
980 #ifdef MACOS_TRADITIONAL
981 /* ignore -e for Dev:Pseudo argument */
982 if (argv[1] && !strcmp(argv[1], "Dev:Pseudo"))
985 if (PL_euid != PL_uid || PL_egid != PL_gid)
986 Perl_croak(aTHX_ "No -e allowed in setuid scripts");
988 PL_e_script = newSVpvn("",0);
989 filter_add(read_e_script, NULL);
992 sv_catpv(PL_e_script, s);
994 sv_catpv(PL_e_script, argv[1]);
998 Perl_croak(aTHX_ "No code specified for -e");
999 sv_catpv(PL_e_script, "\n");
1002 case 'I': /* -I handled both here and in moreswitches() */
1004 if (!*++s && (s=argv[1]) != Nullch) {
1009 STRLEN len = strlen(s);
1010 p = savepvn(s, len);
1011 incpush(p, TRUE, TRUE);
1012 sv_catpvn(sv, "-I", 2);
1013 sv_catpvn(sv, p, len);
1014 sv_catpvn(sv, " ", 1);
1018 Perl_croak(aTHX_ "No directory specified for -I");
1022 PL_preprocess = TRUE;
1032 PL_preambleav = newAV();
1033 av_push(PL_preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
1035 PL_Sv = newSVpv("print myconfig();",0);
1037 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
1039 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
1041 sv_catpv(PL_Sv,"\" Compile-time options:");
1043 sv_catpv(PL_Sv," DEBUGGING");
1045 # ifdef MULTIPLICITY
1046 sv_catpv(PL_Sv," MULTIPLICITY");
1049 sv_catpv(PL_Sv," USE_THREADS");
1051 # ifdef USE_ITHREADS
1052 sv_catpv(PL_Sv," USE_ITHREADS");
1054 # ifdef USE_64_BIT_INT
1055 sv_catpv(PL_Sv," USE_64_BIT_INT");
1057 # ifdef USE_64_BIT_ALL
1058 sv_catpv(PL_Sv," USE_64_BIT_ALL");
1060 # ifdef USE_LONG_DOUBLE
1061 sv_catpv(PL_Sv," USE_LONG_DOUBLE");
1063 # ifdef USE_LARGE_FILES
1064 sv_catpv(PL_Sv," USE_LARGE_FILES");
1067 sv_catpv(PL_Sv," USE_SOCKS");
1070 sv_catpv(PL_Sv," PERL_OBJECT");
1072 # ifdef PERL_IMPLICIT_CONTEXT
1073 sv_catpv(PL_Sv," PERL_IMPLICIT_CONTEXT");
1075 # ifdef PERL_IMPLICIT_SYS
1076 sv_catpv(PL_Sv," PERL_IMPLICIT_SYS");
1078 sv_catpv(PL_Sv,"\\n\",");
1080 #if defined(LOCAL_PATCH_COUNT)
1081 if (LOCAL_PATCH_COUNT > 0) {
1083 sv_catpv(PL_Sv,"\" Locally applied patches:\\n\",");
1084 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
1085 if (PL_localpatches[i])
1086 Perl_sv_catpvf(aTHX_ PL_Sv,"q\" \t%s\n\",",PL_localpatches[i]);
1090 Perl_sv_catpvf(aTHX_ PL_Sv,"\" Built under %s\\n\"",OSNAME);
1093 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
1095 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled on %s\\n\"",__DATE__);
1098 sv_catpv(PL_Sv, "; \
1100 @env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; \
1101 print \" \\%ENV:\\n @env\\n\" if @env; \
1102 print \" \\@INC:\\n @INC\\n\";");
1105 PL_Sv = newSVpv("config_vars(qw(",0);
1106 sv_catpv(PL_Sv, ++s);
1107 sv_catpv(PL_Sv, "))");
1110 av_push(PL_preambleav, PL_Sv);
1111 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
1114 PL_doextract = TRUE;
1122 if (!*++s || isSPACE(*s)) {
1126 /* catch use of gnu style long options */
1127 if (strEQ(s, "version")) {
1131 if (strEQ(s, "help")) {
1138 Perl_croak(aTHX_ "Unrecognized switch: -%s (-h will show valid options)",s);
1144 #ifndef SECURE_INTERNAL_GETENV
1147 (s = PerlEnv_getenv("PERL5OPT")))
1151 if (*s == '-' && *(s+1) == 'T')
1164 if (!strchr("DIMUdmw", *s))
1165 Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
1166 s = moreswitches(s);
1172 scriptname = argv[0];
1175 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
1177 else if (scriptname == Nullch) {
1179 if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
1187 open_script(scriptname,dosearch,sv,&fdscript);
1189 validate_suid(validarg, scriptname,fdscript);
1192 #if defined(SIGCHLD) || defined(SIGCLD)
1195 # define SIGCHLD SIGCLD
1197 Sighandler_t sigstate = rsignal_state(SIGCHLD);
1198 if (sigstate == SIG_IGN) {
1199 if (ckWARN(WARN_SIGNAL))
1200 Perl_warner(aTHX_ WARN_SIGNAL,
1201 "Can't ignore signal CHLD, forcing to default");
1202 (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL);
1208 #ifdef MACOS_TRADITIONAL
1209 if (PL_doextract || gMacPerl_AlwaysExtract) {
1214 if (cddir && PerlDir_chdir(cddir) < 0)
1215 Perl_croak(aTHX_ "Can't chdir to %s",cddir);
1219 PL_main_cv = PL_compcv = (CV*)NEWSV(1104,0);
1220 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
1221 CvUNIQUE_on(PL_compcv);
1223 PL_comppad = newAV();
1224 av_push(PL_comppad, Nullsv);
1225 PL_curpad = AvARRAY(PL_comppad);
1226 PL_comppad_name = newAV();
1227 PL_comppad_name_fill = 0;
1228 PL_min_intro_pending = 0;
1231 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
1232 PL_curpad[0] = (SV*)newAV();
1233 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
1234 CvOWNER(PL_compcv) = 0;
1235 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
1236 MUTEX_INIT(CvMUTEXP(PL_compcv));
1237 #endif /* USE_THREADS */
1239 comppadlist = newAV();
1240 AvREAL_off(comppadlist);
1241 av_store(comppadlist, 0, (SV*)PL_comppad_name);
1242 av_store(comppadlist, 1, (SV*)PL_comppad);
1243 CvPADLIST(PL_compcv) = comppadlist;
1245 boot_core_UNIVERSAL();
1247 boot_core_xsutils();
1251 (*xsinit)(aTHXo); /* in case linked C routines want magical variables */
1253 #if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__)
1262 init_predump_symbols();
1263 /* init_postdump_symbols not currently designed to be called */
1264 /* more than once (ENV isn't cleared first, for example) */
1265 /* But running with -u leaves %ENV & @ARGV undefined! XXX */
1267 init_postdump_symbols(argc,argv,env);
1271 /* now parse the script */
1273 SETERRNO(0,SS$_NORMAL);
1275 #ifdef MACOS_TRADITIONAL
1276 if (gMacPerl_SyntaxError = (yyparse() || PL_error_count)) {
1278 Perl_croak(aTHX_ "%s had compilation errors.\n", MacPerl_MPWFileName(PL_origfilename));
1280 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
1281 MacPerl_MPWFileName(PL_origfilename));
1285 if (yyparse() || PL_error_count) {
1287 Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
1289 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
1294 CopLINE_set(PL_curcop, 0);
1295 PL_curstash = PL_defstash;
1296 PL_preprocess = FALSE;
1298 SvREFCNT_dec(PL_e_script);
1299 PL_e_script = Nullsv;
1302 /* now that script is parsed, we can modify record separator */
1303 SvREFCNT_dec(PL_rs);
1304 PL_rs = SvREFCNT_inc(PL_nrs);
1305 sv_setsv(get_sv("/", TRUE), PL_rs);
1310 SAVECOPFILE(PL_curcop);
1311 SAVECOPLINE(PL_curcop);
1312 gv_check(PL_defstash);
1319 if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
1320 dump_mstats("after compilation:");
1329 =for apidoc perl_run
1331 Tells a Perl interpreter to run. See L<perlembed>.
1347 oldscope = PL_scopestack_ix;
1349 #ifdef PERL_FLEXIBLE_EXCEPTIONS
1351 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vrun_body), oldscope);
1357 cxstack_ix = -1; /* start context stack again */
1359 case 0: /* normal completion */
1360 #ifndef PERL_FLEXIBLE_EXCEPTIONS
1365 case 2: /* my_exit() */
1366 while (PL_scopestack_ix > oldscope)
1369 PL_curstash = PL_defstash;
1370 if (PL_endav && !PL_minus_c)
1371 call_list(oldscope, PL_endav);
1373 if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
1374 dump_mstats("after execution: ");
1376 ret = STATUS_NATIVE_EXPORT;
1380 POPSTACK_TO(PL_mainstack);
1383 PerlIO_printf(Perl_error_log, "panic: restartop\n");
1393 #ifdef PERL_FLEXIBLE_EXCEPTIONS
1395 S_vrun_body(pTHX_ va_list args)
1397 I32 oldscope = va_arg(args, I32);
1399 return run_body(oldscope);
1405 S_run_body(pTHX_ I32 oldscope)
1409 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
1410 PL_sawampersand ? "Enabling" : "Omitting"));
1412 if (!PL_restartop) {
1413 DEBUG_x(dump_all());
1414 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
1415 DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%"UVxf"\n",
1419 #ifdef MACOS_TRADITIONAL
1420 PerlIO_printf(Perl_error_log, "%s syntax OK\n", MacPerl_MPWFileName(PL_origfilename));
1422 PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
1426 if (PERLDB_SINGLE && PL_DBsingle)
1427 sv_setiv(PL_DBsingle, 1);
1429 call_list(oldscope, PL_initav);
1435 PL_op = PL_restartop;
1439 else if (PL_main_start) {
1440 CvDEPTH(PL_main_cv) = 1;
1441 PL_op = PL_main_start;
1451 =for apidoc p||get_sv
1453 Returns the SV of the specified Perl scalar. If C<create> is set and the
1454 Perl variable does not exist then it will be created. If C<create> is not
1455 set and the variable does not exist then NULL is returned.
1461 Perl_get_sv(pTHX_ const char *name, I32 create)
1465 if (name[1] == '\0' && !isALPHA(name[0])) {
1466 PADOFFSET tmp = find_threadsv(name);
1467 if (tmp != NOT_IN_PAD) {
1469 return THREADSV(tmp);
1472 #endif /* USE_THREADS */
1473 gv = gv_fetchpv(name, create, SVt_PV);
1480 =for apidoc p||get_av
1482 Returns the AV of the specified Perl array. If C<create> is set and the
1483 Perl variable does not exist then it will be created. If C<create> is not
1484 set and the variable does not exist then NULL is returned.
1490 Perl_get_av(pTHX_ const char *name, I32 create)
1492 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1501 =for apidoc p||get_hv
1503 Returns the HV of the specified Perl hash. If C<create> is set and the
1504 Perl variable does not exist then it will be created. If C<create> is not
1505 set and the variable does not exist then NULL is returned.
1511 Perl_get_hv(pTHX_ const char *name, I32 create)
1513 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1522 =for apidoc p||get_cv
1524 Returns the CV of the specified Perl subroutine. If C<create> is set and
1525 the Perl subroutine does not exist then it will be declared (which has the
1526 same effect as saying C<sub name;>). If C<create> is not set and the
1527 subroutine does not exist then NULL is returned.
1533 Perl_get_cv(pTHX_ const char *name, I32 create)
1535 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
1536 /* XXX unsafe for threads if eval_owner isn't held */
1537 /* XXX this is probably not what they think they're getting.
1538 * It has the same effect as "sub name;", i.e. just a forward
1540 if (create && !GvCVu(gv))
1541 return newSUB(start_subparse(FALSE, 0),
1542 newSVOP(OP_CONST, 0, newSVpv(name,0)),
1550 /* Be sure to refetch the stack pointer after calling these routines. */
1553 =for apidoc p||call_argv
1555 Performs a callback to the specified Perl sub. See L<perlcall>.
1561 Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv)
1563 /* See G_* flags in cop.h */
1564 /* null terminated arg list */
1571 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
1576 return call_pv(sub_name, flags);
1580 =for apidoc p||call_pv
1582 Performs a callback to the specified Perl sub. See L<perlcall>.
1588 Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
1589 /* name of the subroutine */
1590 /* See G_* flags in cop.h */
1592 return call_sv((SV*)get_cv(sub_name, TRUE), flags);
1596 =for apidoc p||call_method
1598 Performs a callback to the specified Perl method. The blessed object must
1599 be on the stack. See L<perlcall>.
1605 Perl_call_method(pTHX_ const char *methname, I32 flags)
1606 /* name of the subroutine */
1607 /* See G_* flags in cop.h */
1609 return call_sv(sv_2mortal(newSVpv(methname,0)), flags | G_METHOD);
1612 /* May be called with any of a CV, a GV, or an SV containing the name. */
1614 =for apidoc p||call_sv
1616 Performs a callback to the Perl sub whose name is in the SV. See
1623 Perl_call_sv(pTHX_ SV *sv, I32 flags)
1624 /* See G_* flags in cop.h */
1627 LOGOP myop; /* fake syntax tree node */
1632 bool oldcatch = CATCH_GET;
1637 if (flags & G_DISCARD) {
1642 Zero(&myop, 1, LOGOP);
1643 myop.op_next = Nullop;
1644 if (!(flags & G_NOARGS))
1645 myop.op_flags |= OPf_STACKED;
1646 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1647 (flags & G_ARRAY) ? OPf_WANT_LIST :
1652 EXTEND(PL_stack_sp, 1);
1653 *++PL_stack_sp = sv;
1655 oldscope = PL_scopestack_ix;
1657 if (PERLDB_SUB && PL_curstash != PL_debstash
1658 /* Handle first BEGIN of -d. */
1659 && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
1660 /* Try harder, since this may have been a sighandler, thus
1661 * curstash may be meaningless. */
1662 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != PL_debstash)
1663 && !(flags & G_NODEBUG))
1664 PL_op->op_private |= OPpENTERSUB_DB;
1666 if (flags & G_METHOD) {
1667 Zero(&method_op, 1, UNOP);
1668 method_op.op_next = PL_op;
1669 method_op.op_ppaddr = PL_ppaddr[OP_METHOD];
1670 myop.op_ppaddr = PL_ppaddr[OP_ENTERSUB];
1671 PL_op = (OP*)&method_op;
1674 if (!(flags & G_EVAL)) {
1676 call_body((OP*)&myop, FALSE);
1677 retval = PL_stack_sp - (PL_stack_base + oldmark);
1678 CATCH_SET(oldcatch);
1681 myop.op_other = (OP*)&myop;
1683 /* we're trying to emulate pp_entertry() here */
1685 register PERL_CONTEXT *cx;
1686 I32 gimme = GIMME_V;
1691 push_return(Nullop);
1692 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
1694 PL_eval_root = PL_op; /* Only needed so that goto works right. */
1696 PL_in_eval = EVAL_INEVAL;
1697 if (flags & G_KEEPERR)
1698 PL_in_eval |= EVAL_KEEPERR;
1704 #ifdef PERL_FLEXIBLE_EXCEPTIONS
1706 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_body),
1713 #ifndef PERL_FLEXIBLE_EXCEPTIONS
1715 call_body((OP*)&myop, FALSE);
1717 retval = PL_stack_sp - (PL_stack_base + oldmark);
1718 if (!(flags & G_KEEPERR))
1725 /* my_exit() was called */
1726 PL_curstash = PL_defstash;
1729 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
1730 Perl_croak(aTHX_ "Callback called exit");
1735 PL_op = PL_restartop;
1739 PL_stack_sp = PL_stack_base + oldmark;
1740 if (flags & G_ARRAY)
1744 *++PL_stack_sp = &PL_sv_undef;
1749 if (PL_scopestack_ix > oldscope) {
1753 register PERL_CONTEXT *cx;
1765 if (flags & G_DISCARD) {
1766 PL_stack_sp = PL_stack_base + oldmark;
1775 #ifdef PERL_FLEXIBLE_EXCEPTIONS
1777 S_vcall_body(pTHX_ va_list args)
1779 OP *myop = va_arg(args, OP*);
1780 int is_eval = va_arg(args, int);
1782 call_body(myop, is_eval);
1788 S_call_body(pTHX_ OP *myop, int is_eval)
1792 if (PL_op == myop) {
1794 PL_op = Perl_pp_entereval(aTHX); /* this doesn't do a POPMARK */
1796 PL_op = Perl_pp_entersub(aTHX); /* this does */
1802 /* Eval a string. The G_EVAL flag is always assumed. */
1805 =for apidoc p||eval_sv
1807 Tells Perl to C<eval> the string in the SV.
1813 Perl_eval_sv(pTHX_ SV *sv, I32 flags)
1815 /* See G_* flags in cop.h */
1818 UNOP myop; /* fake syntax tree node */
1819 I32 oldmark = SP - PL_stack_base;
1826 if (flags & G_DISCARD) {
1833 Zero(PL_op, 1, UNOP);
1834 EXTEND(PL_stack_sp, 1);
1835 *++PL_stack_sp = sv;
1836 oldscope = PL_scopestack_ix;
1838 if (!(flags & G_NOARGS))
1839 myop.op_flags = OPf_STACKED;
1840 myop.op_next = Nullop;
1841 myop.op_type = OP_ENTEREVAL;
1842 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1843 (flags & G_ARRAY) ? OPf_WANT_LIST :
1845 if (flags & G_KEEPERR)
1846 myop.op_flags |= OPf_SPECIAL;
1848 #ifdef PERL_FLEXIBLE_EXCEPTIONS
1850 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_body),
1857 #ifndef PERL_FLEXIBLE_EXCEPTIONS
1859 call_body((OP*)&myop,TRUE);
1861 retval = PL_stack_sp - (PL_stack_base + oldmark);
1862 if (!(flags & G_KEEPERR))
1869 /* my_exit() was called */
1870 PL_curstash = PL_defstash;
1873 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
1874 Perl_croak(aTHX_ "Callback called exit");
1879 PL_op = PL_restartop;
1883 PL_stack_sp = PL_stack_base + oldmark;
1884 if (flags & G_ARRAY)
1888 *++PL_stack_sp = &PL_sv_undef;
1894 if (flags & G_DISCARD) {
1895 PL_stack_sp = PL_stack_base + oldmark;
1905 =for apidoc p||eval_pv
1907 Tells Perl to C<eval> the given string and return an SV* result.
1913 Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
1916 SV* sv = newSVpv(p, 0);
1918 eval_sv(sv, G_SCALAR);
1925 if (croak_on_error && SvTRUE(ERRSV)) {
1927 Perl_croak(aTHX_ SvPVx(ERRSV, n_a));
1933 /* Require a module. */
1936 =for apidoc p||require_pv
1938 Tells Perl to C<require> a module.
1944 Perl_require_pv(pTHX_ const char *pv)
1948 PUSHSTACKi(PERLSI_REQUIRE);
1950 sv = sv_newmortal();
1951 sv_setpv(sv, "require '");
1954 eval_sv(sv, G_DISCARD);
1960 Perl_magicname(pTHX_ char *sym, char *name, I32 namlen)
1964 if ((gv = gv_fetchpv(sym,TRUE, SVt_PV)))
1965 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1969 S_usage(pTHX_ char *name) /* XXX move this out into a module ? */
1971 /* This message really ought to be max 23 lines.
1972 * Removed -h because the user already knows that opton. Others? */
1974 static char *usage_msg[] = {
1975 "-0[octal] specify record separator (\\0, if no argument)",
1976 "-a autosplit mode with -n or -p (splits $_ into @F)",
1977 "-C enable native wide character system interfaces",
1978 "-c check syntax only (runs BEGIN and CHECK blocks)",
1979 "-d[:debugger] run program under debugger",
1980 "-D[number/list] set debugging flags (argument is a bit mask or alphabets)",
1981 "-e 'command' one line of program (several -e's allowed, omit programfile)",
1982 "-F/pattern/ split() pattern for -a switch (//'s are optional)",
1983 "-i[extension] edit <> files in place (makes backup if extension supplied)",
1984 "-Idirectory specify @INC/#include directory (several -I's allowed)",
1985 "-l[octal] enable line ending processing, specifies line terminator",
1986 "-[mM][-]module execute `use/no module...' before executing program",
1987 "-n assume 'while (<>) { ... }' loop around program",
1988 "-p assume loop like -n but print line also, like sed",
1989 "-P run program through C preprocessor before compilation",
1990 "-s enable rudimentary parsing for switches after programfile",
1991 "-S look for programfile using PATH environment variable",
1992 "-T enable tainting checks",
1993 "-u dump core after parsing program",
1994 "-U allow unsafe operations",
1995 "-v print version, subversion (includes VERY IMPORTANT perl info)",
1996 "-V[:variable] print configuration summary (or a single Config.pm variable)",
1997 "-w enable many useful warnings (RECOMMENDED)",
1998 "-W enable all warnings",
1999 "-X disable all warnings",
2000 "-x[directory] strip off text before #!perl line and perhaps cd to directory",
2004 char **p = usage_msg;
2006 PerlIO_printf(PerlIO_stdout(),
2007 "\nUsage: %s [switches] [--] [programfile] [arguments]",
2010 PerlIO_printf(PerlIO_stdout(), "\n %s", *p++);
2013 /* This routine handles any switches that can be given during run */
2016 Perl_moreswitches(pTHX_ char *s)
2025 numlen = 0; /* disallow underscores */
2026 rschar = (U32)scan_oct(s, 4, &numlen);
2027 SvREFCNT_dec(PL_nrs);
2028 if (rschar & ~((U8)~0))
2029 PL_nrs = &PL_sv_undef;
2030 else if (!rschar && numlen >= 2)
2031 PL_nrs = newSVpvn("", 0);
2034 PL_nrs = newSVpvn(&ch, 1);
2039 PL_widesyscalls = TRUE;
2044 PL_splitstr = savepv(s + 1);
2058 if (*s == ':' || *s == '=') {
2059 my_setenv("PERL5DB", Perl_form(aTHX_ "use Devel::%s;", ++s));
2063 PL_perldb = PERLDB_ALL;
2071 if (isALPHA(s[1])) {
2072 static char debopts[] = "psltocPmfrxuLHXDS";
2075 for (s++; *s && (d = strchr(debopts,*s)); s++)
2076 PL_debug |= 1 << (d - debopts);
2079 PL_debug = atoi(s+1);
2080 for (s++; isDIGIT(*s); s++) ;
2082 PL_debug |= 0x80000000;
2085 if (ckWARN_d(WARN_DEBUGGING))
2086 Perl_warner(aTHX_ WARN_DEBUGGING,
2087 "Recompile perl with -DDEBUGGING to use -D switch\n");
2088 for (s++; isALNUM(*s); s++) ;
2094 usage(PL_origargv[0]);
2098 Safefree(PL_inplace);
2099 PL_inplace = savepv(s+1);
2101 for (s = PL_inplace; *s && !isSPACE(*s); s++) ;
2104 if (*s == '-') /* Additional switches on #! line. */
2108 case 'I': /* -I handled both here and in parse_perl() */
2111 while (*s && isSPACE(*s))
2116 /* ignore trailing spaces (possibly followed by other switches) */
2118 for (e = p; *e && !isSPACE(*e); e++) ;
2122 } while (*p && *p != '-');
2123 e = savepvn(s, e-s);
2124 incpush(e, TRUE, TRUE);
2131 Perl_croak(aTHX_ "No directory specified for -I");
2139 PL_ors = savepv("\n");
2141 numlen = 0; /* disallow underscores */
2142 *PL_ors = (char)scan_oct(s, 3 + (*s == '0'), &numlen);
2147 if (RsPARA(PL_nrs)) {
2152 PL_ors = SvPV(PL_nrs, PL_orslen);
2153 PL_ors = savepvn(PL_ors, PL_orslen);
2157 forbid_setid("-M"); /* XXX ? */
2160 forbid_setid("-m"); /* XXX ? */
2165 /* -M-foo == 'no foo' */
2166 if (*s == '-') { use = "no "; ++s; }
2167 sv = newSVpv(use,0);
2169 /* We allow -M'Module qw(Foo Bar)' */
2170 while(isALNUM(*s) || *s==':') ++s;
2172 sv_catpv(sv, start);
2173 if (*(start-1) == 'm') {
2175 Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
2176 sv_catpv( sv, " ()");
2180 Perl_croak(aTHX_ "Module name required with -%c option",
2182 sv_catpvn(sv, start, s-start);
2183 sv_catpv(sv, " split(/,/,q{");
2189 PL_preambleav = newAV();
2190 av_push(PL_preambleav, sv);
2193 Perl_croak(aTHX_ "No space allowed after -%c", *(s-1));
2205 PL_doswitches = TRUE;
2210 Perl_croak(aTHX_ "Too late for \"-T\" option");
2214 #ifdef MACOS_TRADITIONAL
2215 Perl_croak(aTHX_ "Believe me, you don't want to use \"-u\" on a Macintosh");
2217 PL_do_undump = TRUE;
2225 PerlIO_printf(PerlIO_stdout(),
2226 Perl_form(aTHX_ "\nThis is perl, v%vd built for %s",
2227 PL_patchlevel, ARCHNAME));
2228 #if defined(LOCAL_PATCH_COUNT)
2229 if (LOCAL_PATCH_COUNT > 0)
2230 PerlIO_printf(PerlIO_stdout(),
2231 "\n(with %d registered patch%s, "
2232 "see perl -V for more detail)",
2233 (int)LOCAL_PATCH_COUNT,
2234 (LOCAL_PATCH_COUNT!=1) ? "es" : "");
2237 PerlIO_printf(PerlIO_stdout(),
2238 "\n\nCopyright 1987-2000, Larry Wall\n");
2240 PerlIO_printf(PerlIO_stdout(),
2241 "\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
2244 PerlIO_printf(PerlIO_stdout(),
2245 "djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n"
2246 "djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
2249 PerlIO_printf(PerlIO_stdout(),
2250 "\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
2251 "Version 5 port Copyright (c) 1994-1999, Andreas Kaiser, Ilya Zakharevich\n");
2254 PerlIO_printf(PerlIO_stdout(),
2255 "atariST series port, ++jrb bammi@cadence.com\n");
2258 PerlIO_printf(PerlIO_stdout(),
2259 "BeOS port Copyright Tom Spindler, 1997-1999\n");
2262 PerlIO_printf(PerlIO_stdout(),
2263 "MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-1999\n");
2266 PerlIO_printf(PerlIO_stdout(),
2267 "MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
2270 PerlIO_printf(PerlIO_stdout(),
2271 "Stratus VOS port by Paul_Green@stratus.com, 1997-1999\n");
2274 PerlIO_printf(PerlIO_stdout(),
2275 "VM/ESA port by Neale Ferguson, 1998-1999\n");
2278 PerlIO_printf(PerlIO_stdout(),
2279 "BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
2282 PerlIO_printf(PerlIO_stdout(),
2283 "MiNT port by Guido Flohr, 1997-1999\n");
2286 PerlIO_printf(PerlIO_stdout(),
2287 "EPOC port by Olaf Flebbe, 1999-2000\n");
2289 #ifdef BINARY_BUILD_NOTICE
2290 BINARY_BUILD_NOTICE;
2292 PerlIO_printf(PerlIO_stdout(),
2294 Perl may be copied only under the terms of either the Artistic License or the\n\
2295 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n\
2296 Complete documentation for Perl, including FAQ lists, should be found on\n\
2297 this system using `man perl' or `perldoc perl'. If you have access to the\n\
2298 Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
2301 if (! (PL_dowarn & G_WARN_ALL_MASK))
2302 PL_dowarn |= G_WARN_ON;
2306 PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
2307 PL_compiling.cop_warnings = pWARN_ALL ;
2311 PL_dowarn = G_WARN_ALL_OFF;
2312 PL_compiling.cop_warnings = pWARN_NONE ;
2317 if (s[1] == '-') /* Additional switches on #! line. */
2322 #if defined(WIN32) || !defined(PERL_STRICT_CR)
2328 #ifdef ALTERNATE_SHEBANG
2329 case 'S': /* OS/2 needs -S on "extproc" line. */
2337 Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
2342 /* compliments of Tom Christiansen */
2344 /* unexec() can be found in the Gnu emacs distribution */
2345 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
2348 Perl_my_unexec(pTHX)
2356 prog = newSVpv(BIN_EXP, 0);
2357 sv_catpv(prog, "/perl");
2358 file = newSVpv(PL_origfilename, 0);
2359 sv_catpv(file, ".perldump");
2361 unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
2362 /* unexec prints msg to stderr in case of failure */
2363 PerlProc_exit(status);
2366 # include <lib$routines.h>
2367 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
2369 ABORT(); /* for use with undump */
2374 /* initialize curinterp */
2379 #ifdef PERL_OBJECT /* XXX kludge */
2382 PL_chopset = " \n-"; \
2383 PL_copline = NOLINE; \
2384 PL_curcop = &PL_compiling;\
2385 PL_curcopdb = NULL; \
2387 PL_dumpindent = 4; \
2388 PL_laststatval = -1; \
2389 PL_laststype = OP_STAT; \
2390 PL_maxscream = -1; \
2391 PL_maxsysfd = MAXSYSFD; \
2392 PL_statname = Nullsv; \
2393 PL_tmps_floor = -1; \
2395 PL_op_mask = NULL; \
2396 PL_laststatval = -1; \
2397 PL_laststype = OP_STAT; \
2398 PL_mess_sv = Nullsv; \
2399 PL_splitstr = " "; \
2400 PL_generation = 100; \
2401 PL_exitlist = NULL; \
2402 PL_exitlistlen = 0; \
2404 PL_in_clean_objs = FALSE; \
2405 PL_in_clean_all = FALSE; \
2406 PL_profiledata = NULL; \
2408 PL_rsfp_filters = Nullav; \
2413 # ifdef MULTIPLICITY
2414 # define PERLVAR(var,type)
2415 # define PERLVARA(var,n,type)
2416 # if defined(PERL_IMPLICIT_CONTEXT)
2417 # if defined(USE_THREADS)
2418 # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
2419 # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
2420 # else /* !USE_THREADS */
2421 # define PERLVARI(var,type,init) aTHX->var = init;
2422 # define PERLVARIC(var,type,init) aTHX->var = init;
2423 # endif /* USE_THREADS */
2425 # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
2426 # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
2428 # include "intrpvar.h"
2429 # ifndef USE_THREADS
2430 # include "thrdvar.h"
2437 # define PERLVAR(var,type)
2438 # define PERLVARA(var,n,type)
2439 # define PERLVARI(var,type,init) PL_##var = init;
2440 # define PERLVARIC(var,type,init) PL_##var = init;
2441 # include "intrpvar.h"
2442 # ifndef USE_THREADS
2443 # include "thrdvar.h"
2455 S_init_main_stash(pTHX)
2460 /* Note that strtab is a rather special HV. Assumptions are made
2461 about not iterating on it, and not adding tie magic to it.
2462 It is properly deallocated in perl_destruct() */
2463 PL_strtab = newHV();
2465 MUTEX_INIT(&PL_strtab_mutex);
2467 HvSHAREKEYS_off(PL_strtab); /* mandatory */
2468 hv_ksplit(PL_strtab, 512);
2470 PL_curstash = PL_defstash = newHV();
2471 PL_curstname = newSVpvn("main",4);
2472 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
2473 SvREFCNT_dec(GvHV(gv));
2474 GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
2476 HvNAME(PL_defstash) = savepv("main");
2477 PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
2478 GvMULTI_on(PL_incgv);
2479 PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
2480 GvMULTI_on(PL_hintgv);
2481 PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
2482 PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
2483 GvMULTI_on(PL_errgv);
2484 PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
2485 GvMULTI_on(PL_replgv);
2486 (void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */
2487 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
2488 sv_setpvn(ERRSV, "", 0);
2489 PL_curstash = PL_defstash;
2490 CopSTASH_set(&PL_compiling, PL_defstash);
2491 PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
2492 PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
2493 PL_nullstash = GvHV(gv_fetchpv("<none>::", GV_ADDMULTI, SVt_PVHV));
2494 /* We must init $/ before switches are processed. */
2495 sv_setpvn(get_sv("/", TRUE), "\n", 1);
2499 S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
2506 PL_origfilename = savepv("-e");
2509 /* if find_script() returns, it returns a malloc()-ed value */
2510 PL_origfilename = scriptname = find_script(scriptname, dosearch, NULL, 1);
2512 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
2513 char *s = scriptname + 8;
2514 *fdscript = atoi(s);
2518 scriptname = savepv(s + 1);
2519 Safefree(PL_origfilename);
2520 PL_origfilename = scriptname;
2526 Safefree(CopFILE(PL_curcop));
2528 SvREFCNT_dec(CopFILEGV(PL_curcop));
2530 CopFILE_set(PL_curcop, PL_origfilename);
2531 if (strEQ(PL_origfilename,"-"))
2533 if (*fdscript >= 0) {
2534 PL_rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE);
2535 #if defined(HAS_FCNTL) && defined(F_SETFD)
2537 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); /* ensure close-on-exec */
2540 else if (PL_preprocess) {
2541 char *cpp_cfg = CPPSTDIN;
2542 SV *cpp = newSVpvn("",0);
2543 SV *cmd = NEWSV(0,0);
2545 if (strEQ(cpp_cfg, "cppstdin"))
2546 Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
2547 sv_catpv(cpp, cpp_cfg);
2549 sv_catpvn(sv, "-I", 2);
2550 sv_catpv(sv,PRIVLIB_EXP);
2552 #if defined(MSDOS) || defined(WIN32)
2553 Perl_sv_setpvf(aTHX_ cmd, "\
2554 sed %s -e \"/^[^#]/b\" \
2555 -e \"/^#[ ]*include[ ]/b\" \
2556 -e \"/^#[ ]*define[ ]/b\" \
2557 -e \"/^#[ ]*if[ ]/b\" \
2558 -e \"/^#[ ]*ifdef[ ]/b\" \
2559 -e \"/^#[ ]*ifndef[ ]/b\" \
2560 -e \"/^#[ ]*else/b\" \
2561 -e \"/^#[ ]*elif[ ]/b\" \
2562 -e \"/^#[ ]*undef[ ]/b\" \
2563 -e \"/^#[ ]*endif/b\" \
2565 %s | %"SVf" -C %"SVf" %s",
2566 (PL_doextract ? "-e \"1,/^#/d\n\"" : ""),
2569 Perl_sv_setpvf(aTHX_ cmd, "\
2570 %s %s -e '/^[^#]/b' \
2571 -e '/^#[ ]*include[ ]/b' \
2572 -e '/^#[ ]*define[ ]/b' \
2573 -e '/^#[ ]*if[ ]/b' \
2574 -e '/^#[ ]*ifdef[ ]/b' \
2575 -e '/^#[ ]*ifndef[ ]/b' \
2576 -e '/^#[ ]*else/b' \
2577 -e '/^#[ ]*elif[ ]/b' \
2578 -e '/^#[ ]*undef[ ]/b' \
2579 -e '/^#[ ]*endif/b' \
2581 %s | %"SVf" %"SVf" %s",
2583 Perl_sv_setpvf(aTHX_ cmd, "\
2584 %s %s -e '/^[^#]/b' \
2585 -e '/^#[ ]*include[ ]/b' \
2586 -e '/^#[ ]*define[ ]/b' \
2587 -e '/^#[ ]*if[ ]/b' \
2588 -e '/^#[ ]*ifdef[ ]/b' \
2589 -e '/^#[ ]*ifndef[ ]/b' \
2590 -e '/^#[ ]*else/b' \
2591 -e '/^#[ ]*elif[ ]/b' \
2592 -e '/^#[ ]*undef[ ]/b' \
2593 -e '/^#[ ]*endif/b' \
2595 %s | %"SVf" -C %"SVf" %s",
2602 (PL_doextract ? "-e '1,/^#/d\n'" : ""),
2604 scriptname, cpp, sv, CPPMINUS);
2605 PL_doextract = FALSE;
2606 #ifdef IAMSUID /* actually, this is caught earlier */
2607 if (PL_euid != PL_uid && !PL_euid) { /* if running suidperl */
2609 (void)seteuid(PL_uid); /* musn't stay setuid root */
2612 (void)setreuid((Uid_t)-1, PL_uid);
2614 #ifdef HAS_SETRESUID
2615 (void)setresuid((Uid_t)-1, PL_uid, (Uid_t)-1);
2617 PerlProc_setuid(PL_uid);
2621 if (PerlProc_geteuid() != PL_uid)
2622 Perl_croak(aTHX_ "Can't do seteuid!\n");
2624 #endif /* IAMSUID */
2625 PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
2629 else if (!*scriptname) {
2630 forbid_setid("program input from stdin");
2631 PL_rsfp = PerlIO_stdin();
2634 PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
2635 #if defined(HAS_FCNTL) && defined(F_SETFD)
2637 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); /* ensure close-on-exec */
2642 #ifndef IAMSUID /* in case script is not readable before setuid */
2644 PerlLIO_stat(CopFILE(PL_curcop),&PL_statbuf) >= 0 &&
2645 PL_statbuf.st_mode & (S_ISUID|S_ISGID))
2648 PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
2649 (int)PERL_REVISION, (int)PERL_VERSION,
2650 (int)PERL_SUBVERSION), PL_origargv);
2651 Perl_croak(aTHX_ "Can't do setuid\n");
2655 Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
2656 CopFILE(PL_curcop), Strerror(errno));
2661 * I_SYSSTATVFS HAS_FSTATVFS
2663 * I_STATFS HAS_FSTATFS HAS_GETFSSTAT
2664 * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT
2665 * here so that metaconfig picks them up. */
2669 S_fd_on_nosuid_fs(pTHX_ int fd)
2671 int check_okay = 0; /* able to do all the required sys/libcalls */
2672 int on_nosuid = 0; /* the fd is on a nosuid fs */
2674 * Preferred order: fstatvfs(), fstatfs(), ustat()+getmnt(), getmntent().
2675 * fstatvfs() is UNIX98.
2676 * fstatfs() is 4.3 BSD.
2677 * ustat()+getmnt() is pre-4.3 BSD.
2678 * getmntent() is O(number-of-mounted-filesystems) and can hang on
2679 * an irrelevant filesystem while trying to reach the right one.
2682 #undef FD_ON_NOSUID_CHECK_OKAY /* found the syscalls to do the check? */
2684 # if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
2685 defined(HAS_FSTATVFS)
2686 # define FD_ON_NOSUID_CHECK_OKAY
2687 struct statvfs stfs;
2689 check_okay = fstatvfs(fd, &stfs) == 0;
2690 on_nosuid = check_okay && (stfs.f_flag & ST_NOSUID);
2691 # endif /* fstatvfs */
2693 # if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
2694 defined(PERL_MOUNT_NOSUID) && \
2695 defined(HAS_FSTATFS) && \
2696 defined(HAS_STRUCT_STATFS) && \
2697 defined(HAS_STRUCT_STATFS_F_FLAGS)
2698 # define FD_ON_NOSUID_CHECK_OKAY
2701 check_okay = fstatfs(fd, &stfs) == 0;
2702 on_nosuid = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
2703 # endif /* fstatfs */
2705 # if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
2706 defined(PERL_MOUNT_NOSUID) && \
2707 defined(HAS_FSTAT) && \
2708 defined(HAS_USTAT) && \
2709 defined(HAS_GETMNT) && \
2710 defined(HAS_STRUCT_FS_DATA) && \
2712 # define FD_ON_NOSUID_CHECK_OKAY
2715 if (fstat(fd, &fdst) == 0) {
2717 if (ustat(fdst.st_dev, &us) == 0) {
2719 /* NOSTAT_ONE here because we're not examining fields which
2720 * vary between that case and STAT_ONE. */
2721 if (getmnt((int*)0, &fsd, (int)0, NOSTAT_ONE, us.f_fname) == 0) {
2722 size_t cmplen = sizeof(us.f_fname);
2723 if (sizeof(fsd.fd_req.path) < cmplen)
2724 cmplen = sizeof(fsd.fd_req.path);
2725 if (strnEQ(fsd.fd_req.path, us.f_fname, cmplen) &&
2726 fdst.st_dev == fsd.fd_req.dev) {
2728 on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID;
2734 # endif /* fstat+ustat+getmnt */
2736 # if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
2737 defined(HAS_GETMNTENT) && \
2738 defined(HAS_HASMNTOPT) && \
2739 defined(MNTOPT_NOSUID)
2740 # define FD_ON_NOSUID_CHECK_OKAY
2741 FILE *mtab = fopen("/etc/mtab", "r");
2742 struct mntent *entry;
2743 struct stat stb, fsb;
2745 if (mtab && (fstat(fd, &stb) == 0)) {
2746 while (entry = getmntent(mtab)) {
2747 if (stat(entry->mnt_dir, &fsb) == 0
2748 && fsb.st_dev == stb.st_dev)
2750 /* found the filesystem */
2752 if (hasmntopt(entry, MNTOPT_NOSUID))
2755 } /* A single fs may well fail its stat(). */
2760 # endif /* getmntent+hasmntopt */
2763 Perl_croak(aTHX_ "Can't check filesystem of script \"%s\" for nosuid", PL_origfilename);
2766 #endif /* IAMSUID */
2769 S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript)
2775 /* do we need to emulate setuid on scripts? */
2777 /* This code is for those BSD systems that have setuid #! scripts disabled
2778 * in the kernel because of a security problem. Merely defining DOSUID
2779 * in perl will not fix that problem, but if you have disabled setuid
2780 * scripts in the kernel, this will attempt to emulate setuid and setgid
2781 * on scripts that have those now-otherwise-useless bits set. The setuid
2782 * root version must be called suidperl or sperlN.NNN. If regular perl
2783 * discovers that it has opened a setuid script, it calls suidperl with
2784 * the same argv that it had. If suidperl finds that the script it has
2785 * just opened is NOT setuid root, it sets the effective uid back to the
2786 * uid. We don't just make perl setuid root because that loses the
2787 * effective uid we had before invoking perl, if it was different from the
2790 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
2791 * be defined in suidperl only. suidperl must be setuid root. The
2792 * Configure script will set this up for you if you want it.
2799 if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */
2800 Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
2801 if (fdscript < 0 && PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
2806 #ifndef HAS_SETREUID
2807 /* On this access check to make sure the directories are readable,
2808 * there is actually a small window that the user could use to make
2809 * filename point to an accessible directory. So there is a faint
2810 * chance that someone could execute a setuid script down in a
2811 * non-accessible directory. I don't know what to do about that.
2812 * But I don't think it's too important. The manual lies when
2813 * it says access() is useful in setuid programs.
2815 if (PerlLIO_access(CopFILE(PL_curcop),1)) /*double check*/
2816 Perl_croak(aTHX_ "Permission denied");
2818 /* If we can swap euid and uid, then we can determine access rights
2819 * with a simple stat of the file, and then compare device and
2820 * inode to make sure we did stat() on the same file we opened.
2821 * Then we just have to make sure he or she can execute it.
2824 struct stat tmpstatbuf;
2828 setreuid(PL_euid,PL_uid) < 0
2831 setresuid(PL_euid,PL_uid,(Uid_t)-1) < 0
2834 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
2835 Perl_croak(aTHX_ "Can't swap uid and euid"); /* really paranoid */
2836 if (PerlLIO_stat(CopFILE(PL_curcop),&tmpstatbuf) < 0)
2837 Perl_croak(aTHX_ "Permission denied"); /* testing full pathname here */
2838 #if defined(IAMSUID) && !defined(NO_NOSUID_CHECK)
2839 if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp)))
2840 Perl_croak(aTHX_ "Permission denied");
2842 if (tmpstatbuf.st_dev != PL_statbuf.st_dev ||
2843 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
2844 (void)PerlIO_close(PL_rsfp);
2845 if (PL_rsfp = PerlProc_popen("/bin/mail root","w")) { /* heh, heh */
2846 PerlIO_printf(PL_rsfp,
2847 "User %"Uid_t_f" tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2848 (Filename of set-id script was %s, uid %"Uid_t_f" gid %"Gid_t_f".)\n\nSincerely,\nperl\n",
2849 PL_uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
2850 (long)PL_statbuf.st_dev, (long)PL_statbuf.st_ino,
2852 PL_statbuf.st_uid, PL_statbuf.st_gid);
2853 (void)PerlProc_pclose(PL_rsfp);
2855 Perl_croak(aTHX_ "Permission denied\n");
2859 setreuid(PL_uid,PL_euid) < 0
2861 # if defined(HAS_SETRESUID)
2862 setresuid(PL_uid,PL_euid,(Uid_t)-1) < 0
2865 || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
2866 Perl_croak(aTHX_ "Can't reswap uid and euid");
2867 if (!cando(S_IXUSR,FALSE,&PL_statbuf)) /* can real uid exec? */
2868 Perl_croak(aTHX_ "Permission denied\n");
2870 #endif /* HAS_SETREUID */
2871 #endif /* IAMSUID */
2873 if (!S_ISREG(PL_statbuf.st_mode))
2874 Perl_croak(aTHX_ "Permission denied");
2875 if (PL_statbuf.st_mode & S_IWOTH)
2876 Perl_croak(aTHX_ "Setuid/gid script is writable by world");
2877 PL_doswitches = FALSE; /* -s is insecure in suid */
2878 CopLINE_inc(PL_curcop);
2879 if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
2880 strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */
2881 Perl_croak(aTHX_ "No #! line");
2882 s = SvPV(PL_linestr,n_a)+2;
2884 while (!isSPACE(*s)) s++;
2885 for (s2 = s; (s2 > SvPV(PL_linestr,n_a)+2 &&
2886 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
2887 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
2888 Perl_croak(aTHX_ "Not a perl script");
2889 while (*s == ' ' || *s == '\t') s++;
2891 * #! arg must be what we saw above. They can invoke it by
2892 * mentioning suidperl explicitly, but they may not add any strange
2893 * arguments beyond what #! says if they do invoke suidperl that way.
2895 len = strlen(validarg);
2896 if (strEQ(validarg," PHOOEY ") ||
2897 strnNE(s,validarg,len) || !isSPACE(s[len]))
2898 Perl_croak(aTHX_ "Args must match #! line");
2901 if (PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
2902 PL_euid == PL_statbuf.st_uid)
2904 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2905 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2906 #endif /* IAMSUID */
2908 if (PL_euid) { /* oops, we're not the setuid root perl */
2909 (void)PerlIO_close(PL_rsfp);
2912 PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
2913 (int)PERL_REVISION, (int)PERL_VERSION,
2914 (int)PERL_SUBVERSION), PL_origargv);
2916 Perl_croak(aTHX_ "Can't do setuid\n");
2919 if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
2921 (void)setegid(PL_statbuf.st_gid);
2924 (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
2926 #ifdef HAS_SETRESGID
2927 (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
2929 PerlProc_setgid(PL_statbuf.st_gid);
2933 if (PerlProc_getegid() != PL_statbuf.st_gid)
2934 Perl_croak(aTHX_ "Can't do setegid!\n");
2936 if (PL_statbuf.st_mode & S_ISUID) {
2937 if (PL_statbuf.st_uid != PL_euid)
2939 (void)seteuid(PL_statbuf.st_uid); /* all that for this */
2942 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
2944 #ifdef HAS_SETRESUID
2945 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
2947 PerlProc_setuid(PL_statbuf.st_uid);
2951 if (PerlProc_geteuid() != PL_statbuf.st_uid)
2952 Perl_croak(aTHX_ "Can't do seteuid!\n");
2954 else if (PL_uid) { /* oops, mustn't run as root */
2956 (void)seteuid((Uid_t)PL_uid);
2959 (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
2961 #ifdef HAS_SETRESUID
2962 (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
2964 PerlProc_setuid((Uid_t)PL_uid);
2968 if (PerlProc_geteuid() != PL_uid)
2969 Perl_croak(aTHX_ "Can't do seteuid!\n");
2972 if (!cando(S_IXUSR,TRUE,&PL_statbuf))
2973 Perl_croak(aTHX_ "Permission denied\n"); /* they can't do this */
2976 else if (PL_preprocess)
2977 Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
2978 else if (fdscript >= 0)
2979 Perl_croak(aTHX_ "fd script not allowed in suidperl\n");
2981 Perl_croak(aTHX_ "Script is not setuid/setgid in suidperl\n");
2983 /* We absolutely must clear out any saved ids here, so we */
2984 /* exec the real perl, substituting fd script for scriptname. */
2985 /* (We pass script name as "subdir" of fd, which perl will grok.) */
2986 PerlIO_rewind(PL_rsfp);
2987 PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0); /* just in case rewind didn't */
2988 for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
2989 if (!PL_origargv[which])
2990 Perl_croak(aTHX_ "Permission denied");
2991 PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
2992 PerlIO_fileno(PL_rsfp), PL_origargv[which]));
2993 #if defined(HAS_FCNTL) && defined(F_SETFD)
2994 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */
2996 PerlProc_execv(Perl_form(aTHX_ "%s/perl"PERL_FS_VER_FMT, BIN_EXP,
2997 (int)PERL_REVISION, (int)PERL_VERSION,
2998 (int)PERL_SUBVERSION), PL_origargv);/* try again */
2999 Perl_croak(aTHX_ "Can't do setuid\n");
3000 #endif /* IAMSUID */
3002 if (PL_euid != PL_uid || PL_egid != PL_gid) { /* (suidperl doesn't exist, in fact) */
3003 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
3005 PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf); /* may be either wrapped or real suid */
3006 if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
3008 (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
3011 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
3012 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
3013 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
3014 /* not set-id, must be wrapped */
3020 S_find_beginning(pTHX)
3022 register char *s, *s2;
3024 /* skip forward in input to the real script? */
3027 #ifdef MACOS_TRADITIONAL
3028 /* Since the Mac OS does not honor !# arguments for us, we do it ourselves */
3030 while (PL_doextract || gMacPerl_AlwaysExtract) {
3031 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
3032 if (!gMacPerl_AlwaysExtract)
3033 Perl_croak(aTHX_ "No Perl script found in input\n");
3035 if (PL_doextract) /* require explicit override ? */
3036 if (!OverrideExtract(PL_origfilename))
3037 Perl_croak(aTHX_ "User aborted script\n");
3039 PL_doextract = FALSE;
3041 /* Pater peccavi, file does not have #! */
3042 PerlIO_rewind(PL_rsfp);
3047 while (PL_doextract) {
3048 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
3049 Perl_croak(aTHX_ "No Perl script found in input\n");
3051 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
3052 PerlIO_ungetc(PL_rsfp, '\n'); /* to keep line count right */
3053 PL_doextract = FALSE;
3054 while (*s && !(isSPACE (*s) || *s == '#')) s++;
3056 while (*s == ' ' || *s == '\t') s++;
3058 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
3059 if (strnEQ(s2-4,"perl",4))
3061 while ((s = moreswitches(s)))
3072 PL_uid = PerlProc_getuid();
3073 PL_euid = PerlProc_geteuid();
3074 PL_gid = PerlProc_getgid();
3075 PL_egid = PerlProc_getegid();
3077 PL_uid |= PL_gid << 16;
3078 PL_euid |= PL_egid << 16;
3080 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
3084 S_forbid_setid(pTHX_ char *s)
3086 if (PL_euid != PL_uid)
3087 Perl_croak(aTHX_ "No %s allowed while running setuid", s);
3088 if (PL_egid != PL_gid)
3089 Perl_croak(aTHX_ "No %s allowed while running setgid", s);
3093 Perl_init_debugger(pTHX)
3096 HV *ostash = PL_curstash;
3098 PL_curstash = PL_debstash;
3099 PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
3100 AvREAL_off(PL_dbargs);
3101 PL_DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
3102 PL_DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
3103 PL_DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
3104 sv_upgrade(GvSV(PL_DBsub), SVt_IV); /* IVX accessed if PERLDB_SUB_NN */
3105 PL_DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
3106 sv_setiv(PL_DBsingle, 0);
3107 PL_DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
3108 sv_setiv(PL_DBtrace, 0);
3109 PL_DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
3110 sv_setiv(PL_DBsignal, 0);
3111 PL_curstash = ostash;
3114 #ifndef STRESS_REALLOC
3115 #define REASONABLE(size) (size)
3117 #define REASONABLE(size) (1) /* unreasonable */
3121 Perl_init_stacks(pTHX)
3123 /* start with 128-item stack and 8K cxstack */
3124 PL_curstackinfo = new_stackinfo(REASONABLE(128),
3125 REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
3126 PL_curstackinfo->si_type = PERLSI_MAIN;
3127 PL_curstack = PL_curstackinfo->si_stack;
3128 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
3130 PL_stack_base = AvARRAY(PL_curstack);
3131 PL_stack_sp = PL_stack_base;
3132 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
3134 New(50,PL_tmps_stack,REASONABLE(128),SV*);
3137 PL_tmps_max = REASONABLE(128);
3139 New(54,PL_markstack,REASONABLE(32),I32);
3140 PL_markstack_ptr = PL_markstack;
3141 PL_markstack_max = PL_markstack + REASONABLE(32);
3145 New(54,PL_scopestack,REASONABLE(32),I32);
3146 PL_scopestack_ix = 0;
3147 PL_scopestack_max = REASONABLE(32);
3149 New(54,PL_savestack,REASONABLE(128),ANY);
3150 PL_savestack_ix = 0;
3151 PL_savestack_max = REASONABLE(128);
3153 New(54,PL_retstack,REASONABLE(16),OP*);
3155 PL_retstack_max = REASONABLE(16);
3164 while (PL_curstackinfo->si_next)
3165 PL_curstackinfo = PL_curstackinfo->si_next;
3166 while (PL_curstackinfo) {
3167 PERL_SI *p = PL_curstackinfo->si_prev;
3168 /* curstackinfo->si_stack got nuked by sv_free_arenas() */
3169 Safefree(PL_curstackinfo->si_cxstack);
3170 Safefree(PL_curstackinfo);
3171 PL_curstackinfo = p;
3173 Safefree(PL_tmps_stack);
3174 Safefree(PL_markstack);
3175 Safefree(PL_scopestack);
3176 Safefree(PL_savestack);
3177 Safefree(PL_retstack);
3181 static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
3192 lex_start(PL_linestr);
3194 PL_subname = newSVpvn("main",4);
3198 S_init_predump_symbols(pTHX)
3204 sv_setpvn(get_sv("\"", TRUE), " ", 1);
3205 PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
3206 GvMULTI_on(PL_stdingv);
3207 io = GvIOp(PL_stdingv);
3208 IoIFP(io) = PerlIO_stdin();
3209 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
3211 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
3213 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
3216 IoOFP(io) = IoIFP(io) = PerlIO_stdout();
3218 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
3220 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
3222 PL_stderrgv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
3223 GvMULTI_on(PL_stderrgv);
3224 io = GvIOp(PL_stderrgv);
3225 IoOFP(io) = IoIFP(io) = PerlIO_stderr();
3226 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
3228 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
3230 PL_statname = NEWSV(66,0); /* last filename we did stat on */
3233 Safefree(PL_osname);
3234 PL_osname = savepv(OSNAME);
3238 S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
3245 argc--,argv++; /* skip name of script */
3246 if (PL_doswitches) {
3247 for (; argc > 0 && **argv == '-'; argc--,argv++) {
3250 if (argv[0][1] == '-' && !argv[0][2]) {
3254 if ((s = strchr(argv[0], '='))) {
3256 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
3259 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
3262 PL_toptarget = NEWSV(0,0);
3263 sv_upgrade(PL_toptarget, SVt_PVFM);
3264 sv_setpvn(PL_toptarget, "", 0);
3265 PL_bodytarget = NEWSV(0,0);
3266 sv_upgrade(PL_bodytarget, SVt_PVFM);
3267 sv_setpvn(PL_bodytarget, "", 0);
3268 PL_formtarget = PL_bodytarget;
3271 if ((tmpgv = gv_fetchpv("0",TRUE, SVt_PV))) {
3272 #ifdef MACOS_TRADITIONAL
3273 /* $0 is not majick on a Mac */
3274 sv_setpv(GvSV(tmpgv),MacPerl_MPWFileName(PL_origfilename));
3276 sv_setpv(GvSV(tmpgv),PL_origfilename);
3277 magicname("0", "0", 1);
3280 if ((tmpgv = gv_fetchpv("\030",TRUE, SVt_PV)))
3282 sv_setpv(GvSV(tmpgv), os2_execname(aTHX));
3284 sv_setpv(GvSV(tmpgv),PL_origargv[0]);
3286 if ((PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV))) {
3287 GvMULTI_on(PL_argvgv);
3288 (void)gv_AVadd(PL_argvgv);
3289 av_clear(GvAVn(PL_argvgv));
3290 for (; argc > 0; argc--,argv++) {
3291 SV *sv = newSVpv(argv[0],0);
3292 av_push(GvAVn(PL_argvgv),sv);
3293 if (PL_widesyscalls)
3294 (void)sv_utf8_decode(sv);
3297 if ((PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV))) {
3299 GvMULTI_on(PL_envgv);
3300 hv = GvHVn(PL_envgv);
3301 hv_magic(hv, PL_envgv, 'E');
3302 #if !defined( VMS) && !defined(EPOC) && !defined(MACOS_TRADITIONAL) /* VMS doesn't have environ array */
3303 /* Note that if the supplied env parameter is actually a copy
3304 of the global environ then it may now point to free'd memory
3305 if the environment has been modified since. To avoid this
3306 problem we treat env==NULL as meaning 'use the default'
3311 environ[0] = Nullch;
3312 for (; *env; env++) {
3313 if (!(s = strchr(*env,'=')))
3319 sv = newSVpv(s--,0);
3320 (void)hv_store(hv, *env, s - *env, sv, 0);
3322 #if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
3323 /* Sins of the RTL. See note in my_setenv(). */
3324 (void)PerlEnv_putenv(savepv(*env));
3328 #ifdef DYNAMIC_ENV_FETCH
3329 HvNAME(hv) = savepv(ENV_HV_NAME);
3333 if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV)))
3334 sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
3338 S_init_perllib(pTHX)
3343 s = PerlEnv_getenv("PERL5LIB");
3345 incpush(s, TRUE, TRUE);
3347 incpush(PerlEnv_getenv("PERLLIB"), FALSE, FALSE);
3349 /* Treat PERL5?LIB as a possible search list logical name -- the
3350 * "natural" VMS idiom for a Unix path string. We allow each
3351 * element to be a set of |-separated directories for compatibility.
3355 if (my_trnlnm("PERL5LIB",buf,0))
3356 do { incpush(buf,TRUE,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
3358 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE,FALSE);
3362 /* Use the ~-expanded versions of APPLLIB (undocumented),
3363 ARCHLIB PRIVLIB SITEARCH SITELIB VENDORARCH and VENDORLIB
3366 incpush(APPLLIB_EXP, TRUE, TRUE);
3370 incpush(ARCHLIB_EXP, FALSE, FALSE);
3372 #ifdef MACOS_TRADITIONAL
3374 struct stat tmpstatbuf;
3375 SV * privdir = NEWSV(55, 0);
3376 char * macperl = PerlEnv_getenv("MACPERL");
3381 Perl_sv_setpvf(aTHX_ privdir, "%slib:", macperl);
3382 if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
3383 incpush(SvPVX(privdir), TRUE, FALSE);
3384 Perl_sv_setpvf(aTHX_ privdir, "%ssite_perl:", macperl);
3385 if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
3386 incpush(SvPVX(privdir), TRUE, FALSE);
3388 SvREFCNT_dec(privdir);
3391 incpush(":", FALSE, FALSE);
3394 # define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
3397 incpush(PRIVLIB_EXP, TRUE, FALSE);
3399 incpush(PRIVLIB_EXP, FALSE, FALSE);
3403 /* sitearch is always relative to sitelib on Windows for
3404 * DLL-based path intuition to work correctly */
3405 # if !defined(WIN32)
3406 incpush(SITEARCH_EXP, FALSE, FALSE);
3412 incpush(SITELIB_EXP, TRUE, FALSE); /* this picks up sitearch as well */
3414 incpush(SITELIB_EXP, FALSE, FALSE);
3418 #ifdef SITELIB_STEM /* Search for version-specific dirs below here */
3419 incpush(SITELIB_STEM, FALSE, TRUE);
3422 #ifdef PERL_VENDORARCH_EXP
3423 /* vendorarch is always relative to vendorlib on Windows for
3424 * DLL-based path intuition to work correctly */
3425 # if !defined(WIN32)
3426 incpush(PERL_VENDORARCH_EXP, FALSE, FALSE);
3430 #ifdef PERL_VENDORLIB_EXP
3432 incpush(PERL_VENDORLIB_EXP, TRUE, FALSE); /* this picks up vendorarch as well */
3434 incpush(PERL_VENDORLIB_EXP, FALSE, FALSE);
3438 #ifdef PERL_VENDORLIB_STEM /* Search for version-specific dirs below here */
3439 incpush(PERL_VENDORLIB_STEM, FALSE, TRUE);
3442 #ifdef PERL_OTHERLIBDIRS
3443 incpush(PERL_OTHERLIBDIRS, TRUE, TRUE);
3447 incpush(".", FALSE, FALSE);
3448 #endif /* MACOS_TRADITIONAL */
3452 # define PERLLIB_SEP ';'
3455 # define PERLLIB_SEP '|'
3457 # if defined(MACOS_TRADITIONAL)
3458 # define PERLLIB_SEP ','
3460 # define PERLLIB_SEP ':'
3464 #ifndef PERLLIB_MANGLE
3465 # define PERLLIB_MANGLE(s,n) (s)
3469 S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers)
3471 SV *subdir = Nullsv;
3476 if (addsubdirs || addoldvers) {
3477 subdir = sv_newmortal();
3480 /* Break at all separators */
3482 SV *libdir = NEWSV(55,0);
3485 /* skip any consecutive separators */
3486 while ( *p == PERLLIB_SEP ) {
3487 /* Uncomment the next line for PATH semantics */
3488 /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */
3492 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
3493 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
3498 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
3499 p = Nullch; /* break out */
3501 #ifdef MACOS_TRADITIONAL
3502 if (!strchr(SvPVX(libdir), ':'))
3503 sv_insert(libdir, 0, 0, ":", 1);
3504 if (SvPVX(libdir)[SvCUR(libdir)-1] != ':')
3505 sv_catpv(libdir, ":");
3509 * BEFORE pushing libdir onto @INC we may first push version- and
3510 * archname-specific sub-directories.
3512 if (addsubdirs || addoldvers) {
3513 #ifdef PERL_INC_VERSION_LIST
3514 /* Configure terminates PERL_INC_VERSION_LIST with a NULL */
3515 const char *incverlist[] = { PERL_INC_VERSION_LIST };
3516 const char **incver;
3518 struct stat tmpstatbuf;
3523 if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) {
3525 while (unix[len-1] == '/') len--; /* Cosmetic */
3526 sv_usepvn(libdir,unix,len);
3529 PerlIO_printf(Perl_error_log,
3530 "Failed to unixify @INC element \"%s\"\n",
3534 #ifdef MACOS_TRADITIONAL
3535 #define PERL_AV_SUFFIX_FMT ""
3536 #define PERL_ARCH_FMT ":%s"
3538 #define PERL_AV_SUFFIX_FMT "/"
3539 #define PERL_ARCH_FMT "/%s"
3541 /* .../version/archname if -d .../version/archname */
3542 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_AV_SUFFIX_FMT PERL_FS_VER_FMT PERL_ARCH_FMT,
3544 (int)PERL_REVISION, (int)PERL_VERSION,
3545 (int)PERL_SUBVERSION, ARCHNAME);
3546 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3547 S_ISDIR(tmpstatbuf.st_mode))
3548 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3550 /* .../version if -d .../version */
3551 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_AV_SUFFIX_FMT PERL_FS_VER_FMT, libdir,
3552 (int)PERL_REVISION, (int)PERL_VERSION,
3553 (int)PERL_SUBVERSION);
3554 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3555 S_ISDIR(tmpstatbuf.st_mode))
3556 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3558 /* .../archname if -d .../archname */
3559 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, ARCHNAME);
3560 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3561 S_ISDIR(tmpstatbuf.st_mode))
3562 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3565 #ifdef PERL_INC_VERSION_LIST
3567 for (incver = incverlist; *incver; incver++) {
3568 /* .../xxx if -d .../xxx */
3569 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, *incver);
3570 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3571 S_ISDIR(tmpstatbuf.st_mode))
3572 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3578 /* finally push this lib directory on the end of @INC */
3579 av_push(GvAVn(PL_incgv), libdir);
3584 STATIC struct perl_thread *
3585 S_init_main_thread(pTHX)
3587 #if !defined(PERL_IMPLICIT_CONTEXT)
3588 struct perl_thread *thr;
3592 Newz(53, thr, 1, struct perl_thread);
3593 PL_curcop = &PL_compiling;
3594 thr->interp = PERL_GET_INTERP;
3595 thr->cvcache = newHV();
3596 thr->threadsv = newAV();
3597 /* thr->threadsvp is set when find_threadsv is called */
3598 thr->specific = newAV();
3599 thr->flags = THRf_R_JOINABLE;
3600 MUTEX_INIT(&thr->mutex);
3601 /* Handcraft thrsv similarly to mess_sv */
3602 New(53, PL_thrsv, 1, SV);
3603 Newz(53, xpv, 1, XPV);
3604 SvFLAGS(PL_thrsv) = SVt_PV;
3605 SvANY(PL_thrsv) = (void*)xpv;
3606 SvREFCNT(PL_thrsv) = 1 << 30; /* practically infinite */
3607 SvPVX(PL_thrsv) = (char*)thr;
3608 SvCUR_set(PL_thrsv, sizeof(thr));
3609 SvLEN_set(PL_thrsv, sizeof(thr));
3610 *SvEND(PL_thrsv) = '\0'; /* in the trailing_nul field */
3611 thr->oursv = PL_thrsv;
3612 PL_chopset = " \n-";
3615 MUTEX_LOCK(&PL_threads_mutex);
3620 MUTEX_UNLOCK(&PL_threads_mutex);
3622 #ifdef HAVE_THREAD_INTERN
3623 Perl_init_thread_intern(thr);
3626 #ifdef SET_THREAD_SELF
3627 SET_THREAD_SELF(thr);
3629 thr->self = pthread_self();
3630 #endif /* SET_THREAD_SELF */
3634 * These must come after the SET_THR because sv_setpvn does
3635 * SvTAINT and the taint fields require dTHR.
3637 PL_toptarget = NEWSV(0,0);
3638 sv_upgrade(PL_toptarget, SVt_PVFM);
3639 sv_setpvn(PL_toptarget, "", 0);
3640 PL_bodytarget = NEWSV(0,0);
3641 sv_upgrade(PL_bodytarget, SVt_PVFM);
3642 sv_setpvn(PL_bodytarget, "", 0);
3643 PL_formtarget = PL_bodytarget;
3644 thr->errsv = newSVpvn("", 0);
3645 (void) find_threadsv("@"); /* Ensure $@ is initialised early */
3648 PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
3649 PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
3650 PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
3651 PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
3652 PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
3654 PL_reginterp_cnt = 0;
3658 #endif /* USE_THREADS */
3661 Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
3665 line_t oldline = CopLINE(PL_curcop);
3671 while (AvFILL(paramList) >= 0) {
3672 cv = (CV*)av_shift(paramList);
3673 if ((PL_minus_c & 0x10) && (paramList == PL_beginav)) {
3674 /* save PL_beginav for compiler */
3675 if (! PL_beginav_save)
3676 PL_beginav_save = newAV();
3677 av_push(PL_beginav_save, (SV*)cv);
3681 #ifdef PERL_FLEXIBLE_EXCEPTIONS
3682 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_list_body), cv);
3688 #ifndef PERL_FLEXIBLE_EXCEPTIONS
3692 (void)SvPV(atsv, len);
3695 PL_curcop = &PL_compiling;
3696 CopLINE_set(PL_curcop, oldline);
3697 if (paramList == PL_beginav)
3698 sv_catpv(atsv, "BEGIN failed--compilation aborted");
3700 Perl_sv_catpvf(aTHX_ atsv,
3701 "%s failed--call queue aborted",
3702 paramList == PL_checkav ? "CHECK"
3703 : paramList == PL_initav ? "INIT"
3705 while (PL_scopestack_ix > oldscope)
3708 Perl_croak(aTHX_ "%s", SvPVx(atsv, n_a));
3715 /* my_exit() was called */
3716 while (PL_scopestack_ix > oldscope)
3719 PL_curstash = PL_defstash;
3720 PL_curcop = &PL_compiling;
3721 CopLINE_set(PL_curcop, oldline);
3723 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) {
3724 if (paramList == PL_beginav)
3725 Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
3727 Perl_croak(aTHX_ "%s failed--call queue aborted",
3728 paramList == PL_checkav ? "CHECK"
3729 : paramList == PL_initav ? "INIT"
3736 PL_curcop = &PL_compiling;
3737 CopLINE_set(PL_curcop, oldline);
3740 PerlIO_printf(Perl_error_log, "panic: restartop\n");
3748 #ifdef PERL_FLEXIBLE_EXCEPTIONS
3750 S_vcall_list_body(pTHX_ va_list args)
3752 CV *cv = va_arg(args, CV*);
3753 return call_list_body(cv);
3758 S_call_list_body(pTHX_ CV *cv)
3760 PUSHMARK(PL_stack_sp);
3761 call_sv((SV*)cv, G_EVAL|G_DISCARD);
3766 Perl_my_exit(pTHX_ U32 status)
3770 DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
3771 thr, (unsigned long) status));
3780 STATUS_NATIVE_SET(status);
3787 Perl_my_failure_exit(pTHX)
3790 if (vaxc$errno & 1) {
3791 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
3792 STATUS_NATIVE_SET(44);
3795 if (!vaxc$errno && errno) /* unlikely */
3796 STATUS_NATIVE_SET(44);
3798 STATUS_NATIVE_SET(vaxc$errno);
3803 STATUS_POSIX_SET(errno);
3805 exitstatus = STATUS_POSIX >> 8;
3806 if (exitstatus & 255)
3807 STATUS_POSIX_SET(exitstatus);
3809 STATUS_POSIX_SET(255);
3816 S_my_exit_jump(pTHX)
3819 register PERL_CONTEXT *cx;
3824 SvREFCNT_dec(PL_e_script);
3825 PL_e_script = Nullsv;
3828 POPSTACK_TO(PL_mainstack);
3829 if (cxstack_ix >= 0) {
3832 POPBLOCK(cx,PL_curpm);
3844 read_e_script(pTHXo_ int idx, SV *buf_sv, int maxlen)
3847 p = SvPVX(PL_e_script);
3848 nl = strchr(p, '\n');
3849 nl = (nl) ? nl+1 : SvEND(PL_e_script);
3851 filter_del(read_e_script);
3854 sv_catpvn(buf_sv, p, nl-p);
3855 sv_chop(PL_e_script, nl);