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 && ckWARN_d(WARN_INTERNAL)) {
452 if (PL_scopestack_ix != 0)
453 Perl_warner(aTHX_ WARN_INTERNAL,
454 "Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
455 (long)PL_scopestack_ix);
456 if (PL_savestack_ix != 0)
457 Perl_warner(aTHX_ WARN_INTERNAL,
458 "Unbalanced saves: %ld more saves than restores\n",
459 (long)PL_savestack_ix);
460 if (PL_tmps_floor != -1)
461 Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced tmps: %ld more allocs than frees\n",
462 (long)PL_tmps_floor + 1);
463 if (cxstack_ix != -1)
464 Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced context: %ld more PUSHes than POPs\n",
465 (long)cxstack_ix + 1);
468 /* Now absolutely destruct everything, somehow or other, loops or no. */
470 SvFLAGS(PL_strtab) |= SVTYPEMASK; /* don't clean out strtab now */
471 while (PL_sv_count != 0 && PL_sv_count != last_sv_count) {
472 last_sv_count = PL_sv_count;
475 SvFLAGS(PL_strtab) &= ~SVTYPEMASK;
476 SvFLAGS(PL_strtab) |= SVt_PVHV;
478 /* Destruct the global string table. */
480 /* Yell and reset the HeVAL() slots that are still holding refcounts,
481 * so that sv_free() won't fail on them.
489 max = HvMAX(PL_strtab);
490 array = HvARRAY(PL_strtab);
493 if (hent && ckWARN_d(WARN_INTERNAL)) {
494 Perl_warner(aTHX_ WARN_INTERNAL,
495 "Unbalanced string table refcount: (%d) for \"%s\"",
496 HeVAL(hent) - Nullsv, HeKEY(hent));
497 HeVAL(hent) = Nullsv;
507 SvREFCNT_dec(PL_strtab);
509 if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL))
510 Perl_warner(aTHX_ WARN_INTERNAL,"Scalars leaked: %ld\n", (long)PL_sv_count);
514 /* No SVs have survived, need to clean out */
516 PL_pidstatus = Nullhv;
517 Safefree(PL_origfilename);
518 Safefree(PL_archpat_auto);
519 Safefree(PL_reg_start_tmp);
521 Safefree(PL_reg_curpm);
522 Safefree(HeKEY_hek(&PL_hv_fetch_ent_mh));
523 Safefree(PL_op_mask);
525 PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */
527 DEBUG_P(debprofdump());
529 MUTEX_DESTROY(&PL_strtab_mutex);
530 MUTEX_DESTROY(&PL_sv_mutex);
531 MUTEX_DESTROY(&PL_eval_mutex);
532 MUTEX_DESTROY(&PL_cred_mutex);
533 COND_DESTROY(&PL_eval_cond);
534 #ifdef EMULATE_ATOMIC_REFCOUNTS
535 MUTEX_DESTROY(&PL_svref_mutex);
536 #endif /* EMULATE_ATOMIC_REFCOUNTS */
538 /* As the penultimate thing, free the non-arena SV for thrsv */
539 Safefree(SvPVX(PL_thrsv));
540 Safefree(SvANY(PL_thrsv));
543 #endif /* USE_THREADS */
545 /* As the absolutely last thing, free the non-arena SV for mess() */
548 /* it could have accumulated taint magic */
549 if (SvTYPE(PL_mess_sv) >= SVt_PVMG) {
552 for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) {
553 moremagic = mg->mg_moremagic;
554 if (mg->mg_ptr && mg->mg_type != 'g' && mg->mg_len >= 0)
555 Safefree(mg->mg_ptr);
559 /* we know that type >= SVt_PV */
560 SvOOK_off(PL_mess_sv);
561 Safefree(SvPVX(PL_mess_sv));
562 Safefree(SvANY(PL_mess_sv));
563 Safefree(PL_mess_sv);
574 # if !defined(PERL_IMPLICIT_CONTEXT)
575 if (!(PL_curinterp = my_perl))
583 Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
585 Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry);
586 PL_exitlist[PL_exitlistlen].fn = fn;
587 PL_exitlist[PL_exitlistlen].ptr = ptr;
592 perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
601 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
604 Perl_croak(aTHX_ "suidperl is no longer needed since the kernel can now execute\n\
605 setuid perl scripts securely.\n");
609 #if !defined(PERL_OBJECT) && !defined(PERL_IMPLICIT_CONTEXT)
610 if (!(PL_curinterp = my_perl))
614 #if defined(__DYNAMIC__) && (defined(NeXT) || defined(__NeXT__))
615 _dyld_lookup_and_bind
616 ("__environ", (unsigned long *) &environ_pointer, NULL);
621 #ifndef VMS /* VMS doesn't have environ array */
622 PL_origenviron = environ;
627 /* Come here if running an undumped a.out. */
629 PL_origfilename = savepv(argv[0]);
630 PL_do_undump = FALSE;
631 cxstack_ix = -1; /* start label stack again */
633 init_postdump_symbols(argc,argv,env);
638 PL_curpad = AvARRAY(PL_comppad);
639 op_free(PL_main_root);
640 PL_main_root = Nullop;
642 PL_main_start = Nullop;
643 SvREFCNT_dec(PL_main_cv);
647 oldscope = PL_scopestack_ix;
648 PL_dowarn = G_WARN_OFF;
650 CALLPROTECT(aTHX_ &ret, FUNC_NAME_TO_PTR(S_parse_body), env, xsinit);
658 /* my_exit() was called */
659 while (PL_scopestack_ix > oldscope)
662 PL_curstash = PL_defstash;
664 call_list(oldscope, PL_endav);
665 return STATUS_NATIVE_EXPORT;
667 PerlIO_printf(PerlIO_stderr(), "panic: top_env\n");
674 S_parse_body(pTHX_ va_list args)
677 int argc = PL_origargc;
678 char **argv = PL_origargv;
679 char **env = va_arg(args, char**);
680 char *scriptname = NULL;
682 VOL bool dosearch = FALSE;
688 XSINIT_t xsinit = va_arg(args, XSINIT_t);
690 sv_setpvn(PL_linestr,"",0);
691 sv = newSVpvn("",0); /* first used for -I flags */
695 for (argc--,argv++; argc > 0; argc--,argv++) {
696 if (argv[0][0] != '-' || !argv[0][1])
700 validarg = " PHOOEY ";
707 #ifndef PERL_STRICT_CR
731 if (s = moreswitches(s))
741 if (PL_euid != PL_uid || PL_egid != PL_gid)
742 Perl_croak(aTHX_ "No -e allowed in setuid scripts");
744 PL_e_script = newSVpvn("",0);
745 filter_add(read_e_script, NULL);
748 sv_catpv(PL_e_script, s);
750 sv_catpv(PL_e_script, argv[1]);
754 Perl_croak(aTHX_ "No code specified for -e");
755 sv_catpv(PL_e_script, "\n");
758 case 'I': /* -I handled both here and in moreswitches() */
760 if (!*++s && (s=argv[1]) != Nullch) {
763 while (s && isSPACE(*s))
767 for (e = s; *e && !isSPACE(*e); e++) ;
774 } /* XXX else croak? */
778 PL_preprocess = TRUE;
788 PL_preambleav = newAV();
789 av_push(PL_preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
791 PL_Sv = newSVpv("print myconfig();",0);
793 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
795 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
797 #if defined(DEBUGGING) || defined(MULTIPLICITY)
798 sv_catpv(PL_Sv,"\" Compile-time options:");
800 sv_catpv(PL_Sv," DEBUGGING");
803 sv_catpv(PL_Sv," MULTIPLICITY");
805 sv_catpv(PL_Sv,"\\n\",");
807 #if defined(LOCAL_PATCH_COUNT)
808 if (LOCAL_PATCH_COUNT > 0) {
810 sv_catpv(PL_Sv,"\" Locally applied patches:\\n\",");
811 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
812 if (PL_localpatches[i])
813 Perl_sv_catpvf(aTHX_ PL_Sv,"q\" \t%s\n\",",PL_localpatches[i]);
817 Perl_sv_catpvf(aTHX_ PL_Sv,"\" Built under %s\\n\"",OSNAME);
820 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
822 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled on %s\\n\"",__DATE__);
827 @env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; \
828 print \" \\%ENV:\\n @env\\n\" if @env; \
829 print \" \\@INC:\\n @INC\\n\";");
832 PL_Sv = newSVpv("config_vars(qw(",0);
833 sv_catpv(PL_Sv, ++s);
834 sv_catpv(PL_Sv, "))");
837 av_push(PL_preambleav, PL_Sv);
838 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
844 PL_cddir = savepv(s);
849 if (!*++s || isSPACE(*s)) {
853 /* catch use of gnu style long options */
854 if (strEQ(s, "version")) {
858 if (strEQ(s, "help")) {
865 Perl_croak(aTHX_ "Unrecognized switch: -%s (-h will show valid options)",s);
871 #ifndef SECURE_INTERNAL_GETENV
874 (s = PerlEnv_getenv("PERL5OPT"))) {
877 if (*s == '-' && *(s+1) == 'T')
890 if (!strchr("DIMUdmw", *s))
891 Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
898 scriptname = argv[0];
901 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
903 else if (scriptname == Nullch) {
905 if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
913 open_script(scriptname,dosearch,sv,&fdscript);
915 validate_suid(validarg, scriptname,fdscript);
920 PL_main_cv = PL_compcv = (CV*)NEWSV(1104,0);
921 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
922 CvUNIQUE_on(PL_compcv);
924 PL_comppad = newAV();
925 av_push(PL_comppad, Nullsv);
926 PL_curpad = AvARRAY(PL_comppad);
927 PL_comppad_name = newAV();
928 PL_comppad_name_fill = 0;
929 PL_min_intro_pending = 0;
932 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
933 PL_curpad[0] = (SV*)newAV();
934 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
935 CvOWNER(PL_compcv) = 0;
936 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
937 MUTEX_INIT(CvMUTEXP(PL_compcv));
938 #endif /* USE_THREADS */
940 comppadlist = newAV();
941 AvREAL_off(comppadlist);
942 av_store(comppadlist, 0, (SV*)PL_comppad_name);
943 av_store(comppadlist, 1, (SV*)PL_comppad);
944 CvPADLIST(PL_compcv) = comppadlist;
946 boot_core_UNIVERSAL();
949 (*xsinit)(aTHXo); /* in case linked C routines want magical variables */
950 #if defined(VMS) || defined(WIN32) || defined(DJGPP)
951 init_os_extras(aTHX);
958 init_predump_symbols();
959 /* init_postdump_symbols not currently designed to be called */
960 /* more than once (ENV isn't cleared first, for example) */
961 /* But running with -u leaves %ENV & @ARGV undefined! XXX */
963 init_postdump_symbols(argc,argv,env);
967 /* now parse the script */
969 SETERRNO(0,SS$_NORMAL);
971 if (yyparse() || PL_error_count) {
973 Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
975 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
979 PL_curcop->cop_line = 0;
980 PL_curstash = PL_defstash;
981 PL_preprocess = FALSE;
983 SvREFCNT_dec(PL_e_script);
984 PL_e_script = Nullsv;
987 /* now that script is parsed, we can modify record separator */
989 PL_rs = SvREFCNT_inc(PL_nrs);
990 sv_setsv(get_sv("/", TRUE), PL_rs);
995 gv_check(PL_defstash);
1001 if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
1002 dump_mstats("after compilation:");
1020 #if !defined(PERL_OBJECT) && !defined(PERL_IMPLICIT_CONTEXT)
1021 if (!(PL_curinterp = my_perl))
1025 oldscope = PL_scopestack_ix;
1028 CALLPROTECT(aTHX_ &ret, FUNC_NAME_TO_PTR(S_run_body), oldscope);
1031 cxstack_ix = -1; /* start context stack again */
1033 case 0: /* normal completion */
1034 case 2: /* my_exit() */
1035 while (PL_scopestack_ix > oldscope)
1038 PL_curstash = PL_defstash;
1040 call_list(oldscope, PL_endav);
1042 if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
1043 dump_mstats("after execution: ");
1045 return STATUS_NATIVE_EXPORT;
1048 POPSTACK_TO(PL_mainstack);
1051 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
1061 S_run_body(pTHX_ va_list args)
1064 I32 oldscope = va_arg(args, I32);
1066 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
1067 PL_sawampersand ? "Enabling" : "Omitting"));
1069 if (!PL_restartop) {
1070 DEBUG_x(dump_all());
1071 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
1072 DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%lx\n",
1073 (unsigned long) thr));
1076 PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", PL_origfilename);
1079 if (PERLDB_SINGLE && PL_DBsingle)
1080 sv_setiv(PL_DBsingle, 1);
1082 call_list(oldscope, PL_initav);
1088 PL_op = PL_restartop;
1092 else if (PL_main_start) {
1093 CvDEPTH(PL_main_cv) = 1;
1094 PL_op = PL_main_start;
1104 Perl_get_sv(pTHX_ const char *name, I32 create)
1108 if (name[1] == '\0' && !isALPHA(name[0])) {
1109 PADOFFSET tmp = find_threadsv(name);
1110 if (tmp != NOT_IN_PAD) {
1112 return THREADSV(tmp);
1115 #endif /* USE_THREADS */
1116 gv = gv_fetchpv(name, create, SVt_PV);
1123 Perl_get_av(pTHX_ const char *name, I32 create)
1125 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1134 Perl_get_hv(pTHX_ const char *name, I32 create)
1136 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1145 Perl_get_cv(pTHX_ const char *name, I32 create)
1147 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
1148 /* XXX unsafe for threads if eval_owner isn't held */
1149 /* XXX this is probably not what they think they're getting.
1150 * It has the same effect as "sub name;", i.e. just a forward
1152 if (create && !GvCVu(gv))
1153 return newSUB(start_subparse(FALSE, 0),
1154 newSVOP(OP_CONST, 0, newSVpv(name,0)),
1162 /* Be sure to refetch the stack pointer after calling these routines. */
1165 Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv)
1167 /* See G_* flags in cop.h */
1168 /* null terminated arg list */
1175 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
1180 return call_pv(sub_name, flags);
1184 Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
1185 /* name of the subroutine */
1186 /* See G_* flags in cop.h */
1188 return call_sv((SV*)get_cv(sub_name, TRUE), flags);
1192 Perl_call_method(pTHX_ const char *methname, I32 flags)
1193 /* name of the subroutine */
1194 /* See G_* flags in cop.h */
1200 XPUSHs(sv_2mortal(newSVpv(methname,0)));
1205 return call_sv(*PL_stack_sp--, flags);
1208 /* May be called with any of a CV, a GV, or an SV containing the name. */
1210 Perl_call_sv(pTHX_ SV *sv, I32 flags)
1212 /* See G_* flags in cop.h */
1215 LOGOP myop; /* fake syntax tree node */
1219 bool oldcatch = CATCH_GET;
1223 if (flags & G_DISCARD) {
1228 Zero(&myop, 1, LOGOP);
1229 myop.op_next = Nullop;
1230 if (!(flags & G_NOARGS))
1231 myop.op_flags |= OPf_STACKED;
1232 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1233 (flags & G_ARRAY) ? OPf_WANT_LIST :
1238 EXTEND(PL_stack_sp, 1);
1239 *++PL_stack_sp = sv;
1241 oldscope = PL_scopestack_ix;
1243 if (PERLDB_SUB && PL_curstash != PL_debstash
1244 /* Handle first BEGIN of -d. */
1245 && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
1246 /* Try harder, since this may have been a sighandler, thus
1247 * curstash may be meaningless. */
1248 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != PL_debstash)
1249 && !(flags & G_NODEBUG))
1250 PL_op->op_private |= OPpENTERSUB_DB;
1252 if (!(flags & G_EVAL)) {
1254 call_xbody((OP*)&myop, FALSE);
1255 retval = PL_stack_sp - (PL_stack_base + oldmark);
1259 cLOGOP->op_other = PL_op;
1261 /* we're trying to emulate pp_entertry() here */
1263 register PERL_CONTEXT *cx;
1264 I32 gimme = GIMME_V;
1269 push_return(PL_op->op_next);
1270 PUSHBLOCK(cx, CXt_EVAL, PL_stack_sp);
1272 PL_eval_root = PL_op; /* Only needed so that goto works right. */
1274 PL_in_eval = EVAL_INEVAL;
1275 if (flags & G_KEEPERR)
1276 PL_in_eval |= EVAL_KEEPERR;
1283 CALLPROTECT(aTHX_ &ret, FUNC_NAME_TO_PTR(S_call_body), (OP*)&myop, FALSE);
1286 retval = PL_stack_sp - (PL_stack_base + oldmark);
1287 if (!(flags & G_KEEPERR))
1294 /* my_exit() was called */
1295 PL_curstash = PL_defstash;
1298 Perl_croak(aTHX_ "Callback called exit");
1303 PL_op = PL_restartop;
1307 PL_stack_sp = PL_stack_base + oldmark;
1308 if (flags & G_ARRAY)
1312 *++PL_stack_sp = &PL_sv_undef;
1317 if (PL_scopestack_ix > oldscope) {
1321 register PERL_CONTEXT *cx;
1332 if (flags & G_DISCARD) {
1333 PL_stack_sp = PL_stack_base + oldmark;
1343 S_call_body(pTHX_ va_list args)
1345 OP *myop = va_arg(args, OP*);
1346 int is_eval = va_arg(args, int);
1348 call_xbody(myop, is_eval);
1353 S_call_xbody(pTHX_ OP *myop, int is_eval)
1357 if (PL_op == myop) {
1359 PL_op = Perl_pp_entereval(aTHX);
1361 PL_op = Perl_pp_entersub(aTHX);
1367 /* Eval a string. The G_EVAL flag is always assumed. */
1370 Perl_eval_sv(pTHX_ SV *sv, I32 flags)
1372 /* See G_* flags in cop.h */
1375 UNOP myop; /* fake syntax tree node */
1376 I32 oldmark = SP - PL_stack_base;
1382 if (flags & G_DISCARD) {
1389 Zero(PL_op, 1, UNOP);
1390 EXTEND(PL_stack_sp, 1);
1391 *++PL_stack_sp = sv;
1392 oldscope = PL_scopestack_ix;
1394 if (!(flags & G_NOARGS))
1395 myop.op_flags = OPf_STACKED;
1396 myop.op_next = Nullop;
1397 myop.op_type = OP_ENTEREVAL;
1398 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1399 (flags & G_ARRAY) ? OPf_WANT_LIST :
1401 if (flags & G_KEEPERR)
1402 myop.op_flags |= OPf_SPECIAL;
1405 CALLPROTECT(aTHX_ &ret, FUNC_NAME_TO_PTR(S_call_body), (OP*)&myop, TRUE);
1408 retval = PL_stack_sp - (PL_stack_base + oldmark);
1409 if (!(flags & G_KEEPERR))
1416 /* my_exit() was called */
1417 PL_curstash = PL_defstash;
1420 Perl_croak(aTHX_ "Callback called exit");
1425 PL_op = PL_restartop;
1429 PL_stack_sp = PL_stack_base + oldmark;
1430 if (flags & G_ARRAY)
1434 *++PL_stack_sp = &PL_sv_undef;
1439 if (flags & G_DISCARD) {
1440 PL_stack_sp = PL_stack_base + oldmark;
1450 Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
1453 SV* sv = newSVpv(p, 0);
1456 eval_sv(sv, G_SCALAR);
1463 if (croak_on_error && SvTRUE(ERRSV)) {
1465 Perl_croak(aTHX_ SvPVx(ERRSV, n_a));
1471 /* Require a module. */
1474 Perl_require_pv(pTHX_ const char *pv)
1478 PUSHSTACKi(PERLSI_REQUIRE);
1480 sv = sv_newmortal();
1481 sv_setpv(sv, "require '");
1484 eval_sv(sv, G_DISCARD);
1490 Perl_magicname(pTHX_ char *sym, char *name, I32 namlen)
1494 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1495 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1499 S_usage(pTHX_ char *name) /* XXX move this out into a module ? */
1501 /* This message really ought to be max 23 lines.
1502 * Removed -h because the user already knows that opton. Others? */
1504 static char *usage_msg[] = {
1505 "-0[octal] specify record separator (\\0, if no argument)",
1506 "-a autosplit mode with -n or -p (splits $_ into @F)",
1507 "-c check syntax only (runs BEGIN and END blocks)",
1508 "-d[:debugger] run program under debugger",
1509 "-D[number/list] set debugging flags (argument is a bit mask or alphabets)",
1510 "-e 'command' one line of program (several -e's allowed, omit programfile)",
1511 "-F/pattern/ split() pattern for -a switch (//'s are optional)",
1512 "-i[extension] edit <> files in place (makes backup if extension supplied)",
1513 "-Idirectory specify @INC/#include directory (several -I's allowed)",
1514 "-l[octal] enable line ending processing, specifies line terminator",
1515 "-[mM][-]module execute `use/no module...' before executing program",
1516 "-n assume 'while (<>) { ... }' loop around program",
1517 "-p assume loop like -n but print line also, like sed",
1518 "-P run program through C preprocessor before compilation",
1519 "-s enable rudimentary parsing for switches after programfile",
1520 "-S look for programfile using PATH environment variable",
1521 "-T enable tainting checks",
1522 "-u dump core after parsing program",
1523 "-U allow unsafe operations",
1524 "-v print version, subversion (includes VERY IMPORTANT perl info)",
1525 "-V[:variable] print configuration summary (or a single Config.pm variable)",
1526 "-w enable many useful warnings (RECOMMENDED)",
1527 "-x[directory] strip off text before #!perl line and perhaps cd to directory",
1531 char **p = usage_msg;
1533 printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1535 printf("\n %s", *p++);
1538 /* This routine handles any switches that can be given during run */
1541 Perl_moreswitches(pTHX_ char *s)
1550 rschar = scan_oct(s, 4, &numlen);
1551 SvREFCNT_dec(PL_nrs);
1552 if (rschar & ~((U8)~0))
1553 PL_nrs = &PL_sv_undef;
1554 else if (!rschar && numlen >= 2)
1555 PL_nrs = newSVpvn("", 0);
1558 PL_nrs = newSVpvn(&ch, 1);
1564 PL_splitstr = savepv(s + 1);
1578 if (*s == ':' || *s == '=') {
1579 my_setenv("PERL5DB", Perl_form(aTHX_ "use Devel::%s;", ++s));
1583 PL_perldb = PERLDB_ALL;
1591 if (isALPHA(s[1])) {
1592 static char debopts[] = "psltocPmfrxuLHXDS";
1595 for (s++; *s && (d = strchr(debopts,*s)); s++)
1596 PL_debug |= 1 << (d - debopts);
1599 PL_debug = atoi(s+1);
1600 for (s++; isDIGIT(*s); s++) ;
1602 PL_debug |= 0x80000000;
1605 if (ckWARN_d(WARN_DEBUGGING))
1606 Perl_warner(aTHX_ WARN_DEBUGGING,
1607 "Recompile perl with -DDEBUGGING to use -D switch\n");
1608 for (s++; isALNUM(*s); s++) ;
1614 usage(PL_origargv[0]);
1618 Safefree(PL_inplace);
1619 PL_inplace = savepv(s+1);
1621 for (s = PL_inplace; *s && !isSPACE(*s); s++) ;
1624 if (*s == '-') /* Additional switches on #! line. */
1628 case 'I': /* -I handled both here and in parse_perl() */
1631 while (*s && isSPACE(*s))
1635 for (e = s; *e && !isSPACE(*e); e++) ;
1636 p = savepvn(s, e-s);
1642 Perl_croak(aTHX_ "No space allowed after -I");
1650 PL_ors = savepv("\n");
1652 *PL_ors = scan_oct(s, 3 + (*s == '0'), &numlen);
1657 if (RsPARA(PL_nrs)) {
1662 PL_ors = SvPV(PL_nrs, PL_orslen);
1663 PL_ors = savepvn(PL_ors, PL_orslen);
1667 forbid_setid("-M"); /* XXX ? */
1670 forbid_setid("-m"); /* XXX ? */
1675 /* -M-foo == 'no foo' */
1676 if (*s == '-') { use = "no "; ++s; }
1677 sv = newSVpv(use,0);
1679 /* We allow -M'Module qw(Foo Bar)' */
1680 while(isALNUM(*s) || *s==':') ++s;
1682 sv_catpv(sv, start);
1683 if (*(start-1) == 'm') {
1685 Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
1686 sv_catpv( sv, " ()");
1689 sv_catpvn(sv, start, s-start);
1690 sv_catpv(sv, " split(/,/,q{");
1695 if (PL_preambleav == NULL)
1696 PL_preambleav = newAV();
1697 av_push(PL_preambleav, sv);
1700 Perl_croak(aTHX_ "No space allowed after -%c", *(s-1));
1712 PL_doswitches = TRUE;
1717 Perl_croak(aTHX_ "Too late for \"-T\" option");
1721 PL_do_undump = TRUE;
1729 #if defined(PERL_SUBVERSION) && PERL_SUBVERSION > 0
1730 printf("\nThis is perl, version %d.%03d_%02d built for %s",
1731 PERL_REVISION, PERL_VERSION, PERL_SUBVERSION, ARCHNAME);
1733 printf("\nThis is perl, version %s built for %s",
1734 PL_patchlevel, ARCHNAME);
1736 #if defined(LOCAL_PATCH_COUNT)
1737 if (LOCAL_PATCH_COUNT > 0)
1738 printf("\n(with %d registered patch%s, see perl -V for more detail)",
1739 LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : "");
1742 printf("\n\nCopyright 1987-1999, Larry Wall\n");
1744 printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1747 printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
1748 printf("djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
1751 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1752 "Version 5 port Copyright (c) 1994-1999, Andreas Kaiser, Ilya Zakharevich\n");
1755 printf("atariST series port, ++jrb bammi@cadence.com\n");
1758 printf("BeOS port Copyright Tom Spindler, 1997-1999\n");
1761 printf("MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-1999\n");
1764 printf("MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
1767 printf("Stratus VOS port by Paul_Green@stratus.com, 1997-1999\n");
1770 printf("VM/ESA port by Neale Ferguson, 1998-1999\n");
1773 printf("BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
1776 printf("MiNT port by Guido Flohr, 1997-1999\n");
1778 #ifdef BINARY_BUILD_NOTICE
1779 BINARY_BUILD_NOTICE;
1782 Perl may be copied only under the terms of either the Artistic License or the\n\
1783 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n\
1784 Complete documentation for Perl, including FAQ lists, should be found on\n\
1785 this system using `man perl' or `perldoc perl'. If you have access to the\n\
1786 Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
1789 if (! (PL_dowarn & G_WARN_ALL_MASK))
1790 PL_dowarn |= G_WARN_ON;
1794 PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
1795 PL_compiling.cop_warnings = WARN_ALL ;
1799 PL_dowarn = G_WARN_ALL_OFF;
1800 PL_compiling.cop_warnings = WARN_NONE ;
1805 if (s[1] == '-') /* Additional switches on #! line. */
1810 #if defined(WIN32) || !defined(PERL_STRICT_CR)
1816 #ifdef ALTERNATE_SHEBANG
1817 case 'S': /* OS/2 needs -S on "extproc" line. */
1825 Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
1830 /* compliments of Tom Christiansen */
1832 /* unexec() can be found in the Gnu emacs distribution */
1833 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
1836 Perl_my_unexec(pTHX)
1844 prog = newSVpv(BIN_EXP, 0);
1845 sv_catpv(prog, "/perl");
1846 file = newSVpv(PL_origfilename, 0);
1847 sv_catpv(file, ".perldump");
1849 unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
1850 /* unexec prints msg to stderr in case of failure */
1851 PerlProc_exit(status);
1854 # include <lib$routines.h>
1855 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
1857 ABORT(); /* for use with undump */
1862 /* initialize curinterp */
1867 #ifdef PERL_OBJECT /* XXX kludge */
1870 PL_chopset = " \n-"; \
1871 PL_copline = NOLINE; \
1872 PL_curcop = &PL_compiling;\
1873 PL_curcopdb = NULL; \
1876 PL_dumpindent = 4; \
1877 PL_laststatval = -1; \
1878 PL_laststype = OP_STAT; \
1879 PL_maxscream = -1; \
1880 PL_maxsysfd = MAXSYSFD; \
1881 PL_statname = Nullsv; \
1882 PL_tmps_floor = -1; \
1884 PL_op_mask = NULL; \
1886 PL_laststatval = -1; \
1887 PL_laststype = OP_STAT; \
1888 PL_mess_sv = Nullsv; \
1889 PL_splitstr = " "; \
1890 PL_generation = 100; \
1891 PL_exitlist = NULL; \
1892 PL_exitlistlen = 0; \
1894 PL_in_clean_objs = FALSE; \
1895 PL_in_clean_all = FALSE; \
1896 PL_profiledata = NULL; \
1898 PL_rsfp_filters = Nullav; \
1903 # ifdef MULTIPLICITY
1904 # define PERLVAR(var,type)
1905 # define PERLVARA(var,n,type)
1906 # if defined(PERL_IMPLICIT_CONTEXT)
1907 # define PERLVARI(var,type,init) my_perl->var = init;
1908 # define PERLVARIC(var,type,init) my_perl->var = init;
1910 # define PERLVARI(var,type,init) PL_curinterp->var = init;
1911 # define PERLVARIC(var,type,init) PL_curinterp->var = init;
1913 # include "intrpvar.h"
1914 # ifndef USE_THREADS
1915 # include "thrdvar.h"
1922 # define PERLVAR(var,type)
1923 # define PERLVARA(var,n,type)
1924 # define PERLVARI(var,type,init) PL_##var = init;
1925 # define PERLVARIC(var,type,init) PL_##var = init;
1926 # include "intrpvar.h"
1927 # ifndef USE_THREADS
1928 # include "thrdvar.h"
1940 S_init_main_stash(pTHX)
1945 /* Note that strtab is a rather special HV. Assumptions are made
1946 about not iterating on it, and not adding tie magic to it.
1947 It is properly deallocated in perl_destruct() */
1948 PL_strtab = newHV();
1950 MUTEX_INIT(&PL_strtab_mutex);
1952 HvSHAREKEYS_off(PL_strtab); /* mandatory */
1953 hv_ksplit(PL_strtab, 512);
1955 PL_curstash = PL_defstash = newHV();
1956 PL_curstname = newSVpvn("main",4);
1957 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1958 SvREFCNT_dec(GvHV(gv));
1959 GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
1961 HvNAME(PL_defstash) = savepv("main");
1962 PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1963 GvMULTI_on(PL_incgv);
1964 PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
1965 GvMULTI_on(PL_hintgv);
1966 PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1967 PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1968 GvMULTI_on(PL_errgv);
1969 PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
1970 GvMULTI_on(PL_replgv);
1971 (void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */
1972 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
1973 sv_setpvn(ERRSV, "", 0);
1974 PL_curstash = PL_defstash;
1975 PL_compiling.cop_stash = PL_defstash;
1976 PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
1977 PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
1978 /* We must init $/ before switches are processed. */
1979 sv_setpvn(get_sv("/", TRUE), "\n", 1);
1983 S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
1991 PL_origfilename = savepv("-e");
1994 /* if find_script() returns, it returns a malloc()-ed value */
1995 PL_origfilename = scriptname = find_script(scriptname, dosearch, NULL, 1);
1997 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
1998 char *s = scriptname + 8;
1999 *fdscript = atoi(s);
2003 scriptname = savepv(s + 1);
2004 Safefree(PL_origfilename);
2005 PL_origfilename = scriptname;
2010 PL_curcop->cop_filegv = gv_fetchfile(PL_origfilename);
2011 if (strEQ(PL_origfilename,"-"))
2013 if (*fdscript >= 0) {
2014 PL_rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE);
2015 #if defined(HAS_FCNTL) && defined(F_SETFD)
2017 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); /* ensure close-on-exec */
2020 else if (PL_preprocess) {
2021 char *cpp_cfg = CPPSTDIN;
2022 SV *cpp = newSVpvn("",0);
2023 SV *cmd = NEWSV(0,0);
2025 if (strEQ(cpp_cfg, "cppstdin"))
2026 Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
2027 sv_catpv(cpp, cpp_cfg);
2030 sv_catpv(sv,PRIVLIB_EXP);
2033 Perl_sv_setpvf(aTHX_ cmd, "\
2034 sed %s -e \"/^[^#]/b\" \
2035 -e \"/^#[ ]*include[ ]/b\" \
2036 -e \"/^#[ ]*define[ ]/b\" \
2037 -e \"/^#[ ]*if[ ]/b\" \
2038 -e \"/^#[ ]*ifdef[ ]/b\" \
2039 -e \"/^#[ ]*ifndef[ ]/b\" \
2040 -e \"/^#[ ]*else/b\" \
2041 -e \"/^#[ ]*elif[ ]/b\" \
2042 -e \"/^#[ ]*undef[ ]/b\" \
2043 -e \"/^#[ ]*endif/b\" \
2046 (PL_doextract ? "-e \"1,/^#/d\n\"" : ""),
2049 Perl_sv_setpvf(aTHX_ cmd, "\
2050 %s %s -e '/^[^#]/b' \
2051 -e '/^#[ ]*include[ ]/b' \
2052 -e '/^#[ ]*define[ ]/b' \
2053 -e '/^#[ ]*if[ ]/b' \
2054 -e '/^#[ ]*ifdef[ ]/b' \
2055 -e '/^#[ ]*ifndef[ ]/b' \
2056 -e '/^#[ ]*else/b' \
2057 -e '/^#[ ]*elif[ ]/b' \
2058 -e '/^#[ ]*undef[ ]/b' \
2059 -e '/^#[ ]*endif/b' \
2063 Perl_sv_setpvf(aTHX_ cmd, "\
2064 %s %s -e '/^[^#]/b' \
2065 -e '/^#[ ]*include[ ]/b' \
2066 -e '/^#[ ]*define[ ]/b' \
2067 -e '/^#[ ]*if[ ]/b' \
2068 -e '/^#[ ]*ifdef[ ]/b' \
2069 -e '/^#[ ]*ifndef[ ]/b' \
2070 -e '/^#[ ]*else/b' \
2071 -e '/^#[ ]*elif[ ]/b' \
2072 -e '/^#[ ]*undef[ ]/b' \
2073 -e '/^#[ ]*endif/b' \
2082 (PL_doextract ? "-e '1,/^#/d\n'" : ""),
2084 scriptname, cpp, sv, CPPMINUS);
2085 PL_doextract = FALSE;
2086 #ifdef IAMSUID /* actually, this is caught earlier */
2087 if (PL_euid != PL_uid && !PL_euid) { /* if running suidperl */
2089 (void)seteuid(PL_uid); /* musn't stay setuid root */
2092 (void)setreuid((Uid_t)-1, PL_uid);
2094 #ifdef HAS_SETRESUID
2095 (void)setresuid((Uid_t)-1, PL_uid, (Uid_t)-1);
2097 PerlProc_setuid(PL_uid);
2101 if (PerlProc_geteuid() != PL_uid)
2102 Perl_croak(aTHX_ "Can't do seteuid!\n");
2104 #endif /* IAMSUID */
2105 PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
2109 else if (!*scriptname) {
2110 forbid_setid("program input from stdin");
2111 PL_rsfp = PerlIO_stdin();
2114 PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
2115 #if defined(HAS_FCNTL) && defined(F_SETFD)
2117 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); /* ensure close-on-exec */
2122 #ifndef IAMSUID /* in case script is not readable before setuid */
2124 PerlLIO_stat(SvPVX(GvSV(PL_curcop->cop_filegv)),&PL_statbuf) >= 0 &&
2125 PL_statbuf.st_mode & (S_ISUID|S_ISGID))
2128 PerlProc_execv(Perl_form(aTHX_ "%s/sperl%s", BIN_EXP, PL_patchlevel), PL_origargv);
2129 Perl_croak(aTHX_ "Can't do setuid\n");
2133 Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
2134 SvPVX(GvSV(PL_curcop->cop_filegv)), Strerror(errno));
2139 * I_SYSSTATVFS HAS_FSTATVFS
2141 * I_STATFS HAS_FSTATFS
2142 * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT
2143 * here so that metaconfig picks them up. */
2147 S_fd_on_nosuid_fs(pTHX_ int fd)
2152 * Preferred order: fstatvfs(), fstatfs(), getmntent().
2153 * fstatvfs() is UNIX98.
2155 * getmntent() is O(number-of-mounted-filesystems) and can hang.
2158 # ifdef HAS_FSTATVFS
2159 struct statvfs stfs;
2160 check_okay = fstatvfs(fd, &stfs) == 0;
2161 on_nosuid = check_okay && (stfs.f_flag & ST_NOSUID);
2163 # if defined(HAS_FSTATFS) && defined(HAS_STRUCT_STATFS_FLAGS)
2165 check_okay = fstatfs(fd, &stfs) == 0;
2166 # undef PERL_MOUNT_NOSUID
2167 # if !defined(PERL_MOUNT_NOSUID) && defined(MNT_NOSUID)
2168 # define PERL_MOUNT_NOSUID MNT_NOSUID
2170 # if !defined(PERL_MOUNT_NOSUID) && defined(MS_NOSUID)
2171 # define PERL_MOUNT_NOSUID MS_NOSUID
2173 # if !defined(PERL_MOUNT_NOSUID) && defined(M_NOSUID)
2174 # define PERL_MOUNT_NOSUID M_NOSUID
2176 # ifdef PERL_MOUNT_NOSUID
2177 on_nosuid = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
2180 # if defined(HAS_GETMNTENT) && defined(HAS_HASMNTOPT) && defined(MNTOPT_NOSUID)
2181 FILE *mtab = fopen("/etc/mtab", "r");
2182 struct mntent *entry;
2183 struct stat stb, fsb;
2185 if (mtab && (fstat(fd, &stb) == 0)) {
2186 while (entry = getmntent(mtab)) {
2187 if (stat(entry->mnt_dir, &fsb) == 0
2188 && fsb.st_dev == stb.st_dev)
2190 /* found the filesystem */
2192 if (hasmntopt(entry, MNTOPT_NOSUID))
2195 } /* A single fs may well fail its stat(). */
2200 # endif /* mntent */
2201 # endif /* statfs */
2202 # endif /* statvfs */
2204 Perl_croak(aTHX_ "Can't check filesystem of script \"%s\"", PL_origfilename);
2207 #endif /* IAMSUID */
2210 S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript)
2214 /* do we need to emulate setuid on scripts? */
2216 /* This code is for those BSD systems that have setuid #! scripts disabled
2217 * in the kernel because of a security problem. Merely defining DOSUID
2218 * in perl will not fix that problem, but if you have disabled setuid
2219 * scripts in the kernel, this will attempt to emulate setuid and setgid
2220 * on scripts that have those now-otherwise-useless bits set. The setuid
2221 * root version must be called suidperl or sperlN.NNN. If regular perl
2222 * discovers that it has opened a setuid script, it calls suidperl with
2223 * the same argv that it had. If suidperl finds that the script it has
2224 * just opened is NOT setuid root, it sets the effective uid back to the
2225 * uid. We don't just make perl setuid root because that loses the
2226 * effective uid we had before invoking perl, if it was different from the
2229 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
2230 * be defined in suidperl only. suidperl must be setuid root. The
2231 * Configure script will set this up for you if you want it.
2238 if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */
2239 Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
2240 if (fdscript < 0 && PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
2245 #ifndef HAS_SETREUID
2246 /* On this access check to make sure the directories are readable,
2247 * there is actually a small window that the user could use to make
2248 * filename point to an accessible directory. So there is a faint
2249 * chance that someone could execute a setuid script down in a
2250 * non-accessible directory. I don't know what to do about that.
2251 * But I don't think it's too important. The manual lies when
2252 * it says access() is useful in setuid programs.
2254 if (PerlLIO_access(SvPVX(GvSV(PL_curcop->cop_filegv)),1)) /*double check*/
2255 Perl_croak(aTHX_ "Permission denied");
2257 /* If we can swap euid and uid, then we can determine access rights
2258 * with a simple stat of the file, and then compare device and
2259 * inode to make sure we did stat() on the same file we opened.
2260 * Then we just have to make sure he or she can execute it.
2263 struct stat tmpstatbuf;
2267 setreuid(PL_euid,PL_uid) < 0
2270 setresuid(PL_euid,PL_uid,(Uid_t)-1) < 0
2273 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
2274 Perl_croak(aTHX_ "Can't swap uid and euid"); /* really paranoid */
2275 if (PerlLIO_stat(SvPVX(GvSV(PL_curcop->cop_filegv)),&tmpstatbuf) < 0)
2276 Perl_croak(aTHX_ "Permission denied"); /* testing full pathname here */
2277 #if defined(IAMSUID) && !defined(NO_NOSUID_CHECK)
2278 if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp)))
2279 Perl_croak(aTHX_ "Permission denied");
2281 if (tmpstatbuf.st_dev != PL_statbuf.st_dev ||
2282 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
2283 (void)PerlIO_close(PL_rsfp);
2284 if (PL_rsfp = PerlProc_popen("/bin/mail root","w")) { /* heh, heh */
2285 PerlIO_printf(PL_rsfp,
2286 "User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2287 (Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
2288 (long)PL_uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
2289 (long)PL_statbuf.st_dev, (long)PL_statbuf.st_ino,
2290 SvPVX(GvSV(PL_curcop->cop_filegv)),
2291 (long)PL_statbuf.st_uid, (long)PL_statbuf.st_gid);
2292 (void)PerlProc_pclose(PL_rsfp);
2294 Perl_croak(aTHX_ "Permission denied\n");
2298 setreuid(PL_uid,PL_euid) < 0
2300 # if defined(HAS_SETRESUID)
2301 setresuid(PL_uid,PL_euid,(Uid_t)-1) < 0
2304 || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
2305 Perl_croak(aTHX_ "Can't reswap uid and euid");
2306 if (!cando(S_IXUSR,FALSE,&PL_statbuf)) /* can real uid exec? */
2307 Perl_croak(aTHX_ "Permission denied\n");
2309 #endif /* HAS_SETREUID */
2310 #endif /* IAMSUID */
2312 if (!S_ISREG(PL_statbuf.st_mode))
2313 Perl_croak(aTHX_ "Permission denied");
2314 if (PL_statbuf.st_mode & S_IWOTH)
2315 Perl_croak(aTHX_ "Setuid/gid script is writable by world");
2316 PL_doswitches = FALSE; /* -s is insecure in suid */
2317 PL_curcop->cop_line++;
2318 if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
2319 strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */
2320 Perl_croak(aTHX_ "No #! line");
2321 s = SvPV(PL_linestr,n_a)+2;
2323 while (!isSPACE(*s)) s++;
2324 for (s2 = s; (s2 > SvPV(PL_linestr,n_a)+2 &&
2325 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
2326 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
2327 Perl_croak(aTHX_ "Not a perl script");
2328 while (*s == ' ' || *s == '\t') s++;
2330 * #! arg must be what we saw above. They can invoke it by
2331 * mentioning suidperl explicitly, but they may not add any strange
2332 * arguments beyond what #! says if they do invoke suidperl that way.
2334 len = strlen(validarg);
2335 if (strEQ(validarg," PHOOEY ") ||
2336 strnNE(s,validarg,len) || !isSPACE(s[len]))
2337 Perl_croak(aTHX_ "Args must match #! line");
2340 if (PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
2341 PL_euid == PL_statbuf.st_uid)
2343 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2344 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2345 #endif /* IAMSUID */
2347 if (PL_euid) { /* oops, we're not the setuid root perl */
2348 (void)PerlIO_close(PL_rsfp);
2351 PerlProc_execv(Perl_form(aTHX_ "%s/sperl%s", BIN_EXP, PL_patchlevel), PL_origargv);
2353 Perl_croak(aTHX_ "Can't do setuid\n");
2356 if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
2358 (void)setegid(PL_statbuf.st_gid);
2361 (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
2363 #ifdef HAS_SETRESGID
2364 (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
2366 PerlProc_setgid(PL_statbuf.st_gid);
2370 if (PerlProc_getegid() != PL_statbuf.st_gid)
2371 Perl_croak(aTHX_ "Can't do setegid!\n");
2373 if (PL_statbuf.st_mode & S_ISUID) {
2374 if (PL_statbuf.st_uid != PL_euid)
2376 (void)seteuid(PL_statbuf.st_uid); /* all that for this */
2379 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
2381 #ifdef HAS_SETRESUID
2382 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
2384 PerlProc_setuid(PL_statbuf.st_uid);
2388 if (PerlProc_geteuid() != PL_statbuf.st_uid)
2389 Perl_croak(aTHX_ "Can't do seteuid!\n");
2391 else if (PL_uid) { /* oops, mustn't run as root */
2393 (void)seteuid((Uid_t)PL_uid);
2396 (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
2398 #ifdef HAS_SETRESUID
2399 (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
2401 PerlProc_setuid((Uid_t)PL_uid);
2405 if (PerlProc_geteuid() != PL_uid)
2406 Perl_croak(aTHX_ "Can't do seteuid!\n");
2409 if (!cando(S_IXUSR,TRUE,&PL_statbuf))
2410 Perl_croak(aTHX_ "Permission denied\n"); /* they can't do this */
2413 else if (PL_preprocess)
2414 Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
2415 else if (fdscript >= 0)
2416 Perl_croak(aTHX_ "fd script not allowed in suidperl\n");
2418 Perl_croak(aTHX_ "Script is not setuid/setgid in suidperl\n");
2420 /* We absolutely must clear out any saved ids here, so we */
2421 /* exec the real perl, substituting fd script for scriptname. */
2422 /* (We pass script name as "subdir" of fd, which perl will grok.) */
2423 PerlIO_rewind(PL_rsfp);
2424 PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0); /* just in case rewind didn't */
2425 for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
2426 if (!PL_origargv[which])
2427 Perl_croak(aTHX_ "Permission denied");
2428 PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
2429 PerlIO_fileno(PL_rsfp), PL_origargv[which]));
2430 #if defined(HAS_FCNTL) && defined(F_SETFD)
2431 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */
2433 PerlProc_execv(Perl_form(aTHX_ "%s/perl%s", BIN_EXP, PL_patchlevel), PL_origargv);/* try again */
2434 Perl_croak(aTHX_ "Can't do setuid\n");
2435 #endif /* IAMSUID */
2437 if (PL_euid != PL_uid || PL_egid != PL_gid) { /* (suidperl doesn't exist, in fact) */
2438 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2440 PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf); /* may be either wrapped or real suid */
2441 if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
2443 (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
2446 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2447 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2448 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2449 /* not set-id, must be wrapped */
2455 S_find_beginning(pTHX)
2457 register char *s, *s2;
2459 /* skip forward in input to the real script? */
2462 while (PL_doextract) {
2463 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
2464 Perl_croak(aTHX_ "No Perl script found in input\n");
2465 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2466 PerlIO_ungetc(PL_rsfp, '\n'); /* to keep line count right */
2467 PL_doextract = FALSE;
2468 while (*s && !(isSPACE (*s) || *s == '#')) s++;
2470 while (*s == ' ' || *s == '\t') s++;
2472 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2473 if (strnEQ(s2-4,"perl",4))
2475 while (s = moreswitches(s)) ;
2477 if (PL_cddir && PerlDir_chdir(PL_cddir) < 0)
2478 Perl_croak(aTHX_ "Can't chdir to %s",PL_cddir);
2487 PL_uid = (int)PerlProc_getuid();
2488 PL_euid = (int)PerlProc_geteuid();
2489 PL_gid = (int)PerlProc_getgid();
2490 PL_egid = (int)PerlProc_getegid();
2492 PL_uid |= PL_gid << 16;
2493 PL_euid |= PL_egid << 16;
2495 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2499 S_forbid_setid(pTHX_ char *s)
2501 if (PL_euid != PL_uid)
2502 Perl_croak(aTHX_ "No %s allowed while running setuid", s);
2503 if (PL_egid != PL_gid)
2504 Perl_croak(aTHX_ "No %s allowed while running setgid", s);
2508 S_init_debugger(pTHX)
2511 PL_curstash = PL_debstash;
2512 PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2513 AvREAL_off(PL_dbargs);
2514 PL_DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2515 PL_DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2516 PL_DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2517 PL_DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2518 sv_setiv(PL_DBsingle, 0);
2519 PL_DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2520 sv_setiv(PL_DBtrace, 0);
2521 PL_DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2522 sv_setiv(PL_DBsignal, 0);
2523 PL_curstash = PL_defstash;
2526 #ifndef STRESS_REALLOC
2527 #define REASONABLE(size) (size)
2529 #define REASONABLE(size) (1) /* unreasonable */
2533 Perl_init_stacks(pTHX)
2535 /* start with 128-item stack and 8K cxstack */
2536 PL_curstackinfo = new_stackinfo(REASONABLE(128),
2537 REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
2538 PL_curstackinfo->si_type = PERLSI_MAIN;
2539 PL_curstack = PL_curstackinfo->si_stack;
2540 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
2542 PL_stack_base = AvARRAY(PL_curstack);
2543 PL_stack_sp = PL_stack_base;
2544 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
2546 New(50,PL_tmps_stack,REASONABLE(128),SV*);
2549 PL_tmps_max = REASONABLE(128);
2551 New(54,PL_markstack,REASONABLE(32),I32);
2552 PL_markstack_ptr = PL_markstack;
2553 PL_markstack_max = PL_markstack + REASONABLE(32);
2557 New(54,PL_scopestack,REASONABLE(32),I32);
2558 PL_scopestack_ix = 0;
2559 PL_scopestack_max = REASONABLE(32);
2561 New(54,PL_savestack,REASONABLE(128),ANY);
2562 PL_savestack_ix = 0;
2563 PL_savestack_max = REASONABLE(128);
2565 New(54,PL_retstack,REASONABLE(16),OP*);
2567 PL_retstack_max = REASONABLE(16);
2576 while (PL_curstackinfo->si_next)
2577 PL_curstackinfo = PL_curstackinfo->si_next;
2578 while (PL_curstackinfo) {
2579 PERL_SI *p = PL_curstackinfo->si_prev;
2580 /* curstackinfo->si_stack got nuked by sv_free_arenas() */
2581 Safefree(PL_curstackinfo->si_cxstack);
2582 Safefree(PL_curstackinfo);
2583 PL_curstackinfo = p;
2585 Safefree(PL_tmps_stack);
2586 Safefree(PL_markstack);
2587 Safefree(PL_scopestack);
2588 Safefree(PL_savestack);
2589 Safefree(PL_retstack);
2591 Safefree(PL_debname);
2592 Safefree(PL_debdelim);
2597 static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
2608 lex_start(PL_linestr);
2610 PL_subname = newSVpvn("main",4);
2614 S_init_predump_symbols(pTHX)
2621 sv_setpvn(get_sv("\"", TRUE), " ", 1);
2622 PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2623 GvMULTI_on(PL_stdingv);
2624 io = GvIOp(PL_stdingv);
2625 IoIFP(io) = PerlIO_stdin();
2626 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2628 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
2630 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2633 IoOFP(io) = IoIFP(io) = PerlIO_stdout();
2635 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2637 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
2639 othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2640 GvMULTI_on(othergv);
2641 io = GvIOp(othergv);
2642 IoOFP(io) = IoIFP(io) = PerlIO_stderr();
2643 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2645 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
2647 PL_statname = NEWSV(66,0); /* last filename we did stat on */
2650 PL_osname = savepv(OSNAME);
2654 S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
2661 argc--,argv++; /* skip name of script */
2662 if (PL_doswitches) {
2663 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2666 if (argv[0][1] == '-') {
2670 if (s = strchr(argv[0], '=')) {
2672 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2675 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2678 PL_toptarget = NEWSV(0,0);
2679 sv_upgrade(PL_toptarget, SVt_PVFM);
2680 sv_setpvn(PL_toptarget, "", 0);
2681 PL_bodytarget = NEWSV(0,0);
2682 sv_upgrade(PL_bodytarget, SVt_PVFM);
2683 sv_setpvn(PL_bodytarget, "", 0);
2684 PL_formtarget = PL_bodytarget;
2687 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2688 sv_setpv(GvSV(tmpgv),PL_origfilename);
2689 magicname("0", "0", 1);
2691 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2692 sv_setpv(GvSV(tmpgv),PL_origargv[0]);
2693 if (PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2694 GvMULTI_on(PL_argvgv);
2695 (void)gv_AVadd(PL_argvgv);
2696 av_clear(GvAVn(PL_argvgv));
2697 for (; argc > 0; argc--,argv++) {
2698 av_push(GvAVn(PL_argvgv),newSVpv(argv[0],0));
2701 if (PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2703 GvMULTI_on(PL_envgv);
2704 hv = GvHVn(PL_envgv);
2705 hv_magic(hv, PL_envgv, 'E');
2706 #if !defined( VMS) && !defined(EPOC) /* VMS doesn't have environ array */
2707 /* Note that if the supplied env parameter is actually a copy
2708 of the global environ then it may now point to free'd memory
2709 if the environment has been modified since. To avoid this
2710 problem we treat env==NULL as meaning 'use the default'
2715 environ[0] = Nullch;
2716 for (; *env; env++) {
2717 if (!(s = strchr(*env,'=')))
2723 sv = newSVpv(s--,0);
2724 (void)hv_store(hv, *env, s - *env, sv, 0);
2726 #if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
2727 /* Sins of the RTL. See note in my_setenv(). */
2728 (void)PerlEnv_putenv(savepv(*env));
2732 #ifdef DYNAMIC_ENV_FETCH
2733 HvNAME(hv) = savepv(ENV_HV_NAME);
2737 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2738 sv_setiv(GvSV(tmpgv), (IV)getpid());
2742 S_init_perllib(pTHX)
2747 s = PerlEnv_getenv("PERL5LIB");
2751 incpush(PerlEnv_getenv("PERLLIB"), FALSE);
2753 /* Treat PERL5?LIB as a possible search list logical name -- the
2754 * "natural" VMS idiom for a Unix path string. We allow each
2755 * element to be a set of |-separated directories for compatibility.
2759 if (my_trnlnm("PERL5LIB",buf,0))
2760 do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2762 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2766 /* Use the ~-expanded versions of APPLLIB (undocumented),
2767 ARCHLIB PRIVLIB SITEARCH and SITELIB
2770 incpush(APPLLIB_EXP, TRUE);
2774 incpush(ARCHLIB_EXP, FALSE);
2777 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2780 incpush(PRIVLIB_EXP, TRUE);
2782 incpush(PRIVLIB_EXP, FALSE);
2786 incpush(SITEARCH_EXP, FALSE);
2790 incpush(SITELIB_EXP, TRUE);
2792 incpush(SITELIB_EXP, FALSE);
2796 incpush(".", FALSE);
2800 # define PERLLIB_SEP ';'
2803 # define PERLLIB_SEP '|'
2805 # define PERLLIB_SEP ':'
2808 #ifndef PERLLIB_MANGLE
2809 # define PERLLIB_MANGLE(s,n) (s)
2813 S_incpush(pTHX_ char *p, int addsubdirs)
2815 SV *subdir = Nullsv;
2821 subdir = sv_newmortal();
2822 if (!PL_archpat_auto) {
2823 STRLEN len = (sizeof(ARCHNAME) + strlen(PL_patchlevel)
2824 + sizeof("//auto"));
2825 New(55, PL_archpat_auto, len, char);
2826 sprintf(PL_archpat_auto, "/%s/%s/auto", ARCHNAME, PL_patchlevel);
2828 for (len = sizeof(ARCHNAME) + 2;
2829 PL_archpat_auto[len] != '\0' && PL_archpat_auto[len] != '/'; len++)
2830 if (PL_archpat_auto[len] == '.') PL_archpat_auto[len] = '_';
2835 /* Break at all separators */
2837 SV *libdir = NEWSV(55,0);
2840 /* skip any consecutive separators */
2841 while ( *p == PERLLIB_SEP ) {
2842 /* Uncomment the next line for PATH semantics */
2843 /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */
2847 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2848 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2853 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2854 p = Nullch; /* break out */
2858 * BEFORE pushing libdir onto @INC we may first push version- and
2859 * archname-specific sub-directories.
2862 struct stat tmpstatbuf;
2867 if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) {
2869 while (unix[len-1] == '/') len--; /* Cosmetic */
2870 sv_usepvn(libdir,unix,len);
2873 PerlIO_printf(PerlIO_stderr(),
2874 "Failed to unixify @INC element \"%s\"\n",
2877 /* .../archname/version if -d .../archname/version/auto */
2878 sv_setsv(subdir, libdir);
2879 sv_catpv(subdir, PL_archpat_auto);
2880 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2881 S_ISDIR(tmpstatbuf.st_mode))
2882 av_push(GvAVn(PL_incgv),
2883 newSVpvn(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2885 /* .../archname if -d .../archname/auto */
2886 sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
2887 strlen(PL_patchlevel) + 1, "", 0);
2888 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2889 S_ISDIR(tmpstatbuf.st_mode))
2890 av_push(GvAVn(PL_incgv),
2891 newSVpvn(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2894 /* finally push this lib directory on the end of @INC */
2895 av_push(GvAVn(PL_incgv), libdir);
2900 STATIC struct perl_thread *
2901 S_init_main_thread(pTHX)
2903 #ifndef PERL_IMPLICIT_CONTEXT
2904 struct perl_thread *thr;
2908 Newz(53, thr, 1, struct perl_thread);
2909 PL_curcop = &PL_compiling;
2910 thr->cvcache = newHV();
2911 thr->threadsv = newAV();
2912 /* thr->threadsvp is set when find_threadsv is called */
2913 thr->specific = newAV();
2914 thr->errhv = newHV();
2915 thr->flags = THRf_R_JOINABLE;
2916 MUTEX_INIT(&thr->mutex);
2917 /* Handcraft thrsv similarly to mess_sv */
2918 New(53, PL_thrsv, 1, SV);
2919 Newz(53, xpv, 1, XPV);
2920 SvFLAGS(PL_thrsv) = SVt_PV;
2921 SvANY(PL_thrsv) = (void*)xpv;
2922 SvREFCNT(PL_thrsv) = 1 << 30; /* practically infinite */
2923 SvPVX(PL_thrsv) = (char*)thr;
2924 SvCUR_set(PL_thrsv, sizeof(thr));
2925 SvLEN_set(PL_thrsv, sizeof(thr));
2926 *SvEND(PL_thrsv) = '\0'; /* in the trailing_nul field */
2927 thr->oursv = PL_thrsv;
2928 PL_chopset = " \n-";
2931 MUTEX_LOCK(&PL_threads_mutex);
2936 MUTEX_UNLOCK(&PL_threads_mutex);
2938 #ifdef HAVE_THREAD_INTERN
2939 Perl_init_thread_intern(thr);
2942 #ifdef SET_THREAD_SELF
2943 SET_THREAD_SELF(thr);
2945 thr->self = pthread_self();
2946 #endif /* SET_THREAD_SELF */
2950 * These must come after the SET_THR because sv_setpvn does
2951 * SvTAINT and the taint fields require dTHR.
2953 PL_toptarget = NEWSV(0,0);
2954 sv_upgrade(PL_toptarget, SVt_PVFM);
2955 sv_setpvn(PL_toptarget, "", 0);
2956 PL_bodytarget = NEWSV(0,0);
2957 sv_upgrade(PL_bodytarget, SVt_PVFM);
2958 sv_setpvn(PL_bodytarget, "", 0);
2959 PL_formtarget = PL_bodytarget;
2960 thr->errsv = newSVpvn("", 0);
2961 (void) find_threadsv("@"); /* Ensure $@ is initialised early */
2964 PL_regcompp = FUNC_NAME_TO_PTR(Perl_pregcomp);
2965 PL_regexecp = FUNC_NAME_TO_PTR(Perl_regexec_flags);
2966 PL_regint_start = FUNC_NAME_TO_PTR(Perl_re_intuit_start);
2967 PL_regint_string = FUNC_NAME_TO_PTR(Perl_re_intuit_string);
2968 PL_regfree = FUNC_NAME_TO_PTR(Perl_pregfree);
2970 PL_reginterp_cnt = 0;
2974 #endif /* USE_THREADS */
2977 Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
2981 line_t oldline = PL_curcop->cop_line;
2986 while (AvFILL(paramList) >= 0) {
2987 cv = (CV*)av_shift(paramList);
2989 CALLPROTECT(aTHX_ &ret, FUNC_NAME_TO_PTR(S_call_list_body), cv);
2992 (void)SvPV(atsv, len);
2994 PL_curcop = &PL_compiling;
2995 PL_curcop->cop_line = oldline;
2996 if (paramList == PL_beginav)
2997 sv_catpv(atsv, "BEGIN failed--compilation aborted");
2999 sv_catpv(atsv, "END failed--cleanup aborted");
3000 while (PL_scopestack_ix > oldscope)
3002 Perl_croak(aTHX_ "%s", SvPVX(atsv));
3009 /* my_exit() was called */
3010 while (PL_scopestack_ix > oldscope)
3013 PL_curstash = PL_defstash;
3015 call_list(oldscope, PL_endav);
3016 PL_curcop = &PL_compiling;
3017 PL_curcop->cop_line = oldline;
3018 if (PL_statusvalue) {
3019 if (paramList == PL_beginav)
3020 Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
3022 Perl_croak(aTHX_ "END failed--cleanup aborted");
3028 PL_curcop = &PL_compiling;
3029 PL_curcop->cop_line = oldline;
3032 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
3040 S_call_list_body(pTHX_ va_list args)
3043 CV *cv = va_arg(args, CV*);
3045 PUSHMARK(PL_stack_sp);
3046 call_sv((SV*)cv, G_EVAL|G_DISCARD);
3051 Perl_my_exit(pTHX_ U32 status)
3055 DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
3056 thr, (unsigned long) status));
3065 STATUS_NATIVE_SET(status);
3072 Perl_my_failure_exit(pTHX)
3075 if (vaxc$errno & 1) {
3076 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
3077 STATUS_NATIVE_SET(44);
3080 if (!vaxc$errno && errno) /* unlikely */
3081 STATUS_NATIVE_SET(44);
3083 STATUS_NATIVE_SET(vaxc$errno);
3088 STATUS_POSIX_SET(errno);
3090 exitstatus = STATUS_POSIX >> 8;
3091 if (exitstatus & 255)
3092 STATUS_POSIX_SET(exitstatus);
3094 STATUS_POSIX_SET(255);
3101 S_my_exit_jump(pTHX)
3104 register PERL_CONTEXT *cx;
3109 SvREFCNT_dec(PL_e_script);
3110 PL_e_script = Nullsv;
3113 POPSTACK_TO(PL_mainstack);
3114 if (cxstack_ix >= 0) {
3117 POPBLOCK(cx,PL_curpm);
3130 read_e_script(pTHXo_ int idx, SV *buf_sv, int maxlen)
3133 p = SvPVX(PL_e_script);
3134 nl = strchr(p, '\n');
3135 nl = (nl) ? nl+1 : SvEND(PL_e_script);
3137 filter_del(read_e_script);
3140 sv_catpvn(buf_sv, p, nl-p);
3141 sv_chop(PL_e_script, nl);