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 #if !defined(PERL_IMPLICIT_CONTEXT)
67 New(53, my_perl, 1, PerlInterpreter);
70 #endif /* PERL_OBJECT */
78 struct perl_thread *thr;
79 #endif /* FAKE_THREADS */
80 #endif /* USE_THREADS */
83 if (!(PL_curinterp = my_perl))
88 Zero(my_perl, 1, PerlInterpreter);
91 /* Init the real globals (and main thread)? */
96 #ifdef ALLOC_THREAD_KEY
99 if (pthread_key_create(&PL_thr_key, 0))
100 Perl_croak(aTHX_ "panic: pthread_key_create");
102 MUTEX_INIT(&PL_sv_mutex);
104 * Safe to use basic SV functions from now on (though
105 * not things like mortals or tainting yet).
107 MUTEX_INIT(&PL_eval_mutex);
108 COND_INIT(&PL_eval_cond);
109 MUTEX_INIT(&PL_threads_mutex);
110 COND_INIT(&PL_nthreads_cond);
111 #ifdef EMULATE_ATOMIC_REFCOUNTS
112 MUTEX_INIT(&PL_svref_mutex);
113 #endif /* EMULATE_ATOMIC_REFCOUNTS */
115 MUTEX_INIT(&PL_cred_mutex);
117 thr = init_main_thread();
118 #endif /* USE_THREADS */
120 PL_protect = FUNC_NAME_TO_PTR(Perl_default_protect); /* for exceptions */
122 PL_curcop = &PL_compiling; /* needed by ckWARN, right away */
124 PL_linestr = NEWSV(65,79);
125 sv_upgrade(PL_linestr,SVt_PVIV);
127 if (!SvREADONLY(&PL_sv_undef)) {
128 /* set read-only and try to insure than we wont see REFCNT==0
131 SvREADONLY_on(&PL_sv_undef);
132 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
134 sv_setpv(&PL_sv_no,PL_No);
136 SvREADONLY_on(&PL_sv_no);
137 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
139 sv_setpv(&PL_sv_yes,PL_Yes);
141 SvREADONLY_on(&PL_sv_yes);
142 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
147 /* PL_sighandlerp = sighandler; */
149 PL_sighandlerp = Perl_sighandler;
151 PL_pidstatus = newHV();
155 * There is no way we can refer to them from Perl so close them to save
156 * space. The other alternative would be to provide STDAUX and STDPRN
159 (void)fclose(stdaux);
160 (void)fclose(stdprn);
164 PL_nrs = newSVpvn("\n", 1);
165 PL_rs = SvREFCNT_inc(PL_nrs);
170 PL_perl_destruct_level = 1;
172 if (PL_perl_destruct_level > 0)
177 PL_lex_state = LEX_NOTPARSING;
183 SET_NUMERIC_STANDARD();
184 #if defined(PERL_SUBVERSION) && PERL_SUBVERSION > 0
185 sprintf(PL_patchlevel, "%7.5f", (double) PERL_REVISION
186 + ((double) PERL_VERSION / (double) 1000)
187 + ((double) PERL_SUBVERSION / (double) 100000));
189 sprintf(PL_patchlevel, "%5.3f", (double) PERL_REVISION +
190 ((double) PERL_VERSION / (double) 1000));
193 #if defined(LOCAL_PATCH_COUNT)
194 PL_localpatches = local_patches; /* For possible -v */
197 PerlIO_init(); /* Hook to IO system */
199 PL_fdpid = newAV(); /* for remembering popen pids by fd */
200 PL_modglobal = newHV(); /* pointers to per-interpreter module globals */
203 New(51,PL_debname,128,char);
204 New(52,PL_debdelim,128,char);
214 int destruct_level; /* 0=none, 1=full, 2=full with checks */
220 #endif /* USE_THREADS */
222 #if !defined(PERL_OBJECT) && !defined(PERL_IMPLICIT_CONTEXT)
223 if (!(PL_curinterp = my_perl))
229 /* Pass 1 on any remaining threads: detach joinables, join zombies */
231 MUTEX_LOCK(&PL_threads_mutex);
232 DEBUG_S(PerlIO_printf(PerlIO_stderr(),
233 "perl_destruct: waiting for %d threads...\n",
235 for (t = thr->next; t != thr; t = t->next) {
236 MUTEX_LOCK(&t->mutex);
237 switch (ThrSTATE(t)) {
240 DEBUG_S(PerlIO_printf(PerlIO_stderr(),
241 "perl_destruct: joining zombie %p\n", t));
242 ThrSETSTATE(t, THRf_DEAD);
243 MUTEX_UNLOCK(&t->mutex);
246 * The SvREFCNT_dec below may take a long time (e.g. av
247 * may contain an object scalar whose destructor gets
248 * called) so we have to unlock threads_mutex and start
251 MUTEX_UNLOCK(&PL_threads_mutex);
253 SvREFCNT_dec((SV*)av);
254 DEBUG_S(PerlIO_printf(PerlIO_stderr(),
255 "perl_destruct: joined zombie %p OK\n", t));
257 case THRf_R_JOINABLE:
258 DEBUG_S(PerlIO_printf(PerlIO_stderr(),
259 "perl_destruct: detaching thread %p\n", t));
260 ThrSETSTATE(t, THRf_R_DETACHED);
262 * We unlock threads_mutex and t->mutex in the opposite order
263 * from which we locked them just so that DETACH won't
264 * deadlock if it panics. It's only a breach of good style
265 * not a bug since they are unlocks not locks.
267 MUTEX_UNLOCK(&PL_threads_mutex);
269 MUTEX_UNLOCK(&t->mutex);
272 DEBUG_S(PerlIO_printf(PerlIO_stderr(),
273 "perl_destruct: ignoring %p (state %u)\n",
275 MUTEX_UNLOCK(&t->mutex);
276 /* fall through and out */
279 /* We leave the above "Pass 1" loop with threads_mutex still locked */
281 /* Pass 2 on remaining threads: wait for the thread count to drop to one */
282 while (PL_nthreads > 1)
284 DEBUG_S(PerlIO_printf(PerlIO_stderr(),
285 "perl_destruct: final wait for %d threads\n",
287 COND_WAIT(&PL_nthreads_cond, &PL_threads_mutex);
289 /* At this point, we're the last thread */
290 MUTEX_UNLOCK(&PL_threads_mutex);
291 DEBUG_S(PerlIO_printf(PerlIO_stderr(), "perl_destruct: armageddon has arrived\n"));
292 MUTEX_DESTROY(&PL_threads_mutex);
293 COND_DESTROY(&PL_nthreads_cond);
294 #endif /* !defined(FAKE_THREADS) */
295 #endif /* USE_THREADS */
297 destruct_level = PL_perl_destruct_level;
301 if (s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL")) {
303 if (destruct_level < i)
312 /* We must account for everything. */
314 /* Destroy the main CV and syntax tree */
316 PL_curpad = AvARRAY(PL_comppad);
317 op_free(PL_main_root);
318 PL_main_root = Nullop;
320 PL_curcop = &PL_compiling;
321 PL_main_start = Nullop;
322 SvREFCNT_dec(PL_main_cv);
326 if (PL_sv_objcount) {
328 * Try to destruct global references. We do this first so that the
329 * destructors and destructees still exist. Some sv's might remain.
330 * Non-referenced objects are on their own.
335 /* unhook hooks which will soon be, or use, destroyed data */
336 SvREFCNT_dec(PL_warnhook);
337 PL_warnhook = Nullsv;
338 SvREFCNT_dec(PL_diehook);
340 SvREFCNT_dec(PL_parsehook);
341 PL_parsehook = Nullsv;
343 /* call exit list functions */
344 while (PL_exitlistlen-- > 0)
345 PL_exitlist[PL_exitlistlen].fn(aTHXo_ PL_exitlist[PL_exitlistlen].ptr);
347 Safefree(PL_exitlist);
349 if (destruct_level == 0){
351 DEBUG_P(debprofdump());
353 /* The exit() function will do everything that needs doing. */
357 /* loosen bonds of global variables */
360 (void)PerlIO_close(PL_rsfp);
364 /* Filters for program text */
365 SvREFCNT_dec(PL_rsfp_filters);
366 PL_rsfp_filters = Nullav;
369 PL_preprocess = FALSE;
375 PL_doswitches = FALSE;
376 PL_dowarn = G_WARN_OFF;
377 PL_doextract = FALSE;
378 PL_sawampersand = FALSE; /* must save all match strings */
379 PL_sawstudy = FALSE; /* do fbm_instr on all strings */
383 Safefree(PL_inplace);
387 SvREFCNT_dec(PL_e_script);
388 PL_e_script = Nullsv;
391 /* magical thingies */
393 Safefree(PL_ofs); /* $, */
396 Safefree(PL_ors); /* $\ */
399 SvREFCNT_dec(PL_rs); /* $/ */
402 SvREFCNT_dec(PL_nrs); /* $/ helper */
405 PL_multiline = 0; /* $* */
407 SvREFCNT_dec(PL_statname);
408 PL_statname = Nullsv;
411 /* defgv, aka *_ should be taken care of elsewhere */
413 /* clean up after study() */
414 SvREFCNT_dec(PL_lastscream);
415 PL_lastscream = Nullsv;
416 Safefree(PL_screamfirst);
418 Safefree(PL_screamnext);
421 /* startup and shutdown function lists */
422 SvREFCNT_dec(PL_beginav);
423 SvREFCNT_dec(PL_endav);
424 SvREFCNT_dec(PL_initav);
429 /* shortcuts just get cleared */
436 PL_argvoutgv = Nullgv;
438 PL_last_in_gv = Nullgv;
441 /* reset so print() ends up where we expect */
444 /* Prepare to destruct main symbol table. */
451 if (destruct_level >= 2) {
452 if (PL_scopestack_ix != 0)
453 Perl_warn(aTHX_ "Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
454 (long)PL_scopestack_ix);
455 if (PL_savestack_ix != 0)
456 Perl_warn(aTHX_ "Unbalanced saves: %ld more saves than restores\n",
457 (long)PL_savestack_ix);
458 if (PL_tmps_floor != -1)
459 Perl_warn(aTHX_ "Unbalanced tmps: %ld more allocs than frees\n",
460 (long)PL_tmps_floor + 1);
461 if (cxstack_ix != -1)
462 Perl_warn(aTHX_ "Unbalanced context: %ld more PUSHes than POPs\n",
463 (long)cxstack_ix + 1);
466 /* Now absolutely destruct everything, somehow or other, loops or no. */
468 SvFLAGS(PL_strtab) |= SVTYPEMASK; /* don't clean out strtab now */
469 while (PL_sv_count != 0 && PL_sv_count != last_sv_count) {
470 last_sv_count = PL_sv_count;
473 SvFLAGS(PL_strtab) &= ~SVTYPEMASK;
474 SvFLAGS(PL_strtab) |= SVt_PVHV;
476 /* Destruct the global string table. */
478 /* Yell and reset the HeVAL() slots that are still holding refcounts,
479 * so that sv_free() won't fail on them.
487 max = HvMAX(PL_strtab);
488 array = HvARRAY(PL_strtab);
492 Perl_warn(aTHX_ "Unbalanced string table refcount: (%d) for \"%s\"",
493 HeVAL(hent) - Nullsv, HeKEY(hent));
494 HeVAL(hent) = Nullsv;
504 SvREFCNT_dec(PL_strtab);
506 if (PL_sv_count != 0)
507 Perl_warn(aTHX_ "Scalars leaked: %ld\n", (long)PL_sv_count);
511 /* No SVs have survived, need to clean out */
513 PL_pidstatus = Nullhv;
514 Safefree(PL_origfilename);
515 Safefree(PL_archpat_auto);
516 Safefree(PL_reg_start_tmp);
518 Safefree(PL_reg_curpm);
519 Safefree(HeKEY_hek(&PL_hv_fetch_ent_mh));
520 Safefree(PL_op_mask);
522 PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */
524 DEBUG_P(debprofdump());
526 MUTEX_DESTROY(&PL_strtab_mutex);
527 MUTEX_DESTROY(&PL_sv_mutex);
528 MUTEX_DESTROY(&PL_eval_mutex);
529 MUTEX_DESTROY(&PL_cred_mutex);
530 COND_DESTROY(&PL_eval_cond);
531 #ifdef EMULATE_ATOMIC_REFCOUNTS
532 MUTEX_DESTROY(&PL_svref_mutex);
533 #endif /* EMULATE_ATOMIC_REFCOUNTS */
535 /* As the penultimate thing, free the non-arena SV for thrsv */
536 Safefree(SvPVX(PL_thrsv));
537 Safefree(SvANY(PL_thrsv));
540 #endif /* USE_THREADS */
542 /* As the absolutely last thing, free the non-arena SV for mess() */
545 /* it could have accumulated taint magic */
546 if (SvTYPE(PL_mess_sv) >= SVt_PVMG) {
549 for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) {
550 moremagic = mg->mg_moremagic;
551 if (mg->mg_ptr && mg->mg_type != 'g' && mg->mg_len >= 0)
552 Safefree(mg->mg_ptr);
556 /* we know that type >= SVt_PV */
557 SvOOK_off(PL_mess_sv);
558 Safefree(SvPVX(PL_mess_sv));
559 Safefree(SvANY(PL_mess_sv));
560 Safefree(PL_mess_sv);
571 # if !defined(PERL_IMPLICIT_CONTEXT)
572 if (!(PL_curinterp = my_perl))
580 Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
582 Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry);
583 PL_exitlist[PL_exitlistlen].fn = fn;
584 PL_exitlist[PL_exitlistlen].ptr = ptr;
589 perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
598 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
601 Perl_croak(aTHX_ "suidperl is no longer needed since the kernel can now execute\n\
602 setuid perl scripts securely.\n");
606 #if !defined(PERL_OBJECT) && !defined(PERL_IMPLICIT_CONTEXT)
607 if (!(PL_curinterp = my_perl))
611 #if defined(__DYNAMIC__) && (defined(NeXT) || defined(__NeXT__))
612 _dyld_lookup_and_bind
613 ("__environ", (unsigned long *) &environ_pointer, NULL);
618 #ifndef VMS /* VMS doesn't have environ array */
619 PL_origenviron = environ;
624 /* Come here if running an undumped a.out. */
626 PL_origfilename = savepv(argv[0]);
627 PL_do_undump = FALSE;
628 cxstack_ix = -1; /* start label stack again */
630 init_postdump_symbols(argc,argv,env);
635 PL_curpad = AvARRAY(PL_comppad);
636 op_free(PL_main_root);
637 PL_main_root = Nullop;
639 PL_main_start = Nullop;
640 SvREFCNT_dec(PL_main_cv);
644 oldscope = PL_scopestack_ix;
645 PL_dowarn = G_WARN_OFF;
647 CALLPROTECT(aTHX_ &ret, FUNC_NAME_TO_PTR(S_parse_body), env, xsinit);
655 /* my_exit() was called */
656 while (PL_scopestack_ix > oldscope)
659 PL_curstash = PL_defstash;
661 call_list(oldscope, PL_endav);
662 return STATUS_NATIVE_EXPORT;
664 PerlIO_printf(PerlIO_stderr(), "panic: top_env\n");
671 S_parse_body(pTHX_ va_list args)
674 int argc = PL_origargc;
675 char **argv = PL_origargv;
676 char **env = va_arg(args, char**);
677 char *scriptname = NULL;
679 VOL bool dosearch = FALSE;
685 XSINIT_t xsinit = va_arg(args, XSINIT_t);
687 sv_setpvn(PL_linestr,"",0);
688 sv = newSVpvn("",0); /* first used for -I flags */
692 for (argc--,argv++; argc > 0; argc--,argv++) {
693 if (argv[0][0] != '-' || !argv[0][1])
697 validarg = " PHOOEY ";
704 #ifndef PERL_STRICT_CR
728 if (s = moreswitches(s))
738 if (PL_euid != PL_uid || PL_egid != PL_gid)
739 Perl_croak(aTHX_ "No -e allowed in setuid scripts");
741 PL_e_script = newSVpvn("",0);
742 filter_add(read_e_script, NULL);
745 sv_catpv(PL_e_script, s);
747 sv_catpv(PL_e_script, argv[1]);
751 Perl_croak(aTHX_ "No code specified for -e");
752 sv_catpv(PL_e_script, "\n");
755 case 'I': /* -I handled both here and in moreswitches() */
757 if (!*++s && (s=argv[1]) != Nullch) {
760 while (s && isSPACE(*s))
764 for (e = s; *e && !isSPACE(*e); e++) ;
771 } /* XXX else croak? */
775 PL_preprocess = TRUE;
785 PL_preambleav = newAV();
786 av_push(PL_preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
788 PL_Sv = newSVpv("print myconfig();",0);
790 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
792 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
794 #if defined(DEBUGGING) || defined(MULTIPLICITY)
795 sv_catpv(PL_Sv,"\" Compile-time options:");
797 sv_catpv(PL_Sv," DEBUGGING");
800 sv_catpv(PL_Sv," MULTIPLICITY");
802 sv_catpv(PL_Sv,"\\n\",");
804 #if defined(LOCAL_PATCH_COUNT)
805 if (LOCAL_PATCH_COUNT > 0) {
807 sv_catpv(PL_Sv,"\" Locally applied patches:\\n\",");
808 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
809 if (PL_localpatches[i])
810 Perl_sv_catpvf(aTHX_ PL_Sv,"q\" \t%s\n\",",PL_localpatches[i]);
814 Perl_sv_catpvf(aTHX_ PL_Sv,"\" Built under %s\\n\"",OSNAME);
817 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
819 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled on %s\\n\"",__DATE__);
824 @env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; \
825 print \" \\%ENV:\\n @env\\n\" if @env; \
826 print \" \\@INC:\\n @INC\\n\";");
829 PL_Sv = newSVpv("config_vars(qw(",0);
830 sv_catpv(PL_Sv, ++s);
831 sv_catpv(PL_Sv, "))");
834 av_push(PL_preambleav, PL_Sv);
835 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
841 PL_cddir = savepv(s);
846 if (!*++s || isSPACE(*s)) {
850 /* catch use of gnu style long options */
851 if (strEQ(s, "version")) {
855 if (strEQ(s, "help")) {
862 Perl_croak(aTHX_ "Unrecognized switch: -%s (-h will show valid options)",s);
868 #ifndef SECURE_INTERNAL_GETENV
871 (s = PerlEnv_getenv("PERL5OPT"))) {
874 if (*s == '-' && *(s+1) == 'T')
887 if (!strchr("DIMUdmw", *s))
888 Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
895 scriptname = argv[0];
898 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
900 else if (scriptname == Nullch) {
902 if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
910 open_script(scriptname,dosearch,sv,&fdscript);
912 validate_suid(validarg, scriptname,fdscript);
917 PL_main_cv = PL_compcv = (CV*)NEWSV(1104,0);
918 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
919 CvUNIQUE_on(PL_compcv);
921 PL_comppad = newAV();
922 av_push(PL_comppad, Nullsv);
923 PL_curpad = AvARRAY(PL_comppad);
924 PL_comppad_name = newAV();
925 PL_comppad_name_fill = 0;
926 PL_min_intro_pending = 0;
929 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
930 PL_curpad[0] = (SV*)newAV();
931 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
932 CvOWNER(PL_compcv) = 0;
933 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
934 MUTEX_INIT(CvMUTEXP(PL_compcv));
935 #endif /* USE_THREADS */
937 comppadlist = newAV();
938 AvREAL_off(comppadlist);
939 av_store(comppadlist, 0, (SV*)PL_comppad_name);
940 av_store(comppadlist, 1, (SV*)PL_comppad);
941 CvPADLIST(PL_compcv) = comppadlist;
943 boot_core_UNIVERSAL();
946 (*xsinit)(aTHXo); /* in case linked C routines want magical variables */
947 #if defined(VMS) || defined(WIN32) || defined(DJGPP)
948 init_os_extras(aTHX);
955 init_predump_symbols();
956 /* init_postdump_symbols not currently designed to be called */
957 /* more than once (ENV isn't cleared first, for example) */
958 /* But running with -u leaves %ENV & @ARGV undefined! XXX */
960 init_postdump_symbols(argc,argv,env);
964 /* now parse the script */
966 SETERRNO(0,SS$_NORMAL);
968 if (yyparse() || PL_error_count) {
970 Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
972 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
976 PL_curcop->cop_line = 0;
977 PL_curstash = PL_defstash;
978 PL_preprocess = FALSE;
980 SvREFCNT_dec(PL_e_script);
981 PL_e_script = Nullsv;
984 /* now that script is parsed, we can modify record separator */
986 PL_rs = SvREFCNT_inc(PL_nrs);
987 sv_setsv(get_sv("/", TRUE), PL_rs);
991 if (ckWARN(WARN_ONCE))
992 gv_check(PL_defstash);
998 if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
999 dump_mstats("after compilation:");
1017 #if !defined(PERL_OBJECT) && !defined(PERL_IMPLICIT_CONTEXT)
1018 if (!(PL_curinterp = my_perl))
1022 oldscope = PL_scopestack_ix;
1025 CALLPROTECT(aTHX_ &ret, FUNC_NAME_TO_PTR(S_run_body), oldscope);
1028 cxstack_ix = -1; /* start context stack again */
1030 case 0: /* normal completion */
1031 case 2: /* my_exit() */
1032 while (PL_scopestack_ix > oldscope)
1035 PL_curstash = PL_defstash;
1037 call_list(oldscope, PL_endav);
1039 if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
1040 dump_mstats("after execution: ");
1042 return STATUS_NATIVE_EXPORT;
1045 POPSTACK_TO(PL_mainstack);
1048 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
1058 S_run_body(pTHX_ va_list args)
1061 I32 oldscope = va_arg(args, I32);
1063 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
1064 PL_sawampersand ? "Enabling" : "Omitting"));
1066 if (!PL_restartop) {
1067 DEBUG_x(dump_all());
1068 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
1069 DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%lx\n",
1070 (unsigned long) thr));
1073 PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", PL_origfilename);
1076 if (PERLDB_SINGLE && PL_DBsingle)
1077 sv_setiv(PL_DBsingle, 1);
1079 call_list(oldscope, PL_initav);
1085 PL_op = PL_restartop;
1089 else if (PL_main_start) {
1090 CvDEPTH(PL_main_cv) = 1;
1091 PL_op = PL_main_start;
1101 Perl_get_sv(pTHX_ const char *name, I32 create)
1105 if (name[1] == '\0' && !isALPHA(name[0])) {
1106 PADOFFSET tmp = find_threadsv(name);
1107 if (tmp != NOT_IN_PAD) {
1109 return THREADSV(tmp);
1112 #endif /* USE_THREADS */
1113 gv = gv_fetchpv(name, create, SVt_PV);
1120 Perl_get_av(pTHX_ const char *name, I32 create)
1122 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1131 Perl_get_hv(pTHX_ const char *name, I32 create)
1133 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1142 Perl_get_cv(pTHX_ const char *name, I32 create)
1144 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
1145 /* XXX unsafe for threads if eval_owner isn't held */
1146 /* XXX this is probably not what they think they're getting.
1147 * It has the same effect as "sub name;", i.e. just a forward
1149 if (create && !GvCVu(gv))
1150 return newSUB(start_subparse(FALSE, 0),
1151 newSVOP(OP_CONST, 0, newSVpv(name,0)),
1159 /* Be sure to refetch the stack pointer after calling these routines. */
1162 Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv)
1164 /* See G_* flags in cop.h */
1165 /* null terminated arg list */
1172 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
1177 return call_pv(sub_name, flags);
1181 Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
1182 /* name of the subroutine */
1183 /* See G_* flags in cop.h */
1185 return call_sv((SV*)get_cv(sub_name, TRUE), flags);
1189 Perl_call_method(pTHX_ const char *methname, I32 flags)
1190 /* name of the subroutine */
1191 /* See G_* flags in cop.h */
1197 XPUSHs(sv_2mortal(newSVpv(methname,0)));
1202 return call_sv(*PL_stack_sp--, flags);
1205 /* May be called with any of a CV, a GV, or an SV containing the name. */
1207 Perl_call_sv(pTHX_ SV *sv, I32 flags)
1209 /* See G_* flags in cop.h */
1212 LOGOP myop; /* fake syntax tree node */
1216 bool oldcatch = CATCH_GET;
1220 if (flags & G_DISCARD) {
1225 Zero(&myop, 1, LOGOP);
1226 myop.op_next = Nullop;
1227 if (!(flags & G_NOARGS))
1228 myop.op_flags |= OPf_STACKED;
1229 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1230 (flags & G_ARRAY) ? OPf_WANT_LIST :
1235 EXTEND(PL_stack_sp, 1);
1236 *++PL_stack_sp = sv;
1238 oldscope = PL_scopestack_ix;
1240 if (PERLDB_SUB && PL_curstash != PL_debstash
1241 /* Handle first BEGIN of -d. */
1242 && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
1243 /* Try harder, since this may have been a sighandler, thus
1244 * curstash may be meaningless. */
1245 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != PL_debstash)
1246 && !(flags & G_NODEBUG))
1247 PL_op->op_private |= OPpENTERSUB_DB;
1249 if (!(flags & G_EVAL)) {
1251 call_xbody((OP*)&myop, FALSE);
1252 retval = PL_stack_sp - (PL_stack_base + oldmark);
1256 cLOGOP->op_other = PL_op;
1258 /* we're trying to emulate pp_entertry() here */
1260 register PERL_CONTEXT *cx;
1261 I32 gimme = GIMME_V;
1266 push_return(PL_op->op_next);
1267 PUSHBLOCK(cx, CXt_EVAL, PL_stack_sp);
1269 PL_eval_root = PL_op; /* Only needed so that goto works right. */
1271 PL_in_eval = EVAL_INEVAL;
1272 if (flags & G_KEEPERR)
1273 PL_in_eval |= EVAL_KEEPERR;
1280 CALLPROTECT(aTHX_ &ret, FUNC_NAME_TO_PTR(S_call_body), (OP*)&myop, FALSE);
1283 retval = PL_stack_sp - (PL_stack_base + oldmark);
1284 if (!(flags & G_KEEPERR))
1291 /* my_exit() was called */
1292 PL_curstash = PL_defstash;
1295 Perl_croak(aTHX_ "Callback called exit");
1300 PL_op = PL_restartop;
1304 PL_stack_sp = PL_stack_base + oldmark;
1305 if (flags & G_ARRAY)
1309 *++PL_stack_sp = &PL_sv_undef;
1314 if (PL_scopestack_ix > oldscope) {
1318 register PERL_CONTEXT *cx;
1329 if (flags & G_DISCARD) {
1330 PL_stack_sp = PL_stack_base + oldmark;
1340 S_call_body(pTHX_ va_list args)
1342 OP *myop = va_arg(args, OP*);
1343 int is_eval = va_arg(args, int);
1345 call_xbody(myop, is_eval);
1350 S_call_xbody(pTHX_ OP *myop, int is_eval)
1354 if (PL_op == myop) {
1356 PL_op = Perl_pp_entereval(aTHX);
1358 PL_op = Perl_pp_entersub(aTHX);
1364 /* Eval a string. The G_EVAL flag is always assumed. */
1367 Perl_eval_sv(pTHX_ SV *sv, I32 flags)
1369 /* See G_* flags in cop.h */
1372 UNOP myop; /* fake syntax tree node */
1373 I32 oldmark = SP - PL_stack_base;
1379 if (flags & G_DISCARD) {
1386 Zero(PL_op, 1, UNOP);
1387 EXTEND(PL_stack_sp, 1);
1388 *++PL_stack_sp = sv;
1389 oldscope = PL_scopestack_ix;
1391 if (!(flags & G_NOARGS))
1392 myop.op_flags = OPf_STACKED;
1393 myop.op_next = Nullop;
1394 myop.op_type = OP_ENTEREVAL;
1395 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1396 (flags & G_ARRAY) ? OPf_WANT_LIST :
1398 if (flags & G_KEEPERR)
1399 myop.op_flags |= OPf_SPECIAL;
1402 CALLPROTECT(aTHX_ &ret, FUNC_NAME_TO_PTR(S_call_body), (OP*)&myop, TRUE);
1405 retval = PL_stack_sp - (PL_stack_base + oldmark);
1406 if (!(flags & G_KEEPERR))
1413 /* my_exit() was called */
1414 PL_curstash = PL_defstash;
1417 Perl_croak(aTHX_ "Callback called exit");
1422 PL_op = PL_restartop;
1426 PL_stack_sp = PL_stack_base + oldmark;
1427 if (flags & G_ARRAY)
1431 *++PL_stack_sp = &PL_sv_undef;
1436 if (flags & G_DISCARD) {
1437 PL_stack_sp = PL_stack_base + oldmark;
1447 Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
1450 SV* sv = newSVpv(p, 0);
1453 eval_sv(sv, G_SCALAR);
1460 if (croak_on_error && SvTRUE(ERRSV)) {
1462 Perl_croak(aTHX_ SvPVx(ERRSV, n_a));
1468 /* Require a module. */
1471 Perl_require_pv(pTHX_ const char *pv)
1475 PUSHSTACKi(PERLSI_REQUIRE);
1477 sv = sv_newmortal();
1478 sv_setpv(sv, "require '");
1481 eval_sv(sv, G_DISCARD);
1487 Perl_magicname(pTHX_ char *sym, char *name, I32 namlen)
1491 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1492 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1496 S_usage(pTHX_ char *name) /* XXX move this out into a module ? */
1498 /* This message really ought to be max 23 lines.
1499 * Removed -h because the user already knows that opton. Others? */
1501 static char *usage_msg[] = {
1502 "-0[octal] specify record separator (\\0, if no argument)",
1503 "-a autosplit mode with -n or -p (splits $_ into @F)",
1504 "-c check syntax only (runs BEGIN and END blocks)",
1505 "-d[:debugger] run program under debugger",
1506 "-D[number/list] set debugging flags (argument is a bit mask or alphabets)",
1507 "-e 'command' one line of program (several -e's allowed, omit programfile)",
1508 "-F/pattern/ split() pattern for -a switch (//'s are optional)",
1509 "-i[extension] edit <> files in place (makes backup if extension supplied)",
1510 "-Idirectory specify @INC/#include directory (several -I's allowed)",
1511 "-l[octal] enable line ending processing, specifies line terminator",
1512 "-[mM][-]module execute `use/no module...' before executing program",
1513 "-n assume 'while (<>) { ... }' loop around program",
1514 "-p assume loop like -n but print line also, like sed",
1515 "-P run program through C preprocessor before compilation",
1516 "-s enable rudimentary parsing for switches after programfile",
1517 "-S look for programfile using PATH environment variable",
1518 "-T enable tainting checks",
1519 "-u dump core after parsing program",
1520 "-U allow unsafe operations",
1521 "-v print version, subversion (includes VERY IMPORTANT perl info)",
1522 "-V[:variable] print configuration summary (or a single Config.pm variable)",
1523 "-w enable many useful warnings (RECOMMENDED)",
1524 "-x[directory] strip off text before #!perl line and perhaps cd to directory",
1528 char **p = usage_msg;
1530 printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1532 printf("\n %s", *p++);
1535 /* This routine handles any switches that can be given during run */
1538 Perl_moreswitches(pTHX_ char *s)
1547 rschar = scan_oct(s, 4, &numlen);
1548 SvREFCNT_dec(PL_nrs);
1549 if (rschar & ~((U8)~0))
1550 PL_nrs = &PL_sv_undef;
1551 else if (!rschar && numlen >= 2)
1552 PL_nrs = newSVpvn("", 0);
1555 PL_nrs = newSVpvn(&ch, 1);
1561 PL_splitstr = savepv(s + 1);
1575 if (*s == ':' || *s == '=') {
1576 my_setenv("PERL5DB", Perl_form(aTHX_ "use Devel::%s;", ++s));
1580 PL_perldb = PERLDB_ALL;
1587 if (isALPHA(s[1])) {
1588 static char debopts[] = "psltocPmfrxuLHXDS";
1591 for (s++; *s && (d = strchr(debopts,*s)); s++)
1592 PL_debug |= 1 << (d - debopts);
1595 PL_debug = atoi(s+1);
1596 for (s++; isDIGIT(*s); s++) ;
1598 PL_debug |= 0x80000000;
1600 Perl_warn(aTHX_ "Recompile perl with -DDEBUGGING to use -D switch\n");
1601 for (s++; isALNUM(*s); s++) ;
1606 usage(PL_origargv[0]);
1610 Safefree(PL_inplace);
1611 PL_inplace = savepv(s+1);
1613 for (s = PL_inplace; *s && !isSPACE(*s); s++) ;
1616 if (*s == '-') /* Additional switches on #! line. */
1620 case 'I': /* -I handled both here and in parse_perl() */
1623 while (*s && isSPACE(*s))
1627 for (e = s; *e && !isSPACE(*e); e++) ;
1628 p = savepvn(s, e-s);
1634 Perl_croak(aTHX_ "No space allowed after -I");
1642 PL_ors = savepv("\n");
1644 *PL_ors = scan_oct(s, 3 + (*s == '0'), &numlen);
1649 if (RsPARA(PL_nrs)) {
1654 PL_ors = SvPV(PL_nrs, PL_orslen);
1655 PL_ors = savepvn(PL_ors, PL_orslen);
1659 forbid_setid("-M"); /* XXX ? */
1662 forbid_setid("-m"); /* XXX ? */
1667 /* -M-foo == 'no foo' */
1668 if (*s == '-') { use = "no "; ++s; }
1669 sv = newSVpv(use,0);
1671 /* We allow -M'Module qw(Foo Bar)' */
1672 while(isALNUM(*s) || *s==':') ++s;
1674 sv_catpv(sv, start);
1675 if (*(start-1) == 'm') {
1677 Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
1678 sv_catpv( sv, " ()");
1681 sv_catpvn(sv, start, s-start);
1682 sv_catpv(sv, " split(/,/,q{");
1687 if (PL_preambleav == NULL)
1688 PL_preambleav = newAV();
1689 av_push(PL_preambleav, sv);
1692 Perl_croak(aTHX_ "No space allowed after -%c", *(s-1));
1704 PL_doswitches = TRUE;
1709 Perl_croak(aTHX_ "Too late for \"-T\" option");
1713 PL_do_undump = TRUE;
1721 #if defined(PERL_SUBVERSION) && PERL_SUBVERSION > 0
1722 printf("\nThis is perl, version %d.%03d_%02d built for %s",
1723 PERL_REVISION, PERL_VERSION, PERL_SUBVERSION, ARCHNAME);
1725 printf("\nThis is perl, version %s built for %s",
1726 PL_patchlevel, ARCHNAME);
1728 #if defined(LOCAL_PATCH_COUNT)
1729 if (LOCAL_PATCH_COUNT > 0)
1730 printf("\n(with %d registered patch%s, see perl -V for more detail)",
1731 LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : "");
1734 printf("\n\nCopyright 1987-1999, Larry Wall\n");
1736 printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1739 printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
1740 printf("djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
1743 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1744 "Version 5 port Copyright (c) 1994-1999, Andreas Kaiser, Ilya Zakharevich\n");
1747 printf("atariST series port, ++jrb bammi@cadence.com\n");
1750 printf("BeOS port Copyright Tom Spindler, 1997-1999\n");
1753 printf("MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-1999\n");
1756 printf("MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
1759 printf("Stratus VOS port by Paul_Green@stratus.com, 1997-1999\n");
1762 printf("VM/ESA port by Neale Ferguson, 1998-1999\n");
1765 printf("BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
1768 printf("MiNT port by Guido Flohr, 1997-1999\n");
1770 #ifdef BINARY_BUILD_NOTICE
1771 BINARY_BUILD_NOTICE;
1774 Perl may be copied only under the terms of either the Artistic License or the\n\
1775 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n\
1776 Complete documentation for Perl, including FAQ lists, should be found on\n\
1777 this system using `man perl' or `perldoc perl'. If you have access to the\n\
1778 Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
1781 if (! (PL_dowarn & G_WARN_ALL_MASK))
1782 PL_dowarn |= G_WARN_ON;
1786 PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
1787 PL_compiling.cop_warnings = WARN_ALL ;
1791 PL_dowarn = G_WARN_ALL_OFF;
1792 PL_compiling.cop_warnings = WARN_NONE ;
1797 if (s[1] == '-') /* Additional switches on #! line. */
1802 #if defined(WIN32) || !defined(PERL_STRICT_CR)
1808 #ifdef ALTERNATE_SHEBANG
1809 case 'S': /* OS/2 needs -S on "extproc" line. */
1817 Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
1822 /* compliments of Tom Christiansen */
1824 /* unexec() can be found in the Gnu emacs distribution */
1825 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
1828 Perl_my_unexec(pTHX)
1836 prog = newSVpv(BIN_EXP, 0);
1837 sv_catpv(prog, "/perl");
1838 file = newSVpv(PL_origfilename, 0);
1839 sv_catpv(file, ".perldump");
1841 unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
1842 /* unexec prints msg to stderr in case of failure */
1843 PerlProc_exit(status);
1846 # include <lib$routines.h>
1847 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
1849 ABORT(); /* for use with undump */
1854 /* initialize curinterp */
1859 #ifdef PERL_OBJECT /* XXX kludge */
1862 PL_chopset = " \n-"; \
1863 PL_copline = NOLINE; \
1864 PL_curcop = &PL_compiling;\
1865 PL_curcopdb = NULL; \
1868 PL_dumpindent = 4; \
1869 PL_laststatval = -1; \
1870 PL_laststype = OP_STAT; \
1871 PL_maxscream = -1; \
1872 PL_maxsysfd = MAXSYSFD; \
1873 PL_statname = Nullsv; \
1874 PL_tmps_floor = -1; \
1876 PL_op_mask = NULL; \
1878 PL_laststatval = -1; \
1879 PL_laststype = OP_STAT; \
1880 PL_mess_sv = Nullsv; \
1881 PL_splitstr = " "; \
1882 PL_generation = 100; \
1883 PL_exitlist = NULL; \
1884 PL_exitlistlen = 0; \
1886 PL_in_clean_objs = FALSE; \
1887 PL_in_clean_all = FALSE; \
1888 PL_profiledata = NULL; \
1890 PL_rsfp_filters = Nullav; \
1895 # ifdef MULTIPLICITY
1896 # define PERLVAR(var,type)
1897 # if defined(PERL_IMPLICIT_CONTEXT)
1898 # define PERLVARI(var,type,init) my_perl->var = init;
1899 # define PERLVARIC(var,type,init) my_perl->var = init;
1901 # define PERLVARI(var,type,init) PL_curinterp->var = init;
1902 # define PERLVARIC(var,type,init) PL_curinterp->var = init;
1904 # include "intrpvar.h"
1905 # ifndef USE_THREADS
1906 # include "thrdvar.h"
1912 # define PERLVAR(var,type)
1913 # define PERLVARI(var,type,init) PL_##var = init;
1914 # define PERLVARIC(var,type,init) PL_##var = init;
1915 # include "intrpvar.h"
1916 # ifndef USE_THREADS
1917 # include "thrdvar.h"
1928 S_init_main_stash(pTHX)
1933 /* Note that strtab is a rather special HV. Assumptions are made
1934 about not iterating on it, and not adding tie magic to it.
1935 It is properly deallocated in perl_destruct() */
1936 PL_strtab = newHV();
1938 MUTEX_INIT(&PL_strtab_mutex);
1940 HvSHAREKEYS_off(PL_strtab); /* mandatory */
1941 hv_ksplit(PL_strtab, 512);
1943 PL_curstash = PL_defstash = newHV();
1944 PL_curstname = newSVpvn("main",4);
1945 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1946 SvREFCNT_dec(GvHV(gv));
1947 GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
1949 HvNAME(PL_defstash) = savepv("main");
1950 PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1951 GvMULTI_on(PL_incgv);
1952 PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
1953 GvMULTI_on(PL_hintgv);
1954 PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1955 PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1956 GvMULTI_on(PL_errgv);
1957 PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
1958 GvMULTI_on(PL_replgv);
1959 (void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */
1960 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
1961 sv_setpvn(ERRSV, "", 0);
1962 PL_curstash = PL_defstash;
1963 PL_compiling.cop_stash = PL_defstash;
1964 PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
1965 PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
1966 /* We must init $/ before switches are processed. */
1967 sv_setpvn(get_sv("/", TRUE), "\n", 1);
1971 S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
1979 PL_origfilename = savepv("-e");
1982 /* if find_script() returns, it returns a malloc()-ed value */
1983 PL_origfilename = scriptname = find_script(scriptname, dosearch, NULL, 1);
1985 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
1986 char *s = scriptname + 8;
1987 *fdscript = atoi(s);
1991 scriptname = savepv(s + 1);
1992 Safefree(PL_origfilename);
1993 PL_origfilename = scriptname;
1998 PL_curcop->cop_filegv = gv_fetchfile(PL_origfilename);
1999 if (strEQ(PL_origfilename,"-"))
2001 if (*fdscript >= 0) {
2002 PL_rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE);
2003 #if defined(HAS_FCNTL) && defined(F_SETFD)
2005 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); /* ensure close-on-exec */
2008 else if (PL_preprocess) {
2009 char *cpp_cfg = CPPSTDIN;
2010 SV *cpp = newSVpvn("",0);
2011 SV *cmd = NEWSV(0,0);
2013 if (strEQ(cpp_cfg, "cppstdin"))
2014 Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
2015 sv_catpv(cpp, cpp_cfg);
2018 sv_catpv(sv,PRIVLIB_EXP);
2021 Perl_sv_setpvf(aTHX_ cmd, "\
2022 sed %s -e \"/^[^#]/b\" \
2023 -e \"/^#[ ]*include[ ]/b\" \
2024 -e \"/^#[ ]*define[ ]/b\" \
2025 -e \"/^#[ ]*if[ ]/b\" \
2026 -e \"/^#[ ]*ifdef[ ]/b\" \
2027 -e \"/^#[ ]*ifndef[ ]/b\" \
2028 -e \"/^#[ ]*else/b\" \
2029 -e \"/^#[ ]*elif[ ]/b\" \
2030 -e \"/^#[ ]*undef[ ]/b\" \
2031 -e \"/^#[ ]*endif/b\" \
2034 (PL_doextract ? "-e \"1,/^#/d\n\"" : ""),
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' \
2051 Perl_sv_setpvf(aTHX_ cmd, "\
2052 %s %s -e '/^[^#]/b' \
2053 -e '/^#[ ]*include[ ]/b' \
2054 -e '/^#[ ]*define[ ]/b' \
2055 -e '/^#[ ]*if[ ]/b' \
2056 -e '/^#[ ]*ifdef[ ]/b' \
2057 -e '/^#[ ]*ifndef[ ]/b' \
2058 -e '/^#[ ]*else/b' \
2059 -e '/^#[ ]*elif[ ]/b' \
2060 -e '/^#[ ]*undef[ ]/b' \
2061 -e '/^#[ ]*endif/b' \
2070 (PL_doextract ? "-e '1,/^#/d\n'" : ""),
2072 scriptname, cpp, sv, CPPMINUS);
2073 PL_doextract = FALSE;
2074 #ifdef IAMSUID /* actually, this is caught earlier */
2075 if (PL_euid != PL_uid && !PL_euid) { /* if running suidperl */
2077 (void)seteuid(PL_uid); /* musn't stay setuid root */
2080 (void)setreuid((Uid_t)-1, PL_uid);
2082 #ifdef HAS_SETRESUID
2083 (void)setresuid((Uid_t)-1, PL_uid, (Uid_t)-1);
2085 PerlProc_setuid(PL_uid);
2089 if (PerlProc_geteuid() != PL_uid)
2090 Perl_croak(aTHX_ "Can't do seteuid!\n");
2092 #endif /* IAMSUID */
2093 PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
2097 else if (!*scriptname) {
2098 forbid_setid("program input from stdin");
2099 PL_rsfp = PerlIO_stdin();
2102 PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
2103 #if defined(HAS_FCNTL) && defined(F_SETFD)
2105 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); /* ensure close-on-exec */
2110 #ifndef IAMSUID /* in case script is not readable before setuid */
2112 PerlLIO_stat(SvPVX(GvSV(PL_curcop->cop_filegv)),&PL_statbuf) >= 0 &&
2113 PL_statbuf.st_mode & (S_ISUID|S_ISGID))
2116 PerlProc_execv(Perl_form(aTHX_ "%s/sperl%s", BIN_EXP, PL_patchlevel), PL_origargv);
2117 Perl_croak(aTHX_ "Can't do setuid\n");
2121 Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
2122 SvPVX(GvSV(PL_curcop->cop_filegv)), Strerror(errno));
2127 * I_SYSSTATVFS HAS_FSTATVFS
2129 * I_STATFS HAS_FSTATFS
2130 * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT
2131 * here so that metaconfig picks them up. */
2135 S_fd_on_nosuid_fs(pTHX_ int fd)
2140 * Preferred order: fstatvfs(), fstatfs(), getmntent().
2141 * fstatvfs() is UNIX98.
2143 * getmntent() is O(number-of-mounted-filesystems) and can hang.
2146 # ifdef HAS_FSTATVFS
2147 struct statvfs stfs;
2148 check_okay = fstatvfs(fd, &stfs) == 0;
2149 on_nosuid = check_okay && (stfs.f_flag & ST_NOSUID);
2151 # if defined(HAS_FSTATFS) && defined(HAS_STRUCT_STATFS_FLAGS)
2153 check_okay = fstatfs(fd, &stfs) == 0;
2154 # undef PERL_MOUNT_NOSUID
2155 # if !defined(PERL_MOUNT_NOSUID) && defined(MNT_NOSUID)
2156 # define PERL_MOUNT_NOSUID MNT_NOSUID
2158 # if !defined(PERL_MOUNT_NOSUID) && defined(MS_NOSUID)
2159 # define PERL_MOUNT_NOSUID MS_NOSUID
2161 # if !defined(PERL_MOUNT_NOSUID) && defined(M_NOSUID)
2162 # define PERL_MOUNT_NOSUID M_NOSUID
2164 # ifdef PERL_MOUNT_NOSUID
2165 on_nosuid = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
2168 # if defined(HAS_GETMNTENT) && defined(HAS_HASMNTOPT) && defined(MNTOPT_NOSUID)
2169 FILE *mtab = fopen("/etc/mtab", "r");
2170 struct mntent *entry;
2171 struct stat stb, fsb;
2173 if (mtab && (fstat(fd, &stb) == 0)) {
2174 while (entry = getmntent(mtab)) {
2175 if (stat(entry->mnt_dir, &fsb) == 0
2176 && fsb.st_dev == stb.st_dev)
2178 /* found the filesystem */
2180 if (hasmntopt(entry, MNTOPT_NOSUID))
2183 } /* A single fs may well fail its stat(). */
2188 # endif /* mntent */
2189 # endif /* statfs */
2190 # endif /* statvfs */
2192 Perl_croak(aTHX_ "Can't check filesystem of script \"%s\"", PL_origfilename);
2195 #endif /* IAMSUID */
2198 S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript)
2202 /* do we need to emulate setuid on scripts? */
2204 /* This code is for those BSD systems that have setuid #! scripts disabled
2205 * in the kernel because of a security problem. Merely defining DOSUID
2206 * in perl will not fix that problem, but if you have disabled setuid
2207 * scripts in the kernel, this will attempt to emulate setuid and setgid
2208 * on scripts that have those now-otherwise-useless bits set. The setuid
2209 * root version must be called suidperl or sperlN.NNN. If regular perl
2210 * discovers that it has opened a setuid script, it calls suidperl with
2211 * the same argv that it had. If suidperl finds that the script it has
2212 * just opened is NOT setuid root, it sets the effective uid back to the
2213 * uid. We don't just make perl setuid root because that loses the
2214 * effective uid we had before invoking perl, if it was different from the
2217 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
2218 * be defined in suidperl only. suidperl must be setuid root. The
2219 * Configure script will set this up for you if you want it.
2226 if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */
2227 Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
2228 if (fdscript < 0 && PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
2233 #ifndef HAS_SETREUID
2234 /* On this access check to make sure the directories are readable,
2235 * there is actually a small window that the user could use to make
2236 * filename point to an accessible directory. So there is a faint
2237 * chance that someone could execute a setuid script down in a
2238 * non-accessible directory. I don't know what to do about that.
2239 * But I don't think it's too important. The manual lies when
2240 * it says access() is useful in setuid programs.
2242 if (PerlLIO_access(SvPVX(GvSV(PL_curcop->cop_filegv)),1)) /*double check*/
2243 Perl_croak(aTHX_ "Permission denied");
2245 /* If we can swap euid and uid, then we can determine access rights
2246 * with a simple stat of the file, and then compare device and
2247 * inode to make sure we did stat() on the same file we opened.
2248 * Then we just have to make sure he or she can execute it.
2251 struct stat tmpstatbuf;
2255 setreuid(PL_euid,PL_uid) < 0
2258 setresuid(PL_euid,PL_uid,(Uid_t)-1) < 0
2261 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
2262 Perl_croak(aTHX_ "Can't swap uid and euid"); /* really paranoid */
2263 if (PerlLIO_stat(SvPVX(GvSV(PL_curcop->cop_filegv)),&tmpstatbuf) < 0)
2264 Perl_croak(aTHX_ "Permission denied"); /* testing full pathname here */
2265 #if defined(IAMSUID) && !defined(NO_NOSUID_CHECK)
2266 if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp)))
2267 Perl_croak(aTHX_ "Permission denied");
2269 if (tmpstatbuf.st_dev != PL_statbuf.st_dev ||
2270 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
2271 (void)PerlIO_close(PL_rsfp);
2272 if (PL_rsfp = PerlProc_popen("/bin/mail root","w")) { /* heh, heh */
2273 PerlIO_printf(PL_rsfp,
2274 "User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2275 (Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
2276 (long)PL_uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
2277 (long)PL_statbuf.st_dev, (long)PL_statbuf.st_ino,
2278 SvPVX(GvSV(PL_curcop->cop_filegv)),
2279 (long)PL_statbuf.st_uid, (long)PL_statbuf.st_gid);
2280 (void)PerlProc_pclose(PL_rsfp);
2282 Perl_croak(aTHX_ "Permission denied\n");
2286 setreuid(PL_uid,PL_euid) < 0
2288 # if defined(HAS_SETRESUID)
2289 setresuid(PL_uid,PL_euid,(Uid_t)-1) < 0
2292 || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
2293 Perl_croak(aTHX_ "Can't reswap uid and euid");
2294 if (!cando(S_IXUSR,FALSE,&PL_statbuf)) /* can real uid exec? */
2295 Perl_croak(aTHX_ "Permission denied\n");
2297 #endif /* HAS_SETREUID */
2298 #endif /* IAMSUID */
2300 if (!S_ISREG(PL_statbuf.st_mode))
2301 Perl_croak(aTHX_ "Permission denied");
2302 if (PL_statbuf.st_mode & S_IWOTH)
2303 Perl_croak(aTHX_ "Setuid/gid script is writable by world");
2304 PL_doswitches = FALSE; /* -s is insecure in suid */
2305 PL_curcop->cop_line++;
2306 if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
2307 strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */
2308 Perl_croak(aTHX_ "No #! line");
2309 s = SvPV(PL_linestr,n_a)+2;
2311 while (!isSPACE(*s)) s++;
2312 for (s2 = s; (s2 > SvPV(PL_linestr,n_a)+2 &&
2313 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
2314 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
2315 Perl_croak(aTHX_ "Not a perl script");
2316 while (*s == ' ' || *s == '\t') s++;
2318 * #! arg must be what we saw above. They can invoke it by
2319 * mentioning suidperl explicitly, but they may not add any strange
2320 * arguments beyond what #! says if they do invoke suidperl that way.
2322 len = strlen(validarg);
2323 if (strEQ(validarg," PHOOEY ") ||
2324 strnNE(s,validarg,len) || !isSPACE(s[len]))
2325 Perl_croak(aTHX_ "Args must match #! line");
2328 if (PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
2329 PL_euid == PL_statbuf.st_uid)
2331 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2332 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2333 #endif /* IAMSUID */
2335 if (PL_euid) { /* oops, we're not the setuid root perl */
2336 (void)PerlIO_close(PL_rsfp);
2339 PerlProc_execv(Perl_form(aTHX_ "%s/sperl%s", BIN_EXP, PL_patchlevel), PL_origargv);
2341 Perl_croak(aTHX_ "Can't do setuid\n");
2344 if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
2346 (void)setegid(PL_statbuf.st_gid);
2349 (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
2351 #ifdef HAS_SETRESGID
2352 (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
2354 PerlProc_setgid(PL_statbuf.st_gid);
2358 if (PerlProc_getegid() != PL_statbuf.st_gid)
2359 Perl_croak(aTHX_ "Can't do setegid!\n");
2361 if (PL_statbuf.st_mode & S_ISUID) {
2362 if (PL_statbuf.st_uid != PL_euid)
2364 (void)seteuid(PL_statbuf.st_uid); /* all that for this */
2367 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
2369 #ifdef HAS_SETRESUID
2370 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
2372 PerlProc_setuid(PL_statbuf.st_uid);
2376 if (PerlProc_geteuid() != PL_statbuf.st_uid)
2377 Perl_croak(aTHX_ "Can't do seteuid!\n");
2379 else if (PL_uid) { /* oops, mustn't run as root */
2381 (void)seteuid((Uid_t)PL_uid);
2384 (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
2386 #ifdef HAS_SETRESUID
2387 (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
2389 PerlProc_setuid((Uid_t)PL_uid);
2393 if (PerlProc_geteuid() != PL_uid)
2394 Perl_croak(aTHX_ "Can't do seteuid!\n");
2397 if (!cando(S_IXUSR,TRUE,&PL_statbuf))
2398 Perl_croak(aTHX_ "Permission denied\n"); /* they can't do this */
2401 else if (PL_preprocess)
2402 Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
2403 else if (fdscript >= 0)
2404 Perl_croak(aTHX_ "fd script not allowed in suidperl\n");
2406 Perl_croak(aTHX_ "Script is not setuid/setgid in suidperl\n");
2408 /* We absolutely must clear out any saved ids here, so we */
2409 /* exec the real perl, substituting fd script for scriptname. */
2410 /* (We pass script name as "subdir" of fd, which perl will grok.) */
2411 PerlIO_rewind(PL_rsfp);
2412 PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0); /* just in case rewind didn't */
2413 for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
2414 if (!PL_origargv[which])
2415 Perl_croak(aTHX_ "Permission denied");
2416 PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
2417 PerlIO_fileno(PL_rsfp), PL_origargv[which]));
2418 #if defined(HAS_FCNTL) && defined(F_SETFD)
2419 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */
2421 PerlProc_execv(Perl_form(aTHX_ "%s/perl%s", BIN_EXP, PL_patchlevel), PL_origargv);/* try again */
2422 Perl_croak(aTHX_ "Can't do setuid\n");
2423 #endif /* IAMSUID */
2425 if (PL_euid != PL_uid || PL_egid != PL_gid) { /* (suidperl doesn't exist, in fact) */
2426 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2428 PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf); /* may be either wrapped or real suid */
2429 if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
2431 (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
2434 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2435 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2436 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2437 /* not set-id, must be wrapped */
2443 S_find_beginning(pTHX)
2445 register char *s, *s2;
2447 /* skip forward in input to the real script? */
2450 while (PL_doextract) {
2451 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
2452 Perl_croak(aTHX_ "No Perl script found in input\n");
2453 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2454 PerlIO_ungetc(PL_rsfp, '\n'); /* to keep line count right */
2455 PL_doextract = FALSE;
2456 while (*s && !(isSPACE (*s) || *s == '#')) s++;
2458 while (*s == ' ' || *s == '\t') s++;
2460 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2461 if (strnEQ(s2-4,"perl",4))
2463 while (s = moreswitches(s)) ;
2465 if (PL_cddir && PerlDir_chdir(PL_cddir) < 0)
2466 Perl_croak(aTHX_ "Can't chdir to %s",PL_cddir);
2475 PL_uid = (int)PerlProc_getuid();
2476 PL_euid = (int)PerlProc_geteuid();
2477 PL_gid = (int)PerlProc_getgid();
2478 PL_egid = (int)PerlProc_getegid();
2480 PL_uid |= PL_gid << 16;
2481 PL_euid |= PL_egid << 16;
2483 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2487 S_forbid_setid(pTHX_ char *s)
2489 if (PL_euid != PL_uid)
2490 Perl_croak(aTHX_ "No %s allowed while running setuid", s);
2491 if (PL_egid != PL_gid)
2492 Perl_croak(aTHX_ "No %s allowed while running setgid", s);
2496 S_init_debugger(pTHX)
2499 PL_curstash = PL_debstash;
2500 PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2501 AvREAL_off(PL_dbargs);
2502 PL_DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2503 PL_DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2504 PL_DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2505 PL_DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2506 sv_setiv(PL_DBsingle, 0);
2507 PL_DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2508 sv_setiv(PL_DBtrace, 0);
2509 PL_DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2510 sv_setiv(PL_DBsignal, 0);
2511 PL_curstash = PL_defstash;
2514 #ifndef STRESS_REALLOC
2515 #define REASONABLE(size) (size)
2517 #define REASONABLE(size) (1) /* unreasonable */
2521 Perl_init_stacks(pTHX)
2523 /* start with 128-item stack and 8K cxstack */
2524 PL_curstackinfo = new_stackinfo(REASONABLE(128),
2525 REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
2526 PL_curstackinfo->si_type = PERLSI_MAIN;
2527 PL_curstack = PL_curstackinfo->si_stack;
2528 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
2530 PL_stack_base = AvARRAY(PL_curstack);
2531 PL_stack_sp = PL_stack_base;
2532 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
2534 New(50,PL_tmps_stack,REASONABLE(128),SV*);
2537 PL_tmps_max = REASONABLE(128);
2539 New(54,PL_markstack,REASONABLE(32),I32);
2540 PL_markstack_ptr = PL_markstack;
2541 PL_markstack_max = PL_markstack + REASONABLE(32);
2545 New(54,PL_scopestack,REASONABLE(32),I32);
2546 PL_scopestack_ix = 0;
2547 PL_scopestack_max = REASONABLE(32);
2549 New(54,PL_savestack,REASONABLE(128),ANY);
2550 PL_savestack_ix = 0;
2551 PL_savestack_max = REASONABLE(128);
2553 New(54,PL_retstack,REASONABLE(16),OP*);
2555 PL_retstack_max = REASONABLE(16);
2564 while (PL_curstackinfo->si_next)
2565 PL_curstackinfo = PL_curstackinfo->si_next;
2566 while (PL_curstackinfo) {
2567 PERL_SI *p = PL_curstackinfo->si_prev;
2568 /* curstackinfo->si_stack got nuked by sv_free_arenas() */
2569 Safefree(PL_curstackinfo->si_cxstack);
2570 Safefree(PL_curstackinfo);
2571 PL_curstackinfo = p;
2573 Safefree(PL_tmps_stack);
2574 Safefree(PL_markstack);
2575 Safefree(PL_scopestack);
2576 Safefree(PL_savestack);
2577 Safefree(PL_retstack);
2579 Safefree(PL_debname);
2580 Safefree(PL_debdelim);
2585 static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
2596 lex_start(PL_linestr);
2598 PL_subname = newSVpvn("main",4);
2602 S_init_predump_symbols(pTHX)
2608 sv_setpvn(get_sv("\"", TRUE), " ", 1);
2609 PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2610 GvMULTI_on(PL_stdingv);
2611 IoIFP(GvIOp(PL_stdingv)) = PerlIO_stdin();
2612 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2614 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(PL_stdingv));
2616 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2618 IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
2620 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2622 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(PL_defoutgv));
2624 othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2625 GvMULTI_on(othergv);
2626 IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr();
2627 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2629 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
2631 PL_statname = NEWSV(66,0); /* last filename we did stat on */
2634 PL_osname = savepv(OSNAME);
2638 S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
2645 argc--,argv++; /* skip name of script */
2646 if (PL_doswitches) {
2647 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2650 if (argv[0][1] == '-') {
2654 if (s = strchr(argv[0], '=')) {
2656 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2659 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2662 PL_toptarget = NEWSV(0,0);
2663 sv_upgrade(PL_toptarget, SVt_PVFM);
2664 sv_setpvn(PL_toptarget, "", 0);
2665 PL_bodytarget = NEWSV(0,0);
2666 sv_upgrade(PL_bodytarget, SVt_PVFM);
2667 sv_setpvn(PL_bodytarget, "", 0);
2668 PL_formtarget = PL_bodytarget;
2671 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2672 sv_setpv(GvSV(tmpgv),PL_origfilename);
2673 magicname("0", "0", 1);
2675 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2676 sv_setpv(GvSV(tmpgv),PL_origargv[0]);
2677 if (PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2678 GvMULTI_on(PL_argvgv);
2679 (void)gv_AVadd(PL_argvgv);
2680 av_clear(GvAVn(PL_argvgv));
2681 for (; argc > 0; argc--,argv++) {
2682 av_push(GvAVn(PL_argvgv),newSVpv(argv[0],0));
2685 if (PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2687 GvMULTI_on(PL_envgv);
2688 hv = GvHVn(PL_envgv);
2689 hv_magic(hv, PL_envgv, 'E');
2690 #if !defined( VMS) && !defined(EPOC) /* VMS doesn't have environ array */
2691 /* Note that if the supplied env parameter is actually a copy
2692 of the global environ then it may now point to free'd memory
2693 if the environment has been modified since. To avoid this
2694 problem we treat env==NULL as meaning 'use the default'
2699 environ[0] = Nullch;
2700 for (; *env; env++) {
2701 if (!(s = strchr(*env,'=')))
2707 sv = newSVpv(s--,0);
2708 (void)hv_store(hv, *env, s - *env, sv, 0);
2710 #if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
2711 /* Sins of the RTL. See note in my_setenv(). */
2712 (void)PerlEnv_putenv(savepv(*env));
2716 #ifdef DYNAMIC_ENV_FETCH
2717 HvNAME(hv) = savepv(ENV_HV_NAME);
2721 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2722 sv_setiv(GvSV(tmpgv), (IV)getpid());
2726 S_init_perllib(pTHX)
2731 s = PerlEnv_getenv("PERL5LIB");
2735 incpush(PerlEnv_getenv("PERLLIB"), FALSE);
2737 /* Treat PERL5?LIB as a possible search list logical name -- the
2738 * "natural" VMS idiom for a Unix path string. We allow each
2739 * element to be a set of |-separated directories for compatibility.
2743 if (my_trnlnm("PERL5LIB",buf,0))
2744 do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2746 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2750 /* Use the ~-expanded versions of APPLLIB (undocumented),
2751 ARCHLIB PRIVLIB SITEARCH and SITELIB
2754 incpush(APPLLIB_EXP, TRUE);
2758 incpush(ARCHLIB_EXP, FALSE);
2761 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2764 incpush(PRIVLIB_EXP, TRUE);
2766 incpush(PRIVLIB_EXP, FALSE);
2770 incpush(SITEARCH_EXP, FALSE);
2774 incpush(SITELIB_EXP, TRUE);
2776 incpush(SITELIB_EXP, FALSE);
2780 incpush(".", FALSE);
2784 # define PERLLIB_SEP ';'
2787 # define PERLLIB_SEP '|'
2789 # define PERLLIB_SEP ':'
2792 #ifndef PERLLIB_MANGLE
2793 # define PERLLIB_MANGLE(s,n) (s)
2797 S_incpush(pTHX_ char *p, int addsubdirs)
2799 SV *subdir = Nullsv;
2805 subdir = sv_newmortal();
2806 if (!PL_archpat_auto) {
2807 STRLEN len = (sizeof(ARCHNAME) + strlen(PL_patchlevel)
2808 + sizeof("//auto"));
2809 New(55, PL_archpat_auto, len, char);
2810 sprintf(PL_archpat_auto, "/%s/%s/auto", ARCHNAME, PL_patchlevel);
2812 for (len = sizeof(ARCHNAME) + 2;
2813 PL_archpat_auto[len] != '\0' && PL_archpat_auto[len] != '/'; len++)
2814 if (PL_archpat_auto[len] == '.') PL_archpat_auto[len] = '_';
2819 /* Break at all separators */
2821 SV *libdir = NEWSV(55,0);
2824 /* skip any consecutive separators */
2825 while ( *p == PERLLIB_SEP ) {
2826 /* Uncomment the next line for PATH semantics */
2827 /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */
2831 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2832 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2837 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2838 p = Nullch; /* break out */
2842 * BEFORE pushing libdir onto @INC we may first push version- and
2843 * archname-specific sub-directories.
2846 struct stat tmpstatbuf;
2851 if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) {
2853 while (unix[len-1] == '/') len--; /* Cosmetic */
2854 sv_usepvn(libdir,unix,len);
2857 PerlIO_printf(PerlIO_stderr(),
2858 "Failed to unixify @INC element \"%s\"\n",
2861 /* .../archname/version if -d .../archname/version/auto */
2862 sv_setsv(subdir, libdir);
2863 sv_catpv(subdir, PL_archpat_auto);
2864 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2865 S_ISDIR(tmpstatbuf.st_mode))
2866 av_push(GvAVn(PL_incgv),
2867 newSVpvn(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2869 /* .../archname if -d .../archname/auto */
2870 sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
2871 strlen(PL_patchlevel) + 1, "", 0);
2872 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2873 S_ISDIR(tmpstatbuf.st_mode))
2874 av_push(GvAVn(PL_incgv),
2875 newSVpvn(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2878 /* finally push this lib directory on the end of @INC */
2879 av_push(GvAVn(PL_incgv), libdir);
2884 STATIC struct perl_thread *
2885 S_init_main_thread(pTHX)
2887 #ifndef PERL_IMPLICIT_CONTEXT
2888 struct perl_thread *thr;
2892 Newz(53, thr, 1, struct perl_thread);
2893 PL_curcop = &PL_compiling;
2894 thr->cvcache = newHV();
2895 thr->threadsv = newAV();
2896 /* thr->threadsvp is set when find_threadsv is called */
2897 thr->specific = newAV();
2898 thr->errhv = newHV();
2899 thr->flags = THRf_R_JOINABLE;
2900 MUTEX_INIT(&thr->mutex);
2901 /* Handcraft thrsv similarly to mess_sv */
2902 New(53, PL_thrsv, 1, SV);
2903 Newz(53, xpv, 1, XPV);
2904 SvFLAGS(PL_thrsv) = SVt_PV;
2905 SvANY(PL_thrsv) = (void*)xpv;
2906 SvREFCNT(PL_thrsv) = 1 << 30; /* practically infinite */
2907 SvPVX(PL_thrsv) = (char*)thr;
2908 SvCUR_set(PL_thrsv, sizeof(thr));
2909 SvLEN_set(PL_thrsv, sizeof(thr));
2910 *SvEND(PL_thrsv) = '\0'; /* in the trailing_nul field */
2911 thr->oursv = PL_thrsv;
2912 PL_chopset = " \n-";
2915 MUTEX_LOCK(&PL_threads_mutex);
2920 MUTEX_UNLOCK(&PL_threads_mutex);
2922 #ifdef HAVE_THREAD_INTERN
2923 Perl_init_thread_intern(thr);
2926 #ifdef SET_THREAD_SELF
2927 SET_THREAD_SELF(thr);
2929 thr->self = pthread_self();
2930 #endif /* SET_THREAD_SELF */
2934 * These must come after the SET_THR because sv_setpvn does
2935 * SvTAINT and the taint fields require dTHR.
2937 PL_toptarget = NEWSV(0,0);
2938 sv_upgrade(PL_toptarget, SVt_PVFM);
2939 sv_setpvn(PL_toptarget, "", 0);
2940 PL_bodytarget = NEWSV(0,0);
2941 sv_upgrade(PL_bodytarget, SVt_PVFM);
2942 sv_setpvn(PL_bodytarget, "", 0);
2943 PL_formtarget = PL_bodytarget;
2944 thr->errsv = newSVpvn("", 0);
2945 (void) find_threadsv("@"); /* Ensure $@ is initialised early */
2948 PL_regcompp = FUNC_NAME_TO_PTR(Perl_pregcomp);
2949 PL_regexecp = FUNC_NAME_TO_PTR(Perl_regexec_flags);
2950 PL_regint_start = FUNC_NAME_TO_PTR(Perl_re_intuit_start);
2951 PL_regint_string = FUNC_NAME_TO_PTR(Perl_re_intuit_string);
2952 PL_regfree = FUNC_NAME_TO_PTR(Perl_pregfree);
2954 PL_reginterp_cnt = 0;
2958 #endif /* USE_THREADS */
2961 Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
2965 line_t oldline = PL_curcop->cop_line;
2970 while (AvFILL(paramList) >= 0) {
2971 cv = (CV*)av_shift(paramList);
2973 CALLPROTECT(aTHX_ &ret, FUNC_NAME_TO_PTR(S_call_list_body), cv);
2976 (void)SvPV(atsv, len);
2978 PL_curcop = &PL_compiling;
2979 PL_curcop->cop_line = oldline;
2980 if (paramList == PL_beginav)
2981 sv_catpv(atsv, "BEGIN failed--compilation aborted");
2983 sv_catpv(atsv, "END failed--cleanup aborted");
2984 while (PL_scopestack_ix > oldscope)
2986 Perl_croak(aTHX_ "%s", SvPVX(atsv));
2993 /* my_exit() was called */
2994 while (PL_scopestack_ix > oldscope)
2997 PL_curstash = PL_defstash;
2999 call_list(oldscope, PL_endav);
3000 PL_curcop = &PL_compiling;
3001 PL_curcop->cop_line = oldline;
3002 if (PL_statusvalue) {
3003 if (paramList == PL_beginav)
3004 Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
3006 Perl_croak(aTHX_ "END failed--cleanup aborted");
3012 PL_curcop = &PL_compiling;
3013 PL_curcop->cop_line = oldline;
3016 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
3024 S_call_list_body(pTHX_ va_list args)
3027 CV *cv = va_arg(args, CV*);
3029 PUSHMARK(PL_stack_sp);
3030 call_sv((SV*)cv, G_EVAL|G_DISCARD);
3035 Perl_my_exit(pTHX_ U32 status)
3039 DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
3040 thr, (unsigned long) status));
3049 STATUS_NATIVE_SET(status);
3056 Perl_my_failure_exit(pTHX)
3059 if (vaxc$errno & 1) {
3060 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
3061 STATUS_NATIVE_SET(44);
3064 if (!vaxc$errno && errno) /* unlikely */
3065 STATUS_NATIVE_SET(44);
3067 STATUS_NATIVE_SET(vaxc$errno);
3072 STATUS_POSIX_SET(errno);
3074 exitstatus = STATUS_POSIX >> 8;
3075 if (exitstatus & 255)
3076 STATUS_POSIX_SET(exitstatus);
3078 STATUS_POSIX_SET(255);
3085 S_my_exit_jump(pTHX)
3088 register PERL_CONTEXT *cx;
3093 SvREFCNT_dec(PL_e_script);
3094 PL_e_script = Nullsv;
3097 POPSTACK_TO(PL_mainstack);
3098 if (cxstack_ix >= 0) {
3101 POPBLOCK(cx,PL_curpm);
3110 #endif /* PERL_OBJECT */
3115 read_e_script(pTHXo_ int idx, SV *buf_sv, int maxlen)
3118 p = SvPVX(PL_e_script);
3119 nl = strchr(p, '\n');
3120 nl = (nl) ? nl+1 : SvEND(PL_e_script);
3122 filter_del(read_e_script);
3125 sv_catpvn(buf_sv, p, nl-p);
3126 sv_chop(PL_e_script, nl);