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)? */
125 #ifdef ALLOC_THREAD_KEY
128 if (pthread_key_create(&PL_thr_key, 0))
129 Perl_croak(aTHX_ "panic: pthread_key_create");
131 MUTEX_INIT(&PL_sv_mutex);
133 * Safe to use basic SV functions from now on (though
134 * not things like mortals or tainting yet).
136 MUTEX_INIT(&PL_eval_mutex);
137 COND_INIT(&PL_eval_cond);
138 MUTEX_INIT(&PL_threads_mutex);
139 COND_INIT(&PL_nthreads_cond);
140 #ifdef EMULATE_ATOMIC_REFCOUNTS
141 MUTEX_INIT(&PL_svref_mutex);
142 #endif /* EMULATE_ATOMIC_REFCOUNTS */
144 MUTEX_INIT(&PL_cred_mutex);
146 thr = init_main_thread();
147 #endif /* USE_THREADS */
149 PL_protect = MEMBER_TO_FPTR(Perl_default_protect); /* for exceptions */
151 PL_curcop = &PL_compiling; /* needed by ckWARN, right away */
153 PL_linestr = NEWSV(65,79);
154 sv_upgrade(PL_linestr,SVt_PVIV);
156 if (!SvREADONLY(&PL_sv_undef)) {
157 /* set read-only and try to insure than we wont see REFCNT==0
160 SvREADONLY_on(&PL_sv_undef);
161 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
163 sv_setpv(&PL_sv_no,PL_No);
165 SvREADONLY_on(&PL_sv_no);
166 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
168 sv_setpv(&PL_sv_yes,PL_Yes);
170 SvREADONLY_on(&PL_sv_yes);
171 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
176 /* PL_sighandlerp = sighandler; */
178 PL_sighandlerp = Perl_sighandler;
180 PL_pidstatus = newHV();
184 * There is no way we can refer to them from Perl so close them to save
185 * space. The other alternative would be to provide STDAUX and STDPRN
188 (void)fclose(stdaux);
189 (void)fclose(stdprn);
193 PL_nrs = newSVpvn("\n", 1);
194 PL_rs = SvREFCNT_inc(PL_nrs);
199 PL_lex_state = LEX_NOTPARSING;
205 SET_NUMERIC_STANDARD();
209 PL_patchlevel = NEWSV(0,4);
210 SvUPGRADE(PL_patchlevel, SVt_PVNV);
211 if (PERL_REVISION > 127 || PERL_VERSION > 127 || PERL_SUBVERSION > 127)
212 SvGROW(PL_patchlevel,24);
213 s = (U8*)SvPVX(PL_patchlevel);
214 s = uv_to_utf8(s, (UV)PERL_REVISION);
215 s = uv_to_utf8(s, (UV)PERL_VERSION);
216 s = uv_to_utf8(s, (UV)PERL_SUBVERSION);
218 SvCUR_set(PL_patchlevel, s - (U8*)SvPVX(PL_patchlevel));
219 SvPOK_on(PL_patchlevel);
220 SvNVX(PL_patchlevel) = (NV)PERL_REVISION
221 + ((NV)PERL_VERSION / (NV)1000)
222 #if defined(PERL_SUBVERSION) && PERL_SUBVERSION > 0
223 + ((NV)PERL_SUBVERSION / (NV)1000000)
226 SvNOK_on(PL_patchlevel); /* dual valued */
227 SvUTF8_on(PL_patchlevel);
228 SvREADONLY_on(PL_patchlevel);
231 #if defined(LOCAL_PATCH_COUNT)
232 PL_localpatches = local_patches; /* For possible -v */
235 PerlIO_init(); /* Hook to IO system */
237 PL_fdpid = newAV(); /* for remembering popen pids by fd */
238 PL_modglobal = newHV(); /* pointers to per-interpreter module globals */
247 int destruct_level; /* 0=none, 1=full, 2=full with checks */
253 #endif /* USE_THREADS */
255 /* wait for all pseudo-forked children to finish */
256 PERL_WAIT_FOR_CHILDREN;
260 /* Pass 1 on any remaining threads: detach joinables, join zombies */
262 MUTEX_LOCK(&PL_threads_mutex);
263 DEBUG_S(PerlIO_printf(Perl_debug_log,
264 "perl_destruct: waiting for %d threads...\n",
266 for (t = thr->next; t != thr; t = t->next) {
267 MUTEX_LOCK(&t->mutex);
268 switch (ThrSTATE(t)) {
271 DEBUG_S(PerlIO_printf(Perl_debug_log,
272 "perl_destruct: joining zombie %p\n", t));
273 ThrSETSTATE(t, THRf_DEAD);
274 MUTEX_UNLOCK(&t->mutex);
277 * The SvREFCNT_dec below may take a long time (e.g. av
278 * may contain an object scalar whose destructor gets
279 * called) so we have to unlock threads_mutex and start
282 MUTEX_UNLOCK(&PL_threads_mutex);
284 SvREFCNT_dec((SV*)av);
285 DEBUG_S(PerlIO_printf(Perl_debug_log,
286 "perl_destruct: joined zombie %p OK\n", t));
288 case THRf_R_JOINABLE:
289 DEBUG_S(PerlIO_printf(Perl_debug_log,
290 "perl_destruct: detaching thread %p\n", t));
291 ThrSETSTATE(t, THRf_R_DETACHED);
293 * We unlock threads_mutex and t->mutex in the opposite order
294 * from which we locked them just so that DETACH won't
295 * deadlock if it panics. It's only a breach of good style
296 * not a bug since they are unlocks not locks.
298 MUTEX_UNLOCK(&PL_threads_mutex);
300 MUTEX_UNLOCK(&t->mutex);
303 DEBUG_S(PerlIO_printf(Perl_debug_log,
304 "perl_destruct: ignoring %p (state %u)\n",
306 MUTEX_UNLOCK(&t->mutex);
307 /* fall through and out */
310 /* We leave the above "Pass 1" loop with threads_mutex still locked */
312 /* Pass 2 on remaining threads: wait for the thread count to drop to one */
313 while (PL_nthreads > 1)
315 DEBUG_S(PerlIO_printf(Perl_debug_log,
316 "perl_destruct: final wait for %d threads\n",
318 COND_WAIT(&PL_nthreads_cond, &PL_threads_mutex);
320 /* At this point, we're the last thread */
321 MUTEX_UNLOCK(&PL_threads_mutex);
322 DEBUG_S(PerlIO_printf(Perl_debug_log, "perl_destruct: armageddon has arrived\n"));
323 MUTEX_DESTROY(&PL_threads_mutex);
324 COND_DESTROY(&PL_nthreads_cond);
325 #endif /* !defined(FAKE_THREADS) */
326 #endif /* USE_THREADS */
328 destruct_level = PL_perl_destruct_level;
332 if (s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL")) {
334 if (destruct_level < i)
343 /* We must account for everything. */
345 /* Destroy the main CV and syntax tree */
347 PL_curpad = AvARRAY(PL_comppad);
348 op_free(PL_main_root);
349 PL_main_root = Nullop;
351 PL_curcop = &PL_compiling;
352 PL_main_start = Nullop;
353 SvREFCNT_dec(PL_main_cv);
357 if (PL_sv_objcount) {
359 * Try to destruct global references. We do this first so that the
360 * destructors and destructees still exist. Some sv's might remain.
361 * Non-referenced objects are on their own.
366 /* unhook hooks which will soon be, or use, destroyed data */
367 SvREFCNT_dec(PL_warnhook);
368 PL_warnhook = Nullsv;
369 SvREFCNT_dec(PL_diehook);
372 /* call exit list functions */
373 while (PL_exitlistlen-- > 0)
374 PL_exitlist[PL_exitlistlen].fn(aTHXo_ PL_exitlist[PL_exitlistlen].ptr);
376 Safefree(PL_exitlist);
378 if (destruct_level == 0){
380 DEBUG_P(debprofdump());
382 /* The exit() function will do everything that needs doing. */
386 /* loosen bonds of global variables */
389 (void)PerlIO_close(PL_rsfp);
393 /* Filters for program text */
394 SvREFCNT_dec(PL_rsfp_filters);
395 PL_rsfp_filters = Nullav;
398 PL_preprocess = FALSE;
404 PL_doswitches = FALSE;
405 PL_dowarn = G_WARN_OFF;
406 PL_doextract = FALSE;
407 PL_sawampersand = FALSE; /* must save all match strings */
410 Safefree(PL_inplace);
412 SvREFCNT_dec(PL_patchlevel);
415 SvREFCNT_dec(PL_e_script);
416 PL_e_script = Nullsv;
419 /* magical thingies */
421 Safefree(PL_ofs); /* $, */
424 Safefree(PL_ors); /* $\ */
427 SvREFCNT_dec(PL_rs); /* $/ */
430 SvREFCNT_dec(PL_nrs); /* $/ helper */
433 PL_multiline = 0; /* $* */
435 SvREFCNT_dec(PL_statname);
436 PL_statname = Nullsv;
439 /* defgv, aka *_ should be taken care of elsewhere */
441 /* clean up after study() */
442 SvREFCNT_dec(PL_lastscream);
443 PL_lastscream = Nullsv;
444 Safefree(PL_screamfirst);
446 Safefree(PL_screamnext);
450 Safefree(PL_efloatbuf);
451 PL_efloatbuf = Nullch;
454 /* startup and shutdown function lists */
455 SvREFCNT_dec(PL_beginav);
456 SvREFCNT_dec(PL_endav);
457 SvREFCNT_dec(PL_stopav);
458 SvREFCNT_dec(PL_initav);
464 /* shortcuts just get cleared */
470 PL_argvoutgv = Nullgv;
472 PL_stderrgv = Nullgv;
473 PL_last_in_gv = Nullgv;
475 PL_debstash = Nullhv;
477 /* reset so print() ends up where we expect */
480 SvREFCNT_dec(PL_argvout_stack);
481 PL_argvout_stack = Nullav;
483 SvREFCNT_dec(PL_fdpid);
485 SvREFCNT_dec(PL_modglobal);
486 PL_modglobal = Nullhv;
487 SvREFCNT_dec(PL_preambleav);
488 PL_preambleav = Nullav;
489 SvREFCNT_dec(PL_subname);
491 SvREFCNT_dec(PL_linestr);
493 SvREFCNT_dec(PL_pidstatus);
494 PL_pidstatus = Nullhv;
495 SvREFCNT_dec(PL_toptarget);
496 PL_toptarget = Nullsv;
497 SvREFCNT_dec(PL_bodytarget);
498 PL_bodytarget = Nullsv;
499 PL_formtarget = Nullsv;
501 /* clear utf8 character classes */
502 SvREFCNT_dec(PL_utf8_alnum);
503 SvREFCNT_dec(PL_utf8_alnumc);
504 SvREFCNT_dec(PL_utf8_ascii);
505 SvREFCNT_dec(PL_utf8_alpha);
506 SvREFCNT_dec(PL_utf8_space);
507 SvREFCNT_dec(PL_utf8_cntrl);
508 SvREFCNT_dec(PL_utf8_graph);
509 SvREFCNT_dec(PL_utf8_digit);
510 SvREFCNT_dec(PL_utf8_upper);
511 SvREFCNT_dec(PL_utf8_lower);
512 SvREFCNT_dec(PL_utf8_print);
513 SvREFCNT_dec(PL_utf8_punct);
514 SvREFCNT_dec(PL_utf8_xdigit);
515 SvREFCNT_dec(PL_utf8_mark);
516 SvREFCNT_dec(PL_utf8_toupper);
517 SvREFCNT_dec(PL_utf8_tolower);
518 PL_utf8_alnum = Nullsv;
519 PL_utf8_alnumc = Nullsv;
520 PL_utf8_ascii = Nullsv;
521 PL_utf8_alpha = Nullsv;
522 PL_utf8_space = Nullsv;
523 PL_utf8_cntrl = Nullsv;
524 PL_utf8_graph = Nullsv;
525 PL_utf8_digit = Nullsv;
526 PL_utf8_upper = Nullsv;
527 PL_utf8_lower = Nullsv;
528 PL_utf8_print = Nullsv;
529 PL_utf8_punct = Nullsv;
530 PL_utf8_xdigit = Nullsv;
531 PL_utf8_mark = Nullsv;
532 PL_utf8_toupper = Nullsv;
533 PL_utf8_totitle = Nullsv;
534 PL_utf8_tolower = Nullsv;
536 if (!specialWARN(PL_compiling.cop_warnings))
537 SvREFCNT_dec(PL_compiling.cop_warnings);
538 PL_compiling.cop_warnings = Nullsv;
540 /* Prepare to destruct main symbol table. */
545 SvREFCNT_dec(PL_curstname);
546 PL_curstname = Nullsv;
548 /* clear queued errors */
549 SvREFCNT_dec(PL_errors);
553 if (destruct_level >= 2 && ckWARN_d(WARN_INTERNAL)) {
554 if (PL_scopestack_ix != 0)
555 Perl_warner(aTHX_ WARN_INTERNAL,
556 "Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
557 (long)PL_scopestack_ix);
558 if (PL_savestack_ix != 0)
559 Perl_warner(aTHX_ WARN_INTERNAL,
560 "Unbalanced saves: %ld more saves than restores\n",
561 (long)PL_savestack_ix);
562 if (PL_tmps_floor != -1)
563 Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced tmps: %ld more allocs than frees\n",
564 (long)PL_tmps_floor + 1);
565 if (cxstack_ix != -1)
566 Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced context: %ld more PUSHes than POPs\n",
567 (long)cxstack_ix + 1);
570 /* Now absolutely destruct everything, somehow or other, loops or no. */
572 SvFLAGS(PL_strtab) |= SVTYPEMASK; /* don't clean out strtab now */
573 while (PL_sv_count != 0 && PL_sv_count != last_sv_count) {
574 last_sv_count = PL_sv_count;
577 SvFLAGS(PL_strtab) &= ~SVTYPEMASK;
578 SvFLAGS(PL_strtab) |= SVt_PVHV;
580 /* Destruct the global string table. */
582 /* Yell and reset the HeVAL() slots that are still holding refcounts,
583 * so that sv_free() won't fail on them.
591 max = HvMAX(PL_strtab);
592 array = HvARRAY(PL_strtab);
595 if (hent && ckWARN_d(WARN_INTERNAL)) {
596 Perl_warner(aTHX_ WARN_INTERNAL,
597 "Unbalanced string table refcount: (%d) for \"%s\"",
598 HeVAL(hent) - Nullsv, HeKEY(hent));
599 HeVAL(hent) = Nullsv;
609 SvREFCNT_dec(PL_strtab);
611 if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL))
612 Perl_warner(aTHX_ WARN_INTERNAL,"Scalars leaked: %ld\n", (long)PL_sv_count);
616 /* No SVs have survived, need to clean out */
617 Safefree(PL_origfilename);
618 Safefree(PL_reg_start_tmp);
620 Safefree(PL_reg_curpm);
621 Safefree(PL_reg_poscache);
622 Safefree(HeKEY_hek(&PL_hv_fetch_ent_mh));
623 Safefree(PL_op_mask);
625 PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */
627 DEBUG_P(debprofdump());
629 MUTEX_DESTROY(&PL_strtab_mutex);
630 MUTEX_DESTROY(&PL_sv_mutex);
631 MUTEX_DESTROY(&PL_eval_mutex);
632 MUTEX_DESTROY(&PL_cred_mutex);
633 COND_DESTROY(&PL_eval_cond);
634 #ifdef EMULATE_ATOMIC_REFCOUNTS
635 MUTEX_DESTROY(&PL_svref_mutex);
636 #endif /* EMULATE_ATOMIC_REFCOUNTS */
638 /* As the penultimate thing, free the non-arena SV for thrsv */
639 Safefree(SvPVX(PL_thrsv));
640 Safefree(SvANY(PL_thrsv));
643 #endif /* USE_THREADS */
645 /* As the absolutely last thing, free the non-arena SV for mess() */
648 /* it could have accumulated taint magic */
649 if (SvTYPE(PL_mess_sv) >= SVt_PVMG) {
652 for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) {
653 moremagic = mg->mg_moremagic;
654 if (mg->mg_ptr && mg->mg_type != 'g' && mg->mg_len >= 0)
655 Safefree(mg->mg_ptr);
659 /* we know that type >= SVt_PV */
660 SvOOK_off(PL_mess_sv);
661 Safefree(SvPVX(PL_mess_sv));
662 Safefree(SvANY(PL_mess_sv));
663 Safefree(PL_mess_sv);
671 #if defined(PERL_OBJECT)
679 Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
681 Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry);
682 PL_exitlist[PL_exitlistlen].fn = fn;
683 PL_exitlist[PL_exitlistlen].ptr = ptr;
688 perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
698 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
701 Perl_croak(aTHX_ "suidperl is no longer needed since the kernel can now execute\n\
702 setuid perl scripts securely.\n");
706 #if defined(__DYNAMIC__) && (defined(NeXT) || defined(__NeXT__))
707 _dyld_lookup_and_bind
708 ("__environ", (unsigned long *) &environ_pointer, NULL);
713 #ifndef VMS /* VMS doesn't have environ array */
714 PL_origenviron = environ;
719 /* Come here if running an undumped a.out. */
721 PL_origfilename = savepv(argv[0]);
722 PL_do_undump = FALSE;
723 cxstack_ix = -1; /* start label stack again */
725 init_postdump_symbols(argc,argv,env);
730 PL_curpad = AvARRAY(PL_comppad);
731 op_free(PL_main_root);
732 PL_main_root = Nullop;
734 PL_main_start = Nullop;
735 SvREFCNT_dec(PL_main_cv);
739 oldscope = PL_scopestack_ix;
740 PL_dowarn = G_WARN_OFF;
742 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_parse_body),
747 call_list(oldscope, PL_stopav);
753 /* my_exit() was called */
754 while (PL_scopestack_ix > oldscope)
757 PL_curstash = PL_defstash;
759 call_list(oldscope, PL_stopav);
760 return STATUS_NATIVE_EXPORT;
762 PerlIO_printf(Perl_error_log, "panic: top_env\n");
769 S_parse_body(pTHX_ va_list args)
772 int argc = PL_origargc;
773 char **argv = PL_origargv;
774 char **env = va_arg(args, char**);
775 char *scriptname = NULL;
777 VOL bool dosearch = FALSE;
782 char *cddir = Nullch;
784 XSINIT_t xsinit = va_arg(args, XSINIT_t);
786 sv_setpvn(PL_linestr,"",0);
787 sv = newSVpvn("",0); /* first used for -I flags */
791 for (argc--,argv++; argc > 0; argc--,argv++) {
792 if (argv[0][0] != '-' || !argv[0][1])
796 validarg = " PHOOEY ";
803 #ifndef PERL_STRICT_CR
827 if (s = moreswitches(s))
837 if (PL_euid != PL_uid || PL_egid != PL_gid)
838 Perl_croak(aTHX_ "No -e allowed in setuid scripts");
840 PL_e_script = newSVpvn("",0);
841 filter_add(read_e_script, NULL);
844 sv_catpv(PL_e_script, s);
846 sv_catpv(PL_e_script, argv[1]);
850 Perl_croak(aTHX_ "No code specified for -e");
851 sv_catpv(PL_e_script, "\n");
854 case 'I': /* -I handled both here and in moreswitches() */
856 if (!*++s && (s=argv[1]) != Nullch) {
859 while (s && isSPACE(*s))
863 for (e = s; *e && !isSPACE(*e); e++) ;
870 } /* XXX else croak? */
874 PL_preprocess = TRUE;
884 PL_preambleav = newAV();
885 av_push(PL_preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
887 PL_Sv = newSVpv("print myconfig();",0);
889 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
891 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
893 sv_catpv(PL_Sv,"\" Compile-time options:");
895 sv_catpv(PL_Sv," DEBUGGING");
898 sv_catpv(PL_Sv," MULTIPLICITY");
901 sv_catpv(PL_Sv," USE_THREADS");
904 sv_catpv(PL_Sv," PERL_OBJECT");
906 # ifdef PERL_IMPLICIT_CONTEXT
907 sv_catpv(PL_Sv," PERL_IMPLICIT_CONTEXT");
909 # ifdef PERL_IMPLICIT_SYS
910 sv_catpv(PL_Sv," PERL_IMPLICIT_SYS");
912 sv_catpv(PL_Sv,"\\n\",");
914 #if defined(LOCAL_PATCH_COUNT)
915 if (LOCAL_PATCH_COUNT > 0) {
917 sv_catpv(PL_Sv,"\" Locally applied patches:\\n\",");
918 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
919 if (PL_localpatches[i])
920 Perl_sv_catpvf(aTHX_ PL_Sv,"q\" \t%s\n\",",PL_localpatches[i]);
924 Perl_sv_catpvf(aTHX_ PL_Sv,"\" Built under %s\\n\"",OSNAME);
927 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
929 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled on %s\\n\"",__DATE__);
934 @env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; \
935 print \" \\%ENV:\\n @env\\n\" if @env; \
936 print \" \\@INC:\\n @INC\\n\";");
939 PL_Sv = newSVpv("config_vars(qw(",0);
940 sv_catpv(PL_Sv, ++s);
941 sv_catpv(PL_Sv, "))");
944 av_push(PL_preambleav, PL_Sv);
945 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
956 if (!*++s || isSPACE(*s)) {
960 /* catch use of gnu style long options */
961 if (strEQ(s, "version")) {
965 if (strEQ(s, "help")) {
972 Perl_croak(aTHX_ "Unrecognized switch: -%s (-h will show valid options)",s);
978 #ifndef SECURE_INTERNAL_GETENV
981 (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))
1765 for (e = s; *e && !isSPACE(*e); e++) ;
1766 p = savepvn(s, e-s);
1772 Perl_croak(aTHX_ "No space allowed after -I");
1780 PL_ors = savepv("\n");
1782 *PL_ors = (char)scan_oct(s, 3 + (*s == '0'), &numlen);
1787 if (RsPARA(PL_nrs)) {
1792 PL_ors = SvPV(PL_nrs, PL_orslen);
1793 PL_ors = savepvn(PL_ors, PL_orslen);
1797 forbid_setid("-M"); /* XXX ? */
1800 forbid_setid("-m"); /* XXX ? */
1805 /* -M-foo == 'no foo' */
1806 if (*s == '-') { use = "no "; ++s; }
1807 sv = newSVpv(use,0);
1809 /* We allow -M'Module qw(Foo Bar)' */
1810 while(isALNUM(*s) || *s==':') ++s;
1812 sv_catpv(sv, start);
1813 if (*(start-1) == 'm') {
1815 Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
1816 sv_catpv( sv, " ()");
1819 sv_catpvn(sv, start, s-start);
1820 sv_catpv(sv, " split(/,/,q{");
1826 PL_preambleav = newAV();
1827 av_push(PL_preambleav, sv);
1830 Perl_croak(aTHX_ "No space allowed after -%c", *(s-1));
1842 PL_doswitches = TRUE;
1847 Perl_croak(aTHX_ "Too late for \"-T\" option");
1851 PL_do_undump = TRUE;
1859 printf("\nThis is perl, v%"UVuf".%"UVuf".%"UVuf" built for %s",
1860 (UV)PERL_REVISION, (UV)PERL_VERSION, (UV)PERL_SUBVERSION, ARCHNAME);
1861 #if defined(LOCAL_PATCH_COUNT)
1862 if (LOCAL_PATCH_COUNT > 0)
1863 printf("\n(with %d registered patch%s, see perl -V for more detail)",
1864 (int)LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : "");
1867 printf("\n\nCopyright 1987-1999, Larry Wall\n");
1869 printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1872 printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
1873 printf("djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
1876 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1877 "Version 5 port Copyright (c) 1994-1999, Andreas Kaiser, Ilya Zakharevich\n");
1880 printf("atariST series port, ++jrb bammi@cadence.com\n");
1883 printf("BeOS port Copyright Tom Spindler, 1997-1999\n");
1886 printf("MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-1999\n");
1889 printf("MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
1892 printf("Stratus VOS port by Paul_Green@stratus.com, 1997-1999\n");
1895 printf("VM/ESA port by Neale Ferguson, 1998-1999\n");
1898 printf("BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
1901 printf("MiNT port by Guido Flohr, 1997-1999\n");
1903 #ifdef BINARY_BUILD_NOTICE
1904 BINARY_BUILD_NOTICE;
1907 Perl may be copied only under the terms of either the Artistic License or the\n\
1908 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n\
1909 Complete documentation for Perl, including FAQ lists, should be found on\n\
1910 this system using `man perl' or `perldoc perl'. If you have access to the\n\
1911 Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
1914 if (! (PL_dowarn & G_WARN_ALL_MASK))
1915 PL_dowarn |= G_WARN_ON;
1919 PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
1920 PL_compiling.cop_warnings = WARN_ALL ;
1924 PL_dowarn = G_WARN_ALL_OFF;
1925 PL_compiling.cop_warnings = WARN_NONE ;
1930 if (s[1] == '-') /* Additional switches on #! line. */
1935 #if defined(WIN32) || !defined(PERL_STRICT_CR)
1941 #ifdef ALTERNATE_SHEBANG
1942 case 'S': /* OS/2 needs -S on "extproc" line. */
1950 Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
1955 /* compliments of Tom Christiansen */
1957 /* unexec() can be found in the Gnu emacs distribution */
1958 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
1961 Perl_my_unexec(pTHX)
1969 prog = newSVpv(BIN_EXP, 0);
1970 sv_catpv(prog, "/perl");
1971 file = newSVpv(PL_origfilename, 0);
1972 sv_catpv(file, ".perldump");
1974 unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
1975 /* unexec prints msg to stderr in case of failure */
1976 PerlProc_exit(status);
1979 # include <lib$routines.h>
1980 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
1982 ABORT(); /* for use with undump */
1987 /* initialize curinterp */
1992 #ifdef PERL_OBJECT /* XXX kludge */
1995 PL_chopset = " \n-"; \
1996 PL_copline = NOLINE; \
1997 PL_curcop = &PL_compiling;\
1998 PL_curcopdb = NULL; \
2000 PL_dumpindent = 4; \
2001 PL_laststatval = -1; \
2002 PL_laststype = OP_STAT; \
2003 PL_maxscream = -1; \
2004 PL_maxsysfd = MAXSYSFD; \
2005 PL_statname = Nullsv; \
2006 PL_tmps_floor = -1; \
2008 PL_op_mask = NULL; \
2009 PL_laststatval = -1; \
2010 PL_laststype = OP_STAT; \
2011 PL_mess_sv = Nullsv; \
2012 PL_splitstr = " "; \
2013 PL_generation = 100; \
2014 PL_exitlist = NULL; \
2015 PL_exitlistlen = 0; \
2017 PL_in_clean_objs = FALSE; \
2018 PL_in_clean_all = FALSE; \
2019 PL_profiledata = NULL; \
2021 PL_rsfp_filters = Nullav; \
2026 # ifdef MULTIPLICITY
2027 # define PERLVAR(var,type)
2028 # define PERLVARA(var,n,type)
2029 # if defined(PERL_IMPLICIT_CONTEXT)
2030 # if defined(USE_THREADS)
2031 # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
2032 # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
2033 # else /* !USE_THREADS */
2034 # define PERLVARI(var,type,init) aTHX->var = init;
2035 # define PERLVARIC(var,type,init) aTHX->var = init;
2036 # endif /* USE_THREADS */
2038 # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
2039 # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
2041 # include "intrpvar.h"
2042 # ifndef USE_THREADS
2043 # include "thrdvar.h"
2050 # define PERLVAR(var,type)
2051 # define PERLVARA(var,n,type)
2052 # define PERLVARI(var,type,init) PL_##var = init;
2053 # define PERLVARIC(var,type,init) PL_##var = init;
2054 # include "intrpvar.h"
2055 # ifndef USE_THREADS
2056 # include "thrdvar.h"
2068 S_init_main_stash(pTHX)
2073 /* Note that strtab is a rather special HV. Assumptions are made
2074 about not iterating on it, and not adding tie magic to it.
2075 It is properly deallocated in perl_destruct() */
2076 PL_strtab = newHV();
2078 MUTEX_INIT(&PL_strtab_mutex);
2080 HvSHAREKEYS_off(PL_strtab); /* mandatory */
2081 hv_ksplit(PL_strtab, 512);
2083 PL_curstash = PL_defstash = newHV();
2084 PL_curstname = newSVpvn("main",4);
2085 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
2086 SvREFCNT_dec(GvHV(gv));
2087 GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
2089 HvNAME(PL_defstash) = savepv("main");
2090 PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
2091 GvMULTI_on(PL_incgv);
2092 PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
2093 GvMULTI_on(PL_hintgv);
2094 PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
2095 PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
2096 GvMULTI_on(PL_errgv);
2097 PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
2098 GvMULTI_on(PL_replgv);
2099 (void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */
2100 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
2101 sv_setpvn(ERRSV, "", 0);
2102 PL_curstash = PL_defstash;
2103 CopSTASH_set(&PL_compiling, PL_defstash);
2104 PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
2105 PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
2106 /* We must init $/ before switches are processed. */
2107 sv_setpvn(get_sv("/", TRUE), "\n", 1);
2111 S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
2119 PL_origfilename = savepv("-e");
2122 /* if find_script() returns, it returns a malloc()-ed value */
2123 PL_origfilename = scriptname = find_script(scriptname, dosearch, NULL, 1);
2125 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
2126 char *s = scriptname + 8;
2127 *fdscript = atoi(s);
2131 scriptname = savepv(s + 1);
2132 Safefree(PL_origfilename);
2133 PL_origfilename = scriptname;
2138 CopFILE_set(PL_curcop, PL_origfilename);
2139 if (strEQ(PL_origfilename,"-"))
2141 if (*fdscript >= 0) {
2142 PL_rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE);
2143 #if defined(HAS_FCNTL) && defined(F_SETFD)
2145 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); /* ensure close-on-exec */
2148 else if (PL_preprocess) {
2149 char *cpp_cfg = CPPSTDIN;
2150 SV *cpp = newSVpvn("",0);
2151 SV *cmd = NEWSV(0,0);
2153 if (strEQ(cpp_cfg, "cppstdin"))
2154 Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
2155 sv_catpv(cpp, cpp_cfg);
2158 sv_catpv(sv,PRIVLIB_EXP);
2161 Perl_sv_setpvf(aTHX_ cmd, "\
2162 sed %s -e \"/^[^#]/b\" \
2163 -e \"/^#[ ]*include[ ]/b\" \
2164 -e \"/^#[ ]*define[ ]/b\" \
2165 -e \"/^#[ ]*if[ ]/b\" \
2166 -e \"/^#[ ]*ifdef[ ]/b\" \
2167 -e \"/^#[ ]*ifndef[ ]/b\" \
2168 -e \"/^#[ ]*else/b\" \
2169 -e \"/^#[ ]*elif[ ]/b\" \
2170 -e \"/^#[ ]*undef[ ]/b\" \
2171 -e \"/^#[ ]*endif/b\" \
2174 (PL_doextract ? "-e \"1,/^#/d\n\"" : ""),
2177 Perl_sv_setpvf(aTHX_ cmd, "\
2178 %s %s -e '/^[^#]/b' \
2179 -e '/^#[ ]*include[ ]/b' \
2180 -e '/^#[ ]*define[ ]/b' \
2181 -e '/^#[ ]*if[ ]/b' \
2182 -e '/^#[ ]*ifdef[ ]/b' \
2183 -e '/^#[ ]*ifndef[ ]/b' \
2184 -e '/^#[ ]*else/b' \
2185 -e '/^#[ ]*elif[ ]/b' \
2186 -e '/^#[ ]*undef[ ]/b' \
2187 -e '/^#[ ]*endif/b' \
2191 Perl_sv_setpvf(aTHX_ cmd, "\
2192 %s %s -e '/^[^#]/b' \
2193 -e '/^#[ ]*include[ ]/b' \
2194 -e '/^#[ ]*define[ ]/b' \
2195 -e '/^#[ ]*if[ ]/b' \
2196 -e '/^#[ ]*ifdef[ ]/b' \
2197 -e '/^#[ ]*ifndef[ ]/b' \
2198 -e '/^#[ ]*else/b' \
2199 -e '/^#[ ]*elif[ ]/b' \
2200 -e '/^#[ ]*undef[ ]/b' \
2201 -e '/^#[ ]*endif/b' \
2210 (PL_doextract ? "-e '1,/^#/d\n'" : ""),
2212 scriptname, cpp, sv, CPPMINUS);
2213 PL_doextract = FALSE;
2214 #ifdef IAMSUID /* actually, this is caught earlier */
2215 if (PL_euid != PL_uid && !PL_euid) { /* if running suidperl */
2217 (void)seteuid(PL_uid); /* musn't stay setuid root */
2220 (void)setreuid((Uid_t)-1, PL_uid);
2222 #ifdef HAS_SETRESUID
2223 (void)setresuid((Uid_t)-1, PL_uid, (Uid_t)-1);
2225 PerlProc_setuid(PL_uid);
2229 if (PerlProc_geteuid() != PL_uid)
2230 Perl_croak(aTHX_ "Can't do seteuid!\n");
2232 #endif /* IAMSUID */
2233 PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
2237 else if (!*scriptname) {
2238 forbid_setid("program input from stdin");
2239 PL_rsfp = PerlIO_stdin();
2242 PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
2243 #if defined(HAS_FCNTL) && defined(F_SETFD)
2245 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); /* ensure close-on-exec */
2250 #ifndef IAMSUID /* in case script is not readable before setuid */
2252 PerlLIO_stat(CopFILE(PL_curcop),&PL_statbuf) >= 0 &&
2253 PL_statbuf.st_mode & (S_ISUID|S_ISGID))
2256 PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
2257 (UV)PERL_REVISION, (UV)PERL_VERSION,
2258 (UV)PERL_SUBVERSION), PL_origargv);
2259 Perl_croak(aTHX_ "Can't do setuid\n");
2263 Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
2264 CopFILE(PL_curcop), Strerror(errno));
2269 * I_SYSSTATVFS HAS_FSTATVFS
2271 * I_STATFS HAS_FSTATFS
2272 * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT
2273 * here so that metaconfig picks them up. */
2277 S_fd_on_nosuid_fs(pTHX_ int fd)
2279 int check_okay = 0; /* able to do all the required sys/libcalls */
2280 int on_nosuid = 0; /* the fd is on a nosuid fs */
2282 * Preferred order: fstatvfs(), fstatfs(), ustat()+getmnt(), getmntent().
2283 * fstatvfs() is UNIX98.
2284 * fstatfs() is 4.3 BSD.
2285 * ustat()+getmnt() is pre-4.3 BSD.
2286 * getmntent() is O(number-of-mounted-filesystems) and can hang on
2287 * an irrelevant filesystem while trying to reach the right one.
2290 # ifdef HAS_FSTATVFS
2291 struct statvfs stfs;
2292 check_okay = fstatvfs(fd, &stfs) == 0;
2293 on_nosuid = check_okay && (stfs.f_flag & ST_NOSUID);
2295 # ifdef PERL_MOUNT_NOSUID
2296 # if defined(HAS_FSTATFS) && \
2297 defined(HAS_STRUCT_STATFS) && \
2298 defined(HAS_STRUCT_STATFS_F_FLAGS)
2300 check_okay = fstatfs(fd, &stfs) == 0;
2301 on_nosuid = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
2303 # if defined(HAS_FSTAT) && \
2304 defined(HAS_USTAT) && \
2305 defined(HAS_GETMNT) && \
2306 defined(HAS_STRUCT_FS_DATA) && \
2309 if (fstat(fd, &fdst) == 0) {
2311 if (ustat(fdst.st_dev, &us) == 0) {
2313 /* NOSTAT_ONE here because we're not examining fields which
2314 * vary between that case and STAT_ONE. */
2315 if (getmnt((int*)0, &fsd, (int)0, NOSTAT_ONE, us.f_fname) == 0) {
2316 size_t cmplen = sizeof(us.f_fname);
2317 if (sizeof(fsd.fd_req.path) < cmplen)
2318 cmplen = sizeof(fsd.fd_req.path);
2319 if (strnEQ(fsd.fd_req.path, us.f_fname, cmplen) &&
2320 fdst.st_dev == fsd.fd_req.dev) {
2322 on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID;
2328 # endif /* fstat+ustat+getmnt */
2329 # endif /* fstatfs */
2331 # if defined(HAS_GETMNTENT) && \
2332 defined(HAS_HASMNTOPT) && \
2333 defined(MNTOPT_NOSUID)
2334 FILE *mtab = fopen("/etc/mtab", "r");
2335 struct mntent *entry;
2336 struct stat stb, fsb;
2338 if (mtab && (fstat(fd, &stb) == 0)) {
2339 while (entry = getmntent(mtab)) {
2340 if (stat(entry->mnt_dir, &fsb) == 0
2341 && fsb.st_dev == stb.st_dev)
2343 /* found the filesystem */
2345 if (hasmntopt(entry, MNTOPT_NOSUID))
2348 } /* A single fs may well fail its stat(). */
2353 # endif /* getmntent+hasmntopt */
2354 # endif /* PERL_MOUNT_NOSUID: fstatfs or fstat+ustat+statfs */
2355 # endif /* statvfs */
2358 Perl_croak(aTHX_ "Can't check filesystem of script \"%s\" for nosuid", PL_origfilename);
2361 #endif /* IAMSUID */
2364 S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript)
2368 /* do we need to emulate setuid on scripts? */
2370 /* This code is for those BSD systems that have setuid #! scripts disabled
2371 * in the kernel because of a security problem. Merely defining DOSUID
2372 * in perl will not fix that problem, but if you have disabled setuid
2373 * scripts in the kernel, this will attempt to emulate setuid and setgid
2374 * on scripts that have those now-otherwise-useless bits set. The setuid
2375 * root version must be called suidperl or sperlN.NNN. If regular perl
2376 * discovers that it has opened a setuid script, it calls suidperl with
2377 * the same argv that it had. If suidperl finds that the script it has
2378 * just opened is NOT setuid root, it sets the effective uid back to the
2379 * uid. We don't just make perl setuid root because that loses the
2380 * effective uid we had before invoking perl, if it was different from the
2383 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
2384 * be defined in suidperl only. suidperl must be setuid root. The
2385 * Configure script will set this up for you if you want it.
2392 if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */
2393 Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
2394 if (fdscript < 0 && PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
2399 #ifndef HAS_SETREUID
2400 /* On this access check to make sure the directories are readable,
2401 * there is actually a small window that the user could use to make
2402 * filename point to an accessible directory. So there is a faint
2403 * chance that someone could execute a setuid script down in a
2404 * non-accessible directory. I don't know what to do about that.
2405 * But I don't think it's too important. The manual lies when
2406 * it says access() is useful in setuid programs.
2408 if (PerlLIO_access(CopFILE(PL_curcop),1)) /*double check*/
2409 Perl_croak(aTHX_ "Permission denied");
2411 /* If we can swap euid and uid, then we can determine access rights
2412 * with a simple stat of the file, and then compare device and
2413 * inode to make sure we did stat() on the same file we opened.
2414 * Then we just have to make sure he or she can execute it.
2417 struct stat tmpstatbuf;
2421 setreuid(PL_euid,PL_uid) < 0
2424 setresuid(PL_euid,PL_uid,(Uid_t)-1) < 0
2427 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
2428 Perl_croak(aTHX_ "Can't swap uid and euid"); /* really paranoid */
2429 if (PerlLIO_stat(CopFILE(PL_curcop),&tmpstatbuf) < 0)
2430 Perl_croak(aTHX_ "Permission denied"); /* testing full pathname here */
2431 #if defined(IAMSUID) && !defined(NO_NOSUID_CHECK)
2432 if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp)))
2433 Perl_croak(aTHX_ "Permission denied");
2435 if (tmpstatbuf.st_dev != PL_statbuf.st_dev ||
2436 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
2437 (void)PerlIO_close(PL_rsfp);
2438 if (PL_rsfp = PerlProc_popen("/bin/mail root","w")) { /* heh, heh */
2439 PerlIO_printf(PL_rsfp,
2440 "User %"Uid_t_f" tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2441 (Filename of set-id script was %s, uid %"Uid_t_f" gid %"Gid_t_f".)\n\nSincerely,\nperl\n",
2442 PL_uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
2443 (long)PL_statbuf.st_dev, (long)PL_statbuf.st_ino,
2445 PL_statbuf.st_uid, PL_statbuf.st_gid);
2446 (void)PerlProc_pclose(PL_rsfp);
2448 Perl_croak(aTHX_ "Permission denied\n");
2452 setreuid(PL_uid,PL_euid) < 0
2454 # if defined(HAS_SETRESUID)
2455 setresuid(PL_uid,PL_euid,(Uid_t)-1) < 0
2458 || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
2459 Perl_croak(aTHX_ "Can't reswap uid and euid");
2460 if (!cando(S_IXUSR,FALSE,&PL_statbuf)) /* can real uid exec? */
2461 Perl_croak(aTHX_ "Permission denied\n");
2463 #endif /* HAS_SETREUID */
2464 #endif /* IAMSUID */
2466 if (!S_ISREG(PL_statbuf.st_mode))
2467 Perl_croak(aTHX_ "Permission denied");
2468 if (PL_statbuf.st_mode & S_IWOTH)
2469 Perl_croak(aTHX_ "Setuid/gid script is writable by world");
2470 PL_doswitches = FALSE; /* -s is insecure in suid */
2471 CopLINE_inc(PL_curcop);
2472 if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
2473 strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */
2474 Perl_croak(aTHX_ "No #! line");
2475 s = SvPV(PL_linestr,n_a)+2;
2477 while (!isSPACE(*s)) s++;
2478 for (s2 = s; (s2 > SvPV(PL_linestr,n_a)+2 &&
2479 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
2480 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
2481 Perl_croak(aTHX_ "Not a perl script");
2482 while (*s == ' ' || *s == '\t') s++;
2484 * #! arg must be what we saw above. They can invoke it by
2485 * mentioning suidperl explicitly, but they may not add any strange
2486 * arguments beyond what #! says if they do invoke suidperl that way.
2488 len = strlen(validarg);
2489 if (strEQ(validarg," PHOOEY ") ||
2490 strnNE(s,validarg,len) || !isSPACE(s[len]))
2491 Perl_croak(aTHX_ "Args must match #! line");
2494 if (PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
2495 PL_euid == PL_statbuf.st_uid)
2497 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2498 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2499 #endif /* IAMSUID */
2501 if (PL_euid) { /* oops, we're not the setuid root perl */
2502 (void)PerlIO_close(PL_rsfp);
2505 PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
2506 (UV)PERL_REVISION, (UV)PERL_VERSION,
2507 (UV)PERL_SUBVERSION), PL_origargv);
2509 Perl_croak(aTHX_ "Can't do setuid\n");
2512 if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
2514 (void)setegid(PL_statbuf.st_gid);
2517 (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
2519 #ifdef HAS_SETRESGID
2520 (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
2522 PerlProc_setgid(PL_statbuf.st_gid);
2526 if (PerlProc_getegid() != PL_statbuf.st_gid)
2527 Perl_croak(aTHX_ "Can't do setegid!\n");
2529 if (PL_statbuf.st_mode & S_ISUID) {
2530 if (PL_statbuf.st_uid != PL_euid)
2532 (void)seteuid(PL_statbuf.st_uid); /* all that for this */
2535 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
2537 #ifdef HAS_SETRESUID
2538 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
2540 PerlProc_setuid(PL_statbuf.st_uid);
2544 if (PerlProc_geteuid() != PL_statbuf.st_uid)
2545 Perl_croak(aTHX_ "Can't do seteuid!\n");
2547 else if (PL_uid) { /* oops, mustn't run as root */
2549 (void)seteuid((Uid_t)PL_uid);
2552 (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
2554 #ifdef HAS_SETRESUID
2555 (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
2557 PerlProc_setuid((Uid_t)PL_uid);
2561 if (PerlProc_geteuid() != PL_uid)
2562 Perl_croak(aTHX_ "Can't do seteuid!\n");
2565 if (!cando(S_IXUSR,TRUE,&PL_statbuf))
2566 Perl_croak(aTHX_ "Permission denied\n"); /* they can't do this */
2569 else if (PL_preprocess)
2570 Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
2571 else if (fdscript >= 0)
2572 Perl_croak(aTHX_ "fd script not allowed in suidperl\n");
2574 Perl_croak(aTHX_ "Script is not setuid/setgid in suidperl\n");
2576 /* We absolutely must clear out any saved ids here, so we */
2577 /* exec the real perl, substituting fd script for scriptname. */
2578 /* (We pass script name as "subdir" of fd, which perl will grok.) */
2579 PerlIO_rewind(PL_rsfp);
2580 PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0); /* just in case rewind didn't */
2581 for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
2582 if (!PL_origargv[which])
2583 Perl_croak(aTHX_ "Permission denied");
2584 PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
2585 PerlIO_fileno(PL_rsfp), PL_origargv[which]));
2586 #if defined(HAS_FCNTL) && defined(F_SETFD)
2587 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */
2589 PerlProc_execv(Perl_form(aTHX_ "%s/perl"PERL_FS_VER_FMT, BIN_EXP,
2590 (UV)PERL_REVISION, (UV)PERL_VERSION,
2591 (UV)PERL_SUBVERSION), PL_origargv);/* try again */
2592 Perl_croak(aTHX_ "Can't do setuid\n");
2593 #endif /* IAMSUID */
2595 if (PL_euid != PL_uid || PL_egid != PL_gid) { /* (suidperl doesn't exist, in fact) */
2596 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2598 PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf); /* may be either wrapped or real suid */
2599 if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
2601 (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
2604 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2605 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2606 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2607 /* not set-id, must be wrapped */
2613 S_find_beginning(pTHX)
2615 register char *s, *s2;
2617 /* skip forward in input to the real script? */
2620 while (PL_doextract) {
2621 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
2622 Perl_croak(aTHX_ "No Perl script found in input\n");
2623 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2624 PerlIO_ungetc(PL_rsfp, '\n'); /* to keep line count right */
2625 PL_doextract = FALSE;
2626 while (*s && !(isSPACE (*s) || *s == '#')) s++;
2628 while (*s == ' ' || *s == '\t') s++;
2630 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2631 if (strnEQ(s2-4,"perl",4))
2633 while (s = moreswitches(s)) ;
2643 PL_uid = PerlProc_getuid();
2644 PL_euid = PerlProc_geteuid();
2645 PL_gid = PerlProc_getgid();
2646 PL_egid = PerlProc_getegid();
2648 PL_uid |= PL_gid << 16;
2649 PL_euid |= PL_egid << 16;
2651 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2655 S_forbid_setid(pTHX_ char *s)
2657 if (PL_euid != PL_uid)
2658 Perl_croak(aTHX_ "No %s allowed while running setuid", s);
2659 if (PL_egid != PL_gid)
2660 Perl_croak(aTHX_ "No %s allowed while running setgid", s);
2664 Perl_init_debugger(pTHX)
2667 HV *ostash = PL_curstash;
2669 PL_curstash = PL_debstash;
2670 PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2671 AvREAL_off(PL_dbargs);
2672 PL_DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2673 PL_DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2674 PL_DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2675 sv_upgrade(GvSV(PL_DBsub), SVt_IV); /* IVX accessed if PERLDB_SUB_NN */
2676 PL_DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2677 sv_setiv(PL_DBsingle, 0);
2678 PL_DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2679 sv_setiv(PL_DBtrace, 0);
2680 PL_DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2681 sv_setiv(PL_DBsignal, 0);
2682 PL_curstash = ostash;
2685 #ifndef STRESS_REALLOC
2686 #define REASONABLE(size) (size)
2688 #define REASONABLE(size) (1) /* unreasonable */
2692 Perl_init_stacks(pTHX)
2694 /* start with 128-item stack and 8K cxstack */
2695 PL_curstackinfo = new_stackinfo(REASONABLE(128),
2696 REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
2697 PL_curstackinfo->si_type = PERLSI_MAIN;
2698 PL_curstack = PL_curstackinfo->si_stack;
2699 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
2701 PL_stack_base = AvARRAY(PL_curstack);
2702 PL_stack_sp = PL_stack_base;
2703 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
2705 New(50,PL_tmps_stack,REASONABLE(128),SV*);
2708 PL_tmps_max = REASONABLE(128);
2710 New(54,PL_markstack,REASONABLE(32),I32);
2711 PL_markstack_ptr = PL_markstack;
2712 PL_markstack_max = PL_markstack + REASONABLE(32);
2716 New(54,PL_scopestack,REASONABLE(32),I32);
2717 PL_scopestack_ix = 0;
2718 PL_scopestack_max = REASONABLE(32);
2720 New(54,PL_savestack,REASONABLE(128),ANY);
2721 PL_savestack_ix = 0;
2722 PL_savestack_max = REASONABLE(128);
2724 New(54,PL_retstack,REASONABLE(16),OP*);
2726 PL_retstack_max = REASONABLE(16);
2735 while (PL_curstackinfo->si_next)
2736 PL_curstackinfo = PL_curstackinfo->si_next;
2737 while (PL_curstackinfo) {
2738 PERL_SI *p = PL_curstackinfo->si_prev;
2739 /* curstackinfo->si_stack got nuked by sv_free_arenas() */
2740 Safefree(PL_curstackinfo->si_cxstack);
2741 Safefree(PL_curstackinfo);
2742 PL_curstackinfo = p;
2744 Safefree(PL_tmps_stack);
2745 Safefree(PL_markstack);
2746 Safefree(PL_scopestack);
2747 Safefree(PL_savestack);
2748 Safefree(PL_retstack);
2752 static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
2763 lex_start(PL_linestr);
2765 PL_subname = newSVpvn("main",4);
2769 S_init_predump_symbols(pTHX)
2776 sv_setpvn(get_sv("\"", TRUE), " ", 1);
2777 PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2778 GvMULTI_on(PL_stdingv);
2779 io = GvIOp(PL_stdingv);
2780 IoIFP(io) = PerlIO_stdin();
2781 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2783 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
2785 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2788 IoOFP(io) = IoIFP(io) = PerlIO_stdout();
2790 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2792 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
2794 PL_stderrgv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2795 GvMULTI_on(PL_stderrgv);
2796 io = GvIOp(PL_stderrgv);
2797 IoOFP(io) = IoIFP(io) = PerlIO_stderr();
2798 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2800 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
2802 PL_statname = NEWSV(66,0); /* last filename we did stat on */
2805 PL_osname = savepv(OSNAME);
2809 S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
2816 argc--,argv++; /* skip name of script */
2817 if (PL_doswitches) {
2818 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2821 if (argv[0][1] == '-') {
2825 if (s = strchr(argv[0], '=')) {
2827 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2830 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2833 PL_toptarget = NEWSV(0,0);
2834 sv_upgrade(PL_toptarget, SVt_PVFM);
2835 sv_setpvn(PL_toptarget, "", 0);
2836 PL_bodytarget = NEWSV(0,0);
2837 sv_upgrade(PL_bodytarget, SVt_PVFM);
2838 sv_setpvn(PL_bodytarget, "", 0);
2839 PL_formtarget = PL_bodytarget;
2842 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2843 sv_setpv(GvSV(tmpgv),PL_origfilename);
2844 magicname("0", "0", 1);
2846 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2848 sv_setpv(GvSV(tmpgv), os2_execname());
2850 sv_setpv(GvSV(tmpgv),PL_origargv[0]);
2852 if (PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2853 GvMULTI_on(PL_argvgv);
2854 (void)gv_AVadd(PL_argvgv);
2855 av_clear(GvAVn(PL_argvgv));
2856 for (; argc > 0; argc--,argv++) {
2857 av_push(GvAVn(PL_argvgv),newSVpv(argv[0],0));
2860 if (PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2862 GvMULTI_on(PL_envgv);
2863 hv = GvHVn(PL_envgv);
2864 hv_magic(hv, PL_envgv, 'E');
2865 #if !defined( VMS) && !defined(EPOC) /* VMS doesn't have environ array */
2866 /* Note that if the supplied env parameter is actually a copy
2867 of the global environ then it may now point to free'd memory
2868 if the environment has been modified since. To avoid this
2869 problem we treat env==NULL as meaning 'use the default'
2874 environ[0] = Nullch;
2875 for (; *env; env++) {
2876 if (!(s = strchr(*env,'=')))
2882 sv = newSVpv(s--,0);
2883 (void)hv_store(hv, *env, s - *env, sv, 0);
2885 #if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
2886 /* Sins of the RTL. See note in my_setenv(). */
2887 (void)PerlEnv_putenv(savepv(*env));
2891 #ifdef DYNAMIC_ENV_FETCH
2892 HvNAME(hv) = savepv(ENV_HV_NAME);
2896 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2897 sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
2901 S_init_perllib(pTHX)
2906 s = PerlEnv_getenv("PERL5LIB");
2910 incpush(PerlEnv_getenv("PERLLIB"), FALSE);
2912 /* Treat PERL5?LIB as a possible search list logical name -- the
2913 * "natural" VMS idiom for a Unix path string. We allow each
2914 * element to be a set of |-separated directories for compatibility.
2918 if (my_trnlnm("PERL5LIB",buf,0))
2919 do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2921 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2925 /* Use the ~-expanded versions of APPLLIB (undocumented),
2926 ARCHLIB PRIVLIB SITEARCH and SITELIB
2929 incpush(APPLLIB_EXP, TRUE);
2933 incpush(ARCHLIB_EXP, FALSE);
2936 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2939 incpush(PRIVLIB_EXP, TRUE);
2941 incpush(PRIVLIB_EXP, FALSE);
2945 incpush(SITEARCH_EXP, FALSE);
2949 incpush(SITELIB_EXP, TRUE);
2951 incpush(SITELIB_EXP, FALSE);
2954 #if defined(PERL_VENDORLIB_EXP)
2956 incpush(PERL_VENDORLIB_EXP, TRUE);
2958 incpush(PERL_VENDORLIB_EXP, FALSE);
2962 incpush(".", FALSE);
2966 # define PERLLIB_SEP ';'
2969 # define PERLLIB_SEP '|'
2971 # define PERLLIB_SEP ':'
2974 #ifndef PERLLIB_MANGLE
2975 # define PERLLIB_MANGLE(s,n) (s)
2979 S_incpush(pTHX_ char *p, int addsubdirs)
2981 SV *subdir = Nullsv;
2987 subdir = sv_newmortal();
2990 /* Break at all separators */
2992 SV *libdir = NEWSV(55,0);
2995 /* skip any consecutive separators */
2996 while ( *p == PERLLIB_SEP ) {
2997 /* Uncomment the next line for PATH semantics */
2998 /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */
3002 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
3003 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
3008 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
3009 p = Nullch; /* break out */
3013 * BEFORE pushing libdir onto @INC we may first push version- and
3014 * archname-specific sub-directories.
3017 struct stat tmpstatbuf;
3022 if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) {
3024 while (unix[len-1] == '/') len--; /* Cosmetic */
3025 sv_usepvn(libdir,unix,len);
3028 PerlIO_printf(Perl_error_log,
3029 "Failed to unixify @INC element \"%s\"\n",
3032 /* .../archname/version if -d .../archname/version/auto */
3033 Perl_sv_setpvf(aTHX_ subdir, "%_/%s/"PERL_FS_VER_FMT"/auto", libdir,
3034 ARCHNAME, (UV)PERL_REVISION,
3035 (UV)PERL_VERSION, (UV)PERL_SUBVERSION);
3036 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3037 S_ISDIR(tmpstatbuf.st_mode))
3038 av_push(GvAVn(PL_incgv),
3039 newSVpvn(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
3041 /* .../archname if -d .../archname/auto */
3042 Perl_sv_setpvf(aTHX_ subdir, "%_/%s/auto", libdir, ARCHNAME);
3043 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3044 S_ISDIR(tmpstatbuf.st_mode))
3045 av_push(GvAVn(PL_incgv),
3046 newSVpvn(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
3049 /* finally push this lib directory on the end of @INC */
3050 av_push(GvAVn(PL_incgv), libdir);
3055 STATIC struct perl_thread *
3056 S_init_main_thread(pTHX)
3058 #if !defined(PERL_IMPLICIT_CONTEXT)
3059 struct perl_thread *thr;
3063 Newz(53, thr, 1, struct perl_thread);
3064 PL_curcop = &PL_compiling;
3065 thr->interp = PERL_GET_INTERP;
3066 thr->cvcache = newHV();
3067 thr->threadsv = newAV();
3068 /* thr->threadsvp is set when find_threadsv is called */
3069 thr->specific = newAV();
3070 thr->flags = THRf_R_JOINABLE;
3071 MUTEX_INIT(&thr->mutex);
3072 /* Handcraft thrsv similarly to mess_sv */
3073 New(53, PL_thrsv, 1, SV);
3074 Newz(53, xpv, 1, XPV);
3075 SvFLAGS(PL_thrsv) = SVt_PV;
3076 SvANY(PL_thrsv) = (void*)xpv;
3077 SvREFCNT(PL_thrsv) = 1 << 30; /* practically infinite */
3078 SvPVX(PL_thrsv) = (char*)thr;
3079 SvCUR_set(PL_thrsv, sizeof(thr));
3080 SvLEN_set(PL_thrsv, sizeof(thr));
3081 *SvEND(PL_thrsv) = '\0'; /* in the trailing_nul field */
3082 thr->oursv = PL_thrsv;
3083 PL_chopset = " \n-";
3086 MUTEX_LOCK(&PL_threads_mutex);
3091 MUTEX_UNLOCK(&PL_threads_mutex);
3093 #ifdef HAVE_THREAD_INTERN
3094 Perl_init_thread_intern(thr);
3097 #ifdef SET_THREAD_SELF
3098 SET_THREAD_SELF(thr);
3100 thr->self = pthread_self();
3101 #endif /* SET_THREAD_SELF */
3105 * These must come after the SET_THR because sv_setpvn does
3106 * SvTAINT and the taint fields require dTHR.
3108 PL_toptarget = NEWSV(0,0);
3109 sv_upgrade(PL_toptarget, SVt_PVFM);
3110 sv_setpvn(PL_toptarget, "", 0);
3111 PL_bodytarget = NEWSV(0,0);
3112 sv_upgrade(PL_bodytarget, SVt_PVFM);
3113 sv_setpvn(PL_bodytarget, "", 0);
3114 PL_formtarget = PL_bodytarget;
3115 thr->errsv = newSVpvn("", 0);
3116 (void) find_threadsv("@"); /* Ensure $@ is initialised early */
3119 PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
3120 PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
3121 PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
3122 PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
3123 PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
3125 PL_reginterp_cnt = 0;
3129 #endif /* USE_THREADS */
3132 Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
3136 line_t oldline = CopLINE(PL_curcop);
3142 while (AvFILL(paramList) >= 0) {
3143 cv = (CV*)av_shift(paramList);
3145 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_list_body), cv);
3149 (void)SvPV(atsv, len);
3152 PL_curcop = &PL_compiling;
3153 CopLINE_set(PL_curcop, oldline);
3154 if (paramList == PL_beginav)
3155 sv_catpv(atsv, "BEGIN failed--compilation aborted");
3157 Perl_sv_catpvf(aTHX_ atsv,
3158 "%s failed--call queue aborted",
3159 paramList == PL_stopav ? "STOP"
3160 : paramList == PL_initav ? "INIT"
3162 while (PL_scopestack_ix > oldscope)
3164 Perl_croak(aTHX_ "%s", SvPVx(atsv, n_a));
3171 /* my_exit() was called */
3172 while (PL_scopestack_ix > oldscope)
3175 PL_curstash = PL_defstash;
3176 PL_curcop = &PL_compiling;
3177 CopLINE_set(PL_curcop, oldline);
3178 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) {
3179 if (paramList == PL_beginav)
3180 Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
3182 Perl_croak(aTHX_ "%s failed--call queue aborted",
3183 paramList == PL_stopav ? "STOP"
3184 : paramList == PL_initav ? "INIT"
3191 PL_curcop = &PL_compiling;
3192 CopLINE_set(PL_curcop, oldline);
3195 PerlIO_printf(Perl_error_log, "panic: restartop\n");
3203 S_call_list_body(pTHX_ va_list args)
3206 CV *cv = va_arg(args, CV*);
3208 PUSHMARK(PL_stack_sp);
3209 call_sv((SV*)cv, G_EVAL|G_DISCARD);
3214 Perl_my_exit(pTHX_ U32 status)
3218 DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
3219 thr, (unsigned long) status));
3228 STATUS_NATIVE_SET(status);
3235 Perl_my_failure_exit(pTHX)
3238 if (vaxc$errno & 1) {
3239 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
3240 STATUS_NATIVE_SET(44);
3243 if (!vaxc$errno && errno) /* unlikely */
3244 STATUS_NATIVE_SET(44);
3246 STATUS_NATIVE_SET(vaxc$errno);
3251 STATUS_POSIX_SET(errno);
3253 exitstatus = STATUS_POSIX >> 8;
3254 if (exitstatus & 255)
3255 STATUS_POSIX_SET(exitstatus);
3257 STATUS_POSIX_SET(255);
3264 S_my_exit_jump(pTHX)
3267 register PERL_CONTEXT *cx;
3272 SvREFCNT_dec(PL_e_script);
3273 PL_e_script = Nullsv;
3276 POPSTACK_TO(PL_mainstack);
3277 if (cxstack_ix >= 0) {
3280 POPBLOCK(cx,PL_curpm);
3292 read_e_script(pTHXo_ int idx, SV *buf_sv, int maxlen)
3295 p = SvPVX(PL_e_script);
3296 nl = strchr(p, '\n');
3297 nl = (nl) ? nl+1 : SvEND(PL_e_script);
3299 filter_del(read_e_script);
3302 sv_catpvn(buf_sv, p, nl-p);
3303 sv_chop(PL_e_script, nl);