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 CPerlObj* perl_alloc(IPerlMem* ipM, IPerlEnv* ipE, IPerlStdIO* ipStd,
51 IPerlLIO* ipLIO, IPerlDir* ipD, IPerlSock* ipS, IPerlProc* ipP)
53 CPerlObj* pPerl = new(ipM) CPerlObj(ipM, ipE, ipStd, ipLIO, ipD, ipS, ipP);
63 PerlInterpreter *my_perl;
65 /* New() needs interpreter, so call malloc() instead */
66 my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
67 PERL_SET_INTERP(my_perl);
70 #endif /* PERL_OBJECT */
78 struct perl_thread *thr;
79 #endif /* FAKE_THREADS */
80 #endif /* USE_THREADS */
83 Zero(my_perl, 1, PerlInterpreter);
88 PL_perl_destruct_level = 1;
90 if (PL_perl_destruct_level > 0)
94 /* Init the real globals (and main thread)? */
99 #ifdef ALLOC_THREAD_KEY
102 if (pthread_key_create(&PL_thr_key, 0))
103 Perl_croak(aTHX_ "panic: pthread_key_create");
105 MUTEX_INIT(&PL_sv_mutex);
107 * Safe to use basic SV functions from now on (though
108 * not things like mortals or tainting yet).
110 MUTEX_INIT(&PL_eval_mutex);
111 COND_INIT(&PL_eval_cond);
112 MUTEX_INIT(&PL_threads_mutex);
113 COND_INIT(&PL_nthreads_cond);
114 #ifdef EMULATE_ATOMIC_REFCOUNTS
115 MUTEX_INIT(&PL_svref_mutex);
116 #endif /* EMULATE_ATOMIC_REFCOUNTS */
118 MUTEX_INIT(&PL_cred_mutex);
120 thr = init_main_thread();
121 #endif /* USE_THREADS */
123 PL_protect = MEMBER_TO_FPTR(Perl_default_protect); /* for exceptions */
125 PL_curcop = &PL_compiling; /* needed by ckWARN, right away */
127 PL_linestr = NEWSV(65,79);
128 sv_upgrade(PL_linestr,SVt_PVIV);
130 if (!SvREADONLY(&PL_sv_undef)) {
131 /* set read-only and try to insure than we wont see REFCNT==0
134 SvREADONLY_on(&PL_sv_undef);
135 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
137 sv_setpv(&PL_sv_no,PL_No);
139 SvREADONLY_on(&PL_sv_no);
140 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
142 sv_setpv(&PL_sv_yes,PL_Yes);
144 SvREADONLY_on(&PL_sv_yes);
145 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
150 /* PL_sighandlerp = sighandler; */
152 PL_sighandlerp = Perl_sighandler;
154 PL_pidstatus = newHV();
158 * There is no way we can refer to them from Perl so close them to save
159 * space. The other alternative would be to provide STDAUX and STDPRN
162 (void)fclose(stdaux);
163 (void)fclose(stdprn);
167 PL_nrs = newSVpvn("\n", 1);
168 PL_rs = SvREFCNT_inc(PL_nrs);
173 PL_lex_state = LEX_NOTPARSING;
179 SET_NUMERIC_STANDARD();
180 #if defined(PERL_SUBVERSION) && PERL_SUBVERSION > 0
181 sprintf(PL_patchlevel, "%7.5f", (double) PERL_REVISION
182 + ((double) PERL_VERSION / (double) 1000)
183 + ((double) PERL_SUBVERSION / (double) 100000));
185 sprintf(PL_patchlevel, "%5.3f", (double) PERL_REVISION +
186 ((double) PERL_VERSION / (double) 1000));
189 #if defined(LOCAL_PATCH_COUNT)
190 PL_localpatches = local_patches; /* For possible -v */
193 PerlIO_init(); /* Hook to IO system */
195 PL_fdpid = newAV(); /* for remembering popen pids by fd */
196 PL_modglobal = newHV(); /* pointers to per-interpreter module globals */
199 New(51,PL_debname,128,char);
200 New(52,PL_debdelim,128,char);
210 int destruct_level; /* 0=none, 1=full, 2=full with checks */
216 #endif /* USE_THREADS */
220 /* Pass 1 on any remaining threads: detach joinables, join zombies */
222 MUTEX_LOCK(&PL_threads_mutex);
223 DEBUG_S(PerlIO_printf(PerlIO_stderr(),
224 "perl_destruct: waiting for %d threads...\n",
226 for (t = thr->next; t != thr; t = t->next) {
227 MUTEX_LOCK(&t->mutex);
228 switch (ThrSTATE(t)) {
231 DEBUG_S(PerlIO_printf(PerlIO_stderr(),
232 "perl_destruct: joining zombie %p\n", t));
233 ThrSETSTATE(t, THRf_DEAD);
234 MUTEX_UNLOCK(&t->mutex);
237 * The SvREFCNT_dec below may take a long time (e.g. av
238 * may contain an object scalar whose destructor gets
239 * called) so we have to unlock threads_mutex and start
242 MUTEX_UNLOCK(&PL_threads_mutex);
244 SvREFCNT_dec((SV*)av);
245 DEBUG_S(PerlIO_printf(PerlIO_stderr(),
246 "perl_destruct: joined zombie %p OK\n", t));
248 case THRf_R_JOINABLE:
249 DEBUG_S(PerlIO_printf(PerlIO_stderr(),
250 "perl_destruct: detaching thread %p\n", t));
251 ThrSETSTATE(t, THRf_R_DETACHED);
253 * We unlock threads_mutex and t->mutex in the opposite order
254 * from which we locked them just so that DETACH won't
255 * deadlock if it panics. It's only a breach of good style
256 * not a bug since they are unlocks not locks.
258 MUTEX_UNLOCK(&PL_threads_mutex);
260 MUTEX_UNLOCK(&t->mutex);
263 DEBUG_S(PerlIO_printf(PerlIO_stderr(),
264 "perl_destruct: ignoring %p (state %u)\n",
266 MUTEX_UNLOCK(&t->mutex);
267 /* fall through and out */
270 /* We leave the above "Pass 1" loop with threads_mutex still locked */
272 /* Pass 2 on remaining threads: wait for the thread count to drop to one */
273 while (PL_nthreads > 1)
275 DEBUG_S(PerlIO_printf(PerlIO_stderr(),
276 "perl_destruct: final wait for %d threads\n",
278 COND_WAIT(&PL_nthreads_cond, &PL_threads_mutex);
280 /* At this point, we're the last thread */
281 MUTEX_UNLOCK(&PL_threads_mutex);
282 DEBUG_S(PerlIO_printf(PerlIO_stderr(), "perl_destruct: armageddon has arrived\n"));
283 MUTEX_DESTROY(&PL_threads_mutex);
284 COND_DESTROY(&PL_nthreads_cond);
285 #endif /* !defined(FAKE_THREADS) */
286 #endif /* USE_THREADS */
288 destruct_level = PL_perl_destruct_level;
292 if (s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL")) {
294 if (destruct_level < i)
303 /* We must account for everything. */
305 /* Destroy the main CV and syntax tree */
307 PL_curpad = AvARRAY(PL_comppad);
308 op_free(PL_main_root);
309 PL_main_root = Nullop;
311 PL_curcop = &PL_compiling;
312 PL_main_start = Nullop;
313 SvREFCNT_dec(PL_main_cv);
317 if (PL_sv_objcount) {
319 * Try to destruct global references. We do this first so that the
320 * destructors and destructees still exist. Some sv's might remain.
321 * Non-referenced objects are on their own.
326 /* unhook hooks which will soon be, or use, destroyed data */
327 SvREFCNT_dec(PL_warnhook);
328 PL_warnhook = Nullsv;
329 SvREFCNT_dec(PL_diehook);
331 SvREFCNT_dec(PL_parsehook);
332 PL_parsehook = Nullsv;
334 /* call exit list functions */
335 while (PL_exitlistlen-- > 0)
336 PL_exitlist[PL_exitlistlen].fn(aTHXo_ PL_exitlist[PL_exitlistlen].ptr);
338 Safefree(PL_exitlist);
340 if (destruct_level == 0){
342 DEBUG_P(debprofdump());
344 /* The exit() function will do everything that needs doing. */
348 /* loosen bonds of global variables */
351 (void)PerlIO_close(PL_rsfp);
355 /* Filters for program text */
356 SvREFCNT_dec(PL_rsfp_filters);
357 PL_rsfp_filters = Nullav;
360 PL_preprocess = FALSE;
366 PL_doswitches = FALSE;
367 PL_dowarn = G_WARN_OFF;
368 PL_doextract = FALSE;
369 PL_sawampersand = FALSE; /* must save all match strings */
370 PL_sawstudy = FALSE; /* do fbm_instr on all strings */
374 Safefree(PL_inplace);
378 SvREFCNT_dec(PL_e_script);
379 PL_e_script = Nullsv;
382 /* magical thingies */
384 Safefree(PL_ofs); /* $, */
387 Safefree(PL_ors); /* $\ */
390 SvREFCNT_dec(PL_rs); /* $/ */
393 SvREFCNT_dec(PL_nrs); /* $/ helper */
396 PL_multiline = 0; /* $* */
398 SvREFCNT_dec(PL_statname);
399 PL_statname = Nullsv;
402 /* defgv, aka *_ should be taken care of elsewhere */
404 /* clean up after study() */
405 SvREFCNT_dec(PL_lastscream);
406 PL_lastscream = Nullsv;
407 Safefree(PL_screamfirst);
409 Safefree(PL_screamnext);
412 /* startup and shutdown function lists */
413 SvREFCNT_dec(PL_beginav);
414 SvREFCNT_dec(PL_endav);
415 SvREFCNT_dec(PL_initav);
420 /* shortcuts just get cleared */
427 PL_argvoutgv = Nullgv;
429 PL_last_in_gv = Nullgv;
432 /* reset so print() ends up where we expect */
435 /* Prepare to destruct main symbol table. */
442 if (destruct_level >= 2 && ckWARN_d(WARN_INTERNAL)) {
443 if (PL_scopestack_ix != 0)
444 Perl_warner(aTHX_ WARN_INTERNAL,
445 "Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
446 (long)PL_scopestack_ix);
447 if (PL_savestack_ix != 0)
448 Perl_warner(aTHX_ WARN_INTERNAL,
449 "Unbalanced saves: %ld more saves than restores\n",
450 (long)PL_savestack_ix);
451 if (PL_tmps_floor != -1)
452 Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced tmps: %ld more allocs than frees\n",
453 (long)PL_tmps_floor + 1);
454 if (cxstack_ix != -1)
455 Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced context: %ld more PUSHes than POPs\n",
456 (long)cxstack_ix + 1);
459 /* Now absolutely destruct everything, somehow or other, loops or no. */
461 SvFLAGS(PL_strtab) |= SVTYPEMASK; /* don't clean out strtab now */
462 while (PL_sv_count != 0 && PL_sv_count != last_sv_count) {
463 last_sv_count = PL_sv_count;
466 SvFLAGS(PL_strtab) &= ~SVTYPEMASK;
467 SvFLAGS(PL_strtab) |= SVt_PVHV;
469 /* Destruct the global string table. */
471 /* Yell and reset the HeVAL() slots that are still holding refcounts,
472 * so that sv_free() won't fail on them.
480 max = HvMAX(PL_strtab);
481 array = HvARRAY(PL_strtab);
484 if (hent && ckWARN_d(WARN_INTERNAL)) {
485 Perl_warner(aTHX_ WARN_INTERNAL,
486 "Unbalanced string table refcount: (%d) for \"%s\"",
487 HeVAL(hent) - Nullsv, HeKEY(hent));
488 HeVAL(hent) = Nullsv;
498 SvREFCNT_dec(PL_strtab);
500 if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL))
501 Perl_warner(aTHX_ WARN_INTERNAL,"Scalars leaked: %ld\n", (long)PL_sv_count);
505 /* No SVs have survived, need to clean out */
507 PL_pidstatus = Nullhv;
508 Safefree(PL_origfilename);
509 Safefree(PL_archpat_auto);
510 Safefree(PL_reg_start_tmp);
512 Safefree(PL_reg_curpm);
513 Safefree(PL_reg_poscache);
514 Safefree(HeKEY_hek(&PL_hv_fetch_ent_mh));
515 Safefree(PL_op_mask);
517 PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */
519 DEBUG_P(debprofdump());
521 MUTEX_DESTROY(&PL_strtab_mutex);
522 MUTEX_DESTROY(&PL_sv_mutex);
523 MUTEX_DESTROY(&PL_eval_mutex);
524 MUTEX_DESTROY(&PL_cred_mutex);
525 COND_DESTROY(&PL_eval_cond);
526 #ifdef EMULATE_ATOMIC_REFCOUNTS
527 MUTEX_DESTROY(&PL_svref_mutex);
528 #endif /* EMULATE_ATOMIC_REFCOUNTS */
530 /* As the penultimate thing, free the non-arena SV for thrsv */
531 Safefree(SvPVX(PL_thrsv));
532 Safefree(SvANY(PL_thrsv));
535 #endif /* USE_THREADS */
537 /* As the absolutely last thing, free the non-arena SV for mess() */
540 /* it could have accumulated taint magic */
541 if (SvTYPE(PL_mess_sv) >= SVt_PVMG) {
544 for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) {
545 moremagic = mg->mg_moremagic;
546 if (mg->mg_ptr && mg->mg_type != 'g' && mg->mg_len >= 0)
547 Safefree(mg->mg_ptr);
551 /* we know that type >= SVt_PV */
552 SvOOK_off(PL_mess_sv);
553 Safefree(SvPVX(PL_mess_sv));
554 Safefree(SvANY(PL_mess_sv));
555 Safefree(PL_mess_sv);
563 #if defined(PERL_OBJECT)
571 Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
573 Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry);
574 PL_exitlist[PL_exitlistlen].fn = fn;
575 PL_exitlist[PL_exitlistlen].ptr = ptr;
580 perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
589 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
592 Perl_croak(aTHX_ "suidperl is no longer needed since the kernel can now execute\n\
593 setuid perl scripts securely.\n");
597 #if defined(__DYNAMIC__) && (defined(NeXT) || defined(__NeXT__))
598 _dyld_lookup_and_bind
599 ("__environ", (unsigned long *) &environ_pointer, NULL);
604 #ifndef VMS /* VMS doesn't have environ array */
605 PL_origenviron = environ;
610 /* Come here if running an undumped a.out. */
612 PL_origfilename = savepv(argv[0]);
613 PL_do_undump = FALSE;
614 cxstack_ix = -1; /* start label stack again */
616 init_postdump_symbols(argc,argv,env);
621 PL_curpad = AvARRAY(PL_comppad);
622 op_free(PL_main_root);
623 PL_main_root = Nullop;
625 PL_main_start = Nullop;
626 SvREFCNT_dec(PL_main_cv);
630 oldscope = PL_scopestack_ix;
631 PL_dowarn = G_WARN_OFF;
633 CALLPROTECT(aTHX_ &ret, MEMBER_TO_FPTR(S_parse_body), env, xsinit);
641 /* my_exit() was called */
642 while (PL_scopestack_ix > oldscope)
645 PL_curstash = PL_defstash;
647 call_list(oldscope, PL_endav);
648 return STATUS_NATIVE_EXPORT;
650 PerlIO_printf(PerlIO_stderr(), "panic: top_env\n");
657 S_parse_body(pTHX_ va_list args)
660 int argc = PL_origargc;
661 char **argv = PL_origargv;
662 char **env = va_arg(args, char**);
663 char *scriptname = NULL;
665 VOL bool dosearch = FALSE;
671 XSINIT_t xsinit = va_arg(args, XSINIT_t);
673 sv_setpvn(PL_linestr,"",0);
674 sv = newSVpvn("",0); /* first used for -I flags */
678 for (argc--,argv++; argc > 0; argc--,argv++) {
679 if (argv[0][0] != '-' || !argv[0][1])
683 validarg = " PHOOEY ";
690 #ifndef PERL_STRICT_CR
714 if (s = moreswitches(s))
724 if (PL_euid != PL_uid || PL_egid != PL_gid)
725 Perl_croak(aTHX_ "No -e allowed in setuid scripts");
727 PL_e_script = newSVpvn("",0);
728 filter_add(read_e_script, NULL);
731 sv_catpv(PL_e_script, s);
733 sv_catpv(PL_e_script, argv[1]);
737 Perl_croak(aTHX_ "No code specified for -e");
738 sv_catpv(PL_e_script, "\n");
741 case 'I': /* -I handled both here and in moreswitches() */
743 if (!*++s && (s=argv[1]) != Nullch) {
746 while (s && isSPACE(*s))
750 for (e = s; *e && !isSPACE(*e); e++) ;
757 } /* XXX else croak? */
761 PL_preprocess = TRUE;
771 PL_preambleav = newAV();
772 av_push(PL_preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
774 PL_Sv = newSVpv("print myconfig();",0);
776 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
778 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
780 #if defined(DEBUGGING) || defined(MULTIPLICITY)
781 sv_catpv(PL_Sv,"\" Compile-time options:");
783 sv_catpv(PL_Sv," DEBUGGING");
786 sv_catpv(PL_Sv," MULTIPLICITY");
788 sv_catpv(PL_Sv,"\\n\",");
790 #if defined(LOCAL_PATCH_COUNT)
791 if (LOCAL_PATCH_COUNT > 0) {
793 sv_catpv(PL_Sv,"\" Locally applied patches:\\n\",");
794 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
795 if (PL_localpatches[i])
796 Perl_sv_catpvf(aTHX_ PL_Sv,"q\" \t%s\n\",",PL_localpatches[i]);
800 Perl_sv_catpvf(aTHX_ PL_Sv,"\" Built under %s\\n\"",OSNAME);
803 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
805 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled on %s\\n\"",__DATE__);
810 @env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; \
811 print \" \\%ENV:\\n @env\\n\" if @env; \
812 print \" \\@INC:\\n @INC\\n\";");
815 PL_Sv = newSVpv("config_vars(qw(",0);
816 sv_catpv(PL_Sv, ++s);
817 sv_catpv(PL_Sv, "))");
820 av_push(PL_preambleav, PL_Sv);
821 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
827 PL_cddir = savepv(s);
832 if (!*++s || isSPACE(*s)) {
836 /* catch use of gnu style long options */
837 if (strEQ(s, "version")) {
841 if (strEQ(s, "help")) {
848 Perl_croak(aTHX_ "Unrecognized switch: -%s (-h will show valid options)",s);
854 #ifndef SECURE_INTERNAL_GETENV
857 (s = PerlEnv_getenv("PERL5OPT"))) {
860 if (*s == '-' && *(s+1) == 'T')
873 if (!strchr("DIMUdmw", *s))
874 Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
881 scriptname = argv[0];
884 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
886 else if (scriptname == Nullch) {
888 if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
896 open_script(scriptname,dosearch,sv,&fdscript);
898 validate_suid(validarg, scriptname,fdscript);
903 PL_main_cv = PL_compcv = (CV*)NEWSV(1104,0);
904 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
905 CvUNIQUE_on(PL_compcv);
907 PL_comppad = newAV();
908 av_push(PL_comppad, Nullsv);
909 PL_curpad = AvARRAY(PL_comppad);
910 PL_comppad_name = newAV();
911 PL_comppad_name_fill = 0;
912 PL_min_intro_pending = 0;
915 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
916 PL_curpad[0] = (SV*)newAV();
917 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
918 CvOWNER(PL_compcv) = 0;
919 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
920 MUTEX_INIT(CvMUTEXP(PL_compcv));
921 #endif /* USE_THREADS */
923 comppadlist = newAV();
924 AvREAL_off(comppadlist);
925 av_store(comppadlist, 0, (SV*)PL_comppad_name);
926 av_store(comppadlist, 1, (SV*)PL_comppad);
927 CvPADLIST(PL_compcv) = comppadlist;
929 boot_core_UNIVERSAL();
933 (*xsinit)(aTHXo); /* in case linked C routines want magical variables */
934 #if defined(VMS) || defined(WIN32) || defined(DJGPP)
942 init_predump_symbols();
943 /* init_postdump_symbols not currently designed to be called */
944 /* more than once (ENV isn't cleared first, for example) */
945 /* But running with -u leaves %ENV & @ARGV undefined! XXX */
947 init_postdump_symbols(argc,argv,env);
951 /* now parse the script */
953 SETERRNO(0,SS$_NORMAL);
955 if (yyparse() || PL_error_count) {
957 Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
959 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
963 PL_curcop->cop_line = 0;
964 PL_curstash = PL_defstash;
965 PL_preprocess = FALSE;
967 SvREFCNT_dec(PL_e_script);
968 PL_e_script = Nullsv;
971 /* now that script is parsed, we can modify record separator */
973 PL_rs = SvREFCNT_inc(PL_nrs);
974 sv_setsv(get_sv("/", TRUE), PL_rs);
979 gv_check(PL_defstash);
985 if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
986 dump_mstats("after compilation:");
1004 oldscope = PL_scopestack_ix;
1007 CALLPROTECT(aTHX_ &ret, MEMBER_TO_FPTR(S_run_body), oldscope);
1010 cxstack_ix = -1; /* start context stack again */
1012 case 0: /* normal completion */
1013 case 2: /* my_exit() */
1014 while (PL_scopestack_ix > oldscope)
1017 PL_curstash = PL_defstash;
1019 call_list(oldscope, PL_endav);
1021 if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
1022 dump_mstats("after execution: ");
1024 return STATUS_NATIVE_EXPORT;
1027 POPSTACK_TO(PL_mainstack);
1030 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
1040 S_run_body(pTHX_ va_list args)
1043 I32 oldscope = va_arg(args, I32);
1045 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
1046 PL_sawampersand ? "Enabling" : "Omitting"));
1048 if (!PL_restartop) {
1049 DEBUG_x(dump_all());
1050 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
1051 DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%lx\n",
1052 (unsigned long) thr));
1055 PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", PL_origfilename);
1058 if (PERLDB_SINGLE && PL_DBsingle)
1059 sv_setiv(PL_DBsingle, 1);
1061 call_list(oldscope, PL_initav);
1067 PL_op = PL_restartop;
1071 else if (PL_main_start) {
1072 CvDEPTH(PL_main_cv) = 1;
1073 PL_op = PL_main_start;
1083 Perl_get_sv(pTHX_ const char *name, I32 create)
1087 if (name[1] == '\0' && !isALPHA(name[0])) {
1088 PADOFFSET tmp = find_threadsv(name);
1089 if (tmp != NOT_IN_PAD) {
1091 return THREADSV(tmp);
1094 #endif /* USE_THREADS */
1095 gv = gv_fetchpv(name, create, SVt_PV);
1102 Perl_get_av(pTHX_ const char *name, I32 create)
1104 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1113 Perl_get_hv(pTHX_ const char *name, I32 create)
1115 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1124 Perl_get_cv(pTHX_ const char *name, I32 create)
1126 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
1127 /* XXX unsafe for threads if eval_owner isn't held */
1128 /* XXX this is probably not what they think they're getting.
1129 * It has the same effect as "sub name;", i.e. just a forward
1131 if (create && !GvCVu(gv))
1132 return newSUB(start_subparse(FALSE, 0),
1133 newSVOP(OP_CONST, 0, newSVpv(name,0)),
1141 /* Be sure to refetch the stack pointer after calling these routines. */
1144 Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv)
1146 /* See G_* flags in cop.h */
1147 /* null terminated arg list */
1154 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
1159 return call_pv(sub_name, flags);
1163 Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
1164 /* name of the subroutine */
1165 /* See G_* flags in cop.h */
1167 return call_sv((SV*)get_cv(sub_name, TRUE), flags);
1171 Perl_call_method(pTHX_ const char *methname, I32 flags)
1172 /* name of the subroutine */
1173 /* See G_* flags in cop.h */
1179 XPUSHs(sv_2mortal(newSVpv(methname,0)));
1184 return call_sv(*PL_stack_sp--, flags);
1187 /* May be called with any of a CV, a GV, or an SV containing the name. */
1189 Perl_call_sv(pTHX_ SV *sv, I32 flags)
1191 /* See G_* flags in cop.h */
1194 LOGOP myop; /* fake syntax tree node */
1198 bool oldcatch = CATCH_GET;
1202 if (flags & G_DISCARD) {
1207 Zero(&myop, 1, LOGOP);
1208 myop.op_next = Nullop;
1209 if (!(flags & G_NOARGS))
1210 myop.op_flags |= OPf_STACKED;
1211 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1212 (flags & G_ARRAY) ? OPf_WANT_LIST :
1217 EXTEND(PL_stack_sp, 1);
1218 *++PL_stack_sp = sv;
1220 oldscope = PL_scopestack_ix;
1222 if (PERLDB_SUB && PL_curstash != PL_debstash
1223 /* Handle first BEGIN of -d. */
1224 && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
1225 /* Try harder, since this may have been a sighandler, thus
1226 * curstash may be meaningless. */
1227 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != PL_debstash)
1228 && !(flags & G_NODEBUG))
1229 PL_op->op_private |= OPpENTERSUB_DB;
1231 if (!(flags & G_EVAL)) {
1232 /* G_NOCATCH is a hack for perl_vdie using this path to call
1233 a __DIE__ handler */
1234 if (!(flags & G_NOCATCH)) {
1237 call_xbody((OP*)&myop, FALSE);
1238 retval = PL_stack_sp - (PL_stack_base + oldmark);
1239 if (!(flags & G_NOCATCH)) {
1244 cLOGOP->op_other = PL_op;
1246 /* we're trying to emulate pp_entertry() here */
1248 register PERL_CONTEXT *cx;
1249 I32 gimme = GIMME_V;
1254 push_return(PL_op->op_next);
1255 PUSHBLOCK(cx, CXt_EVAL, PL_stack_sp);
1257 PL_eval_root = PL_op; /* Only needed so that goto works right. */
1259 PL_in_eval = EVAL_INEVAL;
1260 if (flags & G_KEEPERR)
1261 PL_in_eval |= EVAL_KEEPERR;
1268 CALLPROTECT(aTHX_ &ret, MEMBER_TO_FPTR(S_call_body), (OP*)&myop, FALSE);
1271 retval = PL_stack_sp - (PL_stack_base + oldmark);
1272 if (!(flags & G_KEEPERR))
1279 /* my_exit() was called */
1280 PL_curstash = PL_defstash;
1283 Perl_croak(aTHX_ "Callback called exit");
1288 PL_op = PL_restartop;
1292 PL_stack_sp = PL_stack_base + oldmark;
1293 if (flags & G_ARRAY)
1297 *++PL_stack_sp = &PL_sv_undef;
1302 if (PL_scopestack_ix > oldscope) {
1306 register PERL_CONTEXT *cx;
1317 if (flags & G_DISCARD) {
1318 PL_stack_sp = PL_stack_base + oldmark;
1328 S_call_body(pTHX_ va_list args)
1330 OP *myop = va_arg(args, OP*);
1331 int is_eval = va_arg(args, int);
1333 call_xbody(myop, is_eval);
1338 S_call_xbody(pTHX_ OP *myop, int is_eval)
1342 if (PL_op == myop) {
1344 PL_op = Perl_pp_entereval(aTHX);
1346 PL_op = Perl_pp_entersub(aTHX);
1352 /* Eval a string. The G_EVAL flag is always assumed. */
1355 Perl_eval_sv(pTHX_ SV *sv, I32 flags)
1357 /* See G_* flags in cop.h */
1360 UNOP myop; /* fake syntax tree node */
1361 I32 oldmark = SP - PL_stack_base;
1367 if (flags & G_DISCARD) {
1374 Zero(PL_op, 1, UNOP);
1375 EXTEND(PL_stack_sp, 1);
1376 *++PL_stack_sp = sv;
1377 oldscope = PL_scopestack_ix;
1379 if (!(flags & G_NOARGS))
1380 myop.op_flags = OPf_STACKED;
1381 myop.op_next = Nullop;
1382 myop.op_type = OP_ENTEREVAL;
1383 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1384 (flags & G_ARRAY) ? OPf_WANT_LIST :
1386 if (flags & G_KEEPERR)
1387 myop.op_flags |= OPf_SPECIAL;
1390 CALLPROTECT(aTHX_ &ret, MEMBER_TO_FPTR(S_call_body), (OP*)&myop, TRUE);
1393 retval = PL_stack_sp - (PL_stack_base + oldmark);
1394 if (!(flags & G_KEEPERR))
1401 /* my_exit() was called */
1402 PL_curstash = PL_defstash;
1405 Perl_croak(aTHX_ "Callback called exit");
1410 PL_op = PL_restartop;
1414 PL_stack_sp = PL_stack_base + oldmark;
1415 if (flags & G_ARRAY)
1419 *++PL_stack_sp = &PL_sv_undef;
1424 if (flags & G_DISCARD) {
1425 PL_stack_sp = PL_stack_base + oldmark;
1435 Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
1438 SV* sv = newSVpv(p, 0);
1441 eval_sv(sv, G_SCALAR);
1448 if (croak_on_error && SvTRUE(ERRSV)) {
1450 Perl_croak(aTHX_ SvPVx(ERRSV, n_a));
1456 /* Require a module. */
1459 Perl_require_pv(pTHX_ const char *pv)
1463 PUSHSTACKi(PERLSI_REQUIRE);
1465 sv = sv_newmortal();
1466 sv_setpv(sv, "require '");
1469 eval_sv(sv, G_DISCARD);
1475 Perl_magicname(pTHX_ char *sym, char *name, I32 namlen)
1479 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1480 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1484 S_usage(pTHX_ char *name) /* XXX move this out into a module ? */
1486 /* This message really ought to be max 23 lines.
1487 * Removed -h because the user already knows that opton. Others? */
1489 static char *usage_msg[] = {
1490 "-0[octal] specify record separator (\\0, if no argument)",
1491 "-a autosplit mode with -n or -p (splits $_ into @F)",
1492 "-c check syntax only (runs BEGIN and END blocks)",
1493 "-d[:debugger] run program under debugger",
1494 "-D[number/list] set debugging flags (argument is a bit mask or alphabets)",
1495 "-e 'command' one line of program (several -e's allowed, omit programfile)",
1496 "-F/pattern/ split() pattern for -a switch (//'s are optional)",
1497 "-i[extension] edit <> files in place (makes backup if extension supplied)",
1498 "-Idirectory specify @INC/#include directory (several -I's allowed)",
1499 "-l[octal] enable line ending processing, specifies line terminator",
1500 "-[mM][-]module execute `use/no module...' before executing program",
1501 "-n assume 'while (<>) { ... }' loop around program",
1502 "-p assume loop like -n but print line also, like sed",
1503 "-P run program through C preprocessor before compilation",
1504 "-s enable rudimentary parsing for switches after programfile",
1505 "-S look for programfile using PATH environment variable",
1506 "-T enable tainting checks",
1507 "-u dump core after parsing program",
1508 "-U allow unsafe operations",
1509 "-v print version, subversion (includes VERY IMPORTANT perl info)",
1510 "-V[:variable] print configuration summary (or a single Config.pm variable)",
1511 "-w enable many useful warnings (RECOMMENDED)",
1512 "-x[directory] strip off text before #!perl line and perhaps cd to directory",
1516 char **p = usage_msg;
1518 printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1520 printf("\n %s", *p++);
1523 /* This routine handles any switches that can be given during run */
1526 Perl_moreswitches(pTHX_ char *s)
1535 rschar = scan_oct(s, 4, &numlen);
1536 SvREFCNT_dec(PL_nrs);
1537 if (rschar & ~((U8)~0))
1538 PL_nrs = &PL_sv_undef;
1539 else if (!rschar && numlen >= 2)
1540 PL_nrs = newSVpvn("", 0);
1543 PL_nrs = newSVpvn(&ch, 1);
1549 PL_splitstr = savepv(s + 1);
1563 if (*s == ':' || *s == '=') {
1564 my_setenv("PERL5DB", Perl_form(aTHX_ "use Devel::%s;", ++s));
1568 PL_perldb = PERLDB_ALL;
1576 if (isALPHA(s[1])) {
1577 static char debopts[] = "psltocPmfrxuLHXDS";
1580 for (s++; *s && (d = strchr(debopts,*s)); s++)
1581 PL_debug |= 1 << (d - debopts);
1584 PL_debug = atoi(s+1);
1585 for (s++; isDIGIT(*s); s++) ;
1587 PL_debug |= 0x80000000;
1590 if (ckWARN_d(WARN_DEBUGGING))
1591 Perl_warner(aTHX_ WARN_DEBUGGING,
1592 "Recompile perl with -DDEBUGGING to use -D switch\n");
1593 for (s++; isALNUM(*s); s++) ;
1599 usage(PL_origargv[0]);
1603 Safefree(PL_inplace);
1604 PL_inplace = savepv(s+1);
1606 for (s = PL_inplace; *s && !isSPACE(*s); s++) ;
1609 if (*s == '-') /* Additional switches on #! line. */
1613 case 'I': /* -I handled both here and in parse_perl() */
1616 while (*s && isSPACE(*s))
1620 for (e = s; *e && !isSPACE(*e); e++) ;
1621 p = savepvn(s, e-s);
1627 Perl_croak(aTHX_ "No space allowed after -I");
1635 PL_ors = savepv("\n");
1637 *PL_ors = scan_oct(s, 3 + (*s == '0'), &numlen);
1642 if (RsPARA(PL_nrs)) {
1647 PL_ors = SvPV(PL_nrs, PL_orslen);
1648 PL_ors = savepvn(PL_ors, PL_orslen);
1652 forbid_setid("-M"); /* XXX ? */
1655 forbid_setid("-m"); /* XXX ? */
1660 /* -M-foo == 'no foo' */
1661 if (*s == '-') { use = "no "; ++s; }
1662 sv = newSVpv(use,0);
1664 /* We allow -M'Module qw(Foo Bar)' */
1665 while(isALNUM(*s) || *s==':') ++s;
1667 sv_catpv(sv, start);
1668 if (*(start-1) == 'm') {
1670 Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
1671 sv_catpv( sv, " ()");
1674 sv_catpvn(sv, start, s-start);
1675 sv_catpv(sv, " split(/,/,q{");
1680 if (PL_preambleav == NULL)
1681 PL_preambleav = newAV();
1682 av_push(PL_preambleav, sv);
1685 Perl_croak(aTHX_ "No space allowed after -%c", *(s-1));
1697 PL_doswitches = TRUE;
1702 Perl_croak(aTHX_ "Too late for \"-T\" option");
1706 PL_do_undump = TRUE;
1714 #if defined(PERL_SUBVERSION) && PERL_SUBVERSION > 0
1715 printf("\nThis is perl, version %d.%03d_%02d built for %s",
1716 PERL_REVISION, PERL_VERSION, PERL_SUBVERSION, ARCHNAME);
1718 printf("\nThis is perl, version %s built for %s",
1719 PL_patchlevel, ARCHNAME);
1721 #if defined(LOCAL_PATCH_COUNT)
1722 if (LOCAL_PATCH_COUNT > 0)
1723 printf("\n(with %d registered patch%s, see perl -V for more detail)",
1724 LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : "");
1727 printf("\n\nCopyright 1987-1999, Larry Wall\n");
1729 printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1732 printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
1733 printf("djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
1736 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1737 "Version 5 port Copyright (c) 1994-1999, Andreas Kaiser, Ilya Zakharevich\n");
1740 printf("atariST series port, ++jrb bammi@cadence.com\n");
1743 printf("BeOS port Copyright Tom Spindler, 1997-1999\n");
1746 printf("MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-1999\n");
1749 printf("MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
1752 printf("Stratus VOS port by Paul_Green@stratus.com, 1997-1999\n");
1755 printf("VM/ESA port by Neale Ferguson, 1998-1999\n");
1758 printf("BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
1761 printf("MiNT port by Guido Flohr, 1997-1999\n");
1763 #ifdef BINARY_BUILD_NOTICE
1764 BINARY_BUILD_NOTICE;
1767 Perl may be copied only under the terms of either the Artistic License or the\n\
1768 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n\
1769 Complete documentation for Perl, including FAQ lists, should be found on\n\
1770 this system using `man perl' or `perldoc perl'. If you have access to the\n\
1771 Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
1774 if (! (PL_dowarn & G_WARN_ALL_MASK))
1775 PL_dowarn |= G_WARN_ON;
1779 PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
1780 PL_compiling.cop_warnings = WARN_ALL ;
1784 PL_dowarn = G_WARN_ALL_OFF;
1785 PL_compiling.cop_warnings = WARN_NONE ;
1790 if (s[1] == '-') /* Additional switches on #! line. */
1795 #if defined(WIN32) || !defined(PERL_STRICT_CR)
1801 #ifdef ALTERNATE_SHEBANG
1802 case 'S': /* OS/2 needs -S on "extproc" line. */
1810 Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
1815 /* compliments of Tom Christiansen */
1817 /* unexec() can be found in the Gnu emacs distribution */
1818 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
1821 Perl_my_unexec(pTHX)
1829 prog = newSVpv(BIN_EXP, 0);
1830 sv_catpv(prog, "/perl");
1831 file = newSVpv(PL_origfilename, 0);
1832 sv_catpv(file, ".perldump");
1834 unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
1835 /* unexec prints msg to stderr in case of failure */
1836 PerlProc_exit(status);
1839 # include <lib$routines.h>
1840 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
1842 ABORT(); /* for use with undump */
1847 /* initialize curinterp */
1852 #ifdef PERL_OBJECT /* XXX kludge */
1855 PL_chopset = " \n-"; \
1856 PL_copline = NOLINE; \
1857 PL_curcop = &PL_compiling;\
1858 PL_curcopdb = NULL; \
1861 PL_dumpindent = 4; \
1862 PL_laststatval = -1; \
1863 PL_laststype = OP_STAT; \
1864 PL_maxscream = -1; \
1865 PL_maxsysfd = MAXSYSFD; \
1866 PL_statname = Nullsv; \
1867 PL_tmps_floor = -1; \
1869 PL_op_mask = NULL; \
1871 PL_laststatval = -1; \
1872 PL_laststype = OP_STAT; \
1873 PL_mess_sv = Nullsv; \
1874 PL_splitstr = " "; \
1875 PL_generation = 100; \
1876 PL_exitlist = NULL; \
1877 PL_exitlistlen = 0; \
1879 PL_in_clean_objs = FALSE; \
1880 PL_in_clean_all = FALSE; \
1881 PL_profiledata = NULL; \
1883 PL_rsfp_filters = Nullav; \
1888 # ifdef MULTIPLICITY
1889 # define PERLVAR(var,type)
1890 # define PERLVARA(var,n,type)
1891 # if defined(PERL_IMPLICIT_CONTEXT)
1892 # if defined(USE_THREADS)
1893 # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
1894 # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
1895 # else /* !USE_THREADS */
1896 # define PERLVARI(var,type,init) aTHX->var = init;
1897 # define PERLVARIC(var,type,init) aTHX->var = init;
1898 # endif /* USE_THREADS */
1900 # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
1901 # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
1903 # include "intrpvar.h"
1904 # ifndef USE_THREADS
1905 # include "thrdvar.h"
1912 # define PERLVAR(var,type)
1913 # define PERLVARA(var,n,type)
1914 # define PERLVARI(var,type,init) PL_##var = init;
1915 # define PERLVARIC(var,type,init) PL_##var = init;
1916 # include "intrpvar.h"
1917 # ifndef USE_THREADS
1918 # include "thrdvar.h"
1930 S_init_main_stash(pTHX)
1935 /* Note that strtab is a rather special HV. Assumptions are made
1936 about not iterating on it, and not adding tie magic to it.
1937 It is properly deallocated in perl_destruct() */
1938 PL_strtab = newHV();
1940 MUTEX_INIT(&PL_strtab_mutex);
1942 HvSHAREKEYS_off(PL_strtab); /* mandatory */
1943 hv_ksplit(PL_strtab, 512);
1945 PL_curstash = PL_defstash = newHV();
1946 PL_curstname = newSVpvn("main",4);
1947 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1948 SvREFCNT_dec(GvHV(gv));
1949 GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
1951 HvNAME(PL_defstash) = savepv("main");
1952 PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1953 GvMULTI_on(PL_incgv);
1954 PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
1955 GvMULTI_on(PL_hintgv);
1956 PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1957 PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1958 GvMULTI_on(PL_errgv);
1959 PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
1960 GvMULTI_on(PL_replgv);
1961 (void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */
1962 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
1963 sv_setpvn(ERRSV, "", 0);
1964 PL_curstash = PL_defstash;
1965 PL_compiling.cop_stash = PL_defstash;
1966 PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
1967 PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
1968 /* We must init $/ before switches are processed. */
1969 sv_setpvn(get_sv("/", TRUE), "\n", 1);
1973 S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
1981 PL_origfilename = savepv("-e");
1984 /* if find_script() returns, it returns a malloc()-ed value */
1985 PL_origfilename = scriptname = find_script(scriptname, dosearch, NULL, 1);
1987 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
1988 char *s = scriptname + 8;
1989 *fdscript = atoi(s);
1993 scriptname = savepv(s + 1);
1994 Safefree(PL_origfilename);
1995 PL_origfilename = scriptname;
2000 PL_curcop->cop_filegv = gv_fetchfile(PL_origfilename);
2001 if (strEQ(PL_origfilename,"-"))
2003 if (*fdscript >= 0) {
2004 PL_rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE);
2005 #if defined(HAS_FCNTL) && defined(F_SETFD)
2007 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); /* ensure close-on-exec */
2010 else if (PL_preprocess) {
2011 char *cpp_cfg = CPPSTDIN;
2012 SV *cpp = newSVpvn("",0);
2013 SV *cmd = NEWSV(0,0);
2015 if (strEQ(cpp_cfg, "cppstdin"))
2016 Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
2017 sv_catpv(cpp, cpp_cfg);
2020 sv_catpv(sv,PRIVLIB_EXP);
2023 Perl_sv_setpvf(aTHX_ cmd, "\
2024 sed %s -e \"/^[^#]/b\" \
2025 -e \"/^#[ ]*include[ ]/b\" \
2026 -e \"/^#[ ]*define[ ]/b\" \
2027 -e \"/^#[ ]*if[ ]/b\" \
2028 -e \"/^#[ ]*ifdef[ ]/b\" \
2029 -e \"/^#[ ]*ifndef[ ]/b\" \
2030 -e \"/^#[ ]*else/b\" \
2031 -e \"/^#[ ]*elif[ ]/b\" \
2032 -e \"/^#[ ]*undef[ ]/b\" \
2033 -e \"/^#[ ]*endif/b\" \
2036 (PL_doextract ? "-e \"1,/^#/d\n\"" : ""),
2039 Perl_sv_setpvf(aTHX_ cmd, "\
2040 %s %s -e '/^[^#]/b' \
2041 -e '/^#[ ]*include[ ]/b' \
2042 -e '/^#[ ]*define[ ]/b' \
2043 -e '/^#[ ]*if[ ]/b' \
2044 -e '/^#[ ]*ifdef[ ]/b' \
2045 -e '/^#[ ]*ifndef[ ]/b' \
2046 -e '/^#[ ]*else/b' \
2047 -e '/^#[ ]*elif[ ]/b' \
2048 -e '/^#[ ]*undef[ ]/b' \
2049 -e '/^#[ ]*endif/b' \
2053 Perl_sv_setpvf(aTHX_ cmd, "\
2054 %s %s -e '/^[^#]/b' \
2055 -e '/^#[ ]*include[ ]/b' \
2056 -e '/^#[ ]*define[ ]/b' \
2057 -e '/^#[ ]*if[ ]/b' \
2058 -e '/^#[ ]*ifdef[ ]/b' \
2059 -e '/^#[ ]*ifndef[ ]/b' \
2060 -e '/^#[ ]*else/b' \
2061 -e '/^#[ ]*elif[ ]/b' \
2062 -e '/^#[ ]*undef[ ]/b' \
2063 -e '/^#[ ]*endif/b' \
2072 (PL_doextract ? "-e '1,/^#/d\n'" : ""),
2074 scriptname, cpp, sv, CPPMINUS);
2075 PL_doextract = FALSE;
2076 #ifdef IAMSUID /* actually, this is caught earlier */
2077 if (PL_euid != PL_uid && !PL_euid) { /* if running suidperl */
2079 (void)seteuid(PL_uid); /* musn't stay setuid root */
2082 (void)setreuid((Uid_t)-1, PL_uid);
2084 #ifdef HAS_SETRESUID
2085 (void)setresuid((Uid_t)-1, PL_uid, (Uid_t)-1);
2087 PerlProc_setuid(PL_uid);
2091 if (PerlProc_geteuid() != PL_uid)
2092 Perl_croak(aTHX_ "Can't do seteuid!\n");
2094 #endif /* IAMSUID */
2095 PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
2099 else if (!*scriptname) {
2100 forbid_setid("program input from stdin");
2101 PL_rsfp = PerlIO_stdin();
2104 PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
2105 #if defined(HAS_FCNTL) && defined(F_SETFD)
2107 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); /* ensure close-on-exec */
2112 #ifndef IAMSUID /* in case script is not readable before setuid */
2114 PerlLIO_stat(SvPVX(GvSV(PL_curcop->cop_filegv)),&PL_statbuf) >= 0 &&
2115 PL_statbuf.st_mode & (S_ISUID|S_ISGID))
2118 PerlProc_execv(Perl_form(aTHX_ "%s/sperl%s", BIN_EXP, PL_patchlevel), PL_origargv);
2119 Perl_croak(aTHX_ "Can't do setuid\n");
2123 Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
2124 SvPVX(GvSV(PL_curcop->cop_filegv)), Strerror(errno));
2129 * I_SYSSTATVFS HAS_FSTATVFS
2131 * I_STATFS HAS_FSTATFS
2132 * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT
2133 * here so that metaconfig picks them up. */
2137 S_fd_on_nosuid_fs(pTHX_ int fd)
2142 * Preferred order: fstatvfs(), fstatfs(), getmntent().
2143 * fstatvfs() is UNIX98.
2145 * getmntent() is O(number-of-mounted-filesystems) and can hang.
2148 # ifdef HAS_FSTATVFS
2149 struct statvfs stfs;
2150 check_okay = fstatvfs(fd, &stfs) == 0;
2151 on_nosuid = check_okay && (stfs.f_flag & ST_NOSUID);
2153 # if defined(HAS_FSTATFS) && defined(HAS_STRUCT_STATFS_FLAGS)
2155 check_okay = fstatfs(fd, &stfs) == 0;
2156 # undef PERL_MOUNT_NOSUID
2157 # if !defined(PERL_MOUNT_NOSUID) && defined(MNT_NOSUID)
2158 # define PERL_MOUNT_NOSUID MNT_NOSUID
2160 # if !defined(PERL_MOUNT_NOSUID) && defined(MS_NOSUID)
2161 # define PERL_MOUNT_NOSUID MS_NOSUID
2163 # if !defined(PERL_MOUNT_NOSUID) && defined(M_NOSUID)
2164 # define PERL_MOUNT_NOSUID M_NOSUID
2166 # ifdef PERL_MOUNT_NOSUID
2167 on_nosuid = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
2170 # if defined(HAS_GETMNTENT) && defined(HAS_HASMNTOPT) && defined(MNTOPT_NOSUID)
2171 FILE *mtab = fopen("/etc/mtab", "r");
2172 struct mntent *entry;
2173 struct stat stb, fsb;
2175 if (mtab && (fstat(fd, &stb) == 0)) {
2176 while (entry = getmntent(mtab)) {
2177 if (stat(entry->mnt_dir, &fsb) == 0
2178 && fsb.st_dev == stb.st_dev)
2180 /* found the filesystem */
2182 if (hasmntopt(entry, MNTOPT_NOSUID))
2185 } /* A single fs may well fail its stat(). */
2190 # endif /* mntent */
2191 # endif /* statfs */
2192 # endif /* statvfs */
2194 Perl_croak(aTHX_ "Can't check filesystem of script \"%s\"", PL_origfilename);
2197 #endif /* IAMSUID */
2200 S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript)
2204 /* do we need to emulate setuid on scripts? */
2206 /* This code is for those BSD systems that have setuid #! scripts disabled
2207 * in the kernel because of a security problem. Merely defining DOSUID
2208 * in perl will not fix that problem, but if you have disabled setuid
2209 * scripts in the kernel, this will attempt to emulate setuid and setgid
2210 * on scripts that have those now-otherwise-useless bits set. The setuid
2211 * root version must be called suidperl or sperlN.NNN. If regular perl
2212 * discovers that it has opened a setuid script, it calls suidperl with
2213 * the same argv that it had. If suidperl finds that the script it has
2214 * just opened is NOT setuid root, it sets the effective uid back to the
2215 * uid. We don't just make perl setuid root because that loses the
2216 * effective uid we had before invoking perl, if it was different from the
2219 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
2220 * be defined in suidperl only. suidperl must be setuid root. The
2221 * Configure script will set this up for you if you want it.
2228 if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */
2229 Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
2230 if (fdscript < 0 && PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
2235 #ifndef HAS_SETREUID
2236 /* On this access check to make sure the directories are readable,
2237 * there is actually a small window that the user could use to make
2238 * filename point to an accessible directory. So there is a faint
2239 * chance that someone could execute a setuid script down in a
2240 * non-accessible directory. I don't know what to do about that.
2241 * But I don't think it's too important. The manual lies when
2242 * it says access() is useful in setuid programs.
2244 if (PerlLIO_access(SvPVX(GvSV(PL_curcop->cop_filegv)),1)) /*double check*/
2245 Perl_croak(aTHX_ "Permission denied");
2247 /* If we can swap euid and uid, then we can determine access rights
2248 * with a simple stat of the file, and then compare device and
2249 * inode to make sure we did stat() on the same file we opened.
2250 * Then we just have to make sure he or she can execute it.
2253 struct stat tmpstatbuf;
2257 setreuid(PL_euid,PL_uid) < 0
2260 setresuid(PL_euid,PL_uid,(Uid_t)-1) < 0
2263 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
2264 Perl_croak(aTHX_ "Can't swap uid and euid"); /* really paranoid */
2265 if (PerlLIO_stat(SvPVX(GvSV(PL_curcop->cop_filegv)),&tmpstatbuf) < 0)
2266 Perl_croak(aTHX_ "Permission denied"); /* testing full pathname here */
2267 #if defined(IAMSUID) && !defined(NO_NOSUID_CHECK)
2268 if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp)))
2269 Perl_croak(aTHX_ "Permission denied");
2271 if (tmpstatbuf.st_dev != PL_statbuf.st_dev ||
2272 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
2273 (void)PerlIO_close(PL_rsfp);
2274 if (PL_rsfp = PerlProc_popen("/bin/mail root","w")) { /* heh, heh */
2275 PerlIO_printf(PL_rsfp,
2276 "User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2277 (Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
2278 (long)PL_uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
2279 (long)PL_statbuf.st_dev, (long)PL_statbuf.st_ino,
2280 SvPVX(GvSV(PL_curcop->cop_filegv)),
2281 (long)PL_statbuf.st_uid, (long)PL_statbuf.st_gid);
2282 (void)PerlProc_pclose(PL_rsfp);
2284 Perl_croak(aTHX_ "Permission denied\n");
2288 setreuid(PL_uid,PL_euid) < 0
2290 # if defined(HAS_SETRESUID)
2291 setresuid(PL_uid,PL_euid,(Uid_t)-1) < 0
2294 || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
2295 Perl_croak(aTHX_ "Can't reswap uid and euid");
2296 if (!cando(S_IXUSR,FALSE,&PL_statbuf)) /* can real uid exec? */
2297 Perl_croak(aTHX_ "Permission denied\n");
2299 #endif /* HAS_SETREUID */
2300 #endif /* IAMSUID */
2302 if (!S_ISREG(PL_statbuf.st_mode))
2303 Perl_croak(aTHX_ "Permission denied");
2304 if (PL_statbuf.st_mode & S_IWOTH)
2305 Perl_croak(aTHX_ "Setuid/gid script is writable by world");
2306 PL_doswitches = FALSE; /* -s is insecure in suid */
2307 PL_curcop->cop_line++;
2308 if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
2309 strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */
2310 Perl_croak(aTHX_ "No #! line");
2311 s = SvPV(PL_linestr,n_a)+2;
2313 while (!isSPACE(*s)) s++;
2314 for (s2 = s; (s2 > SvPV(PL_linestr,n_a)+2 &&
2315 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
2316 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
2317 Perl_croak(aTHX_ "Not a perl script");
2318 while (*s == ' ' || *s == '\t') s++;
2320 * #! arg must be what we saw above. They can invoke it by
2321 * mentioning suidperl explicitly, but they may not add any strange
2322 * arguments beyond what #! says if they do invoke suidperl that way.
2324 len = strlen(validarg);
2325 if (strEQ(validarg," PHOOEY ") ||
2326 strnNE(s,validarg,len) || !isSPACE(s[len]))
2327 Perl_croak(aTHX_ "Args must match #! line");
2330 if (PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
2331 PL_euid == PL_statbuf.st_uid)
2333 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2334 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2335 #endif /* IAMSUID */
2337 if (PL_euid) { /* oops, we're not the setuid root perl */
2338 (void)PerlIO_close(PL_rsfp);
2341 PerlProc_execv(Perl_form(aTHX_ "%s/sperl%s", BIN_EXP, PL_patchlevel), PL_origargv);
2343 Perl_croak(aTHX_ "Can't do setuid\n");
2346 if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
2348 (void)setegid(PL_statbuf.st_gid);
2351 (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
2353 #ifdef HAS_SETRESGID
2354 (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
2356 PerlProc_setgid(PL_statbuf.st_gid);
2360 if (PerlProc_getegid() != PL_statbuf.st_gid)
2361 Perl_croak(aTHX_ "Can't do setegid!\n");
2363 if (PL_statbuf.st_mode & S_ISUID) {
2364 if (PL_statbuf.st_uid != PL_euid)
2366 (void)seteuid(PL_statbuf.st_uid); /* all that for this */
2369 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
2371 #ifdef HAS_SETRESUID
2372 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
2374 PerlProc_setuid(PL_statbuf.st_uid);
2378 if (PerlProc_geteuid() != PL_statbuf.st_uid)
2379 Perl_croak(aTHX_ "Can't do seteuid!\n");
2381 else if (PL_uid) { /* oops, mustn't run as root */
2383 (void)seteuid((Uid_t)PL_uid);
2386 (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
2388 #ifdef HAS_SETRESUID
2389 (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
2391 PerlProc_setuid((Uid_t)PL_uid);
2395 if (PerlProc_geteuid() != PL_uid)
2396 Perl_croak(aTHX_ "Can't do seteuid!\n");
2399 if (!cando(S_IXUSR,TRUE,&PL_statbuf))
2400 Perl_croak(aTHX_ "Permission denied\n"); /* they can't do this */
2403 else if (PL_preprocess)
2404 Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
2405 else if (fdscript >= 0)
2406 Perl_croak(aTHX_ "fd script not allowed in suidperl\n");
2408 Perl_croak(aTHX_ "Script is not setuid/setgid in suidperl\n");
2410 /* We absolutely must clear out any saved ids here, so we */
2411 /* exec the real perl, substituting fd script for scriptname. */
2412 /* (We pass script name as "subdir" of fd, which perl will grok.) */
2413 PerlIO_rewind(PL_rsfp);
2414 PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0); /* just in case rewind didn't */
2415 for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
2416 if (!PL_origargv[which])
2417 Perl_croak(aTHX_ "Permission denied");
2418 PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
2419 PerlIO_fileno(PL_rsfp), PL_origargv[which]));
2420 #if defined(HAS_FCNTL) && defined(F_SETFD)
2421 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */
2423 PerlProc_execv(Perl_form(aTHX_ "%s/perl%s", BIN_EXP, PL_patchlevel), PL_origargv);/* try again */
2424 Perl_croak(aTHX_ "Can't do setuid\n");
2425 #endif /* IAMSUID */
2427 if (PL_euid != PL_uid || PL_egid != PL_gid) { /* (suidperl doesn't exist, in fact) */
2428 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2430 PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf); /* may be either wrapped or real suid */
2431 if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
2433 (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
2436 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2437 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2438 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2439 /* not set-id, must be wrapped */
2445 S_find_beginning(pTHX)
2447 register char *s, *s2;
2449 /* skip forward in input to the real script? */
2452 while (PL_doextract) {
2453 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
2454 Perl_croak(aTHX_ "No Perl script found in input\n");
2455 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2456 PerlIO_ungetc(PL_rsfp, '\n'); /* to keep line count right */
2457 PL_doextract = FALSE;
2458 while (*s && !(isSPACE (*s) || *s == '#')) s++;
2460 while (*s == ' ' || *s == '\t') s++;
2462 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2463 if (strnEQ(s2-4,"perl",4))
2465 while (s = moreswitches(s)) ;
2467 if (PL_cddir && PerlDir_chdir(PL_cddir) < 0)
2468 Perl_croak(aTHX_ "Can't chdir to %s",PL_cddir);
2477 PL_uid = PerlProc_getuid();
2478 PL_euid = PerlProc_geteuid();
2479 PL_gid = PerlProc_getgid();
2480 PL_egid = PerlProc_getegid();
2482 PL_uid |= PL_gid << 16;
2483 PL_euid |= PL_egid << 16;
2485 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2489 S_forbid_setid(pTHX_ char *s)
2491 if (PL_euid != PL_uid)
2492 Perl_croak(aTHX_ "No %s allowed while running setuid", s);
2493 if (PL_egid != PL_gid)
2494 Perl_croak(aTHX_ "No %s allowed while running setgid", s);
2498 Perl_init_debugger(pTHX)
2501 HV *ostash = PL_curstash;
2503 PL_curstash = PL_debstash;
2504 PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2505 AvREAL_off(PL_dbargs);
2506 PL_DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2507 PL_DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2508 PL_DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2509 sv_upgrade(GvSV(PL_DBsub), SVt_IV); /* IVX accessed if PERLDB_SUB_NN */
2510 PL_DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2511 sv_setiv(PL_DBsingle, 0);
2512 PL_DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2513 sv_setiv(PL_DBtrace, 0);
2514 PL_DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2515 sv_setiv(PL_DBsignal, 0);
2516 PL_curstash = ostash;
2519 #ifndef STRESS_REALLOC
2520 #define REASONABLE(size) (size)
2522 #define REASONABLE(size) (1) /* unreasonable */
2526 Perl_init_stacks(pTHX)
2528 /* start with 128-item stack and 8K cxstack */
2529 PL_curstackinfo = new_stackinfo(REASONABLE(128),
2530 REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
2531 PL_curstackinfo->si_type = PERLSI_MAIN;
2532 PL_curstack = PL_curstackinfo->si_stack;
2533 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
2535 PL_stack_base = AvARRAY(PL_curstack);
2536 PL_stack_sp = PL_stack_base;
2537 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
2539 New(50,PL_tmps_stack,REASONABLE(128),SV*);
2542 PL_tmps_max = REASONABLE(128);
2544 New(54,PL_markstack,REASONABLE(32),I32);
2545 PL_markstack_ptr = PL_markstack;
2546 PL_markstack_max = PL_markstack + REASONABLE(32);
2550 New(54,PL_scopestack,REASONABLE(32),I32);
2551 PL_scopestack_ix = 0;
2552 PL_scopestack_max = REASONABLE(32);
2554 New(54,PL_savestack,REASONABLE(128),ANY);
2555 PL_savestack_ix = 0;
2556 PL_savestack_max = REASONABLE(128);
2558 New(54,PL_retstack,REASONABLE(16),OP*);
2560 PL_retstack_max = REASONABLE(16);
2569 while (PL_curstackinfo->si_next)
2570 PL_curstackinfo = PL_curstackinfo->si_next;
2571 while (PL_curstackinfo) {
2572 PERL_SI *p = PL_curstackinfo->si_prev;
2573 /* curstackinfo->si_stack got nuked by sv_free_arenas() */
2574 Safefree(PL_curstackinfo->si_cxstack);
2575 Safefree(PL_curstackinfo);
2576 PL_curstackinfo = p;
2578 Safefree(PL_tmps_stack);
2579 Safefree(PL_markstack);
2580 Safefree(PL_scopestack);
2581 Safefree(PL_savestack);
2582 Safefree(PL_retstack);
2584 Safefree(PL_debname);
2585 Safefree(PL_debdelim);
2590 static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
2601 lex_start(PL_linestr);
2603 PL_subname = newSVpvn("main",4);
2607 S_init_predump_symbols(pTHX)
2614 sv_setpvn(get_sv("\"", TRUE), " ", 1);
2615 PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2616 GvMULTI_on(PL_stdingv);
2617 io = GvIOp(PL_stdingv);
2618 IoIFP(io) = PerlIO_stdin();
2619 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2621 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
2623 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2626 IoOFP(io) = IoIFP(io) = PerlIO_stdout();
2628 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2630 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
2632 othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2633 GvMULTI_on(othergv);
2634 io = GvIOp(othergv);
2635 IoOFP(io) = IoIFP(io) = PerlIO_stderr();
2636 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2638 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
2640 PL_statname = NEWSV(66,0); /* last filename we did stat on */
2643 PL_osname = savepv(OSNAME);
2647 S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
2654 argc--,argv++; /* skip name of script */
2655 if (PL_doswitches) {
2656 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2659 if (argv[0][1] == '-') {
2663 if (s = strchr(argv[0], '=')) {
2665 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2668 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2671 PL_toptarget = NEWSV(0,0);
2672 sv_upgrade(PL_toptarget, SVt_PVFM);
2673 sv_setpvn(PL_toptarget, "", 0);
2674 PL_bodytarget = NEWSV(0,0);
2675 sv_upgrade(PL_bodytarget, SVt_PVFM);
2676 sv_setpvn(PL_bodytarget, "", 0);
2677 PL_formtarget = PL_bodytarget;
2680 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2681 sv_setpv(GvSV(tmpgv),PL_origfilename);
2682 magicname("0", "0", 1);
2684 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2685 sv_setpv(GvSV(tmpgv),PL_origargv[0]);
2686 if (PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2687 GvMULTI_on(PL_argvgv);
2688 (void)gv_AVadd(PL_argvgv);
2689 av_clear(GvAVn(PL_argvgv));
2690 for (; argc > 0; argc--,argv++) {
2691 av_push(GvAVn(PL_argvgv),newSVpv(argv[0],0));
2694 if (PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2696 GvMULTI_on(PL_envgv);
2697 hv = GvHVn(PL_envgv);
2698 hv_magic(hv, PL_envgv, 'E');
2699 #if !defined( VMS) && !defined(EPOC) /* VMS doesn't have environ array */
2700 /* Note that if the supplied env parameter is actually a copy
2701 of the global environ then it may now point to free'd memory
2702 if the environment has been modified since. To avoid this
2703 problem we treat env==NULL as meaning 'use the default'
2708 environ[0] = Nullch;
2709 for (; *env; env++) {
2710 if (!(s = strchr(*env,'=')))
2716 sv = newSVpv(s--,0);
2717 (void)hv_store(hv, *env, s - *env, sv, 0);
2719 #if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
2720 /* Sins of the RTL. See note in my_setenv(). */
2721 (void)PerlEnv_putenv(savepv(*env));
2725 #ifdef DYNAMIC_ENV_FETCH
2726 HvNAME(hv) = savepv(ENV_HV_NAME);
2730 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2731 sv_setiv(GvSV(tmpgv), (IV)getpid());
2735 S_init_perllib(pTHX)
2740 s = PerlEnv_getenv("PERL5LIB");
2744 incpush(PerlEnv_getenv("PERLLIB"), FALSE);
2746 /* Treat PERL5?LIB as a possible search list logical name -- the
2747 * "natural" VMS idiom for a Unix path string. We allow each
2748 * element to be a set of |-separated directories for compatibility.
2752 if (my_trnlnm("PERL5LIB",buf,0))
2753 do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2755 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2759 /* Use the ~-expanded versions of APPLLIB (undocumented),
2760 ARCHLIB PRIVLIB SITEARCH and SITELIB
2763 incpush(APPLLIB_EXP, TRUE);
2767 incpush(ARCHLIB_EXP, FALSE);
2770 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2773 incpush(PRIVLIB_EXP, TRUE);
2775 incpush(PRIVLIB_EXP, FALSE);
2779 incpush(SITEARCH_EXP, FALSE);
2783 incpush(SITELIB_EXP, TRUE);
2785 incpush(SITELIB_EXP, FALSE);
2788 #if defined(PERL_VENDORLIB_EXP)
2790 incpush(PERL_VENDORLIB_EXP, TRUE);
2792 incpush(PERL_VENDORLIB_EXP, FALSE);
2796 incpush(".", FALSE);
2800 # define PERLLIB_SEP ';'
2803 # define PERLLIB_SEP '|'
2805 # define PERLLIB_SEP ':'
2808 #ifndef PERLLIB_MANGLE
2809 # define PERLLIB_MANGLE(s,n) (s)
2813 S_incpush(pTHX_ char *p, int addsubdirs)
2815 SV *subdir = Nullsv;
2821 subdir = sv_newmortal();
2822 if (!PL_archpat_auto) {
2823 STRLEN len = (sizeof(ARCHNAME) + strlen(PL_patchlevel)
2824 + sizeof("//auto"));
2825 New(55, PL_archpat_auto, len, char);
2826 sprintf(PL_archpat_auto, "/%s/%s/auto", ARCHNAME, PL_patchlevel);
2828 for (len = sizeof(ARCHNAME) + 2;
2829 PL_archpat_auto[len] != '\0' && PL_archpat_auto[len] != '/'; len++)
2830 if (PL_archpat_auto[len] == '.') PL_archpat_auto[len] = '_';
2835 /* Break at all separators */
2837 SV *libdir = NEWSV(55,0);
2840 /* skip any consecutive separators */
2841 while ( *p == PERLLIB_SEP ) {
2842 /* Uncomment the next line for PATH semantics */
2843 /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */
2847 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2848 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2853 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2854 p = Nullch; /* break out */
2858 * BEFORE pushing libdir onto @INC we may first push version- and
2859 * archname-specific sub-directories.
2862 struct stat tmpstatbuf;
2867 if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) {
2869 while (unix[len-1] == '/') len--; /* Cosmetic */
2870 sv_usepvn(libdir,unix,len);
2873 PerlIO_printf(PerlIO_stderr(),
2874 "Failed to unixify @INC element \"%s\"\n",
2877 /* .../archname/version if -d .../archname/version/auto */
2878 sv_setsv(subdir, libdir);
2879 sv_catpv(subdir, PL_archpat_auto);
2880 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2881 S_ISDIR(tmpstatbuf.st_mode))
2882 av_push(GvAVn(PL_incgv),
2883 newSVpvn(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2885 /* .../archname if -d .../archname/auto */
2886 sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
2887 strlen(PL_patchlevel) + 1, "", 0);
2888 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2889 S_ISDIR(tmpstatbuf.st_mode))
2890 av_push(GvAVn(PL_incgv),
2891 newSVpvn(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2894 /* finally push this lib directory on the end of @INC */
2895 av_push(GvAVn(PL_incgv), libdir);
2900 STATIC struct perl_thread *
2901 S_init_main_thread(pTHX)
2903 #if !defined(PERL_IMPLICIT_CONTEXT)
2904 struct perl_thread *thr;
2908 Newz(53, thr, 1, struct perl_thread);
2909 PL_curcop = &PL_compiling;
2910 thr->interp = PERL_GET_INTERP;
2911 thr->cvcache = newHV();
2912 thr->threadsv = newAV();
2913 /* thr->threadsvp is set when find_threadsv is called */
2914 thr->specific = newAV();
2915 thr->errhv = newHV();
2916 thr->flags = THRf_R_JOINABLE;
2917 MUTEX_INIT(&thr->mutex);
2918 /* Handcraft thrsv similarly to mess_sv */
2919 New(53, PL_thrsv, 1, SV);
2920 Newz(53, xpv, 1, XPV);
2921 SvFLAGS(PL_thrsv) = SVt_PV;
2922 SvANY(PL_thrsv) = (void*)xpv;
2923 SvREFCNT(PL_thrsv) = 1 << 30; /* practically infinite */
2924 SvPVX(PL_thrsv) = (char*)thr;
2925 SvCUR_set(PL_thrsv, sizeof(thr));
2926 SvLEN_set(PL_thrsv, sizeof(thr));
2927 *SvEND(PL_thrsv) = '\0'; /* in the trailing_nul field */
2928 thr->oursv = PL_thrsv;
2929 PL_chopset = " \n-";
2932 MUTEX_LOCK(&PL_threads_mutex);
2937 MUTEX_UNLOCK(&PL_threads_mutex);
2939 #ifdef HAVE_THREAD_INTERN
2940 Perl_init_thread_intern(thr);
2943 #ifdef SET_THREAD_SELF
2944 SET_THREAD_SELF(thr);
2946 thr->self = pthread_self();
2947 #endif /* SET_THREAD_SELF */
2951 * These must come after the SET_THR because sv_setpvn does
2952 * SvTAINT and the taint fields require dTHR.
2954 PL_toptarget = NEWSV(0,0);
2955 sv_upgrade(PL_toptarget, SVt_PVFM);
2956 sv_setpvn(PL_toptarget, "", 0);
2957 PL_bodytarget = NEWSV(0,0);
2958 sv_upgrade(PL_bodytarget, SVt_PVFM);
2959 sv_setpvn(PL_bodytarget, "", 0);
2960 PL_formtarget = PL_bodytarget;
2961 thr->errsv = newSVpvn("", 0);
2962 (void) find_threadsv("@"); /* Ensure $@ is initialised early */
2965 PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
2966 PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
2967 PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
2968 PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
2969 PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
2971 PL_reginterp_cnt = 0;
2975 #endif /* USE_THREADS */
2978 Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
2982 line_t oldline = PL_curcop->cop_line;
2987 while (AvFILL(paramList) >= 0) {
2988 cv = (CV*)av_shift(paramList);
2990 CALLPROTECT(aTHX_ &ret, MEMBER_TO_FPTR(S_call_list_body), cv);
2993 (void)SvPV(atsv, len);
2995 PL_curcop = &PL_compiling;
2996 PL_curcop->cop_line = oldline;
2997 if (paramList == PL_beginav)
2998 sv_catpv(atsv, "BEGIN failed--compilation aborted");
3000 sv_catpv(atsv, "END failed--cleanup aborted");
3001 while (PL_scopestack_ix > oldscope)
3003 Perl_croak(aTHX_ "%s", SvPVX(atsv));
3010 /* my_exit() was called */
3011 while (PL_scopestack_ix > oldscope)
3014 PL_curstash = PL_defstash;
3016 call_list(oldscope, PL_endav);
3017 PL_curcop = &PL_compiling;
3018 PL_curcop->cop_line = oldline;
3019 if (PL_statusvalue) {
3020 if (paramList == PL_beginav)
3021 Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
3023 Perl_croak(aTHX_ "END failed--cleanup aborted");
3029 PL_curcop = &PL_compiling;
3030 PL_curcop->cop_line = oldline;
3033 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
3041 S_call_list_body(pTHX_ va_list args)
3044 CV *cv = va_arg(args, CV*);
3046 PUSHMARK(PL_stack_sp);
3047 call_sv((SV*)cv, G_EVAL|G_DISCARD);
3052 Perl_my_exit(pTHX_ U32 status)
3056 DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
3057 thr, (unsigned long) status));
3066 STATUS_NATIVE_SET(status);
3073 Perl_my_failure_exit(pTHX)
3076 if (vaxc$errno & 1) {
3077 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
3078 STATUS_NATIVE_SET(44);
3081 if (!vaxc$errno && errno) /* unlikely */
3082 STATUS_NATIVE_SET(44);
3084 STATUS_NATIVE_SET(vaxc$errno);
3089 STATUS_POSIX_SET(errno);
3091 exitstatus = STATUS_POSIX >> 8;
3092 if (exitstatus & 255)
3093 STATUS_POSIX_SET(exitstatus);
3095 STATUS_POSIX_SET(255);
3102 S_my_exit_jump(pTHX)
3105 register PERL_CONTEXT *cx;
3110 SvREFCNT_dec(PL_e_script);
3111 PL_e_script = Nullsv;
3114 POPSTACK_TO(PL_mainstack);
3115 if (cxstack_ix >= 0) {
3118 POPBLOCK(cx,PL_curpm);
3131 read_e_script(pTHXo_ int idx, SV *buf_sv, int maxlen)
3134 p = SvPVX(PL_e_script);
3135 nl = strchr(p, '\n');
3136 nl = (nl) ? nl+1 : SvEND(PL_e_script);
3138 filter_del(read_e_script);
3141 sv_catpvn(buf_sv, p, nl-p);
3142 sv_chop(PL_e_script, nl);