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);
951 init_predump_symbols();
952 /* init_postdump_symbols not currently designed to be called */
953 /* more than once (ENV isn't cleared first, for example) */
954 /* But running with -u leaves %ENV & @ARGV undefined! XXX */
956 init_postdump_symbols(argc,argv,env);
960 /* now parse the script */
962 SETERRNO(0,SS$_NORMAL);
964 if (yyparse() || PL_error_count) {
966 Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
968 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
972 PL_curcop->cop_line = 0;
973 PL_curstash = PL_defstash;
974 PL_preprocess = FALSE;
976 SvREFCNT_dec(PL_e_script);
977 PL_e_script = Nullsv;
980 /* now that script is parsed, we can modify record separator */
982 PL_rs = SvREFCNT_inc(PL_nrs);
983 sv_setsv(get_sv("/", TRUE), PL_rs);
987 if (ckWARN(WARN_ONCE))
988 gv_check(PL_defstash);
994 if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
995 dump_mstats("after compilation:");
1013 #if !defined(PERL_OBJECT) && !defined(PERL_IMPLICIT_CONTEXT)
1014 if (!(PL_curinterp = my_perl))
1018 oldscope = PL_scopestack_ix;
1021 CALLPROTECT(aTHX_ &ret, FUNC_NAME_TO_PTR(S_run_body), oldscope);
1024 cxstack_ix = -1; /* start context stack again */
1026 case 0: /* normal completion */
1027 case 2: /* my_exit() */
1028 while (PL_scopestack_ix > oldscope)
1031 PL_curstash = PL_defstash;
1033 call_list(oldscope, PL_endav);
1035 if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
1036 dump_mstats("after execution: ");
1038 return STATUS_NATIVE_EXPORT;
1041 POPSTACK_TO(PL_mainstack);
1044 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
1054 S_run_body(pTHX_ va_list args)
1057 I32 oldscope = va_arg(args, I32);
1059 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
1060 PL_sawampersand ? "Enabling" : "Omitting"));
1062 if (!PL_restartop) {
1063 DEBUG_x(dump_all());
1064 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
1065 DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%lx\n",
1066 (unsigned long) thr));
1069 PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", PL_origfilename);
1072 if (PERLDB_SINGLE && PL_DBsingle)
1073 sv_setiv(PL_DBsingle, 1);
1075 call_list(oldscope, PL_initav);
1081 PL_op = PL_restartop;
1085 else if (PL_main_start) {
1086 CvDEPTH(PL_main_cv) = 1;
1087 PL_op = PL_main_start;
1095 Perl_get_sv(pTHX_ const char *name, I32 create)
1099 if (name[1] == '\0' && !isALPHA(name[0])) {
1100 PADOFFSET tmp = find_threadsv(name);
1101 if (tmp != NOT_IN_PAD) {
1103 return THREADSV(tmp);
1106 #endif /* USE_THREADS */
1107 gv = gv_fetchpv(name, create, SVt_PV);
1114 Perl_get_av(pTHX_ const char *name, I32 create)
1116 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1125 Perl_get_hv(pTHX_ const char *name, I32 create)
1127 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1136 Perl_get_cv(pTHX_ const char *name, I32 create)
1138 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
1139 /* XXX unsafe for threads if eval_owner isn't held */
1140 /* XXX this is probably not what they think they're getting.
1141 * It has the same effect as "sub name;", i.e. just a forward
1143 if (create && !GvCVu(gv))
1144 return newSUB(start_subparse(FALSE, 0),
1145 newSVOP(OP_CONST, 0, newSVpv(name,0)),
1153 /* Be sure to refetch the stack pointer after calling these routines. */
1156 Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv)
1158 /* See G_* flags in cop.h */
1159 /* null terminated arg list */
1166 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
1171 return call_pv(sub_name, flags);
1175 Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
1176 /* name of the subroutine */
1177 /* See G_* flags in cop.h */
1179 return call_sv((SV*)get_cv(sub_name, TRUE), flags);
1183 Perl_call_method(pTHX_ const char *methname, I32 flags)
1184 /* name of the subroutine */
1185 /* See G_* flags in cop.h */
1191 XPUSHs(sv_2mortal(newSVpv(methname,0)));
1196 return call_sv(*PL_stack_sp--, flags);
1199 /* May be called with any of a CV, a GV, or an SV containing the name. */
1201 Perl_call_sv(pTHX_ SV *sv, I32 flags)
1203 /* See G_* flags in cop.h */
1206 LOGOP myop; /* fake syntax tree node */
1210 bool oldcatch = CATCH_GET;
1214 if (flags & G_DISCARD) {
1219 Zero(&myop, 1, LOGOP);
1220 myop.op_next = Nullop;
1221 if (!(flags & G_NOARGS))
1222 myop.op_flags |= OPf_STACKED;
1223 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1224 (flags & G_ARRAY) ? OPf_WANT_LIST :
1229 EXTEND(PL_stack_sp, 1);
1230 *++PL_stack_sp = sv;
1232 oldscope = PL_scopestack_ix;
1234 if (PERLDB_SUB && PL_curstash != PL_debstash
1235 /* Handle first BEGIN of -d. */
1236 && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
1237 /* Try harder, since this may have been a sighandler, thus
1238 * curstash may be meaningless. */
1239 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != PL_debstash)
1240 && !(flags & G_NODEBUG))
1241 PL_op->op_private |= OPpENTERSUB_DB;
1243 if (!(flags & G_EVAL)) {
1245 call_xbody((OP*)&myop, FALSE);
1246 retval = PL_stack_sp - (PL_stack_base + oldmark);
1250 cLOGOP->op_other = PL_op;
1252 /* we're trying to emulate pp_entertry() here */
1254 register PERL_CONTEXT *cx;
1255 I32 gimme = GIMME_V;
1260 push_return(PL_op->op_next);
1261 PUSHBLOCK(cx, CXt_EVAL, PL_stack_sp);
1263 PL_eval_root = PL_op; /* Only needed so that goto works right. */
1265 PL_in_eval = EVAL_INEVAL;
1266 if (flags & G_KEEPERR)
1267 PL_in_eval |= EVAL_KEEPERR;
1274 CALLPROTECT(aTHX_ &ret, FUNC_NAME_TO_PTR(S_call_body), (OP*)&myop, FALSE);
1277 retval = PL_stack_sp - (PL_stack_base + oldmark);
1278 if (!(flags & G_KEEPERR))
1285 /* my_exit() was called */
1286 PL_curstash = PL_defstash;
1289 Perl_croak(aTHX_ "Callback called exit");
1294 PL_op = PL_restartop;
1298 PL_stack_sp = PL_stack_base + oldmark;
1299 if (flags & G_ARRAY)
1303 *++PL_stack_sp = &PL_sv_undef;
1308 if (PL_scopestack_ix > oldscope) {
1312 register PERL_CONTEXT *cx;
1323 if (flags & G_DISCARD) {
1324 PL_stack_sp = PL_stack_base + oldmark;
1334 S_call_body(pTHX_ va_list args)
1336 OP *myop = va_arg(args, OP*);
1337 int is_eval = va_arg(args, int);
1339 call_xbody(myop, is_eval);
1344 S_call_xbody(pTHX_ OP *myop, int is_eval)
1348 if (PL_op == myop) {
1350 PL_op = Perl_pp_entereval(aTHX);
1352 PL_op = Perl_pp_entersub(aTHX);
1358 /* Eval a string. The G_EVAL flag is always assumed. */
1361 Perl_eval_sv(pTHX_ SV *sv, I32 flags)
1363 /* See G_* flags in cop.h */
1366 UNOP myop; /* fake syntax tree node */
1367 I32 oldmark = SP - PL_stack_base;
1373 if (flags & G_DISCARD) {
1380 Zero(PL_op, 1, UNOP);
1381 EXTEND(PL_stack_sp, 1);
1382 *++PL_stack_sp = sv;
1383 oldscope = PL_scopestack_ix;
1385 if (!(flags & G_NOARGS))
1386 myop.op_flags = OPf_STACKED;
1387 myop.op_next = Nullop;
1388 myop.op_type = OP_ENTEREVAL;
1389 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1390 (flags & G_ARRAY) ? OPf_WANT_LIST :
1392 if (flags & G_KEEPERR)
1393 myop.op_flags |= OPf_SPECIAL;
1396 CALLPROTECT(aTHX_ &ret, FUNC_NAME_TO_PTR(S_call_body), (OP*)&myop, TRUE);
1399 retval = PL_stack_sp - (PL_stack_base + oldmark);
1400 if (!(flags & G_KEEPERR))
1407 /* my_exit() was called */
1408 PL_curstash = PL_defstash;
1411 Perl_croak(aTHX_ "Callback called exit");
1416 PL_op = PL_restartop;
1420 PL_stack_sp = PL_stack_base + oldmark;
1421 if (flags & G_ARRAY)
1425 *++PL_stack_sp = &PL_sv_undef;
1430 if (flags & G_DISCARD) {
1431 PL_stack_sp = PL_stack_base + oldmark;
1441 Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
1444 SV* sv = newSVpv(p, 0);
1447 eval_sv(sv, G_SCALAR);
1454 if (croak_on_error && SvTRUE(ERRSV)) {
1456 Perl_croak(aTHX_ SvPVx(ERRSV, n_a));
1462 /* Require a module. */
1465 Perl_require_pv(pTHX_ const char *pv)
1469 PUSHSTACKi(PERLSI_REQUIRE);
1471 sv = sv_newmortal();
1472 sv_setpv(sv, "require '");
1475 eval_sv(sv, G_DISCARD);
1481 Perl_magicname(pTHX_ char *sym, char *name, I32 namlen)
1485 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1486 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1490 S_usage(pTHX_ char *name) /* XXX move this out into a module ? */
1492 /* This message really ought to be max 23 lines.
1493 * Removed -h because the user already knows that opton. Others? */
1495 static char *usage_msg[] = {
1496 "-0[octal] specify record separator (\\0, if no argument)",
1497 "-a autosplit mode with -n or -p (splits $_ into @F)",
1498 "-c check syntax only (runs BEGIN and END blocks)",
1499 "-d[:debugger] run program under debugger",
1500 "-D[number/list] set debugging flags (argument is a bit mask or alphabets)",
1501 "-e 'command' one line of program (several -e's allowed, omit programfile)",
1502 "-F/pattern/ split() pattern for -a switch (//'s are optional)",
1503 "-i[extension] edit <> files in place (makes backup if extension supplied)",
1504 "-Idirectory specify @INC/#include directory (several -I's allowed)",
1505 "-l[octal] enable line ending processing, specifies line terminator",
1506 "-[mM][-]module execute `use/no module...' before executing program",
1507 "-n assume 'while (<>) { ... }' loop around program",
1508 "-p assume loop like -n but print line also, like sed",
1509 "-P run program through C preprocessor before compilation",
1510 "-s enable rudimentary parsing for switches after programfile",
1511 "-S look for programfile using PATH environment variable",
1512 "-T enable tainting checks",
1513 "-u dump core after parsing program",
1514 "-U allow unsafe operations",
1515 "-v print version, subversion (includes VERY IMPORTANT perl info)",
1516 "-V[:variable] print configuration summary (or a single Config.pm variable)",
1517 "-w enable many useful warnings (RECOMMENDED)",
1518 "-x[directory] strip off text before #!perl line and perhaps cd to directory",
1522 char **p = usage_msg;
1524 printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1526 printf("\n %s", *p++);
1529 /* This routine handles any switches that can be given during run */
1532 Perl_moreswitches(pTHX_ char *s)
1541 rschar = scan_oct(s, 4, &numlen);
1542 SvREFCNT_dec(PL_nrs);
1543 if (rschar & ~((U8)~0))
1544 PL_nrs = &PL_sv_undef;
1545 else if (!rschar && numlen >= 2)
1546 PL_nrs = newSVpvn("", 0);
1549 PL_nrs = newSVpvn(&ch, 1);
1555 PL_splitstr = savepv(s + 1);
1569 if (*s == ':' || *s == '=') {
1570 my_setenv("PERL5DB", Perl_form(aTHX_ "use Devel::%s;", ++s));
1574 PL_perldb = PERLDB_ALL;
1581 if (isALPHA(s[1])) {
1582 static char debopts[] = "psltocPmfrxuLHXDS";
1585 for (s++; *s && (d = strchr(debopts,*s)); s++)
1586 PL_debug |= 1 << (d - debopts);
1589 PL_debug = atoi(s+1);
1590 for (s++; isDIGIT(*s); s++) ;
1592 PL_debug |= 0x80000000;
1594 Perl_warn(aTHX_ "Recompile perl with -DDEBUGGING to use -D switch\n");
1595 for (s++; isALNUM(*s); s++) ;
1600 usage(PL_origargv[0]);
1604 Safefree(PL_inplace);
1605 PL_inplace = savepv(s+1);
1607 for (s = PL_inplace; *s && !isSPACE(*s); s++) ;
1610 if (*s == '-') /* Additional switches on #! line. */
1614 case 'I': /* -I handled both here and in parse_perl() */
1617 while (*s && isSPACE(*s))
1621 for (e = s; *e && !isSPACE(*e); e++) ;
1622 p = savepvn(s, e-s);
1628 Perl_croak(aTHX_ "No space allowed after -I");
1636 PL_ors = savepv("\n");
1638 *PL_ors = scan_oct(s, 3 + (*s == '0'), &numlen);
1643 if (RsPARA(PL_nrs)) {
1648 PL_ors = SvPV(PL_nrs, PL_orslen);
1649 PL_ors = savepvn(PL_ors, PL_orslen);
1653 forbid_setid("-M"); /* XXX ? */
1656 forbid_setid("-m"); /* XXX ? */
1661 /* -M-foo == 'no foo' */
1662 if (*s == '-') { use = "no "; ++s; }
1663 sv = newSVpv(use,0);
1665 /* We allow -M'Module qw(Foo Bar)' */
1666 while(isALNUM(*s) || *s==':') ++s;
1668 sv_catpv(sv, start);
1669 if (*(start-1) == 'm') {
1671 Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
1672 sv_catpv( sv, " ()");
1675 sv_catpvn(sv, start, s-start);
1676 sv_catpv(sv, " split(/,/,q{");
1681 if (PL_preambleav == NULL)
1682 PL_preambleav = newAV();
1683 av_push(PL_preambleav, sv);
1686 Perl_croak(aTHX_ "No space allowed after -%c", *(s-1));
1698 PL_doswitches = TRUE;
1703 Perl_croak(aTHX_ "Too late for \"-T\" option");
1707 PL_do_undump = TRUE;
1715 #if defined(PERL_SUBVERSION) && PERL_SUBVERSION > 0
1716 printf("\nThis is perl, version %d.%03d_%02d built for %s",
1717 PERL_REVISION, PERL_VERSION, PERL_SUBVERSION, ARCHNAME);
1719 printf("\nThis is perl, version %s built for %s",
1720 PL_patchlevel, ARCHNAME);
1722 #if defined(LOCAL_PATCH_COUNT)
1723 if (LOCAL_PATCH_COUNT > 0)
1724 printf("\n(with %d registered patch%s, see perl -V for more detail)",
1725 LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : "");
1728 printf("\n\nCopyright 1987-1999, Larry Wall\n");
1730 printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1733 printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
1734 printf("djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
1737 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1738 "Version 5 port Copyright (c) 1994-1999, Andreas Kaiser, Ilya Zakharevich\n");
1741 printf("atariST series port, ++jrb bammi@cadence.com\n");
1744 printf("BeOS port Copyright Tom Spindler, 1997-1999\n");
1747 printf("MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-1999\n");
1750 printf("MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
1753 printf("Stratus VOS port by Paul_Green@stratus.com, 1997-1999\n");
1756 printf("VM/ESA port by Neale Ferguson, 1998-1999\n");
1759 printf("BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
1762 printf("MiNT port by Guido Flohr, 1997-1999\n");
1764 #ifdef BINARY_BUILD_NOTICE
1765 BINARY_BUILD_NOTICE;
1768 Perl may be copied only under the terms of either the Artistic License or the\n\
1769 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n\
1770 Complete documentation for Perl, including FAQ lists, should be found on\n\
1771 this system using `man perl' or `perldoc perl'. If you have access to the\n\
1772 Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
1775 if (! (PL_dowarn & G_WARN_ALL_MASK))
1776 PL_dowarn |= G_WARN_ON;
1780 PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
1781 PL_compiling.cop_warnings = WARN_ALL ;
1785 PL_dowarn = G_WARN_ALL_OFF;
1786 PL_compiling.cop_warnings = WARN_NONE ;
1791 if (s[1] == '-') /* Additional switches on #! line. */
1796 #if defined(WIN32) || !defined(PERL_STRICT_CR)
1802 #ifdef ALTERNATE_SHEBANG
1803 case 'S': /* OS/2 needs -S on "extproc" line. */
1811 Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
1816 /* compliments of Tom Christiansen */
1818 /* unexec() can be found in the Gnu emacs distribution */
1819 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
1822 Perl_my_unexec(pTHX)
1830 prog = newSVpv(BIN_EXP, 0);
1831 sv_catpv(prog, "/perl");
1832 file = newSVpv(PL_origfilename, 0);
1833 sv_catpv(file, ".perldump");
1835 unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
1836 /* unexec prints msg to stderr in case of failure */
1837 PerlProc_exit(status);
1840 # include <lib$routines.h>
1841 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
1843 ABORT(); /* for use with undump */
1848 /* initialize curinterp */
1853 #ifdef PERL_OBJECT /* XXX kludge */
1856 PL_chopset = " \n-"; \
1857 PL_copline = NOLINE; \
1858 PL_curcop = &PL_compiling;\
1859 PL_curcopdb = NULL; \
1862 PL_dumpindent = 4; \
1863 PL_laststatval = -1; \
1864 PL_laststype = OP_STAT; \
1865 PL_maxscream = -1; \
1866 PL_maxsysfd = MAXSYSFD; \
1867 PL_statname = Nullsv; \
1868 PL_tmps_floor = -1; \
1870 PL_op_mask = NULL; \
1872 PL_laststatval = -1; \
1873 PL_laststype = OP_STAT; \
1874 PL_mess_sv = Nullsv; \
1875 PL_splitstr = " "; \
1876 PL_generation = 100; \
1877 PL_exitlist = NULL; \
1878 PL_exitlistlen = 0; \
1880 PL_in_clean_objs = FALSE; \
1881 PL_in_clean_all = FALSE; \
1882 PL_profiledata = NULL; \
1884 PL_rsfp_filters = Nullav; \
1889 # ifdef MULTIPLICITY
1890 # define PERLVAR(var,type)
1891 # if defined(PERL_IMPLICIT_CONTEXT)
1892 # define PERLVARI(var,type,init) my_perl->var = init;
1893 # define PERLVARIC(var,type,init) my_perl->var = init;
1895 # define PERLVARI(var,type,init) PL_curinterp->var = init;
1896 # define PERLVARIC(var,type,init) PL_curinterp->var = init;
1898 # include "intrpvar.h"
1899 # ifndef USE_THREADS
1900 # include "thrdvar.h"
1906 # define PERLVAR(var,type)
1907 # define PERLVARI(var,type,init) PL_##var = init;
1908 # define PERLVARIC(var,type,init) PL_##var = init;
1909 # include "intrpvar.h"
1910 # ifndef USE_THREADS
1911 # include "thrdvar.h"
1922 S_init_main_stash(pTHX)
1927 /* Note that strtab is a rather special HV. Assumptions are made
1928 about not iterating on it, and not adding tie magic to it.
1929 It is properly deallocated in perl_destruct() */
1930 PL_strtab = newHV();
1932 MUTEX_INIT(&PL_strtab_mutex);
1934 HvSHAREKEYS_off(PL_strtab); /* mandatory */
1935 hv_ksplit(PL_strtab, 512);
1937 PL_curstash = PL_defstash = newHV();
1938 PL_curstname = newSVpvn("main",4);
1939 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1940 SvREFCNT_dec(GvHV(gv));
1941 GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
1943 HvNAME(PL_defstash) = savepv("main");
1944 PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1945 GvMULTI_on(PL_incgv);
1946 PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
1947 GvMULTI_on(PL_hintgv);
1948 PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1949 PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1950 GvMULTI_on(PL_errgv);
1951 PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
1952 GvMULTI_on(PL_replgv);
1953 (void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */
1954 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
1955 sv_setpvn(ERRSV, "", 0);
1956 PL_curstash = PL_defstash;
1957 PL_compiling.cop_stash = PL_defstash;
1958 PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
1959 PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
1960 /* We must init $/ before switches are processed. */
1961 sv_setpvn(get_sv("/", TRUE), "\n", 1);
1965 S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
1973 PL_origfilename = savepv("-e");
1976 /* if find_script() returns, it returns a malloc()-ed value */
1977 PL_origfilename = scriptname = find_script(scriptname, dosearch, NULL, 1);
1979 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
1980 char *s = scriptname + 8;
1981 *fdscript = atoi(s);
1985 scriptname = savepv(s + 1);
1986 Safefree(PL_origfilename);
1987 PL_origfilename = scriptname;
1992 PL_curcop->cop_filegv = gv_fetchfile(PL_origfilename);
1993 if (strEQ(PL_origfilename,"-"))
1995 if (*fdscript >= 0) {
1996 PL_rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE);
1997 #if defined(HAS_FCNTL) && defined(F_SETFD)
1999 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); /* ensure close-on-exec */
2002 else if (PL_preprocess) {
2003 char *cpp_cfg = CPPSTDIN;
2004 SV *cpp = newSVpvn("",0);
2005 SV *cmd = NEWSV(0,0);
2007 if (strEQ(cpp_cfg, "cppstdin"))
2008 Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
2009 sv_catpv(cpp, cpp_cfg);
2012 sv_catpv(sv,PRIVLIB_EXP);
2015 Perl_sv_setpvf(aTHX_ cmd, "\
2016 sed %s -e \"/^[^#]/b\" \
2017 -e \"/^#[ ]*include[ ]/b\" \
2018 -e \"/^#[ ]*define[ ]/b\" \
2019 -e \"/^#[ ]*if[ ]/b\" \
2020 -e \"/^#[ ]*ifdef[ ]/b\" \
2021 -e \"/^#[ ]*ifndef[ ]/b\" \
2022 -e \"/^#[ ]*else/b\" \
2023 -e \"/^#[ ]*elif[ ]/b\" \
2024 -e \"/^#[ ]*undef[ ]/b\" \
2025 -e \"/^#[ ]*endif/b\" \
2028 (PL_doextract ? "-e \"1,/^#/d\n\"" : ""),
2031 Perl_sv_setpvf(aTHX_ cmd, "\
2032 %s %s -e '/^[^#]/b' \
2033 -e '/^#[ ]*include[ ]/b' \
2034 -e '/^#[ ]*define[ ]/b' \
2035 -e '/^#[ ]*if[ ]/b' \
2036 -e '/^#[ ]*ifdef[ ]/b' \
2037 -e '/^#[ ]*ifndef[ ]/b' \
2038 -e '/^#[ ]*else/b' \
2039 -e '/^#[ ]*elif[ ]/b' \
2040 -e '/^#[ ]*undef[ ]/b' \
2041 -e '/^#[ ]*endif/b' \
2045 Perl_sv_setpvf(aTHX_ cmd, "\
2046 %s %s -e '/^[^#]/b' \
2047 -e '/^#[ ]*include[ ]/b' \
2048 -e '/^#[ ]*define[ ]/b' \
2049 -e '/^#[ ]*if[ ]/b' \
2050 -e '/^#[ ]*ifdef[ ]/b' \
2051 -e '/^#[ ]*ifndef[ ]/b' \
2052 -e '/^#[ ]*else/b' \
2053 -e '/^#[ ]*elif[ ]/b' \
2054 -e '/^#[ ]*undef[ ]/b' \
2055 -e '/^#[ ]*endif/b' \
2064 (PL_doextract ? "-e '1,/^#/d\n'" : ""),
2066 scriptname, cpp, sv, CPPMINUS);
2067 PL_doextract = FALSE;
2068 #ifdef IAMSUID /* actually, this is caught earlier */
2069 if (PL_euid != PL_uid && !PL_euid) { /* if running suidperl */
2071 (void)seteuid(PL_uid); /* musn't stay setuid root */
2074 (void)setreuid((Uid_t)-1, PL_uid);
2076 #ifdef HAS_SETRESUID
2077 (void)setresuid((Uid_t)-1, PL_uid, (Uid_t)-1);
2079 PerlProc_setuid(PL_uid);
2083 if (PerlProc_geteuid() != PL_uid)
2084 Perl_croak(aTHX_ "Can't do seteuid!\n");
2086 #endif /* IAMSUID */
2087 PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
2091 else if (!*scriptname) {
2092 forbid_setid("program input from stdin");
2093 PL_rsfp = PerlIO_stdin();
2096 PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
2097 #if defined(HAS_FCNTL) && defined(F_SETFD)
2099 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); /* ensure close-on-exec */
2104 #ifndef IAMSUID /* in case script is not readable before setuid */
2106 PerlLIO_stat(SvPVX(GvSV(PL_curcop->cop_filegv)),&PL_statbuf) >= 0 &&
2107 PL_statbuf.st_mode & (S_ISUID|S_ISGID))
2110 PerlProc_execv(Perl_form(aTHX_ "%s/sperl%s", BIN_EXP, PL_patchlevel), PL_origargv);
2111 Perl_croak(aTHX_ "Can't do setuid\n");
2115 Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
2116 SvPVX(GvSV(PL_curcop->cop_filegv)), Strerror(errno));
2121 * I_SYSSTATVFS HAS_FSTATVFS
2123 * I_STATFS HAS_FSTATFS
2124 * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT
2125 * here so that metaconfig picks them up. */
2129 S_fd_on_nosuid_fs(pTHX_ int fd)
2134 * Preferred order: fstatvfs(), fstatfs(), getmntent().
2135 * fstatvfs() is UNIX98.
2137 * getmntent() is O(number-of-mounted-filesystems) and can hang.
2140 # ifdef HAS_FSTATVFS
2141 struct statvfs stfs;
2142 check_okay = fstatvfs(fd, &stfs) == 0;
2143 on_nosuid = check_okay && (stfs.f_flag & ST_NOSUID);
2145 # if defined(HAS_FSTATFS) && defined(HAS_STRUCT_STATFS_FLAGS)
2147 check_okay = fstatfs(fd, &stfs) == 0;
2148 # undef PERL_MOUNT_NOSUID
2149 # if !defined(PERL_MOUNT_NOSUID) && defined(MNT_NOSUID)
2150 # define PERL_MOUNT_NOSUID MNT_NOSUID
2152 # if !defined(PERL_MOUNT_NOSUID) && defined(MS_NOSUID)
2153 # define PERL_MOUNT_NOSUID MS_NOSUID
2155 # if !defined(PERL_MOUNT_NOSUID) && defined(M_NOSUID)
2156 # define PERL_MOUNT_NOSUID M_NOSUID
2158 # ifdef PERL_MOUNT_NOSUID
2159 on_nosuid = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
2162 # if defined(HAS_GETMNTENT) && defined(HAS_HASMNTOPT) && defined(MNTOPT_NOSUID)
2163 FILE *mtab = fopen("/etc/mtab", "r");
2164 struct mntent *entry;
2165 struct stat stb, fsb;
2167 if (mtab && (fstat(fd, &stb) == 0)) {
2168 while (entry = getmntent(mtab)) {
2169 if (stat(entry->mnt_dir, &fsb) == 0
2170 && fsb.st_dev == stb.st_dev)
2172 /* found the filesystem */
2174 if (hasmntopt(entry, MNTOPT_NOSUID))
2177 } /* A single fs may well fail its stat(). */
2182 # endif /* mntent */
2183 # endif /* statfs */
2184 # endif /* statvfs */
2186 Perl_croak(aTHX_ "Can't check filesystem of script \"%s\"", PL_origfilename);
2189 #endif /* IAMSUID */
2192 S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript)
2196 /* do we need to emulate setuid on scripts? */
2198 /* This code is for those BSD systems that have setuid #! scripts disabled
2199 * in the kernel because of a security problem. Merely defining DOSUID
2200 * in perl will not fix that problem, but if you have disabled setuid
2201 * scripts in the kernel, this will attempt to emulate setuid and setgid
2202 * on scripts that have those now-otherwise-useless bits set. The setuid
2203 * root version must be called suidperl or sperlN.NNN. If regular perl
2204 * discovers that it has opened a setuid script, it calls suidperl with
2205 * the same argv that it had. If suidperl finds that the script it has
2206 * just opened is NOT setuid root, it sets the effective uid back to the
2207 * uid. We don't just make perl setuid root because that loses the
2208 * effective uid we had before invoking perl, if it was different from the
2211 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
2212 * be defined in suidperl only. suidperl must be setuid root. The
2213 * Configure script will set this up for you if you want it.
2220 if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */
2221 Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
2222 if (fdscript < 0 && PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
2227 #ifndef HAS_SETREUID
2228 /* On this access check to make sure the directories are readable,
2229 * there is actually a small window that the user could use to make
2230 * filename point to an accessible directory. So there is a faint
2231 * chance that someone could execute a setuid script down in a
2232 * non-accessible directory. I don't know what to do about that.
2233 * But I don't think it's too important. The manual lies when
2234 * it says access() is useful in setuid programs.
2236 if (PerlLIO_access(SvPVX(GvSV(PL_curcop->cop_filegv)),1)) /*double check*/
2237 Perl_croak(aTHX_ "Permission denied");
2239 /* If we can swap euid and uid, then we can determine access rights
2240 * with a simple stat of the file, and then compare device and
2241 * inode to make sure we did stat() on the same file we opened.
2242 * Then we just have to make sure he or she can execute it.
2245 struct stat tmpstatbuf;
2249 setreuid(PL_euid,PL_uid) < 0
2252 setresuid(PL_euid,PL_uid,(Uid_t)-1) < 0
2255 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
2256 Perl_croak(aTHX_ "Can't swap uid and euid"); /* really paranoid */
2257 if (PerlLIO_stat(SvPVX(GvSV(PL_curcop->cop_filegv)),&tmpstatbuf) < 0)
2258 Perl_croak(aTHX_ "Permission denied"); /* testing full pathname here */
2259 #if defined(IAMSUID) && !defined(NO_NOSUID_CHECK)
2260 if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp)))
2261 Perl_croak(aTHX_ "Permission denied");
2263 if (tmpstatbuf.st_dev != PL_statbuf.st_dev ||
2264 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
2265 (void)PerlIO_close(PL_rsfp);
2266 if (PL_rsfp = PerlProc_popen("/bin/mail root","w")) { /* heh, heh */
2267 PerlIO_printf(PL_rsfp,
2268 "User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2269 (Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
2270 (long)PL_uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
2271 (long)PL_statbuf.st_dev, (long)PL_statbuf.st_ino,
2272 SvPVX(GvSV(PL_curcop->cop_filegv)),
2273 (long)PL_statbuf.st_uid, (long)PL_statbuf.st_gid);
2274 (void)PerlProc_pclose(PL_rsfp);
2276 Perl_croak(aTHX_ "Permission denied\n");
2280 setreuid(PL_uid,PL_euid) < 0
2282 # if defined(HAS_SETRESUID)
2283 setresuid(PL_uid,PL_euid,(Uid_t)-1) < 0
2286 || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
2287 Perl_croak(aTHX_ "Can't reswap uid and euid");
2288 if (!cando(S_IXUSR,FALSE,&PL_statbuf)) /* can real uid exec? */
2289 Perl_croak(aTHX_ "Permission denied\n");
2291 #endif /* HAS_SETREUID */
2292 #endif /* IAMSUID */
2294 if (!S_ISREG(PL_statbuf.st_mode))
2295 Perl_croak(aTHX_ "Permission denied");
2296 if (PL_statbuf.st_mode & S_IWOTH)
2297 Perl_croak(aTHX_ "Setuid/gid script is writable by world");
2298 PL_doswitches = FALSE; /* -s is insecure in suid */
2299 PL_curcop->cop_line++;
2300 if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
2301 strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */
2302 Perl_croak(aTHX_ "No #! line");
2303 s = SvPV(PL_linestr,n_a)+2;
2305 while (!isSPACE(*s)) s++;
2306 for (s2 = s; (s2 > SvPV(PL_linestr,n_a)+2 &&
2307 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
2308 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
2309 Perl_croak(aTHX_ "Not a perl script");
2310 while (*s == ' ' || *s == '\t') s++;
2312 * #! arg must be what we saw above. They can invoke it by
2313 * mentioning suidperl explicitly, but they may not add any strange
2314 * arguments beyond what #! says if they do invoke suidperl that way.
2316 len = strlen(validarg);
2317 if (strEQ(validarg," PHOOEY ") ||
2318 strnNE(s,validarg,len) || !isSPACE(s[len]))
2319 Perl_croak(aTHX_ "Args must match #! line");
2322 if (PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
2323 PL_euid == PL_statbuf.st_uid)
2325 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2326 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2327 #endif /* IAMSUID */
2329 if (PL_euid) { /* oops, we're not the setuid root perl */
2330 (void)PerlIO_close(PL_rsfp);
2333 PerlProc_execv(Perl_form(aTHX_ "%s/sperl%s", BIN_EXP, PL_patchlevel), PL_origargv);
2335 Perl_croak(aTHX_ "Can't do setuid\n");
2338 if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
2340 (void)setegid(PL_statbuf.st_gid);
2343 (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
2345 #ifdef HAS_SETRESGID
2346 (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
2348 PerlProc_setgid(PL_statbuf.st_gid);
2352 if (PerlProc_getegid() != PL_statbuf.st_gid)
2353 Perl_croak(aTHX_ "Can't do setegid!\n");
2355 if (PL_statbuf.st_mode & S_ISUID) {
2356 if (PL_statbuf.st_uid != PL_euid)
2358 (void)seteuid(PL_statbuf.st_uid); /* all that for this */
2361 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
2363 #ifdef HAS_SETRESUID
2364 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
2366 PerlProc_setuid(PL_statbuf.st_uid);
2370 if (PerlProc_geteuid() != PL_statbuf.st_uid)
2371 Perl_croak(aTHX_ "Can't do seteuid!\n");
2373 else if (PL_uid) { /* oops, mustn't run as root */
2375 (void)seteuid((Uid_t)PL_uid);
2378 (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
2380 #ifdef HAS_SETRESUID
2381 (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
2383 PerlProc_setuid((Uid_t)PL_uid);
2387 if (PerlProc_geteuid() != PL_uid)
2388 Perl_croak(aTHX_ "Can't do seteuid!\n");
2391 if (!cando(S_IXUSR,TRUE,&PL_statbuf))
2392 Perl_croak(aTHX_ "Permission denied\n"); /* they can't do this */
2395 else if (PL_preprocess)
2396 Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
2397 else if (fdscript >= 0)
2398 Perl_croak(aTHX_ "fd script not allowed in suidperl\n");
2400 Perl_croak(aTHX_ "Script is not setuid/setgid in suidperl\n");
2402 /* We absolutely must clear out any saved ids here, so we */
2403 /* exec the real perl, substituting fd script for scriptname. */
2404 /* (We pass script name as "subdir" of fd, which perl will grok.) */
2405 PerlIO_rewind(PL_rsfp);
2406 PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0); /* just in case rewind didn't */
2407 for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
2408 if (!PL_origargv[which])
2409 Perl_croak(aTHX_ "Permission denied");
2410 PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
2411 PerlIO_fileno(PL_rsfp), PL_origargv[which]));
2412 #if defined(HAS_FCNTL) && defined(F_SETFD)
2413 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */
2415 PerlProc_execv(Perl_form(aTHX_ "%s/perl%s", BIN_EXP, PL_patchlevel), PL_origargv);/* try again */
2416 Perl_croak(aTHX_ "Can't do setuid\n");
2417 #endif /* IAMSUID */
2419 if (PL_euid != PL_uid || PL_egid != PL_gid) { /* (suidperl doesn't exist, in fact) */
2420 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2422 PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf); /* may be either wrapped or real suid */
2423 if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
2425 (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
2428 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2429 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2430 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2431 /* not set-id, must be wrapped */
2437 S_find_beginning(pTHX)
2439 register char *s, *s2;
2441 /* skip forward in input to the real script? */
2444 while (PL_doextract) {
2445 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
2446 Perl_croak(aTHX_ "No Perl script found in input\n");
2447 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2448 PerlIO_ungetc(PL_rsfp, '\n'); /* to keep line count right */
2449 PL_doextract = FALSE;
2450 while (*s && !(isSPACE (*s) || *s == '#')) s++;
2452 while (*s == ' ' || *s == '\t') s++;
2454 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2455 if (strnEQ(s2-4,"perl",4))
2457 while (s = moreswitches(s)) ;
2459 if (PL_cddir && PerlDir_chdir(PL_cddir) < 0)
2460 Perl_croak(aTHX_ "Can't chdir to %s",PL_cddir);
2469 PL_uid = (int)PerlProc_getuid();
2470 PL_euid = (int)PerlProc_geteuid();
2471 PL_gid = (int)PerlProc_getgid();
2472 PL_egid = (int)PerlProc_getegid();
2474 PL_uid |= PL_gid << 16;
2475 PL_euid |= PL_egid << 16;
2477 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2481 S_forbid_setid(pTHX_ char *s)
2483 if (PL_euid != PL_uid)
2484 Perl_croak(aTHX_ "No %s allowed while running setuid", s);
2485 if (PL_egid != PL_gid)
2486 Perl_croak(aTHX_ "No %s allowed while running setgid", s);
2490 S_init_debugger(pTHX)
2493 PL_curstash = PL_debstash;
2494 PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2495 AvREAL_off(PL_dbargs);
2496 PL_DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2497 PL_DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2498 PL_DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2499 PL_DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2500 sv_setiv(PL_DBsingle, 0);
2501 PL_DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2502 sv_setiv(PL_DBtrace, 0);
2503 PL_DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2504 sv_setiv(PL_DBsignal, 0);
2505 PL_curstash = PL_defstash;
2508 #ifndef STRESS_REALLOC
2509 #define REASONABLE(size) (size)
2511 #define REASONABLE(size) (1) /* unreasonable */
2515 Perl_init_stacks(pTHX)
2517 /* start with 128-item stack and 8K cxstack */
2518 PL_curstackinfo = new_stackinfo(REASONABLE(128),
2519 REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
2520 PL_curstackinfo->si_type = PERLSI_MAIN;
2521 PL_curstack = PL_curstackinfo->si_stack;
2522 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
2524 PL_stack_base = AvARRAY(PL_curstack);
2525 PL_stack_sp = PL_stack_base;
2526 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
2528 New(50,PL_tmps_stack,REASONABLE(128),SV*);
2531 PL_tmps_max = REASONABLE(128);
2533 New(54,PL_markstack,REASONABLE(32),I32);
2534 PL_markstack_ptr = PL_markstack;
2535 PL_markstack_max = PL_markstack + REASONABLE(32);
2539 New(54,PL_scopestack,REASONABLE(32),I32);
2540 PL_scopestack_ix = 0;
2541 PL_scopestack_max = REASONABLE(32);
2543 New(54,PL_savestack,REASONABLE(128),ANY);
2544 PL_savestack_ix = 0;
2545 PL_savestack_max = REASONABLE(128);
2547 New(54,PL_retstack,REASONABLE(16),OP*);
2549 PL_retstack_max = REASONABLE(16);
2558 while (PL_curstackinfo->si_next)
2559 PL_curstackinfo = PL_curstackinfo->si_next;
2560 while (PL_curstackinfo) {
2561 PERL_SI *p = PL_curstackinfo->si_prev;
2562 /* curstackinfo->si_stack got nuked by sv_free_arenas() */
2563 Safefree(PL_curstackinfo->si_cxstack);
2564 Safefree(PL_curstackinfo);
2565 PL_curstackinfo = p;
2567 Safefree(PL_tmps_stack);
2568 Safefree(PL_markstack);
2569 Safefree(PL_scopestack);
2570 Safefree(PL_savestack);
2571 Safefree(PL_retstack);
2573 Safefree(PL_debname);
2574 Safefree(PL_debdelim);
2579 static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
2590 lex_start(PL_linestr);
2592 PL_subname = newSVpvn("main",4);
2596 S_init_predump_symbols(pTHX)
2602 sv_setpvn(get_sv("\"", TRUE), " ", 1);
2603 PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2604 GvMULTI_on(PL_stdingv);
2605 IoIFP(GvIOp(PL_stdingv)) = PerlIO_stdin();
2606 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2608 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(PL_stdingv));
2610 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2612 IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
2614 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2616 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(PL_defoutgv));
2618 othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2619 GvMULTI_on(othergv);
2620 IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr();
2621 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2623 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
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);
2774 incpush(".", FALSE);
2778 # define PERLLIB_SEP ';'
2781 # define PERLLIB_SEP '|'
2783 # define PERLLIB_SEP ':'
2786 #ifndef PERLLIB_MANGLE
2787 # define PERLLIB_MANGLE(s,n) (s)
2791 S_incpush(pTHX_ char *p, int addsubdirs)
2793 SV *subdir = Nullsv;
2799 subdir = sv_newmortal();
2800 if (!PL_archpat_auto) {
2801 STRLEN len = (sizeof(ARCHNAME) + strlen(PL_patchlevel)
2802 + sizeof("//auto"));
2803 New(55, PL_archpat_auto, len, char);
2804 sprintf(PL_archpat_auto, "/%s/%s/auto", ARCHNAME, PL_patchlevel);
2806 for (len = sizeof(ARCHNAME) + 2;
2807 PL_archpat_auto[len] != '\0' && PL_archpat_auto[len] != '/'; len++)
2808 if (PL_archpat_auto[len] == '.') PL_archpat_auto[len] = '_';
2813 /* Break at all separators */
2815 SV *libdir = NEWSV(55,0);
2818 /* skip any consecutive separators */
2819 while ( *p == PERLLIB_SEP ) {
2820 /* Uncomment the next line for PATH semantics */
2821 /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */
2825 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2826 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2831 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2832 p = Nullch; /* break out */
2836 * BEFORE pushing libdir onto @INC we may first push version- and
2837 * archname-specific sub-directories.
2840 struct stat tmpstatbuf;
2845 if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) {
2847 while (unix[len-1] == '/') len--; /* Cosmetic */
2848 sv_usepvn(libdir,unix,len);
2851 PerlIO_printf(PerlIO_stderr(),
2852 "Failed to unixify @INC element \"%s\"\n",
2855 /* .../archname/version if -d .../archname/version/auto */
2856 sv_setsv(subdir, libdir);
2857 sv_catpv(subdir, PL_archpat_auto);
2858 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2859 S_ISDIR(tmpstatbuf.st_mode))
2860 av_push(GvAVn(PL_incgv),
2861 newSVpvn(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2863 /* .../archname if -d .../archname/auto */
2864 sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
2865 strlen(PL_patchlevel) + 1, "", 0);
2866 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2867 S_ISDIR(tmpstatbuf.st_mode))
2868 av_push(GvAVn(PL_incgv),
2869 newSVpvn(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2872 /* finally push this lib directory on the end of @INC */
2873 av_push(GvAVn(PL_incgv), libdir);
2878 STATIC struct perl_thread *
2879 S_init_main_thread(pTHX)
2881 #ifndef PERL_IMPLICIT_CONTEXT
2882 struct perl_thread *thr;
2886 Newz(53, thr, 1, struct perl_thread);
2887 PL_curcop = &PL_compiling;
2888 thr->cvcache = newHV();
2889 thr->threadsv = newAV();
2890 /* thr->threadsvp is set when find_threadsv is called */
2891 thr->specific = newAV();
2892 thr->errhv = newHV();
2893 thr->flags = THRf_R_JOINABLE;
2894 MUTEX_INIT(&thr->mutex);
2895 /* Handcraft thrsv similarly to mess_sv */
2896 New(53, PL_thrsv, 1, SV);
2897 Newz(53, xpv, 1, XPV);
2898 SvFLAGS(PL_thrsv) = SVt_PV;
2899 SvANY(PL_thrsv) = (void*)xpv;
2900 SvREFCNT(PL_thrsv) = 1 << 30; /* practically infinite */
2901 SvPVX(PL_thrsv) = (char*)thr;
2902 SvCUR_set(PL_thrsv, sizeof(thr));
2903 SvLEN_set(PL_thrsv, sizeof(thr));
2904 *SvEND(PL_thrsv) = '\0'; /* in the trailing_nul field */
2905 thr->oursv = PL_thrsv;
2906 PL_chopset = " \n-";
2909 MUTEX_LOCK(&PL_threads_mutex);
2914 MUTEX_UNLOCK(&PL_threads_mutex);
2916 #ifdef HAVE_THREAD_INTERN
2917 Perl_init_thread_intern(thr);
2920 #ifdef SET_THREAD_SELF
2921 SET_THREAD_SELF(thr);
2923 thr->self = pthread_self();
2924 #endif /* SET_THREAD_SELF */
2928 * These must come after the SET_THR because sv_setpvn does
2929 * SvTAINT and the taint fields require dTHR.
2931 PL_toptarget = NEWSV(0,0);
2932 sv_upgrade(PL_toptarget, SVt_PVFM);
2933 sv_setpvn(PL_toptarget, "", 0);
2934 PL_bodytarget = NEWSV(0,0);
2935 sv_upgrade(PL_bodytarget, SVt_PVFM);
2936 sv_setpvn(PL_bodytarget, "", 0);
2937 PL_formtarget = PL_bodytarget;
2938 thr->errsv = newSVpvn("", 0);
2939 (void) find_threadsv("@"); /* Ensure $@ is initialised early */
2942 PL_regcompp = FUNC_NAME_TO_PTR(Perl_pregcomp);
2943 PL_regexecp = FUNC_NAME_TO_PTR(Perl_regexec_flags);
2945 PL_reginterp_cnt = 0;
2949 #endif /* USE_THREADS */
2952 Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
2956 line_t oldline = PL_curcop->cop_line;
2961 while (AvFILL(paramList) >= 0) {
2962 cv = (CV*)av_shift(paramList);
2964 CALLPROTECT(aTHX_ &ret, FUNC_NAME_TO_PTR(S_call_list_body), cv);
2967 (void)SvPV(atsv, len);
2969 PL_curcop = &PL_compiling;
2970 PL_curcop->cop_line = oldline;
2971 if (paramList == PL_beginav)
2972 sv_catpv(atsv, "BEGIN failed--compilation aborted");
2974 sv_catpv(atsv, "END failed--cleanup aborted");
2975 while (PL_scopestack_ix > oldscope)
2977 Perl_croak(aTHX_ "%s", SvPVX(atsv));
2984 /* my_exit() was called */
2985 while (PL_scopestack_ix > oldscope)
2988 PL_curstash = PL_defstash;
2990 call_list(oldscope, PL_endav);
2991 PL_curcop = &PL_compiling;
2992 PL_curcop->cop_line = oldline;
2993 if (PL_statusvalue) {
2994 if (paramList == PL_beginav)
2995 Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
2997 Perl_croak(aTHX_ "END failed--cleanup aborted");
3003 PL_curcop = &PL_compiling;
3004 PL_curcop->cop_line = oldline;
3007 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
3015 S_call_list_body(pTHX_ va_list args)
3018 CV *cv = va_arg(args, CV*);
3020 PUSHMARK(PL_stack_sp);
3021 call_sv((SV*)cv, G_EVAL|G_DISCARD);
3026 Perl_my_exit(pTHX_ U32 status)
3030 DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
3031 thr, (unsigned long) status));
3040 STATUS_NATIVE_SET(status);
3047 Perl_my_failure_exit(pTHX)
3050 if (vaxc$errno & 1) {
3051 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
3052 STATUS_NATIVE_SET(44);
3055 if (!vaxc$errno && errno) /* unlikely */
3056 STATUS_NATIVE_SET(44);
3058 STATUS_NATIVE_SET(vaxc$errno);
3063 STATUS_POSIX_SET(errno);
3065 exitstatus = STATUS_POSIX >> 8;
3066 if (exitstatus & 255)
3067 STATUS_POSIX_SET(exitstatus);
3069 STATUS_POSIX_SET(255);
3076 S_my_exit_jump(pTHX)
3079 register PERL_CONTEXT *cx;
3084 SvREFCNT_dec(PL_e_script);
3085 PL_e_script = Nullsv;
3088 POPSTACK_TO(PL_mainstack);
3089 if (cxstack_ix >= 0) {
3092 POPBLOCK(cx,PL_curpm);
3101 #endif /* PERL_OBJECT */
3106 read_e_script(pTHXo_ int idx, SV *buf_sv, int maxlen)
3109 p = SvPVX(PL_e_script);
3110 nl = strchr(p, '\n');
3111 nl = (nl) ? nl+1 : SvEND(PL_e_script);
3113 filter_del(read_e_script);
3116 sv_catpvn(buf_sv, p, nl-p);
3117 sv_chop(PL_e_script, nl);