3 * Copyright (c) 1987-1999 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);
43 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
50 #define perl_construct Perl_construct
51 #define perl_parse Perl_parse
52 #define perl_run Perl_run
53 #define perl_destruct Perl_destruct
54 #define perl_free Perl_free
57 #ifdef PERL_IMPLICIT_SYS
59 perl_alloc_using(struct IPerlMem* ipM, struct IPerlMem* ipMS,
60 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
61 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
62 struct IPerlDir* ipD, struct IPerlSock* ipS,
63 struct IPerlProc* ipP)
65 PerlInterpreter *my_perl;
67 my_perl = (PerlInterpreter*)new(ipM) CPerlObj(ipM, ipMS, ipMP, ipE, ipStd,
68 ipLIO, ipD, ipS, ipP);
69 PERL_SET_INTERP(my_perl);
71 /* New() needs interpreter, so call malloc() instead */
72 my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
73 PERL_SET_INTERP(my_perl);
74 Zero(my_perl, 1, PerlInterpreter);
92 PerlInterpreter *my_perl;
94 /* New() needs interpreter, so call malloc() instead */
95 my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
96 PERL_SET_INTERP(my_perl);
97 Zero(my_perl, 1, PerlInterpreter);
100 #endif /* PERL_IMPLICIT_SYS */
103 perl_construct(pTHXx)
108 struct perl_thread *thr = NULL;
109 #endif /* FAKE_THREADS */
110 #endif /* USE_THREADS */
114 PL_perl_destruct_level = 1;
116 if (PL_perl_destruct_level > 0)
120 /* Init the real globals (and main thread)? */
124 #ifdef ALLOC_THREAD_KEY
127 if (pthread_key_create(&PL_thr_key, 0))
128 Perl_croak(aTHX_ "panic: pthread_key_create");
130 MUTEX_INIT(&PL_sv_mutex);
132 * Safe to use basic SV functions from now on (though
133 * not things like mortals or tainting yet).
135 MUTEX_INIT(&PL_eval_mutex);
136 COND_INIT(&PL_eval_cond);
137 MUTEX_INIT(&PL_threads_mutex);
138 COND_INIT(&PL_nthreads_cond);
139 #ifdef EMULATE_ATOMIC_REFCOUNTS
140 MUTEX_INIT(&PL_svref_mutex);
141 #endif /* EMULATE_ATOMIC_REFCOUNTS */
143 MUTEX_INIT(&PL_cred_mutex);
145 thr = init_main_thread();
146 #endif /* USE_THREADS */
148 PL_protect = MEMBER_TO_FPTR(Perl_default_protect); /* for exceptions */
150 PL_curcop = &PL_compiling; /* needed by ckWARN, right away */
152 PL_linestr = NEWSV(65,79);
153 sv_upgrade(PL_linestr,SVt_PVIV);
155 if (!SvREADONLY(&PL_sv_undef)) {
156 /* set read-only and try to insure than we wont see REFCNT==0
159 SvREADONLY_on(&PL_sv_undef);
160 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
162 sv_setpv(&PL_sv_no,PL_No);
164 SvREADONLY_on(&PL_sv_no);
165 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
167 sv_setpv(&PL_sv_yes,PL_Yes);
169 SvREADONLY_on(&PL_sv_yes);
170 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
175 /* PL_sighandlerp = sighandler; */
177 PL_sighandlerp = Perl_sighandler;
179 PL_pidstatus = newHV();
183 * There is no way we can refer to them from Perl so close them to save
184 * space. The other alternative would be to provide STDAUX and STDPRN
187 (void)fclose(stdaux);
188 (void)fclose(stdprn);
192 PL_nrs = newSVpvn("\n", 1);
193 PL_rs = SvREFCNT_inc(PL_nrs);
198 PL_lex_state = LEX_NOTPARSING;
204 SET_NUMERIC_STANDARD();
208 PL_patchlevel = NEWSV(0,4);
209 SvUPGRADE(PL_patchlevel, SVt_PVNV);
210 if (PERL_REVISION > 127 || PERL_VERSION > 127 || PERL_SUBVERSION > 127)
211 SvGROW(PL_patchlevel,24);
212 s = (U8*)SvPVX(PL_patchlevel);
213 s = uv_to_utf8(s, (UV)PERL_REVISION);
214 s = uv_to_utf8(s, (UV)PERL_VERSION);
215 s = uv_to_utf8(s, (UV)PERL_SUBVERSION);
217 SvCUR_set(PL_patchlevel, s - (U8*)SvPVX(PL_patchlevel));
218 SvPOK_on(PL_patchlevel);
219 SvNVX(PL_patchlevel) = (NV)PERL_REVISION
220 + ((NV)PERL_VERSION / (NV)1000)
221 #if defined(PERL_SUBVERSION) && PERL_SUBVERSION > 0
222 + ((NV)PERL_SUBVERSION / (NV)1000000)
225 SvNOK_on(PL_patchlevel); /* dual valued */
226 SvUTF8_on(PL_patchlevel);
227 SvREADONLY_on(PL_patchlevel);
230 #if defined(LOCAL_PATCH_COUNT)
231 PL_localpatches = local_patches; /* For possible -v */
234 PerlIO_init(); /* Hook to IO system */
236 PL_fdpid = newAV(); /* for remembering popen pids by fd */
237 PL_modglobal = newHV(); /* pointers to per-interpreter module globals */
246 int destruct_level; /* 0=none, 1=full, 2=full with checks */
252 #endif /* USE_THREADS */
254 /* wait for all pseudo-forked children to finish */
255 PERL_WAIT_FOR_CHILDREN;
259 /* Pass 1 on any remaining threads: detach joinables, join zombies */
261 MUTEX_LOCK(&PL_threads_mutex);
262 DEBUG_S(PerlIO_printf(Perl_debug_log,
263 "perl_destruct: waiting for %d threads...\n",
265 for (t = thr->next; t != thr; t = t->next) {
266 MUTEX_LOCK(&t->mutex);
267 switch (ThrSTATE(t)) {
270 DEBUG_S(PerlIO_printf(Perl_debug_log,
271 "perl_destruct: joining zombie %p\n", t));
272 ThrSETSTATE(t, THRf_DEAD);
273 MUTEX_UNLOCK(&t->mutex);
276 * The SvREFCNT_dec below may take a long time (e.g. av
277 * may contain an object scalar whose destructor gets
278 * called) so we have to unlock threads_mutex and start
281 MUTEX_UNLOCK(&PL_threads_mutex);
283 SvREFCNT_dec((SV*)av);
284 DEBUG_S(PerlIO_printf(Perl_debug_log,
285 "perl_destruct: joined zombie %p OK\n", t));
287 case THRf_R_JOINABLE:
288 DEBUG_S(PerlIO_printf(Perl_debug_log,
289 "perl_destruct: detaching thread %p\n", t));
290 ThrSETSTATE(t, THRf_R_DETACHED);
292 * We unlock threads_mutex and t->mutex in the opposite order
293 * from which we locked them just so that DETACH won't
294 * deadlock if it panics. It's only a breach of good style
295 * not a bug since they are unlocks not locks.
297 MUTEX_UNLOCK(&PL_threads_mutex);
299 MUTEX_UNLOCK(&t->mutex);
302 DEBUG_S(PerlIO_printf(Perl_debug_log,
303 "perl_destruct: ignoring %p (state %u)\n",
305 MUTEX_UNLOCK(&t->mutex);
306 /* fall through and out */
309 /* We leave the above "Pass 1" loop with threads_mutex still locked */
311 /* Pass 2 on remaining threads: wait for the thread count to drop to one */
312 while (PL_nthreads > 1)
314 DEBUG_S(PerlIO_printf(Perl_debug_log,
315 "perl_destruct: final wait for %d threads\n",
317 COND_WAIT(&PL_nthreads_cond, &PL_threads_mutex);
319 /* At this point, we're the last thread */
320 MUTEX_UNLOCK(&PL_threads_mutex);
321 DEBUG_S(PerlIO_printf(Perl_debug_log, "perl_destruct: armageddon has arrived\n"));
322 MUTEX_DESTROY(&PL_threads_mutex);
323 COND_DESTROY(&PL_nthreads_cond);
324 #endif /* !defined(FAKE_THREADS) */
325 #endif /* USE_THREADS */
327 destruct_level = PL_perl_destruct_level;
331 if (s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL")) {
333 if (destruct_level < i)
342 /* We must account for everything. */
344 /* Destroy the main CV and syntax tree */
346 PL_curpad = AvARRAY(PL_comppad);
347 op_free(PL_main_root);
348 PL_main_root = Nullop;
350 PL_curcop = &PL_compiling;
351 PL_main_start = Nullop;
352 SvREFCNT_dec(PL_main_cv);
356 if (PL_sv_objcount) {
358 * Try to destruct global references. We do this first so that the
359 * destructors and destructees still exist. Some sv's might remain.
360 * Non-referenced objects are on their own.
365 /* unhook hooks which will soon be, or use, destroyed data */
366 SvREFCNT_dec(PL_warnhook);
367 PL_warnhook = Nullsv;
368 SvREFCNT_dec(PL_diehook);
371 /* call exit list functions */
372 while (PL_exitlistlen-- > 0)
373 PL_exitlist[PL_exitlistlen].fn(aTHXo_ PL_exitlist[PL_exitlistlen].ptr);
375 Safefree(PL_exitlist);
377 if (destruct_level == 0){
379 DEBUG_P(debprofdump());
381 /* The exit() function will do everything that needs doing. */
385 /* loosen bonds of global variables */
388 (void)PerlIO_close(PL_rsfp);
392 /* Filters for program text */
393 SvREFCNT_dec(PL_rsfp_filters);
394 PL_rsfp_filters = Nullav;
397 PL_preprocess = FALSE;
403 PL_doswitches = FALSE;
404 PL_dowarn = G_WARN_OFF;
405 PL_doextract = FALSE;
406 PL_sawampersand = FALSE; /* must save all match strings */
409 Safefree(PL_inplace);
411 SvREFCNT_dec(PL_patchlevel);
414 SvREFCNT_dec(PL_e_script);
415 PL_e_script = Nullsv;
418 /* magical thingies */
420 Safefree(PL_ofs); /* $, */
423 Safefree(PL_ors); /* $\ */
426 SvREFCNT_dec(PL_rs); /* $/ */
429 SvREFCNT_dec(PL_nrs); /* $/ helper */
432 PL_multiline = 0; /* $* */
434 SvREFCNT_dec(PL_statname);
435 PL_statname = Nullsv;
438 /* defgv, aka *_ should be taken care of elsewhere */
440 /* clean up after study() */
441 SvREFCNT_dec(PL_lastscream);
442 PL_lastscream = Nullsv;
443 Safefree(PL_screamfirst);
445 Safefree(PL_screamnext);
449 Safefree(PL_efloatbuf);
450 PL_efloatbuf = Nullch;
453 /* startup and shutdown function lists */
454 SvREFCNT_dec(PL_beginav);
455 SvREFCNT_dec(PL_endav);
456 SvREFCNT_dec(PL_stopav);
457 SvREFCNT_dec(PL_initav);
463 /* shortcuts just get cleared */
469 PL_argvoutgv = Nullgv;
471 PL_stderrgv = Nullgv;
472 PL_last_in_gv = Nullgv;
474 PL_debstash = Nullhv;
476 /* reset so print() ends up where we expect */
479 SvREFCNT_dec(PL_argvout_stack);
480 PL_argvout_stack = Nullav;
482 SvREFCNT_dec(PL_fdpid);
484 SvREFCNT_dec(PL_modglobal);
485 PL_modglobal = Nullhv;
486 SvREFCNT_dec(PL_preambleav);
487 PL_preambleav = Nullav;
488 SvREFCNT_dec(PL_subname);
490 SvREFCNT_dec(PL_linestr);
492 SvREFCNT_dec(PL_pidstatus);
493 PL_pidstatus = Nullhv;
494 SvREFCNT_dec(PL_toptarget);
495 PL_toptarget = Nullsv;
496 SvREFCNT_dec(PL_bodytarget);
497 PL_bodytarget = Nullsv;
498 PL_formtarget = Nullsv;
500 /* clear utf8 character classes */
501 SvREFCNT_dec(PL_utf8_alnum);
502 SvREFCNT_dec(PL_utf8_alnumc);
503 SvREFCNT_dec(PL_utf8_ascii);
504 SvREFCNT_dec(PL_utf8_alpha);
505 SvREFCNT_dec(PL_utf8_space);
506 SvREFCNT_dec(PL_utf8_cntrl);
507 SvREFCNT_dec(PL_utf8_graph);
508 SvREFCNT_dec(PL_utf8_digit);
509 SvREFCNT_dec(PL_utf8_upper);
510 SvREFCNT_dec(PL_utf8_lower);
511 SvREFCNT_dec(PL_utf8_print);
512 SvREFCNT_dec(PL_utf8_punct);
513 SvREFCNT_dec(PL_utf8_xdigit);
514 SvREFCNT_dec(PL_utf8_mark);
515 SvREFCNT_dec(PL_utf8_toupper);
516 SvREFCNT_dec(PL_utf8_tolower);
517 PL_utf8_alnum = Nullsv;
518 PL_utf8_alnumc = Nullsv;
519 PL_utf8_ascii = Nullsv;
520 PL_utf8_alpha = Nullsv;
521 PL_utf8_space = Nullsv;
522 PL_utf8_cntrl = Nullsv;
523 PL_utf8_graph = Nullsv;
524 PL_utf8_digit = Nullsv;
525 PL_utf8_upper = Nullsv;
526 PL_utf8_lower = Nullsv;
527 PL_utf8_print = Nullsv;
528 PL_utf8_punct = Nullsv;
529 PL_utf8_xdigit = Nullsv;
530 PL_utf8_mark = Nullsv;
531 PL_utf8_toupper = Nullsv;
532 PL_utf8_totitle = Nullsv;
533 PL_utf8_tolower = Nullsv;
535 if (!specialWARN(PL_compiling.cop_warnings))
536 SvREFCNT_dec(PL_compiling.cop_warnings);
537 PL_compiling.cop_warnings = Nullsv;
539 /* Prepare to destruct main symbol table. */
544 SvREFCNT_dec(PL_curstname);
545 PL_curstname = Nullsv;
547 /* clear queued errors */
548 SvREFCNT_dec(PL_errors);
552 if (destruct_level >= 2 && ckWARN_d(WARN_INTERNAL)) {
553 if (PL_scopestack_ix != 0)
554 Perl_warner(aTHX_ WARN_INTERNAL,
555 "Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
556 (long)PL_scopestack_ix);
557 if (PL_savestack_ix != 0)
558 Perl_warner(aTHX_ WARN_INTERNAL,
559 "Unbalanced saves: %ld more saves than restores\n",
560 (long)PL_savestack_ix);
561 if (PL_tmps_floor != -1)
562 Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced tmps: %ld more allocs than frees\n",
563 (long)PL_tmps_floor + 1);
564 if (cxstack_ix != -1)
565 Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced context: %ld more PUSHes than POPs\n",
566 (long)cxstack_ix + 1);
569 /* Now absolutely destruct everything, somehow or other, loops or no. */
571 SvFLAGS(PL_strtab) |= SVTYPEMASK; /* don't clean out strtab now */
572 while (PL_sv_count != 0 && PL_sv_count != last_sv_count) {
573 last_sv_count = PL_sv_count;
576 SvFLAGS(PL_strtab) &= ~SVTYPEMASK;
577 SvFLAGS(PL_strtab) |= SVt_PVHV;
579 /* Destruct the global string table. */
581 /* Yell and reset the HeVAL() slots that are still holding refcounts,
582 * so that sv_free() won't fail on them.
590 max = HvMAX(PL_strtab);
591 array = HvARRAY(PL_strtab);
594 if (hent && ckWARN_d(WARN_INTERNAL)) {
595 Perl_warner(aTHX_ WARN_INTERNAL,
596 "Unbalanced string table refcount: (%d) for \"%s\"",
597 HeVAL(hent) - Nullsv, HeKEY(hent));
598 HeVAL(hent) = Nullsv;
608 SvREFCNT_dec(PL_strtab);
610 if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL))
611 Perl_warner(aTHX_ WARN_INTERNAL,"Scalars leaked: %ld\n", (long)PL_sv_count);
615 /* No SVs have survived, need to clean out */
616 Safefree(PL_origfilename);
617 Safefree(PL_reg_start_tmp);
619 Safefree(PL_reg_curpm);
620 Safefree(PL_reg_poscache);
621 Safefree(HeKEY_hek(&PL_hv_fetch_ent_mh));
622 Safefree(PL_op_mask);
624 PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */
626 DEBUG_P(debprofdump());
628 MUTEX_DESTROY(&PL_strtab_mutex);
629 MUTEX_DESTROY(&PL_sv_mutex);
630 MUTEX_DESTROY(&PL_eval_mutex);
631 MUTEX_DESTROY(&PL_cred_mutex);
632 COND_DESTROY(&PL_eval_cond);
633 #ifdef EMULATE_ATOMIC_REFCOUNTS
634 MUTEX_DESTROY(&PL_svref_mutex);
635 #endif /* EMULATE_ATOMIC_REFCOUNTS */
637 /* As the penultimate thing, free the non-arena SV for thrsv */
638 Safefree(SvPVX(PL_thrsv));
639 Safefree(SvANY(PL_thrsv));
642 #endif /* USE_THREADS */
644 /* As the absolutely last thing, free the non-arena SV for mess() */
647 /* it could have accumulated taint magic */
648 if (SvTYPE(PL_mess_sv) >= SVt_PVMG) {
651 for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) {
652 moremagic = mg->mg_moremagic;
653 if (mg->mg_ptr && mg->mg_type != 'g' && mg->mg_len >= 0)
654 Safefree(mg->mg_ptr);
658 /* we know that type >= SVt_PV */
659 SvOOK_off(PL_mess_sv);
660 Safefree(SvPVX(PL_mess_sv));
661 Safefree(SvANY(PL_mess_sv));
662 Safefree(PL_mess_sv);
670 #if defined(PERL_OBJECT)
678 Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
680 Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry);
681 PL_exitlist[PL_exitlistlen].fn = fn;
682 PL_exitlist[PL_exitlistlen].ptr = ptr;
687 perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
697 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
700 Perl_croak(aTHX_ "suidperl is no longer needed since the kernel can now execute\n\
701 setuid perl scripts securely.\n");
705 #if defined(__DYNAMIC__) && (defined(NeXT) || defined(__NeXT__))
706 _dyld_lookup_and_bind
707 ("__environ", (unsigned long *) &environ_pointer, NULL);
712 #ifndef VMS /* VMS doesn't have environ array */
713 PL_origenviron = environ;
718 /* Come here if running an undumped a.out. */
720 PL_origfilename = savepv(argv[0]);
721 PL_do_undump = FALSE;
722 cxstack_ix = -1; /* start label stack again */
724 init_postdump_symbols(argc,argv,env);
729 PL_curpad = AvARRAY(PL_comppad);
730 op_free(PL_main_root);
731 PL_main_root = Nullop;
733 PL_main_start = Nullop;
734 SvREFCNT_dec(PL_main_cv);
738 oldscope = PL_scopestack_ix;
739 PL_dowarn = G_WARN_OFF;
741 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_parse_body),
746 call_list(oldscope, PL_stopav);
752 /* my_exit() was called */
753 while (PL_scopestack_ix > oldscope)
756 PL_curstash = PL_defstash;
758 call_list(oldscope, PL_stopav);
759 return STATUS_NATIVE_EXPORT;
761 PerlIO_printf(Perl_error_log, "panic: top_env\n");
768 S_parse_body(pTHX_ va_list args)
771 int argc = PL_origargc;
772 char **argv = PL_origargv;
773 char **env = va_arg(args, char**);
774 char *scriptname = NULL;
776 VOL bool dosearch = FALSE;
781 char *cddir = Nullch;
783 XSINIT_t xsinit = va_arg(args, XSINIT_t);
785 sv_setpvn(PL_linestr,"",0);
786 sv = newSVpvn("",0); /* first used for -I flags */
790 for (argc--,argv++; argc > 0; argc--,argv++) {
791 if (argv[0][0] != '-' || !argv[0][1])
795 validarg = " PHOOEY ";
802 #ifndef PERL_STRICT_CR
826 if (s = moreswitches(s))
836 if (PL_euid != PL_uid || PL_egid != PL_gid)
837 Perl_croak(aTHX_ "No -e allowed in setuid scripts");
839 PL_e_script = newSVpvn("",0);
840 filter_add(read_e_script, NULL);
843 sv_catpv(PL_e_script, s);
845 sv_catpv(PL_e_script, argv[1]);
849 Perl_croak(aTHX_ "No code specified for -e");
850 sv_catpv(PL_e_script, "\n");
853 case 'I': /* -I handled both here and in moreswitches() */
855 if (!*++s && (s=argv[1]) != Nullch) {
860 STRLEN len = strlen(s);
863 sv_catpvn(sv, "-I", 2);
864 sv_catpvn(sv, p, len);
865 sv_catpvn(sv, " ", 1);
869 Perl_croak(aTHX_ "No directory specified for -I");
873 PL_preprocess = TRUE;
883 PL_preambleav = newAV();
884 av_push(PL_preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
886 PL_Sv = newSVpv("print myconfig();",0);
888 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
890 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
892 sv_catpv(PL_Sv,"\" Compile-time options:");
894 sv_catpv(PL_Sv," DEBUGGING");
897 sv_catpv(PL_Sv," MULTIPLICITY");
900 sv_catpv(PL_Sv," USE_THREADS");
903 sv_catpv(PL_Sv," PERL_OBJECT");
905 # ifdef PERL_IMPLICIT_CONTEXT
906 sv_catpv(PL_Sv," PERL_IMPLICIT_CONTEXT");
908 # ifdef PERL_IMPLICIT_SYS
909 sv_catpv(PL_Sv," PERL_IMPLICIT_SYS");
911 sv_catpv(PL_Sv,"\\n\",");
913 #if defined(LOCAL_PATCH_COUNT)
914 if (LOCAL_PATCH_COUNT > 0) {
916 sv_catpv(PL_Sv,"\" Locally applied patches:\\n\",");
917 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
918 if (PL_localpatches[i])
919 Perl_sv_catpvf(aTHX_ PL_Sv,"q\" \t%s\n\",",PL_localpatches[i]);
923 Perl_sv_catpvf(aTHX_ PL_Sv,"\" Built under %s\\n\"",OSNAME);
926 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
928 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled on %s\\n\"",__DATE__);
933 @env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; \
934 print \" \\%ENV:\\n @env\\n\" if @env; \
935 print \" \\@INC:\\n @INC\\n\";");
938 PL_Sv = newSVpv("config_vars(qw(",0);
939 sv_catpv(PL_Sv, ++s);
940 sv_catpv(PL_Sv, "))");
943 av_push(PL_preambleav, PL_Sv);
944 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
955 if (!*++s || isSPACE(*s)) {
959 /* catch use of gnu style long options */
960 if (strEQ(s, "version")) {
964 if (strEQ(s, "help")) {
971 Perl_croak(aTHX_ "Unrecognized switch: -%s (-h will show valid options)",s);
977 #ifndef SECURE_INTERNAL_GETENV
980 (s = PerlEnv_getenv("PERL5OPT")))
984 if (*s == '-' && *(s+1) == 'T')
997 if (!strchr("DIMUdmw", *s))
998 Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
1005 scriptname = argv[0];
1008 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
1010 else if (scriptname == Nullch) {
1012 if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
1020 open_script(scriptname,dosearch,sv,&fdscript);
1022 validate_suid(validarg, scriptname,fdscript);
1024 #if defined(SIGCHLD) || defined(SIGCLD)
1027 # define SIGCHLD SIGCLD
1029 Sighandler_t sigstate = rsignal_state(SIGCHLD);
1030 if (sigstate == SIG_IGN) {
1031 if (ckWARN(WARN_SIGNAL))
1032 Perl_warner(aTHX_ WARN_SIGNAL,
1033 "Can't ignore signal CHLD, forcing to default");
1034 (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL);
1041 if (cddir && PerlDir_chdir(cddir) < 0)
1042 Perl_croak(aTHX_ "Can't chdir to %s",cddir);
1046 PL_main_cv = PL_compcv = (CV*)NEWSV(1104,0);
1047 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
1048 CvUNIQUE_on(PL_compcv);
1050 PL_comppad = newAV();
1051 av_push(PL_comppad, Nullsv);
1052 PL_curpad = AvARRAY(PL_comppad);
1053 PL_comppad_name = newAV();
1054 PL_comppad_name_fill = 0;
1055 PL_min_intro_pending = 0;
1058 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
1059 PL_curpad[0] = (SV*)newAV();
1060 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
1061 CvOWNER(PL_compcv) = 0;
1062 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
1063 MUTEX_INIT(CvMUTEXP(PL_compcv));
1064 #endif /* USE_THREADS */
1066 comppadlist = newAV();
1067 AvREAL_off(comppadlist);
1068 av_store(comppadlist, 0, (SV*)PL_comppad_name);
1069 av_store(comppadlist, 1, (SV*)PL_comppad);
1070 CvPADLIST(PL_compcv) = comppadlist;
1072 boot_core_UNIVERSAL();
1073 boot_core_xsutils();
1076 (*xsinit)(aTHXo); /* in case linked C routines want magical variables */
1077 #if defined(VMS) || defined(WIN32) || defined(DJGPP)
1085 init_predump_symbols();
1086 /* init_postdump_symbols not currently designed to be called */
1087 /* more than once (ENV isn't cleared first, for example) */
1088 /* But running with -u leaves %ENV & @ARGV undefined! XXX */
1090 init_postdump_symbols(argc,argv,env);
1094 /* now parse the script */
1096 SETERRNO(0,SS$_NORMAL);
1098 if (yyparse() || PL_error_count) {
1100 Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
1102 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
1106 CopLINE_set(PL_curcop, 0);
1107 PL_curstash = PL_defstash;
1108 PL_preprocess = FALSE;
1110 SvREFCNT_dec(PL_e_script);
1111 PL_e_script = Nullsv;
1114 /* now that script is parsed, we can modify record separator */
1115 SvREFCNT_dec(PL_rs);
1116 PL_rs = SvREFCNT_inc(PL_nrs);
1117 sv_setsv(get_sv("/", TRUE), PL_rs);
1122 SAVECOPFILE(PL_curcop);
1123 SAVECOPLINE(PL_curcop);
1124 gv_check(PL_defstash);
1131 if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
1132 dump_mstats("after compilation:");
1151 oldscope = PL_scopestack_ix;
1154 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_run_body), oldscope);
1157 cxstack_ix = -1; /* start context stack again */
1159 case 0: /* normal completion */
1160 case 2: /* my_exit() */
1161 while (PL_scopestack_ix > oldscope)
1164 PL_curstash = PL_defstash;
1165 if (PL_endav && !PL_minus_c)
1166 call_list(oldscope, PL_endav);
1168 if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
1169 dump_mstats("after execution: ");
1171 return STATUS_NATIVE_EXPORT;
1174 POPSTACK_TO(PL_mainstack);
1177 PerlIO_printf(Perl_error_log, "panic: restartop\n");
1187 S_run_body(pTHX_ va_list args)
1190 I32 oldscope = va_arg(args, I32);
1192 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
1193 PL_sawampersand ? "Enabling" : "Omitting"));
1195 if (!PL_restartop) {
1196 DEBUG_x(dump_all());
1197 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
1198 DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%"UVxf"\n",
1202 PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
1205 if (PERLDB_SINGLE && PL_DBsingle)
1206 sv_setiv(PL_DBsingle, 1);
1208 call_list(oldscope, PL_initav);
1214 PL_op = PL_restartop;
1218 else if (PL_main_start) {
1219 CvDEPTH(PL_main_cv) = 1;
1220 PL_op = PL_main_start;
1230 Perl_get_sv(pTHX_ const char *name, I32 create)
1234 if (name[1] == '\0' && !isALPHA(name[0])) {
1235 PADOFFSET tmp = find_threadsv(name);
1236 if (tmp != NOT_IN_PAD) {
1238 return THREADSV(tmp);
1241 #endif /* USE_THREADS */
1242 gv = gv_fetchpv(name, create, SVt_PV);
1249 Perl_get_av(pTHX_ const char *name, I32 create)
1251 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1260 Perl_get_hv(pTHX_ const char *name, I32 create)
1262 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1271 Perl_get_cv(pTHX_ const char *name, I32 create)
1273 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
1274 /* XXX unsafe for threads if eval_owner isn't held */
1275 /* XXX this is probably not what they think they're getting.
1276 * It has the same effect as "sub name;", i.e. just a forward
1278 if (create && !GvCVu(gv))
1279 return newSUB(start_subparse(FALSE, 0),
1280 newSVOP(OP_CONST, 0, newSVpv(name,0)),
1288 /* Be sure to refetch the stack pointer after calling these routines. */
1291 Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv)
1293 /* See G_* flags in cop.h */
1294 /* null terminated arg list */
1301 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
1306 return call_pv(sub_name, flags);
1310 Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
1311 /* name of the subroutine */
1312 /* See G_* flags in cop.h */
1314 return call_sv((SV*)get_cv(sub_name, TRUE), flags);
1318 Perl_call_method(pTHX_ const char *methname, I32 flags)
1319 /* name of the subroutine */
1320 /* See G_* flags in cop.h */
1326 XPUSHs(sv_2mortal(newSVpv(methname,0)));
1331 return call_sv(*PL_stack_sp--, flags);
1334 /* May be called with any of a CV, a GV, or an SV containing the name. */
1336 Perl_call_sv(pTHX_ SV *sv, I32 flags)
1338 /* See G_* flags in cop.h */
1341 LOGOP myop; /* fake syntax tree node */
1345 bool oldcatch = CATCH_GET;
1350 if (flags & G_DISCARD) {
1355 Zero(&myop, 1, LOGOP);
1356 myop.op_next = Nullop;
1357 if (!(flags & G_NOARGS))
1358 myop.op_flags |= OPf_STACKED;
1359 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1360 (flags & G_ARRAY) ? OPf_WANT_LIST :
1365 EXTEND(PL_stack_sp, 1);
1366 *++PL_stack_sp = sv;
1368 oldscope = PL_scopestack_ix;
1370 if (PERLDB_SUB && PL_curstash != PL_debstash
1371 /* Handle first BEGIN of -d. */
1372 && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
1373 /* Try harder, since this may have been a sighandler, thus
1374 * curstash may be meaningless. */
1375 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != PL_debstash)
1376 && !(flags & G_NODEBUG))
1377 PL_op->op_private |= OPpENTERSUB_DB;
1379 if (!(flags & G_EVAL)) {
1381 call_xbody((OP*)&myop, FALSE);
1382 retval = PL_stack_sp - (PL_stack_base + oldmark);
1383 CATCH_SET(oldcatch);
1386 cLOGOP->op_other = PL_op;
1388 /* we're trying to emulate pp_entertry() here */
1390 register PERL_CONTEXT *cx;
1391 I32 gimme = GIMME_V;
1396 push_return(PL_op->op_next);
1397 PUSHBLOCK(cx, CXt_EVAL, PL_stack_sp);
1399 PL_eval_root = PL_op; /* Only needed so that goto works right. */
1401 PL_in_eval = EVAL_INEVAL;
1402 if (flags & G_KEEPERR)
1403 PL_in_eval |= EVAL_KEEPERR;
1410 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_body),
1414 retval = PL_stack_sp - (PL_stack_base + oldmark);
1415 if (!(flags & G_KEEPERR))
1422 /* my_exit() was called */
1423 PL_curstash = PL_defstash;
1425 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
1426 Perl_croak(aTHX_ "Callback called exit");
1431 PL_op = PL_restartop;
1435 PL_stack_sp = PL_stack_base + oldmark;
1436 if (flags & G_ARRAY)
1440 *++PL_stack_sp = &PL_sv_undef;
1445 if (PL_scopestack_ix > oldscope) {
1449 register PERL_CONTEXT *cx;
1460 if (flags & G_DISCARD) {
1461 PL_stack_sp = PL_stack_base + oldmark;
1471 S_call_body(pTHX_ va_list args)
1473 OP *myop = va_arg(args, OP*);
1474 int is_eval = va_arg(args, int);
1476 call_xbody(myop, is_eval);
1481 S_call_xbody(pTHX_ OP *myop, int is_eval)
1485 if (PL_op == myop) {
1487 PL_op = Perl_pp_entereval(aTHX);
1489 PL_op = Perl_pp_entersub(aTHX);
1495 /* Eval a string. The G_EVAL flag is always assumed. */
1498 Perl_eval_sv(pTHX_ SV *sv, I32 flags)
1500 /* See G_* flags in cop.h */
1503 UNOP myop; /* fake syntax tree node */
1504 I32 oldmark = SP - PL_stack_base;
1511 if (flags & G_DISCARD) {
1518 Zero(PL_op, 1, UNOP);
1519 EXTEND(PL_stack_sp, 1);
1520 *++PL_stack_sp = sv;
1521 oldscope = PL_scopestack_ix;
1523 if (!(flags & G_NOARGS))
1524 myop.op_flags = OPf_STACKED;
1525 myop.op_next = Nullop;
1526 myop.op_type = OP_ENTEREVAL;
1527 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1528 (flags & G_ARRAY) ? OPf_WANT_LIST :
1530 if (flags & G_KEEPERR)
1531 myop.op_flags |= OPf_SPECIAL;
1534 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_body),
1538 retval = PL_stack_sp - (PL_stack_base + oldmark);
1539 if (!(flags & G_KEEPERR))
1546 /* my_exit() was called */
1547 PL_curstash = PL_defstash;
1549 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
1550 Perl_croak(aTHX_ "Callback called exit");
1555 PL_op = PL_restartop;
1559 PL_stack_sp = PL_stack_base + oldmark;
1560 if (flags & G_ARRAY)
1564 *++PL_stack_sp = &PL_sv_undef;
1569 if (flags & G_DISCARD) {
1570 PL_stack_sp = PL_stack_base + oldmark;
1580 Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
1583 SV* sv = newSVpv(p, 0);
1586 eval_sv(sv, G_SCALAR);
1593 if (croak_on_error && SvTRUE(ERRSV)) {
1595 Perl_croak(aTHX_ SvPVx(ERRSV, n_a));
1601 /* Require a module. */
1604 Perl_require_pv(pTHX_ const char *pv)
1608 PUSHSTACKi(PERLSI_REQUIRE);
1610 sv = sv_newmortal();
1611 sv_setpv(sv, "require '");
1614 eval_sv(sv, G_DISCARD);
1620 Perl_magicname(pTHX_ char *sym, char *name, I32 namlen)
1624 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1625 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1629 S_usage(pTHX_ char *name) /* XXX move this out into a module ? */
1631 /* This message really ought to be max 23 lines.
1632 * Removed -h because the user already knows that opton. Others? */
1634 static char *usage_msg[] = {
1635 "-0[octal] specify record separator (\\0, if no argument)",
1636 "-a autosplit mode with -n or -p (splits $_ into @F)",
1637 "-c check syntax only (runs BEGIN and END blocks)",
1638 "-d[:debugger] run program under debugger",
1639 "-D[number/list] set debugging flags (argument is a bit mask or alphabets)",
1640 "-e 'command' one line of program (several -e's allowed, omit programfile)",
1641 "-F/pattern/ split() pattern for -a switch (//'s are optional)",
1642 "-i[extension] edit <> files in place (makes backup if extension supplied)",
1643 "-Idirectory specify @INC/#include directory (several -I's allowed)",
1644 "-l[octal] enable line ending processing, specifies line terminator",
1645 "-[mM][-]module execute `use/no module...' before executing program",
1646 "-n assume 'while (<>) { ... }' loop around program",
1647 "-p assume loop like -n but print line also, like sed",
1648 "-P run program through C preprocessor before compilation",
1649 "-s enable rudimentary parsing for switches after programfile",
1650 "-S look for programfile using PATH environment variable",
1651 "-T enable tainting checks",
1652 "-u dump core after parsing program",
1653 "-U allow unsafe operations",
1654 "-v print version, subversion (includes VERY IMPORTANT perl info)",
1655 "-V[:variable] print configuration summary (or a single Config.pm variable)",
1656 "-w enable many useful warnings (RECOMMENDED)",
1657 "-x[directory] strip off text before #!perl line and perhaps cd to directory",
1661 char **p = usage_msg;
1663 printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1665 printf("\n %s", *p++);
1668 /* This routine handles any switches that can be given during run */
1671 Perl_moreswitches(pTHX_ char *s)
1680 rschar = (U32)scan_oct(s, 4, &numlen);
1681 SvREFCNT_dec(PL_nrs);
1682 if (rschar & ~((U8)~0))
1683 PL_nrs = &PL_sv_undef;
1684 else if (!rschar && numlen >= 2)
1685 PL_nrs = newSVpvn("", 0);
1688 PL_nrs = newSVpvn(&ch, 1);
1694 PL_splitstr = savepv(s + 1);
1708 if (*s == ':' || *s == '=') {
1709 my_setenv("PERL5DB", Perl_form(aTHX_ "use Devel::%s;", ++s));
1713 PL_perldb = PERLDB_ALL;
1721 if (isALPHA(s[1])) {
1722 static char debopts[] = "psltocPmfrxuLHXDS";
1725 for (s++; *s && (d = strchr(debopts,*s)); s++)
1726 PL_debug |= 1 << (d - debopts);
1729 PL_debug = atoi(s+1);
1730 for (s++; isDIGIT(*s); s++) ;
1732 PL_debug |= 0x80000000;
1735 if (ckWARN_d(WARN_DEBUGGING))
1736 Perl_warner(aTHX_ WARN_DEBUGGING,
1737 "Recompile perl with -DDEBUGGING to use -D switch\n");
1738 for (s++; isALNUM(*s); s++) ;
1744 usage(PL_origargv[0]);
1748 Safefree(PL_inplace);
1749 PL_inplace = savepv(s+1);
1751 for (s = PL_inplace; *s && !isSPACE(*s); s++) ;
1754 if (*s == '-') /* Additional switches on #! line. */
1758 case 'I': /* -I handled both here and in parse_perl() */
1761 while (*s && isSPACE(*s))
1766 /* ignore trailing spaces (possibly followed by other switches) */
1768 for (e = p; *e && !isSPACE(*e); e++) ;
1772 } while (*p && *p != '-');
1773 e = savepvn(s, e-s);
1781 Perl_croak(aTHX_ "No directory specified for -I");
1789 PL_ors = savepv("\n");
1791 *PL_ors = (char)scan_oct(s, 3 + (*s == '0'), &numlen);
1796 if (RsPARA(PL_nrs)) {
1801 PL_ors = SvPV(PL_nrs, PL_orslen);
1802 PL_ors = savepvn(PL_ors, PL_orslen);
1806 forbid_setid("-M"); /* XXX ? */
1809 forbid_setid("-m"); /* XXX ? */
1814 /* -M-foo == 'no foo' */
1815 if (*s == '-') { use = "no "; ++s; }
1816 sv = newSVpv(use,0);
1818 /* We allow -M'Module qw(Foo Bar)' */
1819 while(isALNUM(*s) || *s==':') ++s;
1821 sv_catpv(sv, start);
1822 if (*(start-1) == 'm') {
1824 Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
1825 sv_catpv( sv, " ()");
1828 sv_catpvn(sv, start, s-start);
1829 sv_catpv(sv, " split(/,/,q{");
1835 PL_preambleav = newAV();
1836 av_push(PL_preambleav, sv);
1839 Perl_croak(aTHX_ "No space allowed after -%c", *(s-1));
1851 PL_doswitches = TRUE;
1856 Perl_croak(aTHX_ "Too late for \"-T\" option");
1860 PL_do_undump = TRUE;
1868 printf("\nThis is perl, v%"UVuf".%"UVuf".%"UVuf" built for %s",
1869 (UV)PERL_REVISION, (UV)PERL_VERSION, (UV)PERL_SUBVERSION, ARCHNAME);
1870 #if defined(LOCAL_PATCH_COUNT)
1871 if (LOCAL_PATCH_COUNT > 0)
1872 printf("\n(with %d registered patch%s, see perl -V for more detail)",
1873 (int)LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : "");
1876 printf("\n\nCopyright 1987-1999, Larry Wall\n");
1878 printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1881 printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
1882 printf("djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
1885 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1886 "Version 5 port Copyright (c) 1994-1999, Andreas Kaiser, Ilya Zakharevich\n");
1889 printf("atariST series port, ++jrb bammi@cadence.com\n");
1892 printf("BeOS port Copyright Tom Spindler, 1997-1999\n");
1895 printf("MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-1999\n");
1898 printf("MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
1901 printf("Stratus VOS port by Paul_Green@stratus.com, 1997-1999\n");
1904 printf("VM/ESA port by Neale Ferguson, 1998-1999\n");
1907 printf("BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
1910 printf("MiNT port by Guido Flohr, 1997-1999\n");
1912 #ifdef BINARY_BUILD_NOTICE
1913 BINARY_BUILD_NOTICE;
1916 Perl may be copied only under the terms of either the Artistic License or the\n\
1917 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n\
1918 Complete documentation for Perl, including FAQ lists, should be found on\n\
1919 this system using `man perl' or `perldoc perl'. If you have access to the\n\
1920 Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
1923 if (! (PL_dowarn & G_WARN_ALL_MASK))
1924 PL_dowarn |= G_WARN_ON;
1928 PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
1929 PL_compiling.cop_warnings = WARN_ALL ;
1933 PL_dowarn = G_WARN_ALL_OFF;
1934 PL_compiling.cop_warnings = WARN_NONE ;
1939 if (s[1] == '-') /* Additional switches on #! line. */
1944 #if defined(WIN32) || !defined(PERL_STRICT_CR)
1950 #ifdef ALTERNATE_SHEBANG
1951 case 'S': /* OS/2 needs -S on "extproc" line. */
1959 Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
1964 /* compliments of Tom Christiansen */
1966 /* unexec() can be found in the Gnu emacs distribution */
1967 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
1970 Perl_my_unexec(pTHX)
1978 prog = newSVpv(BIN_EXP, 0);
1979 sv_catpv(prog, "/perl");
1980 file = newSVpv(PL_origfilename, 0);
1981 sv_catpv(file, ".perldump");
1983 unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
1984 /* unexec prints msg to stderr in case of failure */
1985 PerlProc_exit(status);
1988 # include <lib$routines.h>
1989 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
1991 ABORT(); /* for use with undump */
1996 /* initialize curinterp */
2001 #ifdef PERL_OBJECT /* XXX kludge */
2004 PL_chopset = " \n-"; \
2005 PL_copline = NOLINE; \
2006 PL_curcop = &PL_compiling;\
2007 PL_curcopdb = NULL; \
2009 PL_dumpindent = 4; \
2010 PL_laststatval = -1; \
2011 PL_laststype = OP_STAT; \
2012 PL_maxscream = -1; \
2013 PL_maxsysfd = MAXSYSFD; \
2014 PL_statname = Nullsv; \
2015 PL_tmps_floor = -1; \
2017 PL_op_mask = NULL; \
2018 PL_laststatval = -1; \
2019 PL_laststype = OP_STAT; \
2020 PL_mess_sv = Nullsv; \
2021 PL_splitstr = " "; \
2022 PL_generation = 100; \
2023 PL_exitlist = NULL; \
2024 PL_exitlistlen = 0; \
2026 PL_in_clean_objs = FALSE; \
2027 PL_in_clean_all = FALSE; \
2028 PL_profiledata = NULL; \
2030 PL_rsfp_filters = Nullav; \
2035 # ifdef MULTIPLICITY
2036 # define PERLVAR(var,type)
2037 # define PERLVARA(var,n,type)
2038 # if defined(PERL_IMPLICIT_CONTEXT)
2039 # if defined(USE_THREADS)
2040 # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
2041 # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
2042 # else /* !USE_THREADS */
2043 # define PERLVARI(var,type,init) aTHX->var = init;
2044 # define PERLVARIC(var,type,init) aTHX->var = init;
2045 # endif /* USE_THREADS */
2047 # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
2048 # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
2050 # include "intrpvar.h"
2051 # ifndef USE_THREADS
2052 # include "thrdvar.h"
2059 # define PERLVAR(var,type)
2060 # define PERLVARA(var,n,type)
2061 # define PERLVARI(var,type,init) PL_##var = init;
2062 # define PERLVARIC(var,type,init) PL_##var = init;
2063 # include "intrpvar.h"
2064 # ifndef USE_THREADS
2065 # include "thrdvar.h"
2077 S_init_main_stash(pTHX)
2082 /* Note that strtab is a rather special HV. Assumptions are made
2083 about not iterating on it, and not adding tie magic to it.
2084 It is properly deallocated in perl_destruct() */
2085 PL_strtab = newHV();
2087 MUTEX_INIT(&PL_strtab_mutex);
2089 HvSHAREKEYS_off(PL_strtab); /* mandatory */
2090 hv_ksplit(PL_strtab, 512);
2092 PL_curstash = PL_defstash = newHV();
2093 PL_curstname = newSVpvn("main",4);
2094 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
2095 SvREFCNT_dec(GvHV(gv));
2096 GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
2098 HvNAME(PL_defstash) = savepv("main");
2099 PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
2100 GvMULTI_on(PL_incgv);
2101 PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
2102 GvMULTI_on(PL_hintgv);
2103 PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
2104 PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
2105 GvMULTI_on(PL_errgv);
2106 PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
2107 GvMULTI_on(PL_replgv);
2108 (void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */
2109 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
2110 sv_setpvn(ERRSV, "", 0);
2111 PL_curstash = PL_defstash;
2112 CopSTASH_set(&PL_compiling, PL_defstash);
2113 PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
2114 PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
2115 /* We must init $/ before switches are processed. */
2116 sv_setpvn(get_sv("/", TRUE), "\n", 1);
2120 S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
2128 PL_origfilename = savepv("-e");
2131 /* if find_script() returns, it returns a malloc()-ed value */
2132 PL_origfilename = scriptname = find_script(scriptname, dosearch, NULL, 1);
2134 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
2135 char *s = scriptname + 8;
2136 *fdscript = atoi(s);
2140 scriptname = savepv(s + 1);
2141 Safefree(PL_origfilename);
2142 PL_origfilename = scriptname;
2147 CopFILE_set(PL_curcop, PL_origfilename);
2148 if (strEQ(PL_origfilename,"-"))
2150 if (*fdscript >= 0) {
2151 PL_rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE);
2152 #if defined(HAS_FCNTL) && defined(F_SETFD)
2154 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); /* ensure close-on-exec */
2157 else if (PL_preprocess) {
2158 char *cpp_cfg = CPPSTDIN;
2159 SV *cpp = newSVpvn("",0);
2160 SV *cmd = NEWSV(0,0);
2162 if (strEQ(cpp_cfg, "cppstdin"))
2163 Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
2164 sv_catpv(cpp, cpp_cfg);
2166 sv_catpvn(sv, "-I", 2);
2167 sv_catpv(sv,PRIVLIB_EXP);
2170 Perl_sv_setpvf(aTHX_ cmd, "\
2171 sed %s -e \"/^[^#]/b\" \
2172 -e \"/^#[ ]*include[ ]/b\" \
2173 -e \"/^#[ ]*define[ ]/b\" \
2174 -e \"/^#[ ]*if[ ]/b\" \
2175 -e \"/^#[ ]*ifdef[ ]/b\" \
2176 -e \"/^#[ ]*ifndef[ ]/b\" \
2177 -e \"/^#[ ]*else/b\" \
2178 -e \"/^#[ ]*elif[ ]/b\" \
2179 -e \"/^#[ ]*undef[ ]/b\" \
2180 -e \"/^#[ ]*endif/b\" \
2183 (PL_doextract ? "-e \"1,/^#/d\n\"" : ""),
2186 Perl_sv_setpvf(aTHX_ cmd, "\
2187 %s %s -e '/^[^#]/b' \
2188 -e '/^#[ ]*include[ ]/b' \
2189 -e '/^#[ ]*define[ ]/b' \
2190 -e '/^#[ ]*if[ ]/b' \
2191 -e '/^#[ ]*ifdef[ ]/b' \
2192 -e '/^#[ ]*ifndef[ ]/b' \
2193 -e '/^#[ ]*else/b' \
2194 -e '/^#[ ]*elif[ ]/b' \
2195 -e '/^#[ ]*undef[ ]/b' \
2196 -e '/^#[ ]*endif/b' \
2200 Perl_sv_setpvf(aTHX_ cmd, "\
2201 %s %s -e '/^[^#]/b' \
2202 -e '/^#[ ]*include[ ]/b' \
2203 -e '/^#[ ]*define[ ]/b' \
2204 -e '/^#[ ]*if[ ]/b' \
2205 -e '/^#[ ]*ifdef[ ]/b' \
2206 -e '/^#[ ]*ifndef[ ]/b' \
2207 -e '/^#[ ]*else/b' \
2208 -e '/^#[ ]*elif[ ]/b' \
2209 -e '/^#[ ]*undef[ ]/b' \
2210 -e '/^#[ ]*endif/b' \
2219 (PL_doextract ? "-e '1,/^#/d\n'" : ""),
2221 scriptname, cpp, sv, CPPMINUS);
2222 PL_doextract = FALSE;
2223 #ifdef IAMSUID /* actually, this is caught earlier */
2224 if (PL_euid != PL_uid && !PL_euid) { /* if running suidperl */
2226 (void)seteuid(PL_uid); /* musn't stay setuid root */
2229 (void)setreuid((Uid_t)-1, PL_uid);
2231 #ifdef HAS_SETRESUID
2232 (void)setresuid((Uid_t)-1, PL_uid, (Uid_t)-1);
2234 PerlProc_setuid(PL_uid);
2238 if (PerlProc_geteuid() != PL_uid)
2239 Perl_croak(aTHX_ "Can't do seteuid!\n");
2241 #endif /* IAMSUID */
2242 PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
2246 else if (!*scriptname) {
2247 forbid_setid("program input from stdin");
2248 PL_rsfp = PerlIO_stdin();
2251 PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
2252 #if defined(HAS_FCNTL) && defined(F_SETFD)
2254 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); /* ensure close-on-exec */
2259 #ifndef IAMSUID /* in case script is not readable before setuid */
2261 PerlLIO_stat(CopFILE(PL_curcop),&PL_statbuf) >= 0 &&
2262 PL_statbuf.st_mode & (S_ISUID|S_ISGID))
2265 PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
2266 (UV)PERL_REVISION, (UV)PERL_VERSION,
2267 (UV)PERL_SUBVERSION), PL_origargv);
2268 Perl_croak(aTHX_ "Can't do setuid\n");
2272 Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
2273 CopFILE(PL_curcop), Strerror(errno));
2278 * I_SYSSTATVFS HAS_FSTATVFS
2280 * I_STATFS HAS_FSTATFS
2281 * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT
2282 * here so that metaconfig picks them up. */
2286 S_fd_on_nosuid_fs(pTHX_ int fd)
2288 int check_okay = 0; /* able to do all the required sys/libcalls */
2289 int on_nosuid = 0; /* the fd is on a nosuid fs */
2291 * Preferred order: fstatvfs(), fstatfs(), ustat()+getmnt(), getmntent().
2292 * fstatvfs() is UNIX98.
2293 * fstatfs() is 4.3 BSD.
2294 * ustat()+getmnt() is pre-4.3 BSD.
2295 * getmntent() is O(number-of-mounted-filesystems) and can hang on
2296 * an irrelevant filesystem while trying to reach the right one.
2299 # ifdef HAS_FSTATVFS
2300 struct statvfs stfs;
2301 check_okay = fstatvfs(fd, &stfs) == 0;
2302 on_nosuid = check_okay && (stfs.f_flag & ST_NOSUID);
2304 # ifdef PERL_MOUNT_NOSUID
2305 # if defined(HAS_FSTATFS) && \
2306 defined(HAS_STRUCT_STATFS) && \
2307 defined(HAS_STRUCT_STATFS_F_FLAGS)
2309 check_okay = fstatfs(fd, &stfs) == 0;
2310 on_nosuid = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
2312 # if defined(HAS_FSTAT) && \
2313 defined(HAS_USTAT) && \
2314 defined(HAS_GETMNT) && \
2315 defined(HAS_STRUCT_FS_DATA) && \
2318 if (fstat(fd, &fdst) == 0) {
2320 if (ustat(fdst.st_dev, &us) == 0) {
2322 /* NOSTAT_ONE here because we're not examining fields which
2323 * vary between that case and STAT_ONE. */
2324 if (getmnt((int*)0, &fsd, (int)0, NOSTAT_ONE, us.f_fname) == 0) {
2325 size_t cmplen = sizeof(us.f_fname);
2326 if (sizeof(fsd.fd_req.path) < cmplen)
2327 cmplen = sizeof(fsd.fd_req.path);
2328 if (strnEQ(fsd.fd_req.path, us.f_fname, cmplen) &&
2329 fdst.st_dev == fsd.fd_req.dev) {
2331 on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID;
2337 # endif /* fstat+ustat+getmnt */
2338 # endif /* fstatfs */
2340 # if defined(HAS_GETMNTENT) && \
2341 defined(HAS_HASMNTOPT) && \
2342 defined(MNTOPT_NOSUID)
2343 FILE *mtab = fopen("/etc/mtab", "r");
2344 struct mntent *entry;
2345 struct stat stb, fsb;
2347 if (mtab && (fstat(fd, &stb) == 0)) {
2348 while (entry = getmntent(mtab)) {
2349 if (stat(entry->mnt_dir, &fsb) == 0
2350 && fsb.st_dev == stb.st_dev)
2352 /* found the filesystem */
2354 if (hasmntopt(entry, MNTOPT_NOSUID))
2357 } /* A single fs may well fail its stat(). */
2362 # endif /* getmntent+hasmntopt */
2363 # endif /* PERL_MOUNT_NOSUID: fstatfs or fstat+ustat+statfs */
2364 # endif /* statvfs */
2367 Perl_croak(aTHX_ "Can't check filesystem of script \"%s\" for nosuid", PL_origfilename);
2370 #endif /* IAMSUID */
2373 S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript)
2377 /* do we need to emulate setuid on scripts? */
2379 /* This code is for those BSD systems that have setuid #! scripts disabled
2380 * in the kernel because of a security problem. Merely defining DOSUID
2381 * in perl will not fix that problem, but if you have disabled setuid
2382 * scripts in the kernel, this will attempt to emulate setuid and setgid
2383 * on scripts that have those now-otherwise-useless bits set. The setuid
2384 * root version must be called suidperl or sperlN.NNN. If regular perl
2385 * discovers that it has opened a setuid script, it calls suidperl with
2386 * the same argv that it had. If suidperl finds that the script it has
2387 * just opened is NOT setuid root, it sets the effective uid back to the
2388 * uid. We don't just make perl setuid root because that loses the
2389 * effective uid we had before invoking perl, if it was different from the
2392 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
2393 * be defined in suidperl only. suidperl must be setuid root. The
2394 * Configure script will set this up for you if you want it.
2401 if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */
2402 Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
2403 if (fdscript < 0 && PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
2408 #ifndef HAS_SETREUID
2409 /* On this access check to make sure the directories are readable,
2410 * there is actually a small window that the user could use to make
2411 * filename point to an accessible directory. So there is a faint
2412 * chance that someone could execute a setuid script down in a
2413 * non-accessible directory. I don't know what to do about that.
2414 * But I don't think it's too important. The manual lies when
2415 * it says access() is useful in setuid programs.
2417 if (PerlLIO_access(CopFILE(PL_curcop),1)) /*double check*/
2418 Perl_croak(aTHX_ "Permission denied");
2420 /* If we can swap euid and uid, then we can determine access rights
2421 * with a simple stat of the file, and then compare device and
2422 * inode to make sure we did stat() on the same file we opened.
2423 * Then we just have to make sure he or she can execute it.
2426 struct stat tmpstatbuf;
2430 setreuid(PL_euid,PL_uid) < 0
2433 setresuid(PL_euid,PL_uid,(Uid_t)-1) < 0
2436 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
2437 Perl_croak(aTHX_ "Can't swap uid and euid"); /* really paranoid */
2438 if (PerlLIO_stat(CopFILE(PL_curcop),&tmpstatbuf) < 0)
2439 Perl_croak(aTHX_ "Permission denied"); /* testing full pathname here */
2440 #if defined(IAMSUID) && !defined(NO_NOSUID_CHECK)
2441 if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp)))
2442 Perl_croak(aTHX_ "Permission denied");
2444 if (tmpstatbuf.st_dev != PL_statbuf.st_dev ||
2445 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
2446 (void)PerlIO_close(PL_rsfp);
2447 if (PL_rsfp = PerlProc_popen("/bin/mail root","w")) { /* heh, heh */
2448 PerlIO_printf(PL_rsfp,
2449 "User %"Uid_t_f" tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2450 (Filename of set-id script was %s, uid %"Uid_t_f" gid %"Gid_t_f".)\n\nSincerely,\nperl\n",
2451 PL_uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
2452 (long)PL_statbuf.st_dev, (long)PL_statbuf.st_ino,
2454 PL_statbuf.st_uid, PL_statbuf.st_gid);
2455 (void)PerlProc_pclose(PL_rsfp);
2457 Perl_croak(aTHX_ "Permission denied\n");
2461 setreuid(PL_uid,PL_euid) < 0
2463 # if defined(HAS_SETRESUID)
2464 setresuid(PL_uid,PL_euid,(Uid_t)-1) < 0
2467 || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
2468 Perl_croak(aTHX_ "Can't reswap uid and euid");
2469 if (!cando(S_IXUSR,FALSE,&PL_statbuf)) /* can real uid exec? */
2470 Perl_croak(aTHX_ "Permission denied\n");
2472 #endif /* HAS_SETREUID */
2473 #endif /* IAMSUID */
2475 if (!S_ISREG(PL_statbuf.st_mode))
2476 Perl_croak(aTHX_ "Permission denied");
2477 if (PL_statbuf.st_mode & S_IWOTH)
2478 Perl_croak(aTHX_ "Setuid/gid script is writable by world");
2479 PL_doswitches = FALSE; /* -s is insecure in suid */
2480 CopLINE_inc(PL_curcop);
2481 if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
2482 strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */
2483 Perl_croak(aTHX_ "No #! line");
2484 s = SvPV(PL_linestr,n_a)+2;
2486 while (!isSPACE(*s)) s++;
2487 for (s2 = s; (s2 > SvPV(PL_linestr,n_a)+2 &&
2488 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
2489 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
2490 Perl_croak(aTHX_ "Not a perl script");
2491 while (*s == ' ' || *s == '\t') s++;
2493 * #! arg must be what we saw above. They can invoke it by
2494 * mentioning suidperl explicitly, but they may not add any strange
2495 * arguments beyond what #! says if they do invoke suidperl that way.
2497 len = strlen(validarg);
2498 if (strEQ(validarg," PHOOEY ") ||
2499 strnNE(s,validarg,len) || !isSPACE(s[len]))
2500 Perl_croak(aTHX_ "Args must match #! line");
2503 if (PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
2504 PL_euid == PL_statbuf.st_uid)
2506 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2507 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2508 #endif /* IAMSUID */
2510 if (PL_euid) { /* oops, we're not the setuid root perl */
2511 (void)PerlIO_close(PL_rsfp);
2514 PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
2515 (UV)PERL_REVISION, (UV)PERL_VERSION,
2516 (UV)PERL_SUBVERSION), PL_origargv);
2518 Perl_croak(aTHX_ "Can't do setuid\n");
2521 if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
2523 (void)setegid(PL_statbuf.st_gid);
2526 (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
2528 #ifdef HAS_SETRESGID
2529 (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
2531 PerlProc_setgid(PL_statbuf.st_gid);
2535 if (PerlProc_getegid() != PL_statbuf.st_gid)
2536 Perl_croak(aTHX_ "Can't do setegid!\n");
2538 if (PL_statbuf.st_mode & S_ISUID) {
2539 if (PL_statbuf.st_uid != PL_euid)
2541 (void)seteuid(PL_statbuf.st_uid); /* all that for this */
2544 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
2546 #ifdef HAS_SETRESUID
2547 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
2549 PerlProc_setuid(PL_statbuf.st_uid);
2553 if (PerlProc_geteuid() != PL_statbuf.st_uid)
2554 Perl_croak(aTHX_ "Can't do seteuid!\n");
2556 else if (PL_uid) { /* oops, mustn't run as root */
2558 (void)seteuid((Uid_t)PL_uid);
2561 (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
2563 #ifdef HAS_SETRESUID
2564 (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
2566 PerlProc_setuid((Uid_t)PL_uid);
2570 if (PerlProc_geteuid() != PL_uid)
2571 Perl_croak(aTHX_ "Can't do seteuid!\n");
2574 if (!cando(S_IXUSR,TRUE,&PL_statbuf))
2575 Perl_croak(aTHX_ "Permission denied\n"); /* they can't do this */
2578 else if (PL_preprocess)
2579 Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
2580 else if (fdscript >= 0)
2581 Perl_croak(aTHX_ "fd script not allowed in suidperl\n");
2583 Perl_croak(aTHX_ "Script is not setuid/setgid in suidperl\n");
2585 /* We absolutely must clear out any saved ids here, so we */
2586 /* exec the real perl, substituting fd script for scriptname. */
2587 /* (We pass script name as "subdir" of fd, which perl will grok.) */
2588 PerlIO_rewind(PL_rsfp);
2589 PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0); /* just in case rewind didn't */
2590 for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
2591 if (!PL_origargv[which])
2592 Perl_croak(aTHX_ "Permission denied");
2593 PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
2594 PerlIO_fileno(PL_rsfp), PL_origargv[which]));
2595 #if defined(HAS_FCNTL) && defined(F_SETFD)
2596 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */
2598 PerlProc_execv(Perl_form(aTHX_ "%s/perl"PERL_FS_VER_FMT, BIN_EXP,
2599 (UV)PERL_REVISION, (UV)PERL_VERSION,
2600 (UV)PERL_SUBVERSION), PL_origargv);/* try again */
2601 Perl_croak(aTHX_ "Can't do setuid\n");
2602 #endif /* IAMSUID */
2604 if (PL_euid != PL_uid || PL_egid != PL_gid) { /* (suidperl doesn't exist, in fact) */
2605 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2607 PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf); /* may be either wrapped or real suid */
2608 if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
2610 (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
2613 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2614 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2615 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2616 /* not set-id, must be wrapped */
2622 S_find_beginning(pTHX)
2624 register char *s, *s2;
2626 /* skip forward in input to the real script? */
2629 while (PL_doextract) {
2630 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
2631 Perl_croak(aTHX_ "No Perl script found in input\n");
2632 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2633 PerlIO_ungetc(PL_rsfp, '\n'); /* to keep line count right */
2634 PL_doextract = FALSE;
2635 while (*s && !(isSPACE (*s) || *s == '#')) s++;
2637 while (*s == ' ' || *s == '\t') s++;
2639 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2640 if (strnEQ(s2-4,"perl",4))
2642 while (s = moreswitches(s)) ;
2652 PL_uid = PerlProc_getuid();
2653 PL_euid = PerlProc_geteuid();
2654 PL_gid = PerlProc_getgid();
2655 PL_egid = PerlProc_getegid();
2657 PL_uid |= PL_gid << 16;
2658 PL_euid |= PL_egid << 16;
2660 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2664 S_forbid_setid(pTHX_ char *s)
2666 if (PL_euid != PL_uid)
2667 Perl_croak(aTHX_ "No %s allowed while running setuid", s);
2668 if (PL_egid != PL_gid)
2669 Perl_croak(aTHX_ "No %s allowed while running setgid", s);
2673 Perl_init_debugger(pTHX)
2676 HV *ostash = PL_curstash;
2678 PL_curstash = PL_debstash;
2679 PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2680 AvREAL_off(PL_dbargs);
2681 PL_DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2682 PL_DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2683 PL_DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2684 sv_upgrade(GvSV(PL_DBsub), SVt_IV); /* IVX accessed if PERLDB_SUB_NN */
2685 PL_DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2686 sv_setiv(PL_DBsingle, 0);
2687 PL_DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2688 sv_setiv(PL_DBtrace, 0);
2689 PL_DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2690 sv_setiv(PL_DBsignal, 0);
2691 PL_curstash = ostash;
2694 #ifndef STRESS_REALLOC
2695 #define REASONABLE(size) (size)
2697 #define REASONABLE(size) (1) /* unreasonable */
2701 Perl_init_stacks(pTHX)
2703 /* start with 128-item stack and 8K cxstack */
2704 PL_curstackinfo = new_stackinfo(REASONABLE(128),
2705 REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
2706 PL_curstackinfo->si_type = PERLSI_MAIN;
2707 PL_curstack = PL_curstackinfo->si_stack;
2708 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
2710 PL_stack_base = AvARRAY(PL_curstack);
2711 PL_stack_sp = PL_stack_base;
2712 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
2714 New(50,PL_tmps_stack,REASONABLE(128),SV*);
2717 PL_tmps_max = REASONABLE(128);
2719 New(54,PL_markstack,REASONABLE(32),I32);
2720 PL_markstack_ptr = PL_markstack;
2721 PL_markstack_max = PL_markstack + REASONABLE(32);
2725 New(54,PL_scopestack,REASONABLE(32),I32);
2726 PL_scopestack_ix = 0;
2727 PL_scopestack_max = REASONABLE(32);
2729 New(54,PL_savestack,REASONABLE(128),ANY);
2730 PL_savestack_ix = 0;
2731 PL_savestack_max = REASONABLE(128);
2733 New(54,PL_retstack,REASONABLE(16),OP*);
2735 PL_retstack_max = REASONABLE(16);
2744 while (PL_curstackinfo->si_next)
2745 PL_curstackinfo = PL_curstackinfo->si_next;
2746 while (PL_curstackinfo) {
2747 PERL_SI *p = PL_curstackinfo->si_prev;
2748 /* curstackinfo->si_stack got nuked by sv_free_arenas() */
2749 Safefree(PL_curstackinfo->si_cxstack);
2750 Safefree(PL_curstackinfo);
2751 PL_curstackinfo = p;
2753 Safefree(PL_tmps_stack);
2754 Safefree(PL_markstack);
2755 Safefree(PL_scopestack);
2756 Safefree(PL_savestack);
2757 Safefree(PL_retstack);
2761 static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
2772 lex_start(PL_linestr);
2774 PL_subname = newSVpvn("main",4);
2778 S_init_predump_symbols(pTHX)
2785 sv_setpvn(get_sv("\"", TRUE), " ", 1);
2786 PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2787 GvMULTI_on(PL_stdingv);
2788 io = GvIOp(PL_stdingv);
2789 IoIFP(io) = PerlIO_stdin();
2790 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2792 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
2794 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2797 IoOFP(io) = IoIFP(io) = PerlIO_stdout();
2799 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2801 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
2803 PL_stderrgv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2804 GvMULTI_on(PL_stderrgv);
2805 io = GvIOp(PL_stderrgv);
2806 IoOFP(io) = IoIFP(io) = PerlIO_stderr();
2807 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2809 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
2811 PL_statname = NEWSV(66,0); /* last filename we did stat on */
2814 PL_osname = savepv(OSNAME);
2818 S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
2825 argc--,argv++; /* skip name of script */
2826 if (PL_doswitches) {
2827 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2830 if (argv[0][1] == '-') {
2834 if (s = strchr(argv[0], '=')) {
2836 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2839 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2842 PL_toptarget = NEWSV(0,0);
2843 sv_upgrade(PL_toptarget, SVt_PVFM);
2844 sv_setpvn(PL_toptarget, "", 0);
2845 PL_bodytarget = NEWSV(0,0);
2846 sv_upgrade(PL_bodytarget, SVt_PVFM);
2847 sv_setpvn(PL_bodytarget, "", 0);
2848 PL_formtarget = PL_bodytarget;
2851 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2852 sv_setpv(GvSV(tmpgv),PL_origfilename);
2853 magicname("0", "0", 1);
2855 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2857 sv_setpv(GvSV(tmpgv), os2_execname());
2859 sv_setpv(GvSV(tmpgv),PL_origargv[0]);
2861 if (PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2862 GvMULTI_on(PL_argvgv);
2863 (void)gv_AVadd(PL_argvgv);
2864 av_clear(GvAVn(PL_argvgv));
2865 for (; argc > 0; argc--,argv++) {
2866 av_push(GvAVn(PL_argvgv),newSVpv(argv[0],0));
2869 if (PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2871 GvMULTI_on(PL_envgv);
2872 hv = GvHVn(PL_envgv);
2873 hv_magic(hv, PL_envgv, 'E');
2874 #if !defined( VMS) && !defined(EPOC) /* VMS doesn't have environ array */
2875 /* Note that if the supplied env parameter is actually a copy
2876 of the global environ then it may now point to free'd memory
2877 if the environment has been modified since. To avoid this
2878 problem we treat env==NULL as meaning 'use the default'
2883 environ[0] = Nullch;
2884 for (; *env; env++) {
2885 if (!(s = strchr(*env,'=')))
2891 sv = newSVpv(s--,0);
2892 (void)hv_store(hv, *env, s - *env, sv, 0);
2894 #if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
2895 /* Sins of the RTL. See note in my_setenv(). */
2896 (void)PerlEnv_putenv(savepv(*env));
2900 #ifdef DYNAMIC_ENV_FETCH
2901 HvNAME(hv) = savepv(ENV_HV_NAME);
2905 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2906 sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
2910 S_init_perllib(pTHX)
2915 s = PerlEnv_getenv("PERL5LIB");
2919 incpush(PerlEnv_getenv("PERLLIB"), FALSE);
2921 /* Treat PERL5?LIB as a possible search list logical name -- the
2922 * "natural" VMS idiom for a Unix path string. We allow each
2923 * element to be a set of |-separated directories for compatibility.
2927 if (my_trnlnm("PERL5LIB",buf,0))
2928 do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2930 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2934 /* Use the ~-expanded versions of APPLLIB (undocumented),
2935 ARCHLIB PRIVLIB SITEARCH and SITELIB
2938 incpush(APPLLIB_EXP, TRUE);
2942 incpush(ARCHLIB_EXP, FALSE);
2945 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2948 incpush(PRIVLIB_EXP, TRUE);
2950 incpush(PRIVLIB_EXP, FALSE);
2954 incpush(SITEARCH_EXP, FALSE);
2958 incpush(SITELIB_EXP, TRUE);
2960 incpush(SITELIB_EXP, FALSE);
2963 #if defined(PERL_VENDORLIB_EXP)
2965 incpush(PERL_VENDORLIB_EXP, TRUE);
2967 incpush(PERL_VENDORLIB_EXP, FALSE);
2971 incpush(".", FALSE);
2975 # define PERLLIB_SEP ';'
2978 # define PERLLIB_SEP '|'
2980 # define PERLLIB_SEP ':'
2983 #ifndef PERLLIB_MANGLE
2984 # define PERLLIB_MANGLE(s,n) (s)
2988 S_incpush(pTHX_ char *p, int addsubdirs)
2990 SV *subdir = Nullsv;
2996 subdir = sv_newmortal();
2999 /* Break at all separators */
3001 SV *libdir = NEWSV(55,0);
3004 /* skip any consecutive separators */
3005 while ( *p == PERLLIB_SEP ) {
3006 /* Uncomment the next line for PATH semantics */
3007 /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */
3011 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
3012 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
3017 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
3018 p = Nullch; /* break out */
3022 * BEFORE pushing libdir onto @INC we may first push version- and
3023 * archname-specific sub-directories.
3026 struct stat tmpstatbuf;
3031 if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) {
3033 while (unix[len-1] == '/') len--; /* Cosmetic */
3034 sv_usepvn(libdir,unix,len);
3037 PerlIO_printf(Perl_error_log,
3038 "Failed to unixify @INC element \"%s\"\n",
3041 /* .../archname/version if -d .../archname/version/auto */
3042 Perl_sv_setpvf(aTHX_ subdir, "%_/%s/"PERL_FS_VER_FMT"/auto", libdir,
3043 ARCHNAME, (UV)PERL_REVISION,
3044 (UV)PERL_VERSION, (UV)PERL_SUBVERSION);
3045 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3046 S_ISDIR(tmpstatbuf.st_mode))
3047 av_push(GvAVn(PL_incgv),
3048 newSVpvn(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
3050 /* .../archname if -d .../archname/auto */
3051 Perl_sv_setpvf(aTHX_ subdir, "%_/%s/auto", libdir, ARCHNAME);
3052 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3053 S_ISDIR(tmpstatbuf.st_mode))
3054 av_push(GvAVn(PL_incgv),
3055 newSVpvn(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
3058 /* finally push this lib directory on the end of @INC */
3059 av_push(GvAVn(PL_incgv), libdir);
3064 STATIC struct perl_thread *
3065 S_init_main_thread(pTHX)
3067 #if !defined(PERL_IMPLICIT_CONTEXT)
3068 struct perl_thread *thr;
3072 Newz(53, thr, 1, struct perl_thread);
3073 PL_curcop = &PL_compiling;
3074 thr->interp = PERL_GET_INTERP;
3075 thr->cvcache = newHV();
3076 thr->threadsv = newAV();
3077 /* thr->threadsvp is set when find_threadsv is called */
3078 thr->specific = newAV();
3079 thr->flags = THRf_R_JOINABLE;
3080 MUTEX_INIT(&thr->mutex);
3081 /* Handcraft thrsv similarly to mess_sv */
3082 New(53, PL_thrsv, 1, SV);
3083 Newz(53, xpv, 1, XPV);
3084 SvFLAGS(PL_thrsv) = SVt_PV;
3085 SvANY(PL_thrsv) = (void*)xpv;
3086 SvREFCNT(PL_thrsv) = 1 << 30; /* practically infinite */
3087 SvPVX(PL_thrsv) = (char*)thr;
3088 SvCUR_set(PL_thrsv, sizeof(thr));
3089 SvLEN_set(PL_thrsv, sizeof(thr));
3090 *SvEND(PL_thrsv) = '\0'; /* in the trailing_nul field */
3091 thr->oursv = PL_thrsv;
3092 PL_chopset = " \n-";
3095 MUTEX_LOCK(&PL_threads_mutex);
3100 MUTEX_UNLOCK(&PL_threads_mutex);
3102 #ifdef HAVE_THREAD_INTERN
3103 Perl_init_thread_intern(thr);
3106 #ifdef SET_THREAD_SELF
3107 SET_THREAD_SELF(thr);
3109 thr->self = pthread_self();
3110 #endif /* SET_THREAD_SELF */
3114 * These must come after the SET_THR because sv_setpvn does
3115 * SvTAINT and the taint fields require dTHR.
3117 PL_toptarget = NEWSV(0,0);
3118 sv_upgrade(PL_toptarget, SVt_PVFM);
3119 sv_setpvn(PL_toptarget, "", 0);
3120 PL_bodytarget = NEWSV(0,0);
3121 sv_upgrade(PL_bodytarget, SVt_PVFM);
3122 sv_setpvn(PL_bodytarget, "", 0);
3123 PL_formtarget = PL_bodytarget;
3124 thr->errsv = newSVpvn("", 0);
3125 (void) find_threadsv("@"); /* Ensure $@ is initialised early */
3128 PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
3129 PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
3130 PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
3131 PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
3132 PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
3134 PL_reginterp_cnt = 0;
3138 #endif /* USE_THREADS */
3141 Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
3145 line_t oldline = CopLINE(PL_curcop);
3151 while (AvFILL(paramList) >= 0) {
3152 cv = (CV*)av_shift(paramList);
3154 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_list_body), cv);
3158 (void)SvPV(atsv, len);
3161 PL_curcop = &PL_compiling;
3162 CopLINE_set(PL_curcop, oldline);
3163 if (paramList == PL_beginav)
3164 sv_catpv(atsv, "BEGIN failed--compilation aborted");
3166 Perl_sv_catpvf(aTHX_ atsv,
3167 "%s failed--call queue aborted",
3168 paramList == PL_stopav ? "STOP"
3169 : paramList == PL_initav ? "INIT"
3171 while (PL_scopestack_ix > oldscope)
3173 Perl_croak(aTHX_ "%s", SvPVx(atsv, n_a));
3180 /* my_exit() was called */
3181 while (PL_scopestack_ix > oldscope)
3184 PL_curstash = PL_defstash;
3185 PL_curcop = &PL_compiling;
3186 CopLINE_set(PL_curcop, oldline);
3187 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) {
3188 if (paramList == PL_beginav)
3189 Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
3191 Perl_croak(aTHX_ "%s failed--call queue aborted",
3192 paramList == PL_stopav ? "STOP"
3193 : paramList == PL_initav ? "INIT"
3200 PL_curcop = &PL_compiling;
3201 CopLINE_set(PL_curcop, oldline);
3204 PerlIO_printf(Perl_error_log, "panic: restartop\n");
3212 S_call_list_body(pTHX_ va_list args)
3215 CV *cv = va_arg(args, CV*);
3217 PUSHMARK(PL_stack_sp);
3218 call_sv((SV*)cv, G_EVAL|G_DISCARD);
3223 Perl_my_exit(pTHX_ U32 status)
3227 DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
3228 thr, (unsigned long) status));
3237 STATUS_NATIVE_SET(status);
3244 Perl_my_failure_exit(pTHX)
3247 if (vaxc$errno & 1) {
3248 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
3249 STATUS_NATIVE_SET(44);
3252 if (!vaxc$errno && errno) /* unlikely */
3253 STATUS_NATIVE_SET(44);
3255 STATUS_NATIVE_SET(vaxc$errno);
3260 STATUS_POSIX_SET(errno);
3262 exitstatus = STATUS_POSIX >> 8;
3263 if (exitstatus & 255)
3264 STATUS_POSIX_SET(exitstatus);
3266 STATUS_POSIX_SET(255);
3273 S_my_exit_jump(pTHX)
3276 register PERL_CONTEXT *cx;
3281 SvREFCNT_dec(PL_e_script);
3282 PL_e_script = Nullsv;
3285 POPSTACK_TO(PL_mainstack);
3286 if (cxstack_ix >= 0) {
3289 POPBLOCK(cx,PL_curpm);
3301 read_e_script(pTHXo_ int idx, SV *buf_sv, int maxlen)
3304 p = SvPVX(PL_e_script);
3305 nl = strchr(p, '\n');
3306 nl = (nl) ? nl+1 : SvEND(PL_e_script);
3308 filter_del(read_e_script);
3311 sv_catpvn(buf_sv, p, nl-p);
3312 sv_chop(PL_e_script, nl);