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
18 /* XXX If this causes problems, set i_unistd=undef in the hint file. */
23 #if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE)
24 char *getenv (char *); /* Usually in <stdlib.h> */
27 static I32 read_e_script(pTHXo_ int idx, SV *buf_sv, int maxlen);
42 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
49 CPerlObj* perl_alloc(IPerlMem* ipM, IPerlEnv* ipE, IPerlStdIO* ipStd,
50 IPerlLIO* ipLIO, IPerlDir* ipD, IPerlSock* ipS, IPerlProc* ipP)
52 CPerlObj* pPerl = new(ipM) CPerlObj(ipM, ipE, ipStd, ipLIO, ipD, ipS, ipP);
62 PerlInterpreter *my_perl;
64 New(53, my_perl, 1, PerlInterpreter);
65 PERL_SET_INTERP(my_perl);
68 #endif /* PERL_OBJECT */
76 struct perl_thread *thr;
77 #endif /* FAKE_THREADS */
78 #endif /* USE_THREADS */
81 Zero(my_perl, 1, PerlInterpreter);
84 /* Init the real globals (and main thread)? */
89 #ifdef ALLOC_THREAD_KEY
92 if (pthread_key_create(&PL_thr_key, 0))
93 Perl_croak(aTHX_ "panic: pthread_key_create");
95 MUTEX_INIT(&PL_sv_mutex);
97 * Safe to use basic SV functions from now on (though
98 * not things like mortals or tainting yet).
100 MUTEX_INIT(&PL_eval_mutex);
101 COND_INIT(&PL_eval_cond);
102 MUTEX_INIT(&PL_threads_mutex);
103 COND_INIT(&PL_nthreads_cond);
104 #ifdef EMULATE_ATOMIC_REFCOUNTS
105 MUTEX_INIT(&PL_svref_mutex);
106 #endif /* EMULATE_ATOMIC_REFCOUNTS */
108 MUTEX_INIT(&PL_cred_mutex);
110 thr = init_main_thread();
111 #endif /* USE_THREADS */
113 PL_protect = FUNC_NAME_TO_PTR(Perl_default_protect); /* for exceptions */
115 PL_curcop = &PL_compiling; /* needed by ckWARN, right away */
117 PL_linestr = NEWSV(65,79);
118 sv_upgrade(PL_linestr,SVt_PVIV);
120 if (!SvREADONLY(&PL_sv_undef)) {
121 /* set read-only and try to insure than we wont see REFCNT==0
124 SvREADONLY_on(&PL_sv_undef);
125 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
127 sv_setpv(&PL_sv_no,PL_No);
129 SvREADONLY_on(&PL_sv_no);
130 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
132 sv_setpv(&PL_sv_yes,PL_Yes);
134 SvREADONLY_on(&PL_sv_yes);
135 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
140 /* PL_sighandlerp = sighandler; */
142 PL_sighandlerp = Perl_sighandler;
144 PL_pidstatus = newHV();
148 * There is no way we can refer to them from Perl so close them to save
149 * space. The other alternative would be to provide STDAUX and STDPRN
152 (void)fclose(stdaux);
153 (void)fclose(stdprn);
157 PL_nrs = newSVpvn("\n", 1);
158 PL_rs = SvREFCNT_inc(PL_nrs);
163 PL_perl_destruct_level = 1;
165 if (PL_perl_destruct_level > 0)
170 PL_lex_state = LEX_NOTPARSING;
176 SET_NUMERIC_STANDARD();
177 #if defined(PERL_SUBVERSION) && PERL_SUBVERSION > 0
178 sprintf(PL_patchlevel, "%7.5f", (double) PERL_REVISION
179 + ((double) PERL_VERSION / (double) 1000)
180 + ((double) PERL_SUBVERSION / (double) 100000));
182 sprintf(PL_patchlevel, "%5.3f", (double) PERL_REVISION +
183 ((double) PERL_VERSION / (double) 1000));
186 #if defined(LOCAL_PATCH_COUNT)
187 PL_localpatches = local_patches; /* For possible -v */
190 PerlIO_init(); /* Hook to IO system */
192 PL_fdpid = newAV(); /* for remembering popen pids by fd */
193 PL_modglobal = newHV(); /* pointers to per-interpreter module globals */
196 New(51,PL_debname,128,char);
197 New(52,PL_debdelim,128,char);
207 int destruct_level; /* 0=none, 1=full, 2=full with checks */
213 #endif /* USE_THREADS */
217 /* Pass 1 on any remaining threads: detach joinables, join zombies */
219 MUTEX_LOCK(&PL_threads_mutex);
220 DEBUG_S(PerlIO_printf(PerlIO_stderr(),
221 "perl_destruct: waiting for %d threads...\n",
223 for (t = thr->next; t != thr; t = t->next) {
224 MUTEX_LOCK(&t->mutex);
225 switch (ThrSTATE(t)) {
228 DEBUG_S(PerlIO_printf(PerlIO_stderr(),
229 "perl_destruct: joining zombie %p\n", t));
230 ThrSETSTATE(t, THRf_DEAD);
231 MUTEX_UNLOCK(&t->mutex);
234 * The SvREFCNT_dec below may take a long time (e.g. av
235 * may contain an object scalar whose destructor gets
236 * called) so we have to unlock threads_mutex and start
239 MUTEX_UNLOCK(&PL_threads_mutex);
241 SvREFCNT_dec((SV*)av);
242 DEBUG_S(PerlIO_printf(PerlIO_stderr(),
243 "perl_destruct: joined zombie %p OK\n", t));
245 case THRf_R_JOINABLE:
246 DEBUG_S(PerlIO_printf(PerlIO_stderr(),
247 "perl_destruct: detaching thread %p\n", t));
248 ThrSETSTATE(t, THRf_R_DETACHED);
250 * We unlock threads_mutex and t->mutex in the opposite order
251 * from which we locked them just so that DETACH won't
252 * deadlock if it panics. It's only a breach of good style
253 * not a bug since they are unlocks not locks.
255 MUTEX_UNLOCK(&PL_threads_mutex);
257 MUTEX_UNLOCK(&t->mutex);
260 DEBUG_S(PerlIO_printf(PerlIO_stderr(),
261 "perl_destruct: ignoring %p (state %u)\n",
263 MUTEX_UNLOCK(&t->mutex);
264 /* fall through and out */
267 /* We leave the above "Pass 1" loop with threads_mutex still locked */
269 /* Pass 2 on remaining threads: wait for the thread count to drop to one */
270 while (PL_nthreads > 1)
272 DEBUG_S(PerlIO_printf(PerlIO_stderr(),
273 "perl_destruct: final wait for %d threads\n",
275 COND_WAIT(&PL_nthreads_cond, &PL_threads_mutex);
277 /* At this point, we're the last thread */
278 MUTEX_UNLOCK(&PL_threads_mutex);
279 DEBUG_S(PerlIO_printf(PerlIO_stderr(), "perl_destruct: armageddon has arrived\n"));
280 MUTEX_DESTROY(&PL_threads_mutex);
281 COND_DESTROY(&PL_nthreads_cond);
282 #endif /* !defined(FAKE_THREADS) */
283 #endif /* USE_THREADS */
285 destruct_level = PL_perl_destruct_level;
289 if (s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL")) {
291 if (destruct_level < i)
300 /* We must account for everything. */
302 /* Destroy the main CV and syntax tree */
304 PL_curpad = AvARRAY(PL_comppad);
305 op_free(PL_main_root);
306 PL_main_root = Nullop;
308 PL_curcop = &PL_compiling;
309 PL_main_start = Nullop;
310 SvREFCNT_dec(PL_main_cv);
314 if (PL_sv_objcount) {
316 * Try to destruct global references. We do this first so that the
317 * destructors and destructees still exist. Some sv's might remain.
318 * Non-referenced objects are on their own.
323 /* unhook hooks which will soon be, or use, destroyed data */
324 SvREFCNT_dec(PL_warnhook);
325 PL_warnhook = Nullsv;
326 SvREFCNT_dec(PL_diehook);
328 SvREFCNT_dec(PL_parsehook);
329 PL_parsehook = Nullsv;
331 /* call exit list functions */
332 while (PL_exitlistlen-- > 0)
333 PL_exitlist[PL_exitlistlen].fn(aTHXo_ PL_exitlist[PL_exitlistlen].ptr);
335 Safefree(PL_exitlist);
337 if (destruct_level == 0){
339 DEBUG_P(debprofdump());
341 /* The exit() function will do everything that needs doing. */
345 /* loosen bonds of global variables */
348 (void)PerlIO_close(PL_rsfp);
352 /* Filters for program text */
353 SvREFCNT_dec(PL_rsfp_filters);
354 PL_rsfp_filters = Nullav;
357 PL_preprocess = FALSE;
363 PL_doswitches = FALSE;
364 PL_dowarn = G_WARN_OFF;
365 PL_doextract = FALSE;
366 PL_sawampersand = FALSE; /* must save all match strings */
367 PL_sawstudy = FALSE; /* do fbm_instr on all strings */
371 Safefree(PL_inplace);
375 SvREFCNT_dec(PL_e_script);
376 PL_e_script = Nullsv;
379 /* magical thingies */
381 Safefree(PL_ofs); /* $, */
384 Safefree(PL_ors); /* $\ */
387 SvREFCNT_dec(PL_rs); /* $/ */
390 SvREFCNT_dec(PL_nrs); /* $/ helper */
393 PL_multiline = 0; /* $* */
395 SvREFCNT_dec(PL_statname);
396 PL_statname = Nullsv;
399 /* defgv, aka *_ should be taken care of elsewhere */
401 /* clean up after study() */
402 SvREFCNT_dec(PL_lastscream);
403 PL_lastscream = Nullsv;
404 Safefree(PL_screamfirst);
406 Safefree(PL_screamnext);
409 /* startup and shutdown function lists */
410 SvREFCNT_dec(PL_beginav);
411 SvREFCNT_dec(PL_endav);
412 SvREFCNT_dec(PL_initav);
417 /* shortcuts just get cleared */
424 PL_argvoutgv = Nullgv;
426 PL_last_in_gv = Nullgv;
429 /* reset so print() ends up where we expect */
432 /* Prepare to destruct main symbol table. */
439 if (destruct_level >= 2 && ckWARN_d(WARN_INTERNAL)) {
440 if (PL_scopestack_ix != 0)
441 Perl_warner(aTHX_ WARN_INTERNAL,
442 "Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
443 (long)PL_scopestack_ix);
444 if (PL_savestack_ix != 0)
445 Perl_warner(aTHX_ WARN_INTERNAL,
446 "Unbalanced saves: %ld more saves than restores\n",
447 (long)PL_savestack_ix);
448 if (PL_tmps_floor != -1)
449 Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced tmps: %ld more allocs than frees\n",
450 (long)PL_tmps_floor + 1);
451 if (cxstack_ix != -1)
452 Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced context: %ld more PUSHes than POPs\n",
453 (long)cxstack_ix + 1);
456 /* Now absolutely destruct everything, somehow or other, loops or no. */
458 SvFLAGS(PL_strtab) |= SVTYPEMASK; /* don't clean out strtab now */
459 while (PL_sv_count != 0 && PL_sv_count != last_sv_count) {
460 last_sv_count = PL_sv_count;
463 SvFLAGS(PL_strtab) &= ~SVTYPEMASK;
464 SvFLAGS(PL_strtab) |= SVt_PVHV;
466 /* Destruct the global string table. */
468 /* Yell and reset the HeVAL() slots that are still holding refcounts,
469 * so that sv_free() won't fail on them.
477 max = HvMAX(PL_strtab);
478 array = HvARRAY(PL_strtab);
481 if (hent && ckWARN_d(WARN_INTERNAL)) {
482 Perl_warner(aTHX_ WARN_INTERNAL,
483 "Unbalanced string table refcount: (%d) for \"%s\"",
484 HeVAL(hent) - Nullsv, HeKEY(hent));
485 HeVAL(hent) = Nullsv;
495 SvREFCNT_dec(PL_strtab);
497 if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL))
498 Perl_warner(aTHX_ WARN_INTERNAL,"Scalars leaked: %ld\n", (long)PL_sv_count);
502 /* No SVs have survived, need to clean out */
504 PL_pidstatus = Nullhv;
505 Safefree(PL_origfilename);
506 Safefree(PL_archpat_auto);
507 Safefree(PL_reg_start_tmp);
509 Safefree(PL_reg_curpm);
510 Safefree(HeKEY_hek(&PL_hv_fetch_ent_mh));
511 Safefree(PL_op_mask);
513 PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */
515 DEBUG_P(debprofdump());
517 MUTEX_DESTROY(&PL_strtab_mutex);
518 MUTEX_DESTROY(&PL_sv_mutex);
519 MUTEX_DESTROY(&PL_eval_mutex);
520 MUTEX_DESTROY(&PL_cred_mutex);
521 COND_DESTROY(&PL_eval_cond);
522 #ifdef EMULATE_ATOMIC_REFCOUNTS
523 MUTEX_DESTROY(&PL_svref_mutex);
524 #endif /* EMULATE_ATOMIC_REFCOUNTS */
526 /* As the penultimate thing, free the non-arena SV for thrsv */
527 Safefree(SvPVX(PL_thrsv));
528 Safefree(SvANY(PL_thrsv));
531 #endif /* USE_THREADS */
533 /* As the absolutely last thing, free the non-arena SV for mess() */
536 /* it could have accumulated taint magic */
537 if (SvTYPE(PL_mess_sv) >= SVt_PVMG) {
540 for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) {
541 moremagic = mg->mg_moremagic;
542 if (mg->mg_ptr && mg->mg_type != 'g' && mg->mg_len >= 0)
543 Safefree(mg->mg_ptr);
547 /* we know that type >= SVt_PV */
548 SvOOK_off(PL_mess_sv);
549 Safefree(SvPVX(PL_mess_sv));
550 Safefree(SvANY(PL_mess_sv));
551 Safefree(PL_mess_sv);
559 #if defined(PERL_OBJECT)
567 Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
569 Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry);
570 PL_exitlist[PL_exitlistlen].fn = fn;
571 PL_exitlist[PL_exitlistlen].ptr = ptr;
576 perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
585 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
588 Perl_croak(aTHX_ "suidperl is no longer needed since the kernel can now execute\n\
589 setuid perl scripts securely.\n");
593 #if defined(__DYNAMIC__) && (defined(NeXT) || defined(__NeXT__))
594 _dyld_lookup_and_bind
595 ("__environ", (unsigned long *) &environ_pointer, NULL);
600 #ifndef VMS /* VMS doesn't have environ array */
601 PL_origenviron = environ;
606 /* Come here if running an undumped a.out. */
608 PL_origfilename = savepv(argv[0]);
609 PL_do_undump = FALSE;
610 cxstack_ix = -1; /* start label stack again */
612 init_postdump_symbols(argc,argv,env);
617 PL_curpad = AvARRAY(PL_comppad);
618 op_free(PL_main_root);
619 PL_main_root = Nullop;
621 PL_main_start = Nullop;
622 SvREFCNT_dec(PL_main_cv);
626 oldscope = PL_scopestack_ix;
627 PL_dowarn = G_WARN_OFF;
629 CALLPROTECT(aTHX_ &ret, FUNC_NAME_TO_PTR(S_parse_body), env, xsinit);
637 /* my_exit() was called */
638 while (PL_scopestack_ix > oldscope)
641 PL_curstash = PL_defstash;
643 call_list(oldscope, PL_endav);
644 return STATUS_NATIVE_EXPORT;
646 PerlIO_printf(PerlIO_stderr(), "panic: top_env\n");
653 S_parse_body(pTHX_ va_list args)
656 int argc = PL_origargc;
657 char **argv = PL_origargv;
658 char **env = va_arg(args, char**);
659 char *scriptname = NULL;
661 VOL bool dosearch = FALSE;
667 XSINIT_t xsinit = va_arg(args, XSINIT_t);
669 sv_setpvn(PL_linestr,"",0);
670 sv = newSVpvn("",0); /* first used for -I flags */
674 for (argc--,argv++; argc > 0; argc--,argv++) {
675 if (argv[0][0] != '-' || !argv[0][1])
679 validarg = " PHOOEY ";
686 #ifndef PERL_STRICT_CR
710 if (s = moreswitches(s))
720 if (PL_euid != PL_uid || PL_egid != PL_gid)
721 Perl_croak(aTHX_ "No -e allowed in setuid scripts");
723 PL_e_script = newSVpvn("",0);
724 filter_add(read_e_script, NULL);
727 sv_catpv(PL_e_script, s);
729 sv_catpv(PL_e_script, argv[1]);
733 Perl_croak(aTHX_ "No code specified for -e");
734 sv_catpv(PL_e_script, "\n");
737 case 'I': /* -I handled both here and in moreswitches() */
739 if (!*++s && (s=argv[1]) != Nullch) {
742 while (s && isSPACE(*s))
746 for (e = s; *e && !isSPACE(*e); e++) ;
753 } /* XXX else croak? */
757 PL_preprocess = TRUE;
767 PL_preambleav = newAV();
768 av_push(PL_preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
770 PL_Sv = newSVpv("print myconfig();",0);
772 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
774 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
776 #if defined(DEBUGGING) || defined(MULTIPLICITY)
777 sv_catpv(PL_Sv,"\" Compile-time options:");
779 sv_catpv(PL_Sv," DEBUGGING");
782 sv_catpv(PL_Sv," MULTIPLICITY");
784 sv_catpv(PL_Sv,"\\n\",");
786 #if defined(LOCAL_PATCH_COUNT)
787 if (LOCAL_PATCH_COUNT > 0) {
789 sv_catpv(PL_Sv,"\" Locally applied patches:\\n\",");
790 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
791 if (PL_localpatches[i])
792 Perl_sv_catpvf(aTHX_ PL_Sv,"q\" \t%s\n\",",PL_localpatches[i]);
796 Perl_sv_catpvf(aTHX_ PL_Sv,"\" Built under %s\\n\"",OSNAME);
799 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
801 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled on %s\\n\"",__DATE__);
806 @env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; \
807 print \" \\%ENV:\\n @env\\n\" if @env; \
808 print \" \\@INC:\\n @INC\\n\";");
811 PL_Sv = newSVpv("config_vars(qw(",0);
812 sv_catpv(PL_Sv, ++s);
813 sv_catpv(PL_Sv, "))");
816 av_push(PL_preambleav, PL_Sv);
817 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
823 PL_cddir = savepv(s);
828 if (!*++s || isSPACE(*s)) {
832 /* catch use of gnu style long options */
833 if (strEQ(s, "version")) {
837 if (strEQ(s, "help")) {
844 Perl_croak(aTHX_ "Unrecognized switch: -%s (-h will show valid options)",s);
850 #ifndef SECURE_INTERNAL_GETENV
853 (s = PerlEnv_getenv("PERL5OPT"))) {
856 if (*s == '-' && *(s+1) == 'T')
869 if (!strchr("DIMUdmw", *s))
870 Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
877 scriptname = argv[0];
880 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
882 else if (scriptname == Nullch) {
884 if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
892 open_script(scriptname,dosearch,sv,&fdscript);
894 validate_suid(validarg, scriptname,fdscript);
899 PL_main_cv = PL_compcv = (CV*)NEWSV(1104,0);
900 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
901 CvUNIQUE_on(PL_compcv);
903 PL_comppad = newAV();
904 av_push(PL_comppad, Nullsv);
905 PL_curpad = AvARRAY(PL_comppad);
906 PL_comppad_name = newAV();
907 PL_comppad_name_fill = 0;
908 PL_min_intro_pending = 0;
911 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
912 PL_curpad[0] = (SV*)newAV();
913 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
914 CvOWNER(PL_compcv) = 0;
915 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
916 MUTEX_INIT(CvMUTEXP(PL_compcv));
917 #endif /* USE_THREADS */
919 comppadlist = newAV();
920 AvREAL_off(comppadlist);
921 av_store(comppadlist, 0, (SV*)PL_comppad_name);
922 av_store(comppadlist, 1, (SV*)PL_comppad);
923 CvPADLIST(PL_compcv) = comppadlist;
925 boot_core_UNIVERSAL();
928 (*xsinit)(aTHXo); /* in case linked C routines want magical variables */
929 #if defined(VMS) || defined(WIN32) || defined(DJGPP)
937 init_predump_symbols();
938 /* init_postdump_symbols not currently designed to be called */
939 /* more than once (ENV isn't cleared first, for example) */
940 /* But running with -u leaves %ENV & @ARGV undefined! XXX */
942 init_postdump_symbols(argc,argv,env);
946 /* now parse the script */
948 SETERRNO(0,SS$_NORMAL);
950 if (yyparse() || PL_error_count) {
952 Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
954 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
958 PL_curcop->cop_line = 0;
959 PL_curstash = PL_defstash;
960 PL_preprocess = FALSE;
962 SvREFCNT_dec(PL_e_script);
963 PL_e_script = Nullsv;
966 /* now that script is parsed, we can modify record separator */
968 PL_rs = SvREFCNT_inc(PL_nrs);
969 sv_setsv(get_sv("/", TRUE), PL_rs);
974 gv_check(PL_defstash);
980 if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
981 dump_mstats("after compilation:");
999 oldscope = PL_scopestack_ix;
1002 CALLPROTECT(aTHX_ &ret, FUNC_NAME_TO_PTR(S_run_body), oldscope);
1005 cxstack_ix = -1; /* start context stack again */
1007 case 0: /* normal completion */
1008 case 2: /* my_exit() */
1009 while (PL_scopestack_ix > oldscope)
1012 PL_curstash = PL_defstash;
1014 call_list(oldscope, PL_endav);
1016 if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
1017 dump_mstats("after execution: ");
1019 return STATUS_NATIVE_EXPORT;
1022 POPSTACK_TO(PL_mainstack);
1025 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
1035 S_run_body(pTHX_ va_list args)
1038 I32 oldscope = va_arg(args, I32);
1040 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
1041 PL_sawampersand ? "Enabling" : "Omitting"));
1043 if (!PL_restartop) {
1044 DEBUG_x(dump_all());
1045 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
1046 DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%lx\n",
1047 (unsigned long) thr));
1050 PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", PL_origfilename);
1053 if (PERLDB_SINGLE && PL_DBsingle)
1054 sv_setiv(PL_DBsingle, 1);
1056 call_list(oldscope, PL_initav);
1062 PL_op = PL_restartop;
1066 else if (PL_main_start) {
1067 CvDEPTH(PL_main_cv) = 1;
1068 PL_op = PL_main_start;
1078 Perl_get_sv(pTHX_ const char *name, I32 create)
1082 if (name[1] == '\0' && !isALPHA(name[0])) {
1083 PADOFFSET tmp = find_threadsv(name);
1084 if (tmp != NOT_IN_PAD) {
1086 return THREADSV(tmp);
1089 #endif /* USE_THREADS */
1090 gv = gv_fetchpv(name, create, SVt_PV);
1097 Perl_get_av(pTHX_ const char *name, I32 create)
1099 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1108 Perl_get_hv(pTHX_ const char *name, I32 create)
1110 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1119 Perl_get_cv(pTHX_ const char *name, I32 create)
1121 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
1122 /* XXX unsafe for threads if eval_owner isn't held */
1123 /* XXX this is probably not what they think they're getting.
1124 * It has the same effect as "sub name;", i.e. just a forward
1126 if (create && !GvCVu(gv))
1127 return newSUB(start_subparse(FALSE, 0),
1128 newSVOP(OP_CONST, 0, newSVpv(name,0)),
1136 /* Be sure to refetch the stack pointer after calling these routines. */
1139 Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv)
1141 /* See G_* flags in cop.h */
1142 /* null terminated arg list */
1149 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
1154 return call_pv(sub_name, flags);
1158 Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
1159 /* name of the subroutine */
1160 /* See G_* flags in cop.h */
1162 return call_sv((SV*)get_cv(sub_name, TRUE), flags);
1166 Perl_call_method(pTHX_ const char *methname, I32 flags)
1167 /* name of the subroutine */
1168 /* See G_* flags in cop.h */
1174 XPUSHs(sv_2mortal(newSVpv(methname,0)));
1179 return call_sv(*PL_stack_sp--, flags);
1182 /* May be called with any of a CV, a GV, or an SV containing the name. */
1184 Perl_call_sv(pTHX_ SV *sv, I32 flags)
1186 /* See G_* flags in cop.h */
1189 LOGOP myop; /* fake syntax tree node */
1193 bool oldcatch = CATCH_GET;
1197 if (flags & G_DISCARD) {
1202 Zero(&myop, 1, LOGOP);
1203 myop.op_next = Nullop;
1204 if (!(flags & G_NOARGS))
1205 myop.op_flags |= OPf_STACKED;
1206 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1207 (flags & G_ARRAY) ? OPf_WANT_LIST :
1212 EXTEND(PL_stack_sp, 1);
1213 *++PL_stack_sp = sv;
1215 oldscope = PL_scopestack_ix;
1217 if (PERLDB_SUB && PL_curstash != PL_debstash
1218 /* Handle first BEGIN of -d. */
1219 && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
1220 /* Try harder, since this may have been a sighandler, thus
1221 * curstash may be meaningless. */
1222 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != PL_debstash)
1223 && !(flags & G_NODEBUG))
1224 PL_op->op_private |= OPpENTERSUB_DB;
1226 if (!(flags & G_EVAL)) {
1228 call_xbody((OP*)&myop, FALSE);
1229 retval = PL_stack_sp - (PL_stack_base + oldmark);
1233 cLOGOP->op_other = PL_op;
1235 /* we're trying to emulate pp_entertry() here */
1237 register PERL_CONTEXT *cx;
1238 I32 gimme = GIMME_V;
1243 push_return(PL_op->op_next);
1244 PUSHBLOCK(cx, CXt_EVAL, PL_stack_sp);
1246 PL_eval_root = PL_op; /* Only needed so that goto works right. */
1248 PL_in_eval = EVAL_INEVAL;
1249 if (flags & G_KEEPERR)
1250 PL_in_eval |= EVAL_KEEPERR;
1257 CALLPROTECT(aTHX_ &ret, FUNC_NAME_TO_PTR(S_call_body), (OP*)&myop, FALSE);
1260 retval = PL_stack_sp - (PL_stack_base + oldmark);
1261 if (!(flags & G_KEEPERR))
1268 /* my_exit() was called */
1269 PL_curstash = PL_defstash;
1272 Perl_croak(aTHX_ "Callback called exit");
1277 PL_op = PL_restartop;
1281 PL_stack_sp = PL_stack_base + oldmark;
1282 if (flags & G_ARRAY)
1286 *++PL_stack_sp = &PL_sv_undef;
1291 if (PL_scopestack_ix > oldscope) {
1295 register PERL_CONTEXT *cx;
1306 if (flags & G_DISCARD) {
1307 PL_stack_sp = PL_stack_base + oldmark;
1317 S_call_body(pTHX_ va_list args)
1319 OP *myop = va_arg(args, OP*);
1320 int is_eval = va_arg(args, int);
1322 call_xbody(myop, is_eval);
1327 S_call_xbody(pTHX_ OP *myop, int is_eval)
1331 if (PL_op == myop) {
1333 PL_op = Perl_pp_entereval(aTHX);
1335 PL_op = Perl_pp_entersub(aTHX);
1341 /* Eval a string. The G_EVAL flag is always assumed. */
1344 Perl_eval_sv(pTHX_ SV *sv, I32 flags)
1346 /* See G_* flags in cop.h */
1349 UNOP myop; /* fake syntax tree node */
1350 I32 oldmark = SP - PL_stack_base;
1356 if (flags & G_DISCARD) {
1363 Zero(PL_op, 1, UNOP);
1364 EXTEND(PL_stack_sp, 1);
1365 *++PL_stack_sp = sv;
1366 oldscope = PL_scopestack_ix;
1368 if (!(flags & G_NOARGS))
1369 myop.op_flags = OPf_STACKED;
1370 myop.op_next = Nullop;
1371 myop.op_type = OP_ENTEREVAL;
1372 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1373 (flags & G_ARRAY) ? OPf_WANT_LIST :
1375 if (flags & G_KEEPERR)
1376 myop.op_flags |= OPf_SPECIAL;
1379 CALLPROTECT(aTHX_ &ret, FUNC_NAME_TO_PTR(S_call_body), (OP*)&myop, TRUE);
1382 retval = PL_stack_sp - (PL_stack_base + oldmark);
1383 if (!(flags & G_KEEPERR))
1390 /* my_exit() was called */
1391 PL_curstash = PL_defstash;
1394 Perl_croak(aTHX_ "Callback called exit");
1399 PL_op = PL_restartop;
1403 PL_stack_sp = PL_stack_base + oldmark;
1404 if (flags & G_ARRAY)
1408 *++PL_stack_sp = &PL_sv_undef;
1413 if (flags & G_DISCARD) {
1414 PL_stack_sp = PL_stack_base + oldmark;
1424 Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
1427 SV* sv = newSVpv(p, 0);
1430 eval_sv(sv, G_SCALAR);
1437 if (croak_on_error && SvTRUE(ERRSV)) {
1439 Perl_croak(aTHX_ SvPVx(ERRSV, n_a));
1445 /* Require a module. */
1448 Perl_require_pv(pTHX_ const char *pv)
1452 PUSHSTACKi(PERLSI_REQUIRE);
1454 sv = sv_newmortal();
1455 sv_setpv(sv, "require '");
1458 eval_sv(sv, G_DISCARD);
1464 Perl_magicname(pTHX_ char *sym, char *name, I32 namlen)
1468 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1469 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1473 S_usage(pTHX_ char *name) /* XXX move this out into a module ? */
1475 /* This message really ought to be max 23 lines.
1476 * Removed -h because the user already knows that opton. Others? */
1478 static char *usage_msg[] = {
1479 "-0[octal] specify record separator (\\0, if no argument)",
1480 "-a autosplit mode with -n or -p (splits $_ into @F)",
1481 "-c check syntax only (runs BEGIN and END blocks)",
1482 "-d[:debugger] run program under debugger",
1483 "-D[number/list] set debugging flags (argument is a bit mask or alphabets)",
1484 "-e 'command' one line of program (several -e's allowed, omit programfile)",
1485 "-F/pattern/ split() pattern for -a switch (//'s are optional)",
1486 "-i[extension] edit <> files in place (makes backup if extension supplied)",
1487 "-Idirectory specify @INC/#include directory (several -I's allowed)",
1488 "-l[octal] enable line ending processing, specifies line terminator",
1489 "-[mM][-]module execute `use/no module...' before executing program",
1490 "-n assume 'while (<>) { ... }' loop around program",
1491 "-p assume loop like -n but print line also, like sed",
1492 "-P run program through C preprocessor before compilation",
1493 "-s enable rudimentary parsing for switches after programfile",
1494 "-S look for programfile using PATH environment variable",
1495 "-T enable tainting checks",
1496 "-u dump core after parsing program",
1497 "-U allow unsafe operations",
1498 "-v print version, subversion (includes VERY IMPORTANT perl info)",
1499 "-V[:variable] print configuration summary (or a single Config.pm variable)",
1500 "-w enable many useful warnings (RECOMMENDED)",
1501 "-x[directory] strip off text before #!perl line and perhaps cd to directory",
1505 char **p = usage_msg;
1507 printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1509 printf("\n %s", *p++);
1512 /* This routine handles any switches that can be given during run */
1515 Perl_moreswitches(pTHX_ char *s)
1524 rschar = scan_oct(s, 4, &numlen);
1525 SvREFCNT_dec(PL_nrs);
1526 if (rschar & ~((U8)~0))
1527 PL_nrs = &PL_sv_undef;
1528 else if (!rschar && numlen >= 2)
1529 PL_nrs = newSVpvn("", 0);
1532 PL_nrs = newSVpvn(&ch, 1);
1538 PL_splitstr = savepv(s + 1);
1552 if (*s == ':' || *s == '=') {
1553 my_setenv("PERL5DB", Perl_form(aTHX_ "use Devel::%s;", ++s));
1557 PL_perldb = PERLDB_ALL;
1565 if (isALPHA(s[1])) {
1566 static char debopts[] = "psltocPmfrxuLHXDS";
1569 for (s++; *s && (d = strchr(debopts,*s)); s++)
1570 PL_debug |= 1 << (d - debopts);
1573 PL_debug = atoi(s+1);
1574 for (s++; isDIGIT(*s); s++) ;
1576 PL_debug |= 0x80000000;
1579 if (ckWARN_d(WARN_DEBUGGING))
1580 Perl_warner(aTHX_ WARN_DEBUGGING,
1581 "Recompile perl with -DDEBUGGING to use -D switch\n");
1582 for (s++; isALNUM(*s); s++) ;
1588 usage(PL_origargv[0]);
1592 Safefree(PL_inplace);
1593 PL_inplace = savepv(s+1);
1595 for (s = PL_inplace; *s && !isSPACE(*s); s++) ;
1598 if (*s == '-') /* Additional switches on #! line. */
1602 case 'I': /* -I handled both here and in parse_perl() */
1605 while (*s && isSPACE(*s))
1609 for (e = s; *e && !isSPACE(*e); e++) ;
1610 p = savepvn(s, e-s);
1616 Perl_croak(aTHX_ "No space allowed after -I");
1624 PL_ors = savepv("\n");
1626 *PL_ors = scan_oct(s, 3 + (*s == '0'), &numlen);
1631 if (RsPARA(PL_nrs)) {
1636 PL_ors = SvPV(PL_nrs, PL_orslen);
1637 PL_ors = savepvn(PL_ors, PL_orslen);
1641 forbid_setid("-M"); /* XXX ? */
1644 forbid_setid("-m"); /* XXX ? */
1649 /* -M-foo == 'no foo' */
1650 if (*s == '-') { use = "no "; ++s; }
1651 sv = newSVpv(use,0);
1653 /* We allow -M'Module qw(Foo Bar)' */
1654 while(isALNUM(*s) || *s==':') ++s;
1656 sv_catpv(sv, start);
1657 if (*(start-1) == 'm') {
1659 Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
1660 sv_catpv( sv, " ()");
1663 sv_catpvn(sv, start, s-start);
1664 sv_catpv(sv, " split(/,/,q{");
1669 if (PL_preambleav == NULL)
1670 PL_preambleav = newAV();
1671 av_push(PL_preambleav, sv);
1674 Perl_croak(aTHX_ "No space allowed after -%c", *(s-1));
1686 PL_doswitches = TRUE;
1691 Perl_croak(aTHX_ "Too late for \"-T\" option");
1695 PL_do_undump = TRUE;
1703 #if defined(PERL_SUBVERSION) && PERL_SUBVERSION > 0
1704 printf("\nThis is perl, version %d.%03d_%02d built for %s",
1705 PERL_REVISION, PERL_VERSION, PERL_SUBVERSION, ARCHNAME);
1707 printf("\nThis is perl, version %s built for %s",
1708 PL_patchlevel, ARCHNAME);
1710 #if defined(LOCAL_PATCH_COUNT)
1711 if (LOCAL_PATCH_COUNT > 0)
1712 printf("\n(with %d registered patch%s, see perl -V for more detail)",
1713 LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : "");
1716 printf("\n\nCopyright 1987-1999, Larry Wall\n");
1718 printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1721 printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
1722 printf("djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
1725 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1726 "Version 5 port Copyright (c) 1994-1999, Andreas Kaiser, Ilya Zakharevich\n");
1729 printf("atariST series port, ++jrb bammi@cadence.com\n");
1732 printf("BeOS port Copyright Tom Spindler, 1997-1999\n");
1735 printf("MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-1999\n");
1738 printf("MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
1741 printf("Stratus VOS port by Paul_Green@stratus.com, 1997-1999\n");
1744 printf("VM/ESA port by Neale Ferguson, 1998-1999\n");
1747 printf("BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
1750 printf("MiNT port by Guido Flohr, 1997-1999\n");
1752 #ifdef BINARY_BUILD_NOTICE
1753 BINARY_BUILD_NOTICE;
1756 Perl may be copied only under the terms of either the Artistic License or the\n\
1757 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n\
1758 Complete documentation for Perl, including FAQ lists, should be found on\n\
1759 this system using `man perl' or `perldoc perl'. If you have access to the\n\
1760 Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
1763 if (! (PL_dowarn & G_WARN_ALL_MASK))
1764 PL_dowarn |= G_WARN_ON;
1768 PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
1769 PL_compiling.cop_warnings = WARN_ALL ;
1773 PL_dowarn = G_WARN_ALL_OFF;
1774 PL_compiling.cop_warnings = WARN_NONE ;
1779 if (s[1] == '-') /* Additional switches on #! line. */
1784 #if defined(WIN32) || !defined(PERL_STRICT_CR)
1790 #ifdef ALTERNATE_SHEBANG
1791 case 'S': /* OS/2 needs -S on "extproc" line. */
1799 Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
1804 /* compliments of Tom Christiansen */
1806 /* unexec() can be found in the Gnu emacs distribution */
1807 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
1810 Perl_my_unexec(pTHX)
1818 prog = newSVpv(BIN_EXP, 0);
1819 sv_catpv(prog, "/perl");
1820 file = newSVpv(PL_origfilename, 0);
1821 sv_catpv(file, ".perldump");
1823 unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
1824 /* unexec prints msg to stderr in case of failure */
1825 PerlProc_exit(status);
1828 # include <lib$routines.h>
1829 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
1831 ABORT(); /* for use with undump */
1836 /* initialize curinterp */
1841 #ifdef PERL_OBJECT /* XXX kludge */
1844 PL_chopset = " \n-"; \
1845 PL_copline = NOLINE; \
1846 PL_curcop = &PL_compiling;\
1847 PL_curcopdb = NULL; \
1850 PL_dumpindent = 4; \
1851 PL_laststatval = -1; \
1852 PL_laststype = OP_STAT; \
1853 PL_maxscream = -1; \
1854 PL_maxsysfd = MAXSYSFD; \
1855 PL_statname = Nullsv; \
1856 PL_tmps_floor = -1; \
1858 PL_op_mask = NULL; \
1860 PL_laststatval = -1; \
1861 PL_laststype = OP_STAT; \
1862 PL_mess_sv = Nullsv; \
1863 PL_splitstr = " "; \
1864 PL_generation = 100; \
1865 PL_exitlist = NULL; \
1866 PL_exitlistlen = 0; \
1868 PL_in_clean_objs = FALSE; \
1869 PL_in_clean_all = FALSE; \
1870 PL_profiledata = NULL; \
1872 PL_rsfp_filters = Nullav; \
1877 # ifdef MULTIPLICITY
1878 # define PERLVAR(var,type)
1879 # define PERLVARA(var,n,type)
1880 # if defined(PERL_IMPLICIT_CONTEXT)
1881 # define PERLVARI(var,type,init) my_perl->var = init;
1882 # define PERLVARIC(var,type,init) my_perl->var = init;
1884 # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
1885 # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
1887 # include "intrpvar.h"
1888 # ifndef USE_THREADS
1889 # include "thrdvar.h"
1896 # define PERLVAR(var,type)
1897 # define PERLVARA(var,n,type)
1898 # define PERLVARI(var,type,init) PL_##var = init;
1899 # define PERLVARIC(var,type,init) PL_##var = init;
1900 # include "intrpvar.h"
1901 # ifndef USE_THREADS
1902 # include "thrdvar.h"
1914 S_init_main_stash(pTHX)
1919 /* Note that strtab is a rather special HV. Assumptions are made
1920 about not iterating on it, and not adding tie magic to it.
1921 It is properly deallocated in perl_destruct() */
1922 PL_strtab = newHV();
1924 MUTEX_INIT(&PL_strtab_mutex);
1926 HvSHAREKEYS_off(PL_strtab); /* mandatory */
1927 hv_ksplit(PL_strtab, 512);
1929 PL_curstash = PL_defstash = newHV();
1930 PL_curstname = newSVpvn("main",4);
1931 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1932 SvREFCNT_dec(GvHV(gv));
1933 GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
1935 HvNAME(PL_defstash) = savepv("main");
1936 PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1937 GvMULTI_on(PL_incgv);
1938 PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
1939 GvMULTI_on(PL_hintgv);
1940 PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1941 PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1942 GvMULTI_on(PL_errgv);
1943 PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
1944 GvMULTI_on(PL_replgv);
1945 (void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */
1946 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
1947 sv_setpvn(ERRSV, "", 0);
1948 PL_curstash = PL_defstash;
1949 PL_compiling.cop_stash = PL_defstash;
1950 PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
1951 PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
1952 /* We must init $/ before switches are processed. */
1953 sv_setpvn(get_sv("/", TRUE), "\n", 1);
1957 S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
1965 PL_origfilename = savepv("-e");
1968 /* if find_script() returns, it returns a malloc()-ed value */
1969 PL_origfilename = scriptname = find_script(scriptname, dosearch, NULL, 1);
1971 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
1972 char *s = scriptname + 8;
1973 *fdscript = atoi(s);
1977 scriptname = savepv(s + 1);
1978 Safefree(PL_origfilename);
1979 PL_origfilename = scriptname;
1984 PL_curcop->cop_filegv = gv_fetchfile(PL_origfilename);
1985 if (strEQ(PL_origfilename,"-"))
1987 if (*fdscript >= 0) {
1988 PL_rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE);
1989 #if defined(HAS_FCNTL) && defined(F_SETFD)
1991 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); /* ensure close-on-exec */
1994 else if (PL_preprocess) {
1995 char *cpp_cfg = CPPSTDIN;
1996 SV *cpp = newSVpvn("",0);
1997 SV *cmd = NEWSV(0,0);
1999 if (strEQ(cpp_cfg, "cppstdin"))
2000 Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
2001 sv_catpv(cpp, cpp_cfg);
2004 sv_catpv(sv,PRIVLIB_EXP);
2007 Perl_sv_setpvf(aTHX_ cmd, "\
2008 sed %s -e \"/^[^#]/b\" \
2009 -e \"/^#[ ]*include[ ]/b\" \
2010 -e \"/^#[ ]*define[ ]/b\" \
2011 -e \"/^#[ ]*if[ ]/b\" \
2012 -e \"/^#[ ]*ifdef[ ]/b\" \
2013 -e \"/^#[ ]*ifndef[ ]/b\" \
2014 -e \"/^#[ ]*else/b\" \
2015 -e \"/^#[ ]*elif[ ]/b\" \
2016 -e \"/^#[ ]*undef[ ]/b\" \
2017 -e \"/^#[ ]*endif/b\" \
2020 (PL_doextract ? "-e \"1,/^#/d\n\"" : ""),
2023 Perl_sv_setpvf(aTHX_ cmd, "\
2024 %s %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' \
2037 Perl_sv_setpvf(aTHX_ cmd, "\
2038 %s %s -e '/^[^#]/b' \
2039 -e '/^#[ ]*include[ ]/b' \
2040 -e '/^#[ ]*define[ ]/b' \
2041 -e '/^#[ ]*if[ ]/b' \
2042 -e '/^#[ ]*ifdef[ ]/b' \
2043 -e '/^#[ ]*ifndef[ ]/b' \
2044 -e '/^#[ ]*else/b' \
2045 -e '/^#[ ]*elif[ ]/b' \
2046 -e '/^#[ ]*undef[ ]/b' \
2047 -e '/^#[ ]*endif/b' \
2056 (PL_doextract ? "-e '1,/^#/d\n'" : ""),
2058 scriptname, cpp, sv, CPPMINUS);
2059 PL_doextract = FALSE;
2060 #ifdef IAMSUID /* actually, this is caught earlier */
2061 if (PL_euid != PL_uid && !PL_euid) { /* if running suidperl */
2063 (void)seteuid(PL_uid); /* musn't stay setuid root */
2066 (void)setreuid((Uid_t)-1, PL_uid);
2068 #ifdef HAS_SETRESUID
2069 (void)setresuid((Uid_t)-1, PL_uid, (Uid_t)-1);
2071 PerlProc_setuid(PL_uid);
2075 if (PerlProc_geteuid() != PL_uid)
2076 Perl_croak(aTHX_ "Can't do seteuid!\n");
2078 #endif /* IAMSUID */
2079 PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
2083 else if (!*scriptname) {
2084 forbid_setid("program input from stdin");
2085 PL_rsfp = PerlIO_stdin();
2088 PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
2089 #if defined(HAS_FCNTL) && defined(F_SETFD)
2091 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); /* ensure close-on-exec */
2096 #ifndef IAMSUID /* in case script is not readable before setuid */
2098 PerlLIO_stat(SvPVX(GvSV(PL_curcop->cop_filegv)),&PL_statbuf) >= 0 &&
2099 PL_statbuf.st_mode & (S_ISUID|S_ISGID))
2102 PerlProc_execv(Perl_form(aTHX_ "%s/sperl%s", BIN_EXP, PL_patchlevel), PL_origargv);
2103 Perl_croak(aTHX_ "Can't do setuid\n");
2107 Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
2108 SvPVX(GvSV(PL_curcop->cop_filegv)), Strerror(errno));
2113 * I_SYSSTATVFS HAS_FSTATVFS
2115 * I_STATFS HAS_FSTATFS
2116 * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT
2117 * here so that metaconfig picks them up. */
2121 S_fd_on_nosuid_fs(pTHX_ int fd)
2126 * Preferred order: fstatvfs(), fstatfs(), getmntent().
2127 * fstatvfs() is UNIX98.
2129 * getmntent() is O(number-of-mounted-filesystems) and can hang.
2132 # ifdef HAS_FSTATVFS
2133 struct statvfs stfs;
2134 check_okay = fstatvfs(fd, &stfs) == 0;
2135 on_nosuid = check_okay && (stfs.f_flag & ST_NOSUID);
2137 # if defined(HAS_FSTATFS) && defined(HAS_STRUCT_STATFS_FLAGS)
2139 check_okay = fstatfs(fd, &stfs) == 0;
2140 # undef PERL_MOUNT_NOSUID
2141 # if !defined(PERL_MOUNT_NOSUID) && defined(MNT_NOSUID)
2142 # define PERL_MOUNT_NOSUID MNT_NOSUID
2144 # if !defined(PERL_MOUNT_NOSUID) && defined(MS_NOSUID)
2145 # define PERL_MOUNT_NOSUID MS_NOSUID
2147 # if !defined(PERL_MOUNT_NOSUID) && defined(M_NOSUID)
2148 # define PERL_MOUNT_NOSUID M_NOSUID
2150 # ifdef PERL_MOUNT_NOSUID
2151 on_nosuid = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
2154 # if defined(HAS_GETMNTENT) && defined(HAS_HASMNTOPT) && defined(MNTOPT_NOSUID)
2155 FILE *mtab = fopen("/etc/mtab", "r");
2156 struct mntent *entry;
2157 struct stat stb, fsb;
2159 if (mtab && (fstat(fd, &stb) == 0)) {
2160 while (entry = getmntent(mtab)) {
2161 if (stat(entry->mnt_dir, &fsb) == 0
2162 && fsb.st_dev == stb.st_dev)
2164 /* found the filesystem */
2166 if (hasmntopt(entry, MNTOPT_NOSUID))
2169 } /* A single fs may well fail its stat(). */
2174 # endif /* mntent */
2175 # endif /* statfs */
2176 # endif /* statvfs */
2178 Perl_croak(aTHX_ "Can't check filesystem of script \"%s\"", PL_origfilename);
2181 #endif /* IAMSUID */
2184 S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript)
2188 /* do we need to emulate setuid on scripts? */
2190 /* This code is for those BSD systems that have setuid #! scripts disabled
2191 * in the kernel because of a security problem. Merely defining DOSUID
2192 * in perl will not fix that problem, but if you have disabled setuid
2193 * scripts in the kernel, this will attempt to emulate setuid and setgid
2194 * on scripts that have those now-otherwise-useless bits set. The setuid
2195 * root version must be called suidperl or sperlN.NNN. If regular perl
2196 * discovers that it has opened a setuid script, it calls suidperl with
2197 * the same argv that it had. If suidperl finds that the script it has
2198 * just opened is NOT setuid root, it sets the effective uid back to the
2199 * uid. We don't just make perl setuid root because that loses the
2200 * effective uid we had before invoking perl, if it was different from the
2203 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
2204 * be defined in suidperl only. suidperl must be setuid root. The
2205 * Configure script will set this up for you if you want it.
2212 if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */
2213 Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
2214 if (fdscript < 0 && PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
2219 #ifndef HAS_SETREUID
2220 /* On this access check to make sure the directories are readable,
2221 * there is actually a small window that the user could use to make
2222 * filename point to an accessible directory. So there is a faint
2223 * chance that someone could execute a setuid script down in a
2224 * non-accessible directory. I don't know what to do about that.
2225 * But I don't think it's too important. The manual lies when
2226 * it says access() is useful in setuid programs.
2228 if (PerlLIO_access(SvPVX(GvSV(PL_curcop->cop_filegv)),1)) /*double check*/
2229 Perl_croak(aTHX_ "Permission denied");
2231 /* If we can swap euid and uid, then we can determine access rights
2232 * with a simple stat of the file, and then compare device and
2233 * inode to make sure we did stat() on the same file we opened.
2234 * Then we just have to make sure he or she can execute it.
2237 struct stat tmpstatbuf;
2241 setreuid(PL_euid,PL_uid) < 0
2244 setresuid(PL_euid,PL_uid,(Uid_t)-1) < 0
2247 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
2248 Perl_croak(aTHX_ "Can't swap uid and euid"); /* really paranoid */
2249 if (PerlLIO_stat(SvPVX(GvSV(PL_curcop->cop_filegv)),&tmpstatbuf) < 0)
2250 Perl_croak(aTHX_ "Permission denied"); /* testing full pathname here */
2251 #if defined(IAMSUID) && !defined(NO_NOSUID_CHECK)
2252 if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp)))
2253 Perl_croak(aTHX_ "Permission denied");
2255 if (tmpstatbuf.st_dev != PL_statbuf.st_dev ||
2256 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
2257 (void)PerlIO_close(PL_rsfp);
2258 if (PL_rsfp = PerlProc_popen("/bin/mail root","w")) { /* heh, heh */
2259 PerlIO_printf(PL_rsfp,
2260 "User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2261 (Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
2262 (long)PL_uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
2263 (long)PL_statbuf.st_dev, (long)PL_statbuf.st_ino,
2264 SvPVX(GvSV(PL_curcop->cop_filegv)),
2265 (long)PL_statbuf.st_uid, (long)PL_statbuf.st_gid);
2266 (void)PerlProc_pclose(PL_rsfp);
2268 Perl_croak(aTHX_ "Permission denied\n");
2272 setreuid(PL_uid,PL_euid) < 0
2274 # if defined(HAS_SETRESUID)
2275 setresuid(PL_uid,PL_euid,(Uid_t)-1) < 0
2278 || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
2279 Perl_croak(aTHX_ "Can't reswap uid and euid");
2280 if (!cando(S_IXUSR,FALSE,&PL_statbuf)) /* can real uid exec? */
2281 Perl_croak(aTHX_ "Permission denied\n");
2283 #endif /* HAS_SETREUID */
2284 #endif /* IAMSUID */
2286 if (!S_ISREG(PL_statbuf.st_mode))
2287 Perl_croak(aTHX_ "Permission denied");
2288 if (PL_statbuf.st_mode & S_IWOTH)
2289 Perl_croak(aTHX_ "Setuid/gid script is writable by world");
2290 PL_doswitches = FALSE; /* -s is insecure in suid */
2291 PL_curcop->cop_line++;
2292 if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
2293 strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */
2294 Perl_croak(aTHX_ "No #! line");
2295 s = SvPV(PL_linestr,n_a)+2;
2297 while (!isSPACE(*s)) s++;
2298 for (s2 = s; (s2 > SvPV(PL_linestr,n_a)+2 &&
2299 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
2300 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
2301 Perl_croak(aTHX_ "Not a perl script");
2302 while (*s == ' ' || *s == '\t') s++;
2304 * #! arg must be what we saw above. They can invoke it by
2305 * mentioning suidperl explicitly, but they may not add any strange
2306 * arguments beyond what #! says if they do invoke suidperl that way.
2308 len = strlen(validarg);
2309 if (strEQ(validarg," PHOOEY ") ||
2310 strnNE(s,validarg,len) || !isSPACE(s[len]))
2311 Perl_croak(aTHX_ "Args must match #! line");
2314 if (PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
2315 PL_euid == PL_statbuf.st_uid)
2317 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2318 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2319 #endif /* IAMSUID */
2321 if (PL_euid) { /* oops, we're not the setuid root perl */
2322 (void)PerlIO_close(PL_rsfp);
2325 PerlProc_execv(Perl_form(aTHX_ "%s/sperl%s", BIN_EXP, PL_patchlevel), PL_origargv);
2327 Perl_croak(aTHX_ "Can't do setuid\n");
2330 if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
2332 (void)setegid(PL_statbuf.st_gid);
2335 (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
2337 #ifdef HAS_SETRESGID
2338 (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
2340 PerlProc_setgid(PL_statbuf.st_gid);
2344 if (PerlProc_getegid() != PL_statbuf.st_gid)
2345 Perl_croak(aTHX_ "Can't do setegid!\n");
2347 if (PL_statbuf.st_mode & S_ISUID) {
2348 if (PL_statbuf.st_uid != PL_euid)
2350 (void)seteuid(PL_statbuf.st_uid); /* all that for this */
2353 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
2355 #ifdef HAS_SETRESUID
2356 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
2358 PerlProc_setuid(PL_statbuf.st_uid);
2362 if (PerlProc_geteuid() != PL_statbuf.st_uid)
2363 Perl_croak(aTHX_ "Can't do seteuid!\n");
2365 else if (PL_uid) { /* oops, mustn't run as root */
2367 (void)seteuid((Uid_t)PL_uid);
2370 (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
2372 #ifdef HAS_SETRESUID
2373 (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
2375 PerlProc_setuid((Uid_t)PL_uid);
2379 if (PerlProc_geteuid() != PL_uid)
2380 Perl_croak(aTHX_ "Can't do seteuid!\n");
2383 if (!cando(S_IXUSR,TRUE,&PL_statbuf))
2384 Perl_croak(aTHX_ "Permission denied\n"); /* they can't do this */
2387 else if (PL_preprocess)
2388 Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
2389 else if (fdscript >= 0)
2390 Perl_croak(aTHX_ "fd script not allowed in suidperl\n");
2392 Perl_croak(aTHX_ "Script is not setuid/setgid in suidperl\n");
2394 /* We absolutely must clear out any saved ids here, so we */
2395 /* exec the real perl, substituting fd script for scriptname. */
2396 /* (We pass script name as "subdir" of fd, which perl will grok.) */
2397 PerlIO_rewind(PL_rsfp);
2398 PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0); /* just in case rewind didn't */
2399 for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
2400 if (!PL_origargv[which])
2401 Perl_croak(aTHX_ "Permission denied");
2402 PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
2403 PerlIO_fileno(PL_rsfp), PL_origargv[which]));
2404 #if defined(HAS_FCNTL) && defined(F_SETFD)
2405 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */
2407 PerlProc_execv(Perl_form(aTHX_ "%s/perl%s", BIN_EXP, PL_patchlevel), PL_origargv);/* try again */
2408 Perl_croak(aTHX_ "Can't do setuid\n");
2409 #endif /* IAMSUID */
2411 if (PL_euid != PL_uid || PL_egid != PL_gid) { /* (suidperl doesn't exist, in fact) */
2412 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2414 PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf); /* may be either wrapped or real suid */
2415 if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
2417 (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
2420 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2421 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2422 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2423 /* not set-id, must be wrapped */
2429 S_find_beginning(pTHX)
2431 register char *s, *s2;
2433 /* skip forward in input to the real script? */
2436 while (PL_doextract) {
2437 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
2438 Perl_croak(aTHX_ "No Perl script found in input\n");
2439 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2440 PerlIO_ungetc(PL_rsfp, '\n'); /* to keep line count right */
2441 PL_doextract = FALSE;
2442 while (*s && !(isSPACE (*s) || *s == '#')) s++;
2444 while (*s == ' ' || *s == '\t') s++;
2446 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2447 if (strnEQ(s2-4,"perl",4))
2449 while (s = moreswitches(s)) ;
2451 if (PL_cddir && PerlDir_chdir(PL_cddir) < 0)
2452 Perl_croak(aTHX_ "Can't chdir to %s",PL_cddir);
2461 PL_uid = (int)PerlProc_getuid();
2462 PL_euid = (int)PerlProc_geteuid();
2463 PL_gid = (int)PerlProc_getgid();
2464 PL_egid = (int)PerlProc_getegid();
2466 PL_uid |= PL_gid << 16;
2467 PL_euid |= PL_egid << 16;
2469 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2473 S_forbid_setid(pTHX_ char *s)
2475 if (PL_euid != PL_uid)
2476 Perl_croak(aTHX_ "No %s allowed while running setuid", s);
2477 if (PL_egid != PL_gid)
2478 Perl_croak(aTHX_ "No %s allowed while running setgid", s);
2482 S_init_debugger(pTHX)
2485 PL_curstash = PL_debstash;
2486 PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2487 AvREAL_off(PL_dbargs);
2488 PL_DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2489 PL_DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2490 PL_DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2491 PL_DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2492 sv_setiv(PL_DBsingle, 0);
2493 PL_DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2494 sv_setiv(PL_DBtrace, 0);
2495 PL_DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2496 sv_setiv(PL_DBsignal, 0);
2497 PL_curstash = PL_defstash;
2500 #ifndef STRESS_REALLOC
2501 #define REASONABLE(size) (size)
2503 #define REASONABLE(size) (1) /* unreasonable */
2507 Perl_init_stacks(pTHX)
2509 /* start with 128-item stack and 8K cxstack */
2510 PL_curstackinfo = new_stackinfo(REASONABLE(128),
2511 REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
2512 PL_curstackinfo->si_type = PERLSI_MAIN;
2513 PL_curstack = PL_curstackinfo->si_stack;
2514 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
2516 PL_stack_base = AvARRAY(PL_curstack);
2517 PL_stack_sp = PL_stack_base;
2518 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
2520 New(50,PL_tmps_stack,REASONABLE(128),SV*);
2523 PL_tmps_max = REASONABLE(128);
2525 New(54,PL_markstack,REASONABLE(32),I32);
2526 PL_markstack_ptr = PL_markstack;
2527 PL_markstack_max = PL_markstack + REASONABLE(32);
2531 New(54,PL_scopestack,REASONABLE(32),I32);
2532 PL_scopestack_ix = 0;
2533 PL_scopestack_max = REASONABLE(32);
2535 New(54,PL_savestack,REASONABLE(128),ANY);
2536 PL_savestack_ix = 0;
2537 PL_savestack_max = REASONABLE(128);
2539 New(54,PL_retstack,REASONABLE(16),OP*);
2541 PL_retstack_max = REASONABLE(16);
2550 while (PL_curstackinfo->si_next)
2551 PL_curstackinfo = PL_curstackinfo->si_next;
2552 while (PL_curstackinfo) {
2553 PERL_SI *p = PL_curstackinfo->si_prev;
2554 /* curstackinfo->si_stack got nuked by sv_free_arenas() */
2555 Safefree(PL_curstackinfo->si_cxstack);
2556 Safefree(PL_curstackinfo);
2557 PL_curstackinfo = p;
2559 Safefree(PL_tmps_stack);
2560 Safefree(PL_markstack);
2561 Safefree(PL_scopestack);
2562 Safefree(PL_savestack);
2563 Safefree(PL_retstack);
2565 Safefree(PL_debname);
2566 Safefree(PL_debdelim);
2571 static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
2582 lex_start(PL_linestr);
2584 PL_subname = newSVpvn("main",4);
2588 S_init_predump_symbols(pTHX)
2595 sv_setpvn(get_sv("\"", TRUE), " ", 1);
2596 PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2597 GvMULTI_on(PL_stdingv);
2598 io = GvIOp(PL_stdingv);
2599 IoIFP(io) = PerlIO_stdin();
2600 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2602 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
2604 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2607 IoOFP(io) = IoIFP(io) = PerlIO_stdout();
2609 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2611 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
2613 othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2614 GvMULTI_on(othergv);
2615 io = GvIOp(othergv);
2616 IoOFP(io) = IoIFP(io) = PerlIO_stderr();
2617 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2619 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
2621 PL_statname = NEWSV(66,0); /* last filename we did stat on */
2624 PL_osname = savepv(OSNAME);
2628 S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
2635 argc--,argv++; /* skip name of script */
2636 if (PL_doswitches) {
2637 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2640 if (argv[0][1] == '-') {
2644 if (s = strchr(argv[0], '=')) {
2646 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2649 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2652 PL_toptarget = NEWSV(0,0);
2653 sv_upgrade(PL_toptarget, SVt_PVFM);
2654 sv_setpvn(PL_toptarget, "", 0);
2655 PL_bodytarget = NEWSV(0,0);
2656 sv_upgrade(PL_bodytarget, SVt_PVFM);
2657 sv_setpvn(PL_bodytarget, "", 0);
2658 PL_formtarget = PL_bodytarget;
2661 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2662 sv_setpv(GvSV(tmpgv),PL_origfilename);
2663 magicname("0", "0", 1);
2665 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2666 sv_setpv(GvSV(tmpgv),PL_origargv[0]);
2667 if (PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2668 GvMULTI_on(PL_argvgv);
2669 (void)gv_AVadd(PL_argvgv);
2670 av_clear(GvAVn(PL_argvgv));
2671 for (; argc > 0; argc--,argv++) {
2672 av_push(GvAVn(PL_argvgv),newSVpv(argv[0],0));
2675 if (PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2677 GvMULTI_on(PL_envgv);
2678 hv = GvHVn(PL_envgv);
2679 hv_magic(hv, PL_envgv, 'E');
2680 #if !defined( VMS) && !defined(EPOC) /* VMS doesn't have environ array */
2681 /* Note that if the supplied env parameter is actually a copy
2682 of the global environ then it may now point to free'd memory
2683 if the environment has been modified since. To avoid this
2684 problem we treat env==NULL as meaning 'use the default'
2689 environ[0] = Nullch;
2690 for (; *env; env++) {
2691 if (!(s = strchr(*env,'=')))
2697 sv = newSVpv(s--,0);
2698 (void)hv_store(hv, *env, s - *env, sv, 0);
2700 #if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
2701 /* Sins of the RTL. See note in my_setenv(). */
2702 (void)PerlEnv_putenv(savepv(*env));
2706 #ifdef DYNAMIC_ENV_FETCH
2707 HvNAME(hv) = savepv(ENV_HV_NAME);
2711 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2712 sv_setiv(GvSV(tmpgv), (IV)getpid());
2716 S_init_perllib(pTHX)
2721 s = PerlEnv_getenv("PERL5LIB");
2725 incpush(PerlEnv_getenv("PERLLIB"), FALSE);
2727 /* Treat PERL5?LIB as a possible search list logical name -- the
2728 * "natural" VMS idiom for a Unix path string. We allow each
2729 * element to be a set of |-separated directories for compatibility.
2733 if (my_trnlnm("PERL5LIB",buf,0))
2734 do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2736 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2740 /* Use the ~-expanded versions of APPLLIB (undocumented),
2741 ARCHLIB PRIVLIB SITEARCH and SITELIB
2744 incpush(APPLLIB_EXP, TRUE);
2748 incpush(ARCHLIB_EXP, FALSE);
2751 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2754 incpush(PRIVLIB_EXP, TRUE);
2756 incpush(PRIVLIB_EXP, FALSE);
2760 incpush(SITEARCH_EXP, FALSE);
2764 incpush(SITELIB_EXP, TRUE);
2766 incpush(SITELIB_EXP, FALSE);
2770 incpush(".", FALSE);
2774 # define PERLLIB_SEP ';'
2777 # define PERLLIB_SEP '|'
2779 # define PERLLIB_SEP ':'
2782 #ifndef PERLLIB_MANGLE
2783 # define PERLLIB_MANGLE(s,n) (s)
2787 S_incpush(pTHX_ char *p, int addsubdirs)
2789 SV *subdir = Nullsv;
2795 subdir = sv_newmortal();
2796 if (!PL_archpat_auto) {
2797 STRLEN len = (sizeof(ARCHNAME) + strlen(PL_patchlevel)
2798 + sizeof("//auto"));
2799 New(55, PL_archpat_auto, len, char);
2800 sprintf(PL_archpat_auto, "/%s/%s/auto", ARCHNAME, PL_patchlevel);
2802 for (len = sizeof(ARCHNAME) + 2;
2803 PL_archpat_auto[len] != '\0' && PL_archpat_auto[len] != '/'; len++)
2804 if (PL_archpat_auto[len] == '.') PL_archpat_auto[len] = '_';
2809 /* Break at all separators */
2811 SV *libdir = NEWSV(55,0);
2814 /* skip any consecutive separators */
2815 while ( *p == PERLLIB_SEP ) {
2816 /* Uncomment the next line for PATH semantics */
2817 /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */
2821 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2822 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2827 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2828 p = Nullch; /* break out */
2832 * BEFORE pushing libdir onto @INC we may first push version- and
2833 * archname-specific sub-directories.
2836 struct stat tmpstatbuf;
2841 if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) {
2843 while (unix[len-1] == '/') len--; /* Cosmetic */
2844 sv_usepvn(libdir,unix,len);
2847 PerlIO_printf(PerlIO_stderr(),
2848 "Failed to unixify @INC element \"%s\"\n",
2851 /* .../archname/version if -d .../archname/version/auto */
2852 sv_setsv(subdir, libdir);
2853 sv_catpv(subdir, PL_archpat_auto);
2854 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2855 S_ISDIR(tmpstatbuf.st_mode))
2856 av_push(GvAVn(PL_incgv),
2857 newSVpvn(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2859 /* .../archname if -d .../archname/auto */
2860 sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
2861 strlen(PL_patchlevel) + 1, "", 0);
2862 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2863 S_ISDIR(tmpstatbuf.st_mode))
2864 av_push(GvAVn(PL_incgv),
2865 newSVpvn(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2868 /* finally push this lib directory on the end of @INC */
2869 av_push(GvAVn(PL_incgv), libdir);
2874 STATIC struct perl_thread *
2875 S_init_main_thread(pTHX)
2877 #if !defined(PERL_IMPLICIT_CONTEXT)
2878 struct perl_thread *thr;
2882 Newz(53, thr, 1, struct perl_thread);
2883 PL_curcop = &PL_compiling;
2884 thr->interp = PERL_GET_INTERP;
2885 thr->cvcache = newHV();
2886 thr->threadsv = newAV();
2887 /* thr->threadsvp is set when find_threadsv is called */
2888 thr->specific = newAV();
2889 thr->errhv = newHV();
2890 thr->flags = THRf_R_JOINABLE;
2891 MUTEX_INIT(&thr->mutex);
2892 /* Handcraft thrsv similarly to mess_sv */
2893 New(53, PL_thrsv, 1, SV);
2894 Newz(53, xpv, 1, XPV);
2895 SvFLAGS(PL_thrsv) = SVt_PV;
2896 SvANY(PL_thrsv) = (void*)xpv;
2897 SvREFCNT(PL_thrsv) = 1 << 30; /* practically infinite */
2898 SvPVX(PL_thrsv) = (char*)thr;
2899 SvCUR_set(PL_thrsv, sizeof(thr));
2900 SvLEN_set(PL_thrsv, sizeof(thr));
2901 *SvEND(PL_thrsv) = '\0'; /* in the trailing_nul field */
2902 thr->oursv = PL_thrsv;
2903 PL_chopset = " \n-";
2906 MUTEX_LOCK(&PL_threads_mutex);
2911 MUTEX_UNLOCK(&PL_threads_mutex);
2913 #ifdef HAVE_THREAD_INTERN
2914 Perl_init_thread_intern(thr);
2917 #ifdef SET_THREAD_SELF
2918 SET_THREAD_SELF(thr);
2920 thr->self = pthread_self();
2921 #endif /* SET_THREAD_SELF */
2925 * These must come after the SET_THR because sv_setpvn does
2926 * SvTAINT and the taint fields require dTHR.
2928 PL_toptarget = NEWSV(0,0);
2929 sv_upgrade(PL_toptarget, SVt_PVFM);
2930 sv_setpvn(PL_toptarget, "", 0);
2931 PL_bodytarget = NEWSV(0,0);
2932 sv_upgrade(PL_bodytarget, SVt_PVFM);
2933 sv_setpvn(PL_bodytarget, "", 0);
2934 PL_formtarget = PL_bodytarget;
2935 thr->errsv = newSVpvn("", 0);
2936 (void) find_threadsv("@"); /* Ensure $@ is initialised early */
2939 PL_regcompp = FUNC_NAME_TO_PTR(Perl_pregcomp);
2940 PL_regexecp = FUNC_NAME_TO_PTR(Perl_regexec_flags);
2941 PL_regint_start = FUNC_NAME_TO_PTR(Perl_re_intuit_start);
2942 PL_regint_string = FUNC_NAME_TO_PTR(Perl_re_intuit_string);
2943 PL_regfree = FUNC_NAME_TO_PTR(Perl_pregfree);
2945 PL_reginterp_cnt = 0;
2949 #endif /* USE_THREADS */
2952 Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
2956 line_t oldline = PL_curcop->cop_line;
2961 while (AvFILL(paramList) >= 0) {
2962 cv = (CV*)av_shift(paramList);
2964 CALLPROTECT(aTHX_ &ret, FUNC_NAME_TO_PTR(S_call_list_body), cv);
2967 (void)SvPV(atsv, len);
2969 PL_curcop = &PL_compiling;
2970 PL_curcop->cop_line = oldline;
2971 if (paramList == PL_beginav)
2972 sv_catpv(atsv, "BEGIN failed--compilation aborted");
2974 sv_catpv(atsv, "END failed--cleanup aborted");
2975 while (PL_scopestack_ix > oldscope)
2977 Perl_croak(aTHX_ "%s", SvPVX(atsv));
2984 /* my_exit() was called */
2985 while (PL_scopestack_ix > oldscope)
2988 PL_curstash = PL_defstash;
2990 call_list(oldscope, PL_endav);
2991 PL_curcop = &PL_compiling;
2992 PL_curcop->cop_line = oldline;
2993 if (PL_statusvalue) {
2994 if (paramList == PL_beginav)
2995 Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
2997 Perl_croak(aTHX_ "END failed--cleanup aborted");
3003 PL_curcop = &PL_compiling;
3004 PL_curcop->cop_line = oldline;
3007 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
3015 S_call_list_body(pTHX_ va_list args)
3018 CV *cv = va_arg(args, CV*);
3020 PUSHMARK(PL_stack_sp);
3021 call_sv((SV*)cv, G_EVAL|G_DISCARD);
3026 Perl_my_exit(pTHX_ U32 status)
3030 DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
3031 thr, (unsigned long) status));
3040 STATUS_NATIVE_SET(status);
3047 Perl_my_failure_exit(pTHX)
3050 if (vaxc$errno & 1) {
3051 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
3052 STATUS_NATIVE_SET(44);
3055 if (!vaxc$errno && errno) /* unlikely */
3056 STATUS_NATIVE_SET(44);
3058 STATUS_NATIVE_SET(vaxc$errno);
3063 STATUS_POSIX_SET(errno);
3065 exitstatus = STATUS_POSIX >> 8;
3066 if (exitstatus & 255)
3067 STATUS_POSIX_SET(exitstatus);
3069 STATUS_POSIX_SET(255);
3076 S_my_exit_jump(pTHX)
3079 register PERL_CONTEXT *cx;
3084 SvREFCNT_dec(PL_e_script);
3085 PL_e_script = Nullsv;
3088 POPSTACK_TO(PL_mainstack);
3089 if (cxstack_ix >= 0) {
3092 POPBLOCK(cx,PL_curpm);
3105 read_e_script(pTHXo_ int idx, SV *buf_sv, int maxlen)
3108 p = SvPVX(PL_e_script);
3109 nl = strchr(p, '\n');
3110 nl = (nl) ? nl+1 : SvEND(PL_e_script);
3112 filter_del(read_e_script);
3115 sv_catpvn(buf_sv, p, nl-p);
3116 sv_chop(PL_e_script, nl);