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 = MEMBER_TO_FPTR(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(PL_reg_poscache);
511 Safefree(HeKEY_hek(&PL_hv_fetch_ent_mh));
512 Safefree(PL_op_mask);
514 PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */
516 DEBUG_P(debprofdump());
518 MUTEX_DESTROY(&PL_strtab_mutex);
519 MUTEX_DESTROY(&PL_sv_mutex);
520 MUTEX_DESTROY(&PL_eval_mutex);
521 MUTEX_DESTROY(&PL_cred_mutex);
522 COND_DESTROY(&PL_eval_cond);
523 #ifdef EMULATE_ATOMIC_REFCOUNTS
524 MUTEX_DESTROY(&PL_svref_mutex);
525 #endif /* EMULATE_ATOMIC_REFCOUNTS */
527 /* As the penultimate thing, free the non-arena SV for thrsv */
528 Safefree(SvPVX(PL_thrsv));
529 Safefree(SvANY(PL_thrsv));
532 #endif /* USE_THREADS */
534 /* As the absolutely last thing, free the non-arena SV for mess() */
537 /* it could have accumulated taint magic */
538 if (SvTYPE(PL_mess_sv) >= SVt_PVMG) {
541 for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) {
542 moremagic = mg->mg_moremagic;
543 if (mg->mg_ptr && mg->mg_type != 'g' && mg->mg_len >= 0)
544 Safefree(mg->mg_ptr);
548 /* we know that type >= SVt_PV */
549 SvOOK_off(PL_mess_sv);
550 Safefree(SvPVX(PL_mess_sv));
551 Safefree(SvANY(PL_mess_sv));
552 Safefree(PL_mess_sv);
560 #if defined(PERL_OBJECT)
568 Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
570 Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry);
571 PL_exitlist[PL_exitlistlen].fn = fn;
572 PL_exitlist[PL_exitlistlen].ptr = ptr;
577 perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
586 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
589 Perl_croak(aTHX_ "suidperl is no longer needed since the kernel can now execute\n\
590 setuid perl scripts securely.\n");
594 #if defined(__DYNAMIC__) && (defined(NeXT) || defined(__NeXT__))
595 _dyld_lookup_and_bind
596 ("__environ", (unsigned long *) &environ_pointer, NULL);
601 #ifndef VMS /* VMS doesn't have environ array */
602 PL_origenviron = environ;
607 /* Come here if running an undumped a.out. */
609 PL_origfilename = savepv(argv[0]);
610 PL_do_undump = FALSE;
611 cxstack_ix = -1; /* start label stack again */
613 init_postdump_symbols(argc,argv,env);
618 PL_curpad = AvARRAY(PL_comppad);
619 op_free(PL_main_root);
620 PL_main_root = Nullop;
622 PL_main_start = Nullop;
623 SvREFCNT_dec(PL_main_cv);
627 oldscope = PL_scopestack_ix;
628 PL_dowarn = G_WARN_OFF;
630 CALLPROTECT(aTHX_ &ret, MEMBER_TO_FPTR(S_parse_body), env, xsinit);
638 /* my_exit() was called */
639 while (PL_scopestack_ix > oldscope)
642 PL_curstash = PL_defstash;
644 call_list(oldscope, PL_endav);
645 return STATUS_NATIVE_EXPORT;
647 PerlIO_printf(PerlIO_stderr(), "panic: top_env\n");
654 S_parse_body(pTHX_ va_list args)
657 int argc = PL_origargc;
658 char **argv = PL_origargv;
659 char **env = va_arg(args, char**);
660 char *scriptname = NULL;
662 VOL bool dosearch = FALSE;
668 XSINIT_t xsinit = va_arg(args, XSINIT_t);
670 sv_setpvn(PL_linestr,"",0);
671 sv = newSVpvn("",0); /* first used for -I flags */
675 for (argc--,argv++; argc > 0; argc--,argv++) {
676 if (argv[0][0] != '-' || !argv[0][1])
680 validarg = " PHOOEY ";
687 #ifndef PERL_STRICT_CR
711 if (s = moreswitches(s))
721 if (PL_euid != PL_uid || PL_egid != PL_gid)
722 Perl_croak(aTHX_ "No -e allowed in setuid scripts");
724 PL_e_script = newSVpvn("",0);
725 filter_add(read_e_script, NULL);
728 sv_catpv(PL_e_script, s);
730 sv_catpv(PL_e_script, argv[1]);
734 Perl_croak(aTHX_ "No code specified for -e");
735 sv_catpv(PL_e_script, "\n");
738 case 'I': /* -I handled both here and in moreswitches() */
740 if (!*++s && (s=argv[1]) != Nullch) {
743 while (s && isSPACE(*s))
747 for (e = s; *e && !isSPACE(*e); e++) ;
754 } /* XXX else croak? */
758 PL_preprocess = TRUE;
768 PL_preambleav = newAV();
769 av_push(PL_preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
771 PL_Sv = newSVpv("print myconfig();",0);
773 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
775 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
777 #if defined(DEBUGGING) || defined(MULTIPLICITY)
778 sv_catpv(PL_Sv,"\" Compile-time options:");
780 sv_catpv(PL_Sv," DEBUGGING");
783 sv_catpv(PL_Sv," MULTIPLICITY");
785 sv_catpv(PL_Sv,"\\n\",");
787 #if defined(LOCAL_PATCH_COUNT)
788 if (LOCAL_PATCH_COUNT > 0) {
790 sv_catpv(PL_Sv,"\" Locally applied patches:\\n\",");
791 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
792 if (PL_localpatches[i])
793 Perl_sv_catpvf(aTHX_ PL_Sv,"q\" \t%s\n\",",PL_localpatches[i]);
797 Perl_sv_catpvf(aTHX_ PL_Sv,"\" Built under %s\\n\"",OSNAME);
800 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
802 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled on %s\\n\"",__DATE__);
807 @env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; \
808 print \" \\%ENV:\\n @env\\n\" if @env; \
809 print \" \\@INC:\\n @INC\\n\";");
812 PL_Sv = newSVpv("config_vars(qw(",0);
813 sv_catpv(PL_Sv, ++s);
814 sv_catpv(PL_Sv, "))");
817 av_push(PL_preambleav, PL_Sv);
818 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
824 PL_cddir = savepv(s);
829 if (!*++s || isSPACE(*s)) {
833 /* catch use of gnu style long options */
834 if (strEQ(s, "version")) {
838 if (strEQ(s, "help")) {
845 Perl_croak(aTHX_ "Unrecognized switch: -%s (-h will show valid options)",s);
851 #ifndef SECURE_INTERNAL_GETENV
854 (s = PerlEnv_getenv("PERL5OPT"))) {
857 if (*s == '-' && *(s+1) == 'T')
870 if (!strchr("DIMUdmw", *s))
871 Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
878 scriptname = argv[0];
881 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
883 else if (scriptname == Nullch) {
885 if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
893 open_script(scriptname,dosearch,sv,&fdscript);
895 validate_suid(validarg, scriptname,fdscript);
900 PL_main_cv = PL_compcv = (CV*)NEWSV(1104,0);
901 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
902 CvUNIQUE_on(PL_compcv);
904 PL_comppad = newAV();
905 av_push(PL_comppad, Nullsv);
906 PL_curpad = AvARRAY(PL_comppad);
907 PL_comppad_name = newAV();
908 PL_comppad_name_fill = 0;
909 PL_min_intro_pending = 0;
912 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
913 PL_curpad[0] = (SV*)newAV();
914 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
915 CvOWNER(PL_compcv) = 0;
916 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
917 MUTEX_INIT(CvMUTEXP(PL_compcv));
918 #endif /* USE_THREADS */
920 comppadlist = newAV();
921 AvREAL_off(comppadlist);
922 av_store(comppadlist, 0, (SV*)PL_comppad_name);
923 av_store(comppadlist, 1, (SV*)PL_comppad);
924 CvPADLIST(PL_compcv) = comppadlist;
926 boot_core_UNIVERSAL();
929 (*xsinit)(aTHXo); /* in case linked C routines want magical variables */
930 #if defined(VMS) || defined(WIN32) || defined(DJGPP)
938 init_predump_symbols();
939 /* init_postdump_symbols not currently designed to be called */
940 /* more than once (ENV isn't cleared first, for example) */
941 /* But running with -u leaves %ENV & @ARGV undefined! XXX */
943 init_postdump_symbols(argc,argv,env);
947 /* now parse the script */
949 SETERRNO(0,SS$_NORMAL);
951 if (yyparse() || PL_error_count) {
953 Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
955 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
959 PL_curcop->cop_line = 0;
960 PL_curstash = PL_defstash;
961 PL_preprocess = FALSE;
963 SvREFCNT_dec(PL_e_script);
964 PL_e_script = Nullsv;
967 /* now that script is parsed, we can modify record separator */
969 PL_rs = SvREFCNT_inc(PL_nrs);
970 sv_setsv(get_sv("/", TRUE), PL_rs);
975 gv_check(PL_defstash);
981 if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
982 dump_mstats("after compilation:");
1000 oldscope = PL_scopestack_ix;
1003 CALLPROTECT(aTHX_ &ret, MEMBER_TO_FPTR(S_run_body), oldscope);
1006 cxstack_ix = -1; /* start context stack again */
1008 case 0: /* normal completion */
1009 case 2: /* my_exit() */
1010 while (PL_scopestack_ix > oldscope)
1013 PL_curstash = PL_defstash;
1015 call_list(oldscope, PL_endav);
1017 if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
1018 dump_mstats("after execution: ");
1020 return STATUS_NATIVE_EXPORT;
1023 POPSTACK_TO(PL_mainstack);
1026 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
1036 S_run_body(pTHX_ va_list args)
1039 I32 oldscope = va_arg(args, I32);
1041 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
1042 PL_sawampersand ? "Enabling" : "Omitting"));
1044 if (!PL_restartop) {
1045 DEBUG_x(dump_all());
1046 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
1047 DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%lx\n",
1048 (unsigned long) thr));
1051 PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", PL_origfilename);
1054 if (PERLDB_SINGLE && PL_DBsingle)
1055 sv_setiv(PL_DBsingle, 1);
1057 call_list(oldscope, PL_initav);
1063 PL_op = PL_restartop;
1067 else if (PL_main_start) {
1068 CvDEPTH(PL_main_cv) = 1;
1069 PL_op = PL_main_start;
1079 Perl_get_sv(pTHX_ const char *name, I32 create)
1083 if (name[1] == '\0' && !isALPHA(name[0])) {
1084 PADOFFSET tmp = find_threadsv(name);
1085 if (tmp != NOT_IN_PAD) {
1087 return THREADSV(tmp);
1090 #endif /* USE_THREADS */
1091 gv = gv_fetchpv(name, create, SVt_PV);
1098 Perl_get_av(pTHX_ const char *name, I32 create)
1100 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1109 Perl_get_hv(pTHX_ const char *name, I32 create)
1111 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1120 Perl_get_cv(pTHX_ const char *name, I32 create)
1122 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
1123 /* XXX unsafe for threads if eval_owner isn't held */
1124 /* XXX this is probably not what they think they're getting.
1125 * It has the same effect as "sub name;", i.e. just a forward
1127 if (create && !GvCVu(gv))
1128 return newSUB(start_subparse(FALSE, 0),
1129 newSVOP(OP_CONST, 0, newSVpv(name,0)),
1137 /* Be sure to refetch the stack pointer after calling these routines. */
1140 Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv)
1142 /* See G_* flags in cop.h */
1143 /* null terminated arg list */
1150 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
1155 return call_pv(sub_name, flags);
1159 Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
1160 /* name of the subroutine */
1161 /* See G_* flags in cop.h */
1163 return call_sv((SV*)get_cv(sub_name, TRUE), flags);
1167 Perl_call_method(pTHX_ const char *methname, I32 flags)
1168 /* name of the subroutine */
1169 /* See G_* flags in cop.h */
1175 XPUSHs(sv_2mortal(newSVpv(methname,0)));
1180 return call_sv(*PL_stack_sp--, flags);
1183 /* May be called with any of a CV, a GV, or an SV containing the name. */
1185 Perl_call_sv(pTHX_ SV *sv, I32 flags)
1187 /* See G_* flags in cop.h */
1190 LOGOP myop; /* fake syntax tree node */
1194 bool oldcatch = CATCH_GET;
1198 if (flags & G_DISCARD) {
1203 Zero(&myop, 1, LOGOP);
1204 myop.op_next = Nullop;
1205 if (!(flags & G_NOARGS))
1206 myop.op_flags |= OPf_STACKED;
1207 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1208 (flags & G_ARRAY) ? OPf_WANT_LIST :
1213 EXTEND(PL_stack_sp, 1);
1214 *++PL_stack_sp = sv;
1216 oldscope = PL_scopestack_ix;
1218 if (PERLDB_SUB && PL_curstash != PL_debstash
1219 /* Handle first BEGIN of -d. */
1220 && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
1221 /* Try harder, since this may have been a sighandler, thus
1222 * curstash may be meaningless. */
1223 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != PL_debstash)
1224 && !(flags & G_NODEBUG))
1225 PL_op->op_private |= OPpENTERSUB_DB;
1227 if (!(flags & G_EVAL)) {
1229 call_xbody((OP*)&myop, FALSE);
1230 retval = PL_stack_sp - (PL_stack_base + oldmark);
1234 cLOGOP->op_other = PL_op;
1236 /* we're trying to emulate pp_entertry() here */
1238 register PERL_CONTEXT *cx;
1239 I32 gimme = GIMME_V;
1244 push_return(PL_op->op_next);
1245 PUSHBLOCK(cx, CXt_EVAL, PL_stack_sp);
1247 PL_eval_root = PL_op; /* Only needed so that goto works right. */
1249 PL_in_eval = EVAL_INEVAL;
1250 if (flags & G_KEEPERR)
1251 PL_in_eval |= EVAL_KEEPERR;
1258 CALLPROTECT(aTHX_ &ret, MEMBER_TO_FPTR(S_call_body), (OP*)&myop, FALSE);
1261 retval = PL_stack_sp - (PL_stack_base + oldmark);
1262 if (!(flags & G_KEEPERR))
1269 /* my_exit() was called */
1270 PL_curstash = PL_defstash;
1273 Perl_croak(aTHX_ "Callback called exit");
1278 PL_op = PL_restartop;
1282 PL_stack_sp = PL_stack_base + oldmark;
1283 if (flags & G_ARRAY)
1287 *++PL_stack_sp = &PL_sv_undef;
1292 if (PL_scopestack_ix > oldscope) {
1296 register PERL_CONTEXT *cx;
1307 if (flags & G_DISCARD) {
1308 PL_stack_sp = PL_stack_base + oldmark;
1318 S_call_body(pTHX_ va_list args)
1320 OP *myop = va_arg(args, OP*);
1321 int is_eval = va_arg(args, int);
1323 call_xbody(myop, is_eval);
1328 S_call_xbody(pTHX_ OP *myop, int is_eval)
1332 if (PL_op == myop) {
1334 PL_op = Perl_pp_entereval(aTHX);
1336 PL_op = Perl_pp_entersub(aTHX);
1342 /* Eval a string. The G_EVAL flag is always assumed. */
1345 Perl_eval_sv(pTHX_ SV *sv, I32 flags)
1347 /* See G_* flags in cop.h */
1350 UNOP myop; /* fake syntax tree node */
1351 I32 oldmark = SP - PL_stack_base;
1357 if (flags & G_DISCARD) {
1364 Zero(PL_op, 1, UNOP);
1365 EXTEND(PL_stack_sp, 1);
1366 *++PL_stack_sp = sv;
1367 oldscope = PL_scopestack_ix;
1369 if (!(flags & G_NOARGS))
1370 myop.op_flags = OPf_STACKED;
1371 myop.op_next = Nullop;
1372 myop.op_type = OP_ENTEREVAL;
1373 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1374 (flags & G_ARRAY) ? OPf_WANT_LIST :
1376 if (flags & G_KEEPERR)
1377 myop.op_flags |= OPf_SPECIAL;
1380 CALLPROTECT(aTHX_ &ret, MEMBER_TO_FPTR(S_call_body), (OP*)&myop, TRUE);
1383 retval = PL_stack_sp - (PL_stack_base + oldmark);
1384 if (!(flags & G_KEEPERR))
1391 /* my_exit() was called */
1392 PL_curstash = PL_defstash;
1395 Perl_croak(aTHX_ "Callback called exit");
1400 PL_op = PL_restartop;
1404 PL_stack_sp = PL_stack_base + oldmark;
1405 if (flags & G_ARRAY)
1409 *++PL_stack_sp = &PL_sv_undef;
1414 if (flags & G_DISCARD) {
1415 PL_stack_sp = PL_stack_base + oldmark;
1425 Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
1428 SV* sv = newSVpv(p, 0);
1431 eval_sv(sv, G_SCALAR);
1438 if (croak_on_error && SvTRUE(ERRSV)) {
1440 Perl_croak(aTHX_ SvPVx(ERRSV, n_a));
1446 /* Require a module. */
1449 Perl_require_pv(pTHX_ const char *pv)
1453 PUSHSTACKi(PERLSI_REQUIRE);
1455 sv = sv_newmortal();
1456 sv_setpv(sv, "require '");
1459 eval_sv(sv, G_DISCARD);
1465 Perl_magicname(pTHX_ char *sym, char *name, I32 namlen)
1469 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1470 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1474 S_usage(pTHX_ char *name) /* XXX move this out into a module ? */
1476 /* This message really ought to be max 23 lines.
1477 * Removed -h because the user already knows that opton. Others? */
1479 static char *usage_msg[] = {
1480 "-0[octal] specify record separator (\\0, if no argument)",
1481 "-a autosplit mode with -n or -p (splits $_ into @F)",
1482 "-c check syntax only (runs BEGIN and END blocks)",
1483 "-d[:debugger] run program under debugger",
1484 "-D[number/list] set debugging flags (argument is a bit mask or alphabets)",
1485 "-e 'command' one line of program (several -e's allowed, omit programfile)",
1486 "-F/pattern/ split() pattern for -a switch (//'s are optional)",
1487 "-i[extension] edit <> files in place (makes backup if extension supplied)",
1488 "-Idirectory specify @INC/#include directory (several -I's allowed)",
1489 "-l[octal] enable line ending processing, specifies line terminator",
1490 "-[mM][-]module execute `use/no module...' before executing program",
1491 "-n assume 'while (<>) { ... }' loop around program",
1492 "-p assume loop like -n but print line also, like sed",
1493 "-P run program through C preprocessor before compilation",
1494 "-s enable rudimentary parsing for switches after programfile",
1495 "-S look for programfile using PATH environment variable",
1496 "-T enable tainting checks",
1497 "-u dump core after parsing program",
1498 "-U allow unsafe operations",
1499 "-v print version, subversion (includes VERY IMPORTANT perl info)",
1500 "-V[:variable] print configuration summary (or a single Config.pm variable)",
1501 "-w enable many useful warnings (RECOMMENDED)",
1502 "-x[directory] strip off text before #!perl line and perhaps cd to directory",
1506 char **p = usage_msg;
1508 printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1510 printf("\n %s", *p++);
1513 /* This routine handles any switches that can be given during run */
1516 Perl_moreswitches(pTHX_ char *s)
1525 rschar = scan_oct(s, 4, &numlen);
1526 SvREFCNT_dec(PL_nrs);
1527 if (rschar & ~((U8)~0))
1528 PL_nrs = &PL_sv_undef;
1529 else if (!rschar && numlen >= 2)
1530 PL_nrs = newSVpvn("", 0);
1533 PL_nrs = newSVpvn(&ch, 1);
1539 PL_splitstr = savepv(s + 1);
1553 if (*s == ':' || *s == '=') {
1554 my_setenv("PERL5DB", Perl_form(aTHX_ "use Devel::%s;", ++s));
1558 PL_perldb = PERLDB_ALL;
1566 if (isALPHA(s[1])) {
1567 static char debopts[] = "psltocPmfrxuLHXDS";
1570 for (s++; *s && (d = strchr(debopts,*s)); s++)
1571 PL_debug |= 1 << (d - debopts);
1574 PL_debug = atoi(s+1);
1575 for (s++; isDIGIT(*s); s++) ;
1577 PL_debug |= 0x80000000;
1580 if (ckWARN_d(WARN_DEBUGGING))
1581 Perl_warner(aTHX_ WARN_DEBUGGING,
1582 "Recompile perl with -DDEBUGGING to use -D switch\n");
1583 for (s++; isALNUM(*s); s++) ;
1589 usage(PL_origargv[0]);
1593 Safefree(PL_inplace);
1594 PL_inplace = savepv(s+1);
1596 for (s = PL_inplace; *s && !isSPACE(*s); s++) ;
1599 if (*s == '-') /* Additional switches on #! line. */
1603 case 'I': /* -I handled both here and in parse_perl() */
1606 while (*s && isSPACE(*s))
1610 for (e = s; *e && !isSPACE(*e); e++) ;
1611 p = savepvn(s, e-s);
1617 Perl_croak(aTHX_ "No space allowed after -I");
1625 PL_ors = savepv("\n");
1627 *PL_ors = scan_oct(s, 3 + (*s == '0'), &numlen);
1632 if (RsPARA(PL_nrs)) {
1637 PL_ors = SvPV(PL_nrs, PL_orslen);
1638 PL_ors = savepvn(PL_ors, PL_orslen);
1642 forbid_setid("-M"); /* XXX ? */
1645 forbid_setid("-m"); /* XXX ? */
1650 /* -M-foo == 'no foo' */
1651 if (*s == '-') { use = "no "; ++s; }
1652 sv = newSVpv(use,0);
1654 /* We allow -M'Module qw(Foo Bar)' */
1655 while(isALNUM(*s) || *s==':') ++s;
1657 sv_catpv(sv, start);
1658 if (*(start-1) == 'm') {
1660 Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
1661 sv_catpv( sv, " ()");
1664 sv_catpvn(sv, start, s-start);
1665 sv_catpv(sv, " split(/,/,q{");
1670 if (PL_preambleav == NULL)
1671 PL_preambleav = newAV();
1672 av_push(PL_preambleav, sv);
1675 Perl_croak(aTHX_ "No space allowed after -%c", *(s-1));
1687 PL_doswitches = TRUE;
1692 Perl_croak(aTHX_ "Too late for \"-T\" option");
1696 PL_do_undump = TRUE;
1704 #if defined(PERL_SUBVERSION) && PERL_SUBVERSION > 0
1705 printf("\nThis is perl, version %d.%03d_%02d built for %s",
1706 PERL_REVISION, PERL_VERSION, PERL_SUBVERSION, ARCHNAME);
1708 printf("\nThis is perl, version %s built for %s",
1709 PL_patchlevel, ARCHNAME);
1711 #if defined(LOCAL_PATCH_COUNT)
1712 if (LOCAL_PATCH_COUNT > 0)
1713 printf("\n(with %d registered patch%s, see perl -V for more detail)",
1714 LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : "");
1717 printf("\n\nCopyright 1987-1999, Larry Wall\n");
1719 printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1722 printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
1723 printf("djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
1726 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1727 "Version 5 port Copyright (c) 1994-1999, Andreas Kaiser, Ilya Zakharevich\n");
1730 printf("atariST series port, ++jrb bammi@cadence.com\n");
1733 printf("BeOS port Copyright Tom Spindler, 1997-1999\n");
1736 printf("MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-1999\n");
1739 printf("MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
1742 printf("Stratus VOS port by Paul_Green@stratus.com, 1997-1999\n");
1745 printf("VM/ESA port by Neale Ferguson, 1998-1999\n");
1748 printf("BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
1751 printf("MiNT port by Guido Flohr, 1997-1999\n");
1753 #ifdef BINARY_BUILD_NOTICE
1754 BINARY_BUILD_NOTICE;
1757 Perl may be copied only under the terms of either the Artistic License or the\n\
1758 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n\
1759 Complete documentation for Perl, including FAQ lists, should be found on\n\
1760 this system using `man perl' or `perldoc perl'. If you have access to the\n\
1761 Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
1764 if (! (PL_dowarn & G_WARN_ALL_MASK))
1765 PL_dowarn |= G_WARN_ON;
1769 PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
1770 PL_compiling.cop_warnings = WARN_ALL ;
1774 PL_dowarn = G_WARN_ALL_OFF;
1775 PL_compiling.cop_warnings = WARN_NONE ;
1780 if (s[1] == '-') /* Additional switches on #! line. */
1785 #if defined(WIN32) || !defined(PERL_STRICT_CR)
1791 #ifdef ALTERNATE_SHEBANG
1792 case 'S': /* OS/2 needs -S on "extproc" line. */
1800 Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
1805 /* compliments of Tom Christiansen */
1807 /* unexec() can be found in the Gnu emacs distribution */
1808 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
1811 Perl_my_unexec(pTHX)
1819 prog = newSVpv(BIN_EXP, 0);
1820 sv_catpv(prog, "/perl");
1821 file = newSVpv(PL_origfilename, 0);
1822 sv_catpv(file, ".perldump");
1824 unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
1825 /* unexec prints msg to stderr in case of failure */
1826 PerlProc_exit(status);
1829 # include <lib$routines.h>
1830 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
1832 ABORT(); /* for use with undump */
1837 /* initialize curinterp */
1842 #ifdef PERL_OBJECT /* XXX kludge */
1845 PL_chopset = " \n-"; \
1846 PL_copline = NOLINE; \
1847 PL_curcop = &PL_compiling;\
1848 PL_curcopdb = NULL; \
1851 PL_dumpindent = 4; \
1852 PL_laststatval = -1; \
1853 PL_laststype = OP_STAT; \
1854 PL_maxscream = -1; \
1855 PL_maxsysfd = MAXSYSFD; \
1856 PL_statname = Nullsv; \
1857 PL_tmps_floor = -1; \
1859 PL_op_mask = NULL; \
1861 PL_laststatval = -1; \
1862 PL_laststype = OP_STAT; \
1863 PL_mess_sv = Nullsv; \
1864 PL_splitstr = " "; \
1865 PL_generation = 100; \
1866 PL_exitlist = NULL; \
1867 PL_exitlistlen = 0; \
1869 PL_in_clean_objs = FALSE; \
1870 PL_in_clean_all = FALSE; \
1871 PL_profiledata = NULL; \
1873 PL_rsfp_filters = Nullav; \
1878 # ifdef MULTIPLICITY
1879 # define PERLVAR(var,type)
1880 # define PERLVARA(var,n,type)
1881 # if defined(PERL_IMPLICIT_CONTEXT)
1882 # define PERLVARI(var,type,init) my_perl->var = init;
1883 # define PERLVARIC(var,type,init) my_perl->var = init;
1885 # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
1886 # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
1888 # include "intrpvar.h"
1889 # ifndef USE_THREADS
1890 # include "thrdvar.h"
1897 # define PERLVAR(var,type)
1898 # define PERLVARA(var,n,type)
1899 # define PERLVARI(var,type,init) PL_##var = init;
1900 # define PERLVARIC(var,type,init) PL_##var = init;
1901 # include "intrpvar.h"
1902 # ifndef USE_THREADS
1903 # include "thrdvar.h"
1915 S_init_main_stash(pTHX)
1920 /* Note that strtab is a rather special HV. Assumptions are made
1921 about not iterating on it, and not adding tie magic to it.
1922 It is properly deallocated in perl_destruct() */
1923 PL_strtab = newHV();
1925 MUTEX_INIT(&PL_strtab_mutex);
1927 HvSHAREKEYS_off(PL_strtab); /* mandatory */
1928 hv_ksplit(PL_strtab, 512);
1930 PL_curstash = PL_defstash = newHV();
1931 PL_curstname = newSVpvn("main",4);
1932 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1933 SvREFCNT_dec(GvHV(gv));
1934 GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
1936 HvNAME(PL_defstash) = savepv("main");
1937 PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1938 GvMULTI_on(PL_incgv);
1939 PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
1940 GvMULTI_on(PL_hintgv);
1941 PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1942 PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1943 GvMULTI_on(PL_errgv);
1944 PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
1945 GvMULTI_on(PL_replgv);
1946 (void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */
1947 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
1948 sv_setpvn(ERRSV, "", 0);
1949 PL_curstash = PL_defstash;
1950 PL_compiling.cop_stash = PL_defstash;
1951 PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
1952 PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
1953 /* We must init $/ before switches are processed. */
1954 sv_setpvn(get_sv("/", TRUE), "\n", 1);
1958 S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
1966 PL_origfilename = savepv("-e");
1969 /* if find_script() returns, it returns a malloc()-ed value */
1970 PL_origfilename = scriptname = find_script(scriptname, dosearch, NULL, 1);
1972 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
1973 char *s = scriptname + 8;
1974 *fdscript = atoi(s);
1978 scriptname = savepv(s + 1);
1979 Safefree(PL_origfilename);
1980 PL_origfilename = scriptname;
1985 PL_curcop->cop_filegv = gv_fetchfile(PL_origfilename);
1986 if (strEQ(PL_origfilename,"-"))
1988 if (*fdscript >= 0) {
1989 PL_rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE);
1990 #if defined(HAS_FCNTL) && defined(F_SETFD)
1992 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); /* ensure close-on-exec */
1995 else if (PL_preprocess) {
1996 char *cpp_cfg = CPPSTDIN;
1997 SV *cpp = newSVpvn("",0);
1998 SV *cmd = NEWSV(0,0);
2000 if (strEQ(cpp_cfg, "cppstdin"))
2001 Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
2002 sv_catpv(cpp, cpp_cfg);
2005 sv_catpv(sv,PRIVLIB_EXP);
2008 Perl_sv_setpvf(aTHX_ cmd, "\
2009 sed %s -e \"/^[^#]/b\" \
2010 -e \"/^#[ ]*include[ ]/b\" \
2011 -e \"/^#[ ]*define[ ]/b\" \
2012 -e \"/^#[ ]*if[ ]/b\" \
2013 -e \"/^#[ ]*ifdef[ ]/b\" \
2014 -e \"/^#[ ]*ifndef[ ]/b\" \
2015 -e \"/^#[ ]*else/b\" \
2016 -e \"/^#[ ]*elif[ ]/b\" \
2017 -e \"/^#[ ]*undef[ ]/b\" \
2018 -e \"/^#[ ]*endif/b\" \
2021 (PL_doextract ? "-e \"1,/^#/d\n\"" : ""),
2024 Perl_sv_setpvf(aTHX_ cmd, "\
2025 %s %s -e '/^[^#]/b' \
2026 -e '/^#[ ]*include[ ]/b' \
2027 -e '/^#[ ]*define[ ]/b' \
2028 -e '/^#[ ]*if[ ]/b' \
2029 -e '/^#[ ]*ifdef[ ]/b' \
2030 -e '/^#[ ]*ifndef[ ]/b' \
2031 -e '/^#[ ]*else/b' \
2032 -e '/^#[ ]*elif[ ]/b' \
2033 -e '/^#[ ]*undef[ ]/b' \
2034 -e '/^#[ ]*endif/b' \
2038 Perl_sv_setpvf(aTHX_ cmd, "\
2039 %s %s -e '/^[^#]/b' \
2040 -e '/^#[ ]*include[ ]/b' \
2041 -e '/^#[ ]*define[ ]/b' \
2042 -e '/^#[ ]*if[ ]/b' \
2043 -e '/^#[ ]*ifdef[ ]/b' \
2044 -e '/^#[ ]*ifndef[ ]/b' \
2045 -e '/^#[ ]*else/b' \
2046 -e '/^#[ ]*elif[ ]/b' \
2047 -e '/^#[ ]*undef[ ]/b' \
2048 -e '/^#[ ]*endif/b' \
2057 (PL_doextract ? "-e '1,/^#/d\n'" : ""),
2059 scriptname, cpp, sv, CPPMINUS);
2060 PL_doextract = FALSE;
2061 #ifdef IAMSUID /* actually, this is caught earlier */
2062 if (PL_euid != PL_uid && !PL_euid) { /* if running suidperl */
2064 (void)seteuid(PL_uid); /* musn't stay setuid root */
2067 (void)setreuid((Uid_t)-1, PL_uid);
2069 #ifdef HAS_SETRESUID
2070 (void)setresuid((Uid_t)-1, PL_uid, (Uid_t)-1);
2072 PerlProc_setuid(PL_uid);
2076 if (PerlProc_geteuid() != PL_uid)
2077 Perl_croak(aTHX_ "Can't do seteuid!\n");
2079 #endif /* IAMSUID */
2080 PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
2084 else if (!*scriptname) {
2085 forbid_setid("program input from stdin");
2086 PL_rsfp = PerlIO_stdin();
2089 PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
2090 #if defined(HAS_FCNTL) && defined(F_SETFD)
2092 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); /* ensure close-on-exec */
2097 #ifndef IAMSUID /* in case script is not readable before setuid */
2099 PerlLIO_stat(SvPVX(GvSV(PL_curcop->cop_filegv)),&PL_statbuf) >= 0 &&
2100 PL_statbuf.st_mode & (S_ISUID|S_ISGID))
2103 PerlProc_execv(Perl_form(aTHX_ "%s/sperl%s", BIN_EXP, PL_patchlevel), PL_origargv);
2104 Perl_croak(aTHX_ "Can't do setuid\n");
2108 Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
2109 SvPVX(GvSV(PL_curcop->cop_filegv)), Strerror(errno));
2114 * I_SYSSTATVFS HAS_FSTATVFS
2116 * I_STATFS HAS_FSTATFS
2117 * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT
2118 * here so that metaconfig picks them up. */
2122 S_fd_on_nosuid_fs(pTHX_ int fd)
2127 * Preferred order: fstatvfs(), fstatfs(), getmntent().
2128 * fstatvfs() is UNIX98.
2130 * getmntent() is O(number-of-mounted-filesystems) and can hang.
2133 # ifdef HAS_FSTATVFS
2134 struct statvfs stfs;
2135 check_okay = fstatvfs(fd, &stfs) == 0;
2136 on_nosuid = check_okay && (stfs.f_flag & ST_NOSUID);
2138 # if defined(HAS_FSTATFS) && defined(HAS_STRUCT_STATFS_FLAGS)
2140 check_okay = fstatfs(fd, &stfs) == 0;
2141 # undef PERL_MOUNT_NOSUID
2142 # if !defined(PERL_MOUNT_NOSUID) && defined(MNT_NOSUID)
2143 # define PERL_MOUNT_NOSUID MNT_NOSUID
2145 # if !defined(PERL_MOUNT_NOSUID) && defined(MS_NOSUID)
2146 # define PERL_MOUNT_NOSUID MS_NOSUID
2148 # if !defined(PERL_MOUNT_NOSUID) && defined(M_NOSUID)
2149 # define PERL_MOUNT_NOSUID M_NOSUID
2151 # ifdef PERL_MOUNT_NOSUID
2152 on_nosuid = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
2155 # if defined(HAS_GETMNTENT) && defined(HAS_HASMNTOPT) && defined(MNTOPT_NOSUID)
2156 FILE *mtab = fopen("/etc/mtab", "r");
2157 struct mntent *entry;
2158 struct stat stb, fsb;
2160 if (mtab && (fstat(fd, &stb) == 0)) {
2161 while (entry = getmntent(mtab)) {
2162 if (stat(entry->mnt_dir, &fsb) == 0
2163 && fsb.st_dev == stb.st_dev)
2165 /* found the filesystem */
2167 if (hasmntopt(entry, MNTOPT_NOSUID))
2170 } /* A single fs may well fail its stat(). */
2175 # endif /* mntent */
2176 # endif /* statfs */
2177 # endif /* statvfs */
2179 Perl_croak(aTHX_ "Can't check filesystem of script \"%s\"", PL_origfilename);
2182 #endif /* IAMSUID */
2185 S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript)
2189 /* do we need to emulate setuid on scripts? */
2191 /* This code is for those BSD systems that have setuid #! scripts disabled
2192 * in the kernel because of a security problem. Merely defining DOSUID
2193 * in perl will not fix that problem, but if you have disabled setuid
2194 * scripts in the kernel, this will attempt to emulate setuid and setgid
2195 * on scripts that have those now-otherwise-useless bits set. The setuid
2196 * root version must be called suidperl or sperlN.NNN. If regular perl
2197 * discovers that it has opened a setuid script, it calls suidperl with
2198 * the same argv that it had. If suidperl finds that the script it has
2199 * just opened is NOT setuid root, it sets the effective uid back to the
2200 * uid. We don't just make perl setuid root because that loses the
2201 * effective uid we had before invoking perl, if it was different from the
2204 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
2205 * be defined in suidperl only. suidperl must be setuid root. The
2206 * Configure script will set this up for you if you want it.
2213 if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */
2214 Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
2215 if (fdscript < 0 && PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
2220 #ifndef HAS_SETREUID
2221 /* On this access check to make sure the directories are readable,
2222 * there is actually a small window that the user could use to make
2223 * filename point to an accessible directory. So there is a faint
2224 * chance that someone could execute a setuid script down in a
2225 * non-accessible directory. I don't know what to do about that.
2226 * But I don't think it's too important. The manual lies when
2227 * it says access() is useful in setuid programs.
2229 if (PerlLIO_access(SvPVX(GvSV(PL_curcop->cop_filegv)),1)) /*double check*/
2230 Perl_croak(aTHX_ "Permission denied");
2232 /* If we can swap euid and uid, then we can determine access rights
2233 * with a simple stat of the file, and then compare device and
2234 * inode to make sure we did stat() on the same file we opened.
2235 * Then we just have to make sure he or she can execute it.
2238 struct stat tmpstatbuf;
2242 setreuid(PL_euid,PL_uid) < 0
2245 setresuid(PL_euid,PL_uid,(Uid_t)-1) < 0
2248 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
2249 Perl_croak(aTHX_ "Can't swap uid and euid"); /* really paranoid */
2250 if (PerlLIO_stat(SvPVX(GvSV(PL_curcop->cop_filegv)),&tmpstatbuf) < 0)
2251 Perl_croak(aTHX_ "Permission denied"); /* testing full pathname here */
2252 #if defined(IAMSUID) && !defined(NO_NOSUID_CHECK)
2253 if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp)))
2254 Perl_croak(aTHX_ "Permission denied");
2256 if (tmpstatbuf.st_dev != PL_statbuf.st_dev ||
2257 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
2258 (void)PerlIO_close(PL_rsfp);
2259 if (PL_rsfp = PerlProc_popen("/bin/mail root","w")) { /* heh, heh */
2260 PerlIO_printf(PL_rsfp,
2261 "User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2262 (Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
2263 (long)PL_uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
2264 (long)PL_statbuf.st_dev, (long)PL_statbuf.st_ino,
2265 SvPVX(GvSV(PL_curcop->cop_filegv)),
2266 (long)PL_statbuf.st_uid, (long)PL_statbuf.st_gid);
2267 (void)PerlProc_pclose(PL_rsfp);
2269 Perl_croak(aTHX_ "Permission denied\n");
2273 setreuid(PL_uid,PL_euid) < 0
2275 # if defined(HAS_SETRESUID)
2276 setresuid(PL_uid,PL_euid,(Uid_t)-1) < 0
2279 || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
2280 Perl_croak(aTHX_ "Can't reswap uid and euid");
2281 if (!cando(S_IXUSR,FALSE,&PL_statbuf)) /* can real uid exec? */
2282 Perl_croak(aTHX_ "Permission denied\n");
2284 #endif /* HAS_SETREUID */
2285 #endif /* IAMSUID */
2287 if (!S_ISREG(PL_statbuf.st_mode))
2288 Perl_croak(aTHX_ "Permission denied");
2289 if (PL_statbuf.st_mode & S_IWOTH)
2290 Perl_croak(aTHX_ "Setuid/gid script is writable by world");
2291 PL_doswitches = FALSE; /* -s is insecure in suid */
2292 PL_curcop->cop_line++;
2293 if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
2294 strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */
2295 Perl_croak(aTHX_ "No #! line");
2296 s = SvPV(PL_linestr,n_a)+2;
2298 while (!isSPACE(*s)) s++;
2299 for (s2 = s; (s2 > SvPV(PL_linestr,n_a)+2 &&
2300 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
2301 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
2302 Perl_croak(aTHX_ "Not a perl script");
2303 while (*s == ' ' || *s == '\t') s++;
2305 * #! arg must be what we saw above. They can invoke it by
2306 * mentioning suidperl explicitly, but they may not add any strange
2307 * arguments beyond what #! says if they do invoke suidperl that way.
2309 len = strlen(validarg);
2310 if (strEQ(validarg," PHOOEY ") ||
2311 strnNE(s,validarg,len) || !isSPACE(s[len]))
2312 Perl_croak(aTHX_ "Args must match #! line");
2315 if (PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
2316 PL_euid == PL_statbuf.st_uid)
2318 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2319 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2320 #endif /* IAMSUID */
2322 if (PL_euid) { /* oops, we're not the setuid root perl */
2323 (void)PerlIO_close(PL_rsfp);
2326 PerlProc_execv(Perl_form(aTHX_ "%s/sperl%s", BIN_EXP, PL_patchlevel), PL_origargv);
2328 Perl_croak(aTHX_ "Can't do setuid\n");
2331 if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
2333 (void)setegid(PL_statbuf.st_gid);
2336 (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
2338 #ifdef HAS_SETRESGID
2339 (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
2341 PerlProc_setgid(PL_statbuf.st_gid);
2345 if (PerlProc_getegid() != PL_statbuf.st_gid)
2346 Perl_croak(aTHX_ "Can't do setegid!\n");
2348 if (PL_statbuf.st_mode & S_ISUID) {
2349 if (PL_statbuf.st_uid != PL_euid)
2351 (void)seteuid(PL_statbuf.st_uid); /* all that for this */
2354 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
2356 #ifdef HAS_SETRESUID
2357 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
2359 PerlProc_setuid(PL_statbuf.st_uid);
2363 if (PerlProc_geteuid() != PL_statbuf.st_uid)
2364 Perl_croak(aTHX_ "Can't do seteuid!\n");
2366 else if (PL_uid) { /* oops, mustn't run as root */
2368 (void)seteuid((Uid_t)PL_uid);
2371 (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
2373 #ifdef HAS_SETRESUID
2374 (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
2376 PerlProc_setuid((Uid_t)PL_uid);
2380 if (PerlProc_geteuid() != PL_uid)
2381 Perl_croak(aTHX_ "Can't do seteuid!\n");
2384 if (!cando(S_IXUSR,TRUE,&PL_statbuf))
2385 Perl_croak(aTHX_ "Permission denied\n"); /* they can't do this */
2388 else if (PL_preprocess)
2389 Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
2390 else if (fdscript >= 0)
2391 Perl_croak(aTHX_ "fd script not allowed in suidperl\n");
2393 Perl_croak(aTHX_ "Script is not setuid/setgid in suidperl\n");
2395 /* We absolutely must clear out any saved ids here, so we */
2396 /* exec the real perl, substituting fd script for scriptname. */
2397 /* (We pass script name as "subdir" of fd, which perl will grok.) */
2398 PerlIO_rewind(PL_rsfp);
2399 PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0); /* just in case rewind didn't */
2400 for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
2401 if (!PL_origargv[which])
2402 Perl_croak(aTHX_ "Permission denied");
2403 PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
2404 PerlIO_fileno(PL_rsfp), PL_origargv[which]));
2405 #if defined(HAS_FCNTL) && defined(F_SETFD)
2406 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */
2408 PerlProc_execv(Perl_form(aTHX_ "%s/perl%s", BIN_EXP, PL_patchlevel), PL_origargv);/* try again */
2409 Perl_croak(aTHX_ "Can't do setuid\n");
2410 #endif /* IAMSUID */
2412 if (PL_euid != PL_uid || PL_egid != PL_gid) { /* (suidperl doesn't exist, in fact) */
2413 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2415 PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf); /* may be either wrapped or real suid */
2416 if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
2418 (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
2421 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2422 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2423 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2424 /* not set-id, must be wrapped */
2430 S_find_beginning(pTHX)
2432 register char *s, *s2;
2434 /* skip forward in input to the real script? */
2437 while (PL_doextract) {
2438 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
2439 Perl_croak(aTHX_ "No Perl script found in input\n");
2440 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2441 PerlIO_ungetc(PL_rsfp, '\n'); /* to keep line count right */
2442 PL_doextract = FALSE;
2443 while (*s && !(isSPACE (*s) || *s == '#')) s++;
2445 while (*s == ' ' || *s == '\t') s++;
2447 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2448 if (strnEQ(s2-4,"perl",4))
2450 while (s = moreswitches(s)) ;
2452 if (PL_cddir && PerlDir_chdir(PL_cddir) < 0)
2453 Perl_croak(aTHX_ "Can't chdir to %s",PL_cddir);
2462 PL_uid = (int)PerlProc_getuid();
2463 PL_euid = (int)PerlProc_geteuid();
2464 PL_gid = (int)PerlProc_getgid();
2465 PL_egid = (int)PerlProc_getegid();
2467 PL_uid |= PL_gid << 16;
2468 PL_euid |= PL_egid << 16;
2470 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2474 S_forbid_setid(pTHX_ char *s)
2476 if (PL_euid != PL_uid)
2477 Perl_croak(aTHX_ "No %s allowed while running setuid", s);
2478 if (PL_egid != PL_gid)
2479 Perl_croak(aTHX_ "No %s allowed while running setgid", s);
2483 Perl_init_debugger(pTHX)
2486 HV *ostash = PL_curstash;
2488 PL_curstash = PL_debstash;
2489 PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2490 AvREAL_off(PL_dbargs);
2491 PL_DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2492 PL_DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2493 PL_DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2494 sv_upgrade(GvSV(PL_DBsub), SVt_IV); /* IVX accessed if PERLDB_SUB_NN */
2495 PL_DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2496 sv_setiv(PL_DBsingle, 0);
2497 PL_DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2498 sv_setiv(PL_DBtrace, 0);
2499 PL_DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2500 sv_setiv(PL_DBsignal, 0);
2501 PL_curstash = ostash;
2504 #ifndef STRESS_REALLOC
2505 #define REASONABLE(size) (size)
2507 #define REASONABLE(size) (1) /* unreasonable */
2511 Perl_init_stacks(pTHX)
2513 /* start with 128-item stack and 8K cxstack */
2514 PL_curstackinfo = new_stackinfo(REASONABLE(128),
2515 REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
2516 PL_curstackinfo->si_type = PERLSI_MAIN;
2517 PL_curstack = PL_curstackinfo->si_stack;
2518 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
2520 PL_stack_base = AvARRAY(PL_curstack);
2521 PL_stack_sp = PL_stack_base;
2522 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
2524 New(50,PL_tmps_stack,REASONABLE(128),SV*);
2527 PL_tmps_max = REASONABLE(128);
2529 New(54,PL_markstack,REASONABLE(32),I32);
2530 PL_markstack_ptr = PL_markstack;
2531 PL_markstack_max = PL_markstack + REASONABLE(32);
2535 New(54,PL_scopestack,REASONABLE(32),I32);
2536 PL_scopestack_ix = 0;
2537 PL_scopestack_max = REASONABLE(32);
2539 New(54,PL_savestack,REASONABLE(128),ANY);
2540 PL_savestack_ix = 0;
2541 PL_savestack_max = REASONABLE(128);
2543 New(54,PL_retstack,REASONABLE(16),OP*);
2545 PL_retstack_max = REASONABLE(16);
2554 while (PL_curstackinfo->si_next)
2555 PL_curstackinfo = PL_curstackinfo->si_next;
2556 while (PL_curstackinfo) {
2557 PERL_SI *p = PL_curstackinfo->si_prev;
2558 /* curstackinfo->si_stack got nuked by sv_free_arenas() */
2559 Safefree(PL_curstackinfo->si_cxstack);
2560 Safefree(PL_curstackinfo);
2561 PL_curstackinfo = p;
2563 Safefree(PL_tmps_stack);
2564 Safefree(PL_markstack);
2565 Safefree(PL_scopestack);
2566 Safefree(PL_savestack);
2567 Safefree(PL_retstack);
2569 Safefree(PL_debname);
2570 Safefree(PL_debdelim);
2575 static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
2586 lex_start(PL_linestr);
2588 PL_subname = newSVpvn("main",4);
2592 S_init_predump_symbols(pTHX)
2599 sv_setpvn(get_sv("\"", TRUE), " ", 1);
2600 PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2601 GvMULTI_on(PL_stdingv);
2602 io = GvIOp(PL_stdingv);
2603 IoIFP(io) = PerlIO_stdin();
2604 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2606 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
2608 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2611 IoOFP(io) = IoIFP(io) = PerlIO_stdout();
2613 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2615 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
2617 othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2618 GvMULTI_on(othergv);
2619 io = GvIOp(othergv);
2620 IoOFP(io) = IoIFP(io) = PerlIO_stderr();
2621 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2623 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
2625 PL_statname = NEWSV(66,0); /* last filename we did stat on */
2628 PL_osname = savepv(OSNAME);
2632 S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
2639 argc--,argv++; /* skip name of script */
2640 if (PL_doswitches) {
2641 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2644 if (argv[0][1] == '-') {
2648 if (s = strchr(argv[0], '=')) {
2650 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2653 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2656 PL_toptarget = NEWSV(0,0);
2657 sv_upgrade(PL_toptarget, SVt_PVFM);
2658 sv_setpvn(PL_toptarget, "", 0);
2659 PL_bodytarget = NEWSV(0,0);
2660 sv_upgrade(PL_bodytarget, SVt_PVFM);
2661 sv_setpvn(PL_bodytarget, "", 0);
2662 PL_formtarget = PL_bodytarget;
2665 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2666 sv_setpv(GvSV(tmpgv),PL_origfilename);
2667 magicname("0", "0", 1);
2669 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2670 sv_setpv(GvSV(tmpgv),PL_origargv[0]);
2671 if (PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2672 GvMULTI_on(PL_argvgv);
2673 (void)gv_AVadd(PL_argvgv);
2674 av_clear(GvAVn(PL_argvgv));
2675 for (; argc > 0; argc--,argv++) {
2676 av_push(GvAVn(PL_argvgv),newSVpv(argv[0],0));
2679 if (PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2681 GvMULTI_on(PL_envgv);
2682 hv = GvHVn(PL_envgv);
2683 hv_magic(hv, PL_envgv, 'E');
2684 #if !defined( VMS) && !defined(EPOC) /* VMS doesn't have environ array */
2685 /* Note that if the supplied env parameter is actually a copy
2686 of the global environ then it may now point to free'd memory
2687 if the environment has been modified since. To avoid this
2688 problem we treat env==NULL as meaning 'use the default'
2693 environ[0] = Nullch;
2694 for (; *env; env++) {
2695 if (!(s = strchr(*env,'=')))
2701 sv = newSVpv(s--,0);
2702 (void)hv_store(hv, *env, s - *env, sv, 0);
2704 #if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
2705 /* Sins of the RTL. See note in my_setenv(). */
2706 (void)PerlEnv_putenv(savepv(*env));
2710 #ifdef DYNAMIC_ENV_FETCH
2711 HvNAME(hv) = savepv(ENV_HV_NAME);
2715 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2716 sv_setiv(GvSV(tmpgv), (IV)getpid());
2720 S_init_perllib(pTHX)
2725 s = PerlEnv_getenv("PERL5LIB");
2729 incpush(PerlEnv_getenv("PERLLIB"), FALSE);
2731 /* Treat PERL5?LIB as a possible search list logical name -- the
2732 * "natural" VMS idiom for a Unix path string. We allow each
2733 * element to be a set of |-separated directories for compatibility.
2737 if (my_trnlnm("PERL5LIB",buf,0))
2738 do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2740 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2744 /* Use the ~-expanded versions of APPLLIB (undocumented),
2745 ARCHLIB PRIVLIB SITEARCH and SITELIB
2748 incpush(APPLLIB_EXP, TRUE);
2752 incpush(ARCHLIB_EXP, FALSE);
2755 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2758 incpush(PRIVLIB_EXP, TRUE);
2760 incpush(PRIVLIB_EXP, FALSE);
2764 incpush(SITEARCH_EXP, FALSE);
2768 incpush(SITELIB_EXP, TRUE);
2770 incpush(SITELIB_EXP, FALSE);
2773 #if defined(PERL_VENDORLIB_EXP)
2775 incpush(PERL_VENDORLIB_EXP, TRUE);
2777 incpush(PERL_VENDORLIB_EXP, FALSE);
2781 incpush(".", FALSE);
2785 # define PERLLIB_SEP ';'
2788 # define PERLLIB_SEP '|'
2790 # define PERLLIB_SEP ':'
2793 #ifndef PERLLIB_MANGLE
2794 # define PERLLIB_MANGLE(s,n) (s)
2798 S_incpush(pTHX_ char *p, int addsubdirs)
2800 SV *subdir = Nullsv;
2806 subdir = sv_newmortal();
2807 if (!PL_archpat_auto) {
2808 STRLEN len = (sizeof(ARCHNAME) + strlen(PL_patchlevel)
2809 + sizeof("//auto"));
2810 New(55, PL_archpat_auto, len, char);
2811 sprintf(PL_archpat_auto, "/%s/%s/auto", ARCHNAME, PL_patchlevel);
2813 for (len = sizeof(ARCHNAME) + 2;
2814 PL_archpat_auto[len] != '\0' && PL_archpat_auto[len] != '/'; len++)
2815 if (PL_archpat_auto[len] == '.') PL_archpat_auto[len] = '_';
2820 /* Break at all separators */
2822 SV *libdir = NEWSV(55,0);
2825 /* skip any consecutive separators */
2826 while ( *p == PERLLIB_SEP ) {
2827 /* Uncomment the next line for PATH semantics */
2828 /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */
2832 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2833 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2838 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2839 p = Nullch; /* break out */
2843 * BEFORE pushing libdir onto @INC we may first push version- and
2844 * archname-specific sub-directories.
2847 struct stat tmpstatbuf;
2852 if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) {
2854 while (unix[len-1] == '/') len--; /* Cosmetic */
2855 sv_usepvn(libdir,unix,len);
2858 PerlIO_printf(PerlIO_stderr(),
2859 "Failed to unixify @INC element \"%s\"\n",
2862 /* .../archname/version if -d .../archname/version/auto */
2863 sv_setsv(subdir, libdir);
2864 sv_catpv(subdir, PL_archpat_auto);
2865 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2866 S_ISDIR(tmpstatbuf.st_mode))
2867 av_push(GvAVn(PL_incgv),
2868 newSVpvn(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2870 /* .../archname if -d .../archname/auto */
2871 sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
2872 strlen(PL_patchlevel) + 1, "", 0);
2873 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2874 S_ISDIR(tmpstatbuf.st_mode))
2875 av_push(GvAVn(PL_incgv),
2876 newSVpvn(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2879 /* finally push this lib directory on the end of @INC */
2880 av_push(GvAVn(PL_incgv), libdir);
2885 STATIC struct perl_thread *
2886 S_init_main_thread(pTHX)
2888 #if !defined(PERL_IMPLICIT_CONTEXT)
2889 struct perl_thread *thr;
2893 Newz(53, thr, 1, struct perl_thread);
2894 PL_curcop = &PL_compiling;
2895 thr->interp = PERL_GET_INTERP;
2896 thr->cvcache = newHV();
2897 thr->threadsv = newAV();
2898 /* thr->threadsvp is set when find_threadsv is called */
2899 thr->specific = newAV();
2900 thr->errhv = newHV();
2901 thr->flags = THRf_R_JOINABLE;
2902 MUTEX_INIT(&thr->mutex);
2903 /* Handcraft thrsv similarly to mess_sv */
2904 New(53, PL_thrsv, 1, SV);
2905 Newz(53, xpv, 1, XPV);
2906 SvFLAGS(PL_thrsv) = SVt_PV;
2907 SvANY(PL_thrsv) = (void*)xpv;
2908 SvREFCNT(PL_thrsv) = 1 << 30; /* practically infinite */
2909 SvPVX(PL_thrsv) = (char*)thr;
2910 SvCUR_set(PL_thrsv, sizeof(thr));
2911 SvLEN_set(PL_thrsv, sizeof(thr));
2912 *SvEND(PL_thrsv) = '\0'; /* in the trailing_nul field */
2913 thr->oursv = PL_thrsv;
2914 PL_chopset = " \n-";
2917 MUTEX_LOCK(&PL_threads_mutex);
2922 MUTEX_UNLOCK(&PL_threads_mutex);
2924 #ifdef HAVE_THREAD_INTERN
2925 Perl_init_thread_intern(thr);
2928 #ifdef SET_THREAD_SELF
2929 SET_THREAD_SELF(thr);
2931 thr->self = pthread_self();
2932 #endif /* SET_THREAD_SELF */
2936 * These must come after the SET_THR because sv_setpvn does
2937 * SvTAINT and the taint fields require dTHR.
2939 PL_toptarget = NEWSV(0,0);
2940 sv_upgrade(PL_toptarget, SVt_PVFM);
2941 sv_setpvn(PL_toptarget, "", 0);
2942 PL_bodytarget = NEWSV(0,0);
2943 sv_upgrade(PL_bodytarget, SVt_PVFM);
2944 sv_setpvn(PL_bodytarget, "", 0);
2945 PL_formtarget = PL_bodytarget;
2946 thr->errsv = newSVpvn("", 0);
2947 (void) find_threadsv("@"); /* Ensure $@ is initialised early */
2950 PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
2951 PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
2952 PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
2953 PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
2954 PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
2956 PL_reginterp_cnt = 0;
2960 #endif /* USE_THREADS */
2963 Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
2967 line_t oldline = PL_curcop->cop_line;
2972 while (AvFILL(paramList) >= 0) {
2973 cv = (CV*)av_shift(paramList);
2975 CALLPROTECT(aTHX_ &ret, MEMBER_TO_FPTR(S_call_list_body), cv);
2978 (void)SvPV(atsv, len);
2980 PL_curcop = &PL_compiling;
2981 PL_curcop->cop_line = oldline;
2982 if (paramList == PL_beginav)
2983 sv_catpv(atsv, "BEGIN failed--compilation aborted");
2985 sv_catpv(atsv, "END failed--cleanup aborted");
2986 while (PL_scopestack_ix > oldscope)
2988 Perl_croak(aTHX_ "%s", SvPVX(atsv));
2995 /* my_exit() was called */
2996 while (PL_scopestack_ix > oldscope)
2999 PL_curstash = PL_defstash;
3001 call_list(oldscope, PL_endav);
3002 PL_curcop = &PL_compiling;
3003 PL_curcop->cop_line = oldline;
3004 if (PL_statusvalue) {
3005 if (paramList == PL_beginav)
3006 Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
3008 Perl_croak(aTHX_ "END failed--cleanup aborted");
3014 PL_curcop = &PL_compiling;
3015 PL_curcop->cop_line = oldline;
3018 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
3026 S_call_list_body(pTHX_ va_list args)
3029 CV *cv = va_arg(args, CV*);
3031 PUSHMARK(PL_stack_sp);
3032 call_sv((SV*)cv, G_EVAL|G_DISCARD);
3037 Perl_my_exit(pTHX_ U32 status)
3041 DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
3042 thr, (unsigned long) status));
3051 STATUS_NATIVE_SET(status);
3058 Perl_my_failure_exit(pTHX)
3061 if (vaxc$errno & 1) {
3062 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
3063 STATUS_NATIVE_SET(44);
3066 if (!vaxc$errno && errno) /* unlikely */
3067 STATUS_NATIVE_SET(44);
3069 STATUS_NATIVE_SET(vaxc$errno);
3074 STATUS_POSIX_SET(errno);
3076 exitstatus = STATUS_POSIX >> 8;
3077 if (exitstatus & 255)
3078 STATUS_POSIX_SET(exitstatus);
3080 STATUS_POSIX_SET(255);
3087 S_my_exit_jump(pTHX)
3090 register PERL_CONTEXT *cx;
3095 SvREFCNT_dec(PL_e_script);
3096 PL_e_script = Nullsv;
3099 POPSTACK_TO(PL_mainstack);
3100 if (cxstack_ix >= 0) {
3103 POPBLOCK(cx,PL_curpm);
3116 read_e_script(pTHXo_ int idx, SV *buf_sv, int maxlen)
3119 p = SvPVX(PL_e_script);
3120 nl = strchr(p, '\n');
3121 nl = (nl) ? nl+1 : SvEND(PL_e_script);
3123 filter_del(read_e_script);
3126 sv_catpvn(buf_sv, p, nl-p);
3127 sv_chop(PL_e_script, nl);