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> */
40 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
47 CPerlObj* perl_alloc(IPerlMem* ipM, IPerlEnv* ipE, IPerlStdIO* ipStd,
48 IPerlLIO* ipLIO, IPerlDir* ipD, IPerlSock* ipS, IPerlProc* ipP)
50 CPerlObj* pPerl = new(ipM) CPerlObj(ipM, ipE, ipStd, ipLIO, ipD, ipS, ipP);
60 PerlInterpreter *my_perl;
62 #if !defined(PERL_IMPLICIT_CONTEXT)
65 New(53, my_perl, 1, PerlInterpreter);
68 #endif /* PERL_OBJECT */
71 perl_construct(register PerlInterpreter *my_perl)
76 struct perl_thread *thr;
77 #endif /* FAKE_THREADS */
78 #endif /* USE_THREADS */
81 if (!(PL_curinterp = my_perl))
87 Zero(my_perl, 1, PerlInterpreter);
90 /* Init the real globals (and main thread)? */
95 #ifdef ALLOC_THREAD_KEY
98 if (pthread_key_create(&PL_thr_key, 0))
99 Perl_croak(aTHX_ "panic: pthread_key_create");
101 MUTEX_INIT(&PL_sv_mutex);
103 * Safe to use basic SV functions from now on (though
104 * not things like mortals or tainting yet).
106 MUTEX_INIT(&PL_eval_mutex);
107 COND_INIT(&PL_eval_cond);
108 MUTEX_INIT(&PL_threads_mutex);
109 COND_INIT(&PL_nthreads_cond);
110 #ifdef EMULATE_ATOMIC_REFCOUNTS
111 MUTEX_INIT(&PL_svref_mutex);
112 #endif /* EMULATE_ATOMIC_REFCOUNTS */
114 MUTEX_INIT(&PL_cred_mutex);
116 thr = init_main_thread();
117 #endif /* USE_THREADS */
119 PL_protect = FUNC_NAME_TO_PTR(Perl_default_protect); /* for exceptions */
121 PL_curcop = &PL_compiling; /* needed by ckWARN, right away */
123 PL_linestr = NEWSV(65,79);
124 sv_upgrade(PL_linestr,SVt_PVIV);
126 if (!SvREADONLY(&PL_sv_undef)) {
127 /* set read-only and try to insure than we wont see REFCNT==0
130 SvREADONLY_on(&PL_sv_undef);
131 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
133 sv_setpv(&PL_sv_no,PL_No);
135 SvREADONLY_on(&PL_sv_no);
136 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
138 sv_setpv(&PL_sv_yes,PL_Yes);
140 SvREADONLY_on(&PL_sv_yes);
141 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
146 /* PL_sighandlerp = sighandler; */
148 PL_sighandlerp = Perl_sighandler;
150 PL_pidstatus = newHV();
154 * There is no way we can refer to them from Perl so close them to save
155 * space. The other alternative would be to provide STDAUX and STDPRN
158 (void)fclose(stdaux);
159 (void)fclose(stdprn);
163 PL_nrs = newSVpvn("\n", 1);
164 PL_rs = SvREFCNT_inc(PL_nrs);
169 PL_perl_destruct_level = 1;
171 if (PL_perl_destruct_level > 0)
176 PL_lex_state = LEX_NOTPARSING;
181 SET_NUMERIC_STANDARD();
182 #if defined(PERL_SUBVERSION) && PERL_SUBVERSION > 0
183 sprintf(PL_patchlevel, "%7.5f", (double) PERL_REVISION
184 + ((double) PERL_VERSION / (double) 1000)
185 + ((double) PERL_SUBVERSION / (double) 100000));
187 sprintf(PL_patchlevel, "%5.3f", (double) PERL_REVISION +
188 ((double) PERL_VERSION / (double) 1000));
191 #if defined(LOCAL_PATCH_COUNT)
192 PL_localpatches = local_patches; /* For possible -v */
195 PerlIO_init(); /* Hook to IO system */
197 PL_fdpid = newAV(); /* for remembering popen pids by fd */
198 PL_modglobal = newHV(); /* pointers to per-interpreter module globals */
201 New(51,PL_debname,128,char);
202 New(52,PL_debdelim,128,char);
209 perl_destruct(register PerlInterpreter *my_perl)
212 int destruct_level; /* 0=none, 1=full, 2=full with checks */
218 #endif /* USE_THREADS */
220 #if !defined(PERL_OBJECT) && !defined(PERL_IMPLICIT_CONTEXT)
221 if (!(PL_curinterp = my_perl))
227 /* Pass 1 on any remaining threads: detach joinables, join zombies */
229 MUTEX_LOCK(&PL_threads_mutex);
230 DEBUG_S(PerlIO_printf(PerlIO_stderr(),
231 "perl_destruct: waiting for %d threads...\n",
233 for (t = thr->next; t != thr; t = t->next) {
234 MUTEX_LOCK(&t->mutex);
235 switch (ThrSTATE(t)) {
238 DEBUG_S(PerlIO_printf(PerlIO_stderr(),
239 "perl_destruct: joining zombie %p\n", t));
240 ThrSETSTATE(t, THRf_DEAD);
241 MUTEX_UNLOCK(&t->mutex);
244 * The SvREFCNT_dec below may take a long time (e.g. av
245 * may contain an object scalar whose destructor gets
246 * called) so we have to unlock threads_mutex and start
249 MUTEX_UNLOCK(&PL_threads_mutex);
251 SvREFCNT_dec((SV*)av);
252 DEBUG_S(PerlIO_printf(PerlIO_stderr(),
253 "perl_destruct: joined zombie %p OK\n", t));
255 case THRf_R_JOINABLE:
256 DEBUG_S(PerlIO_printf(PerlIO_stderr(),
257 "perl_destruct: detaching thread %p\n", t));
258 ThrSETSTATE(t, THRf_R_DETACHED);
260 * We unlock threads_mutex and t->mutex in the opposite order
261 * from which we locked them just so that DETACH won't
262 * deadlock if it panics. It's only a breach of good style
263 * not a bug since they are unlocks not locks.
265 MUTEX_UNLOCK(&PL_threads_mutex);
267 MUTEX_UNLOCK(&t->mutex);
270 DEBUG_S(PerlIO_printf(PerlIO_stderr(),
271 "perl_destruct: ignoring %p (state %u)\n",
273 MUTEX_UNLOCK(&t->mutex);
274 /* fall through and out */
277 /* We leave the above "Pass 1" loop with threads_mutex still locked */
279 /* Pass 2 on remaining threads: wait for the thread count to drop to one */
280 while (PL_nthreads > 1)
282 DEBUG_S(PerlIO_printf(PerlIO_stderr(),
283 "perl_destruct: final wait for %d threads\n",
285 COND_WAIT(&PL_nthreads_cond, &PL_threads_mutex);
287 /* At this point, we're the last thread */
288 MUTEX_UNLOCK(&PL_threads_mutex);
289 DEBUG_S(PerlIO_printf(PerlIO_stderr(), "perl_destruct: armageddon has arrived\n"));
290 MUTEX_DESTROY(&PL_threads_mutex);
291 COND_DESTROY(&PL_nthreads_cond);
292 #endif /* !defined(FAKE_THREADS) */
293 #endif /* USE_THREADS */
295 destruct_level = PL_perl_destruct_level;
299 if (s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL")) {
301 if (destruct_level < i)
314 /* We must account for everything. */
316 /* Destroy the main CV and syntax tree */
318 PL_curpad = AvARRAY(PL_comppad);
319 op_free(PL_main_root);
320 PL_main_root = Nullop;
322 PL_curcop = &PL_compiling;
323 PL_main_start = Nullop;
324 SvREFCNT_dec(PL_main_cv);
328 if (PL_sv_objcount) {
330 * Try to destruct global references. We do this first so that the
331 * destructors and destructees still exist. Some sv's might remain.
332 * Non-referenced objects are on their own.
337 /* unhook hooks which will soon be, or use, destroyed data */
338 SvREFCNT_dec(PL_warnhook);
339 PL_warnhook = Nullsv;
340 SvREFCNT_dec(PL_diehook);
342 SvREFCNT_dec(PL_parsehook);
343 PL_parsehook = Nullsv;
345 /* call exit list functions */
346 while (PL_exitlistlen-- > 0)
347 PL_exitlist[PL_exitlistlen].fn(aTHX_ PL_exitlist[PL_exitlistlen].ptr);
349 Safefree(PL_exitlist);
351 if (destruct_level == 0){
353 DEBUG_P(debprofdump());
355 /* The exit() function will do everything that needs doing. */
359 /* loosen bonds of global variables */
362 (void)PerlIO_close(PL_rsfp);
366 /* Filters for program text */
367 SvREFCNT_dec(PL_rsfp_filters);
368 PL_rsfp_filters = Nullav;
371 PL_preprocess = FALSE;
377 PL_doswitches = FALSE;
378 PL_dowarn = G_WARN_OFF;
379 PL_doextract = FALSE;
380 PL_sawampersand = FALSE; /* must save all match strings */
381 PL_sawstudy = FALSE; /* do fbm_instr on all strings */
385 Safefree(PL_inplace);
389 SvREFCNT_dec(PL_e_script);
390 PL_e_script = Nullsv;
393 /* magical thingies */
395 Safefree(PL_ofs); /* $, */
398 Safefree(PL_ors); /* $\ */
401 SvREFCNT_dec(PL_rs); /* $/ */
404 SvREFCNT_dec(PL_nrs); /* $/ helper */
407 PL_multiline = 0; /* $* */
409 SvREFCNT_dec(PL_statname);
410 PL_statname = Nullsv;
413 /* defgv, aka *_ should be taken care of elsewhere */
415 /* clean up after study() */
416 SvREFCNT_dec(PL_lastscream);
417 PL_lastscream = Nullsv;
418 Safefree(PL_screamfirst);
420 Safefree(PL_screamnext);
423 /* startup and shutdown function lists */
424 SvREFCNT_dec(PL_beginav);
425 SvREFCNT_dec(PL_endav);
426 SvREFCNT_dec(PL_initav);
431 /* shortcuts just get cleared */
438 PL_argvoutgv = Nullgv;
440 PL_last_in_gv = Nullgv;
443 /* reset so print() ends up where we expect */
446 /* Prepare to destruct main symbol table. */
453 if (destruct_level >= 2) {
454 if (PL_scopestack_ix != 0)
455 Perl_warn(aTHX_ "Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
456 (long)PL_scopestack_ix);
457 if (PL_savestack_ix != 0)
458 Perl_warn(aTHX_ "Unbalanced saves: %ld more saves than restores\n",
459 (long)PL_savestack_ix);
460 if (PL_tmps_floor != -1)
461 Perl_warn(aTHX_ "Unbalanced tmps: %ld more allocs than frees\n",
462 (long)PL_tmps_floor + 1);
463 if (cxstack_ix != -1)
464 Perl_warn(aTHX_ "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);
494 Perl_warn(aTHX_ "Unbalanced string table refcount: (%d) for \"%s\"",
495 HeVAL(hent) - Nullsv, HeKEY(hent));
496 HeVAL(hent) = Nullsv;
506 SvREFCNT_dec(PL_strtab);
508 if (PL_sv_count != 0)
509 Perl_warn(aTHX_ "Scalars leaked: %ld\n", (long)PL_sv_count);
513 /* No SVs have survived, need to clean out */
515 PL_pidstatus = Nullhv;
516 Safefree(PL_origfilename);
517 Safefree(PL_archpat_auto);
518 Safefree(PL_reg_start_tmp);
520 Safefree(PL_reg_curpm);
521 Safefree(HeKEY_hek(&PL_hv_fetch_ent_mh));
522 Safefree(PL_op_mask);
524 PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */
526 DEBUG_P(debprofdump());
528 MUTEX_DESTROY(&PL_strtab_mutex);
529 MUTEX_DESTROY(&PL_sv_mutex);
530 MUTEX_DESTROY(&PL_eval_mutex);
531 MUTEX_DESTROY(&PL_cred_mutex);
532 COND_DESTROY(&PL_eval_cond);
533 #ifdef EMULATE_ATOMIC_REFCOUNTS
534 MUTEX_DESTROY(&PL_svref_mutex);
535 #endif /* EMULATE_ATOMIC_REFCOUNTS */
537 /* As the penultimate thing, free the non-arena SV for thrsv */
538 Safefree(SvPVX(PL_thrsv));
539 Safefree(SvANY(PL_thrsv));
542 #endif /* USE_THREADS */
544 /* As the absolutely last thing, free the non-arena SV for mess() */
547 /* it could have accumulated taint magic */
548 if (SvTYPE(PL_mess_sv) >= SVt_PVMG) {
551 for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) {
552 moremagic = mg->mg_moremagic;
553 if (mg->mg_ptr && mg->mg_type != 'g' && mg->mg_len >= 0)
554 Safefree(mg->mg_ptr);
558 /* we know that type >= SVt_PV */
559 SvOOK_off(PL_mess_sv);
560 Safefree(SvPVX(PL_mess_sv));
561 Safefree(SvANY(PL_mess_sv));
562 Safefree(PL_mess_sv);
568 perl_free(PerlInterpreter *my_perl)
573 # if !defined(PERL_IMPLICIT_CONTEXT)
574 if (!(PL_curinterp = my_perl))
582 Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
584 Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry);
585 PL_exitlist[PL_exitlistlen].fn = fn;
586 PL_exitlist[PL_exitlistlen].ptr = ptr;
591 perl_parse(PerlInterpreter *my_perl, XSINIT_t xsinit, int argc, char **argv, char **env)
600 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
603 Perl_croak(aTHX_ "suidperl is no longer needed since the kernel can now execute\n\
604 setuid perl scripts securely.\n");
608 #if !defined(PERL_OBJECT) && !defined(PERL_IMPLICIT_CONTEXT)
609 if (!(PL_curinterp = my_perl))
613 #if defined(__DYNAMIC__) && (defined(NeXT) || defined(__NeXT__))
614 _dyld_lookup_and_bind
615 ("__environ", (unsigned long *) &environ_pointer, NULL);
620 #ifndef VMS /* VMS doesn't have environ array */
621 PL_origenviron = environ;
626 /* Come here if running an undumped a.out. */
628 PL_origfilename = savepv(argv[0]);
629 PL_do_undump = FALSE;
630 cxstack_ix = -1; /* start label stack again */
632 init_postdump_symbols(argc,argv,env);
637 PL_curpad = AvARRAY(PL_comppad);
638 op_free(PL_main_root);
639 PL_main_root = Nullop;
641 PL_main_start = Nullop;
642 SvREFCNT_dec(PL_main_cv);
646 oldscope = PL_scopestack_ix;
647 PL_dowarn = G_WARN_OFF;
649 CALLPROTECT(aTHX_ &ret, FUNC_NAME_TO_PTR(S_parse_body), env, xsinit);
657 /* my_exit() was called */
658 while (PL_scopestack_ix > oldscope)
661 PL_curstash = PL_defstash;
663 call_list(oldscope, PL_endav);
664 return STATUS_NATIVE_EXPORT;
666 PerlIO_printf(PerlIO_stderr(), "panic: top_env\n");
673 S_parse_body(pTHX_ va_list args)
676 int argc = PL_origargc;
677 char **argv = PL_origargv;
678 char **env = va_arg(args, char**);
679 char *scriptname = NULL;
681 VOL bool dosearch = FALSE;
687 XSINIT_t xsinit = va_arg(args, XSINIT_t);
689 sv_setpvn(PL_linestr,"",0);
690 sv = newSVpvn("",0); /* first used for -I flags */
694 for (argc--,argv++; argc > 0; argc--,argv++) {
695 if (argv[0][0] != '-' || !argv[0][1])
699 validarg = " PHOOEY ";
706 #ifndef PERL_STRICT_CR
730 if (s = moreswitches(s))
740 if (PL_euid != PL_uid || PL_egid != PL_gid)
741 Perl_croak(aTHX_ "No -e allowed in setuid scripts");
743 PL_e_script = newSVpvn("",0);
744 filter_add(S_read_e_script, NULL);
747 sv_catpv(PL_e_script, s);
749 sv_catpv(PL_e_script, argv[1]);
753 Perl_croak(aTHX_ "No code specified for -e");
754 sv_catpv(PL_e_script, "\n");
757 case 'I': /* -I handled both here and in moreswitches() */
759 if (!*++s && (s=argv[1]) != Nullch) {
762 while (s && isSPACE(*s))
766 for (e = s; *e && !isSPACE(*e); e++) ;
773 } /* XXX else croak? */
777 PL_preprocess = TRUE;
787 PL_preambleav = newAV();
788 av_push(PL_preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
790 PL_Sv = newSVpv("print myconfig();",0);
792 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
794 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
796 #if defined(DEBUGGING) || defined(MULTIPLICITY)
797 sv_catpv(PL_Sv,"\" Compile-time options:");
799 sv_catpv(PL_Sv," DEBUGGING");
802 sv_catpv(PL_Sv," MULTIPLICITY");
804 sv_catpv(PL_Sv,"\\n\",");
806 #if defined(LOCAL_PATCH_COUNT)
807 if (LOCAL_PATCH_COUNT > 0) {
809 sv_catpv(PL_Sv,"\" Locally applied patches:\\n\",");
810 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
811 if (PL_localpatches[i])
812 Perl_sv_catpvf(aTHX_ PL_Sv,"q\" \t%s\n\",",PL_localpatches[i]);
816 Perl_sv_catpvf(aTHX_ PL_Sv,"\" Built under %s\\n\"",OSNAME);
819 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
821 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled on %s\\n\"",__DATE__);
826 @env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; \
827 print \" \\%ENV:\\n @env\\n\" if @env; \
828 print \" \\@INC:\\n @INC\\n\";");
831 PL_Sv = newSVpv("config_vars(qw(",0);
832 sv_catpv(PL_Sv, ++s);
833 sv_catpv(PL_Sv, "))");
836 av_push(PL_preambleav, PL_Sv);
837 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
843 PL_cddir = savepv(s);
848 if (!*++s || isSPACE(*s)) {
852 /* catch use of gnu style long options */
853 if (strEQ(s, "version")) {
857 if (strEQ(s, "help")) {
864 Perl_croak(aTHX_ "Unrecognized switch: -%s (-h will show valid options)",s);
870 #ifndef SECURE_INTERNAL_GETENV
873 (s = PerlEnv_getenv("PERL5OPT"))) {
876 if (*s == '-' && *(s+1) == 'T')
889 if (!strchr("DIMUdmw", *s))
890 Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
897 scriptname = argv[0];
900 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
902 else if (scriptname == Nullch) {
904 if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
912 open_script(scriptname,dosearch,sv,&fdscript);
914 validate_suid(validarg, scriptname,fdscript);
919 PL_main_cv = PL_compcv = (CV*)NEWSV(1104,0);
920 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
921 CvUNIQUE_on(PL_compcv);
923 PL_comppad = newAV();
924 av_push(PL_comppad, Nullsv);
925 PL_curpad = AvARRAY(PL_comppad);
926 PL_comppad_name = newAV();
927 PL_comppad_name_fill = 0;
928 PL_min_intro_pending = 0;
931 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
932 PL_curpad[0] = (SV*)newAV();
933 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
934 CvOWNER(PL_compcv) = 0;
935 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
936 MUTEX_INIT(CvMUTEXP(PL_compcv));
937 #endif /* USE_THREADS */
939 comppadlist = newAV();
940 AvREAL_off(comppadlist);
941 av_store(comppadlist, 0, (SV*)PL_comppad_name);
942 av_store(comppadlist, 1, (SV*)PL_comppad);
943 CvPADLIST(PL_compcv) = comppadlist;
945 boot_core_UNIVERSAL();
948 (*xsinit)(aTHX); /* in case linked C routines want magical variables */
949 #if defined(VMS) || defined(WIN32) || defined(DJGPP)
950 init_os_extras(aTHX);
953 init_predump_symbols();
954 /* init_postdump_symbols not currently designed to be called */
955 /* more than once (ENV isn't cleared first, for example) */
956 /* But running with -u leaves %ENV & @ARGV undefined! XXX */
958 init_postdump_symbols(argc,argv,env);
962 /* now parse the script */
964 SETERRNO(0,SS$_NORMAL);
966 if (yyparse() || PL_error_count) {
968 Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
970 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
974 PL_curcop->cop_line = 0;
975 PL_curstash = PL_defstash;
976 PL_preprocess = FALSE;
978 SvREFCNT_dec(PL_e_script);
979 PL_e_script = Nullsv;
982 /* now that script is parsed, we can modify record separator */
984 PL_rs = SvREFCNT_inc(PL_nrs);
985 sv_setsv(get_sv("/", TRUE), PL_rs);
989 if (ckWARN(WARN_ONCE))
990 gv_check(PL_defstash);
996 if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
997 dump_mstats("after compilation:");
1006 perl_run(PerlInterpreter *my_perl)
1015 #if !defined(PERL_OBJECT) && !defined(PERL_IMPLICIT_CONTEXT)
1016 if (!(PL_curinterp = my_perl))
1020 oldscope = PL_scopestack_ix;
1023 CALLPROTECT(aTHX_ &ret, FUNC_NAME_TO_PTR(S_run_body), oldscope);
1026 cxstack_ix = -1; /* start context stack again */
1028 case 0: /* normal completion */
1029 case 2: /* my_exit() */
1030 while (PL_scopestack_ix > oldscope)
1033 PL_curstash = PL_defstash;
1035 call_list(oldscope, PL_endav);
1037 if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
1038 dump_mstats("after execution: ");
1040 return STATUS_NATIVE_EXPORT;
1043 POPSTACK_TO(PL_mainstack);
1046 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
1056 S_run_body(pTHX_ va_list args)
1059 I32 oldscope = va_arg(args, I32);
1061 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
1062 PL_sawampersand ? "Enabling" : "Omitting"));
1064 if (!PL_restartop) {
1065 DEBUG_x(dump_all());
1066 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
1067 DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%lx\n",
1068 (unsigned long) thr));
1071 PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", PL_origfilename);
1074 if (PERLDB_SINGLE && PL_DBsingle)
1075 sv_setiv(PL_DBsingle, 1);
1077 call_list(oldscope, PL_initav);
1083 PL_op = PL_restartop;
1087 else if (PL_main_start) {
1088 CvDEPTH(PL_main_cv) = 1;
1089 PL_op = PL_main_start;
1097 Perl_get_sv(pTHX_ const char *name, I32 create)
1101 if (name[1] == '\0' && !isALPHA(name[0])) {
1102 PADOFFSET tmp = find_threadsv(name);
1103 if (tmp != NOT_IN_PAD) {
1105 return THREADSV(tmp);
1108 #endif /* USE_THREADS */
1109 gv = gv_fetchpv(name, create, SVt_PV);
1116 Perl_get_av(pTHX_ const char *name, I32 create)
1118 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1127 Perl_get_hv(pTHX_ const char *name, I32 create)
1129 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1138 Perl_get_cv(pTHX_ const char *name, I32 create)
1140 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
1141 /* XXX unsafe for threads if eval_owner isn't held */
1142 /* XXX this is probably not what they think they're getting.
1143 * It has the same effect as "sub name;", i.e. just a forward
1145 if (create && !GvCVu(gv))
1146 return newSUB(start_subparse(FALSE, 0),
1147 newSVOP(OP_CONST, 0, newSVpv(name,0)),
1155 /* Be sure to refetch the stack pointer after calling these routines. */
1158 Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv)
1160 /* See G_* flags in cop.h */
1161 /* null terminated arg list */
1168 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
1173 return call_pv(sub_name, flags);
1177 Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
1178 /* name of the subroutine */
1179 /* See G_* flags in cop.h */
1181 return call_sv((SV*)get_cv(sub_name, TRUE), flags);
1185 Perl_call_method(pTHX_ const char *methname, I32 flags)
1186 /* name of the subroutine */
1187 /* See G_* flags in cop.h */
1193 XPUSHs(sv_2mortal(newSVpv(methname,0)));
1198 return call_sv(*PL_stack_sp--, flags);
1201 /* May be called with any of a CV, a GV, or an SV containing the name. */
1203 Perl_call_sv(pTHX_ SV *sv, I32 flags)
1205 /* See G_* flags in cop.h */
1208 LOGOP myop; /* fake syntax tree node */
1212 bool oldcatch = CATCH_GET;
1216 if (flags & G_DISCARD) {
1221 Zero(&myop, 1, LOGOP);
1222 myop.op_next = Nullop;
1223 if (!(flags & G_NOARGS))
1224 myop.op_flags |= OPf_STACKED;
1225 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1226 (flags & G_ARRAY) ? OPf_WANT_LIST :
1231 EXTEND(PL_stack_sp, 1);
1232 *++PL_stack_sp = sv;
1234 oldscope = PL_scopestack_ix;
1236 if (PERLDB_SUB && PL_curstash != PL_debstash
1237 /* Handle first BEGIN of -d. */
1238 && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
1239 /* Try harder, since this may have been a sighandler, thus
1240 * curstash may be meaningless. */
1241 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != PL_debstash)
1242 && !(flags & G_NODEBUG))
1243 PL_op->op_private |= OPpENTERSUB_DB;
1245 if (!(flags & G_EVAL)) {
1247 call_xbody((OP*)&myop, FALSE);
1248 retval = PL_stack_sp - (PL_stack_base + oldmark);
1252 cLOGOP->op_other = PL_op;
1254 /* we're trying to emulate pp_entertry() here */
1256 register PERL_CONTEXT *cx;
1257 I32 gimme = GIMME_V;
1262 push_return(PL_op->op_next);
1263 PUSHBLOCK(cx, CXt_EVAL, PL_stack_sp);
1265 PL_eval_root = PL_op; /* Only needed so that goto works right. */
1267 PL_in_eval = EVAL_INEVAL;
1268 if (flags & G_KEEPERR)
1269 PL_in_eval |= EVAL_KEEPERR;
1276 CALLPROTECT(aTHX_ &ret, FUNC_NAME_TO_PTR(S_call_body), (OP*)&myop, FALSE);
1279 retval = PL_stack_sp - (PL_stack_base + oldmark);
1280 if (!(flags & G_KEEPERR))
1287 /* my_exit() was called */
1288 PL_curstash = PL_defstash;
1291 Perl_croak(aTHX_ "Callback called exit");
1296 PL_op = PL_restartop;
1300 PL_stack_sp = PL_stack_base + oldmark;
1301 if (flags & G_ARRAY)
1305 *++PL_stack_sp = &PL_sv_undef;
1310 if (PL_scopestack_ix > oldscope) {
1314 register PERL_CONTEXT *cx;
1325 if (flags & G_DISCARD) {
1326 PL_stack_sp = PL_stack_base + oldmark;
1336 S_call_body(pTHX_ va_list args)
1338 OP *myop = va_arg(args, OP*);
1339 int is_eval = va_arg(args, int);
1341 call_xbody(myop, is_eval);
1346 S_call_xbody(pTHX_ OP *myop, int is_eval)
1350 if (PL_op == myop) {
1352 PL_op = Perl_pp_entereval(aTHX);
1354 PL_op = Perl_pp_entersub(aTHX);
1360 /* Eval a string. The G_EVAL flag is always assumed. */
1363 Perl_eval_sv(pTHX_ SV *sv, I32 flags)
1365 /* See G_* flags in cop.h */
1368 UNOP myop; /* fake syntax tree node */
1369 I32 oldmark = SP - PL_stack_base;
1375 if (flags & G_DISCARD) {
1382 Zero(PL_op, 1, UNOP);
1383 EXTEND(PL_stack_sp, 1);
1384 *++PL_stack_sp = sv;
1385 oldscope = PL_scopestack_ix;
1387 if (!(flags & G_NOARGS))
1388 myop.op_flags = OPf_STACKED;
1389 myop.op_next = Nullop;
1390 myop.op_type = OP_ENTEREVAL;
1391 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1392 (flags & G_ARRAY) ? OPf_WANT_LIST :
1394 if (flags & G_KEEPERR)
1395 myop.op_flags |= OPf_SPECIAL;
1398 CALLPROTECT(aTHX_ &ret, FUNC_NAME_TO_PTR(S_call_body), (OP*)&myop, TRUE);
1401 retval = PL_stack_sp - (PL_stack_base + oldmark);
1402 if (!(flags & G_KEEPERR))
1409 /* my_exit() was called */
1410 PL_curstash = PL_defstash;
1413 Perl_croak(aTHX_ "Callback called exit");
1418 PL_op = PL_restartop;
1422 PL_stack_sp = PL_stack_base + oldmark;
1423 if (flags & G_ARRAY)
1427 *++PL_stack_sp = &PL_sv_undef;
1432 if (flags & G_DISCARD) {
1433 PL_stack_sp = PL_stack_base + oldmark;
1443 Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
1446 SV* sv = newSVpv(p, 0);
1449 eval_sv(sv, G_SCALAR);
1456 if (croak_on_error && SvTRUE(ERRSV)) {
1458 Perl_croak(aTHX_ SvPVx(ERRSV, n_a));
1464 /* Require a module. */
1467 Perl_require_pv(pTHX_ const char *pv)
1471 PUSHSTACKi(PERLSI_REQUIRE);
1473 sv = sv_newmortal();
1474 sv_setpv(sv, "require '");
1477 eval_sv(sv, G_DISCARD);
1483 Perl_magicname(pTHX_ char *sym, char *name, I32 namlen)
1487 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1488 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1492 S_usage(pTHX_ char *name) /* XXX move this out into a module ? */
1494 /* This message really ought to be max 23 lines.
1495 * Removed -h because the user already knows that opton. Others? */
1497 static char *usage_msg[] = {
1498 "-0[octal] specify record separator (\\0, if no argument)",
1499 "-a autosplit mode with -n or -p (splits $_ into @F)",
1500 "-c check syntax only (runs BEGIN and END blocks)",
1501 "-d[:debugger] run program under debugger",
1502 "-D[number/list] set debugging flags (argument is a bit mask or alphabets)",
1503 "-e 'command' one line of program (several -e's allowed, omit programfile)",
1504 "-F/pattern/ split() pattern for -a switch (//'s are optional)",
1505 "-i[extension] edit <> files in place (makes backup if extension supplied)",
1506 "-Idirectory specify @INC/#include directory (several -I's allowed)",
1507 "-l[octal] enable line ending processing, specifies line terminator",
1508 "-[mM][-]module execute `use/no module...' before executing program",
1509 "-n assume 'while (<>) { ... }' loop around program",
1510 "-p assume loop like -n but print line also, like sed",
1511 "-P run program through C preprocessor before compilation",
1512 "-s enable rudimentary parsing for switches after programfile",
1513 "-S look for programfile using PATH environment variable",
1514 "-T enable tainting checks",
1515 "-u dump core after parsing program",
1516 "-U allow unsafe operations",
1517 "-v print version, subversion (includes VERY IMPORTANT perl info)",
1518 "-V[:variable] print configuration summary (or a single Config.pm variable)",
1519 "-w enable many useful warnings (RECOMMENDED)",
1520 "-x[directory] strip off text before #!perl line and perhaps cd to directory",
1524 char **p = usage_msg;
1526 printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1528 printf("\n %s", *p++);
1531 /* This routine handles any switches that can be given during run */
1534 Perl_moreswitches(pTHX_ char *s)
1543 rschar = scan_oct(s, 4, &numlen);
1544 SvREFCNT_dec(PL_nrs);
1545 if (rschar & ~((U8)~0))
1546 PL_nrs = &PL_sv_undef;
1547 else if (!rschar && numlen >= 2)
1548 PL_nrs = newSVpvn("", 0);
1551 PL_nrs = newSVpvn(&ch, 1);
1557 PL_splitstr = savepv(s + 1);
1571 if (*s == ':' || *s == '=') {
1572 my_setenv("PERL5DB", Perl_form(aTHX_ "use Devel::%s;", ++s));
1576 PL_perldb = PERLDB_ALL;
1583 if (isALPHA(s[1])) {
1584 static char debopts[] = "psltocPmfrxuLHXDS";
1587 for (s++; *s && (d = strchr(debopts,*s)); s++)
1588 PL_debug |= 1 << (d - debopts);
1591 PL_debug = atoi(s+1);
1592 for (s++; isDIGIT(*s); s++) ;
1594 PL_debug |= 0x80000000;
1596 Perl_warn(aTHX_ "Recompile perl with -DDEBUGGING to use -D switch\n");
1597 for (s++; isALNUM(*s); s++) ;
1602 usage(PL_origargv[0]);
1606 Safefree(PL_inplace);
1607 PL_inplace = savepv(s+1);
1609 for (s = PL_inplace; *s && !isSPACE(*s); s++) ;
1612 if (*s == '-') /* Additional switches on #! line. */
1616 case 'I': /* -I handled both here and in parse_perl() */
1619 while (*s && isSPACE(*s))
1623 for (e = s; *e && !isSPACE(*e); e++) ;
1624 p = savepvn(s, e-s);
1630 Perl_croak(aTHX_ "No space allowed after -I");
1638 PL_ors = savepv("\n");
1640 *PL_ors = scan_oct(s, 3 + (*s == '0'), &numlen);
1645 if (RsPARA(PL_nrs)) {
1650 PL_ors = SvPV(PL_nrs, PL_orslen);
1651 PL_ors = savepvn(PL_ors, PL_orslen);
1655 forbid_setid("-M"); /* XXX ? */
1658 forbid_setid("-m"); /* XXX ? */
1663 /* -M-foo == 'no foo' */
1664 if (*s == '-') { use = "no "; ++s; }
1665 sv = newSVpv(use,0);
1667 /* We allow -M'Module qw(Foo Bar)' */
1668 while(isALNUM(*s) || *s==':') ++s;
1670 sv_catpv(sv, start);
1671 if (*(start-1) == 'm') {
1673 Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
1674 sv_catpv( sv, " ()");
1677 sv_catpvn(sv, start, s-start);
1678 sv_catpv(sv, " split(/,/,q{");
1683 if (PL_preambleav == NULL)
1684 PL_preambleav = newAV();
1685 av_push(PL_preambleav, sv);
1688 Perl_croak(aTHX_ "No space allowed after -%c", *(s-1));
1700 PL_doswitches = TRUE;
1705 Perl_croak(aTHX_ "Too late for \"-T\" option");
1709 PL_do_undump = TRUE;
1717 #if defined(PERL_SUBVERSION) && PERL_SUBVERSION > 0
1718 printf("\nThis is perl, version %d.%03d_%02d built for %s",
1719 PERL_REVISION, PERL_VERSION, PERL_SUBVERSION, ARCHNAME);
1721 printf("\nThis is perl, version %s built for %s",
1722 PL_patchlevel, ARCHNAME);
1724 #if defined(LOCAL_PATCH_COUNT)
1725 if (LOCAL_PATCH_COUNT > 0)
1726 printf("\n(with %d registered patch%s, see perl -V for more detail)",
1727 LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : "");
1730 printf("\n\nCopyright 1987-1999, Larry Wall\n");
1732 printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1735 printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
1736 printf("djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
1739 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1740 "Version 5 port Copyright (c) 1994-1999, Andreas Kaiser, Ilya Zakharevich\n");
1743 printf("atariST series port, ++jrb bammi@cadence.com\n");
1746 printf("BeOS port Copyright Tom Spindler, 1997-1999\n");
1749 printf("MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-1999\n");
1752 printf("MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
1755 printf("Stratus VOS port by Paul_Green@stratus.com, 1997-1999\n");
1758 printf("VM/ESA port by Neale Ferguson, 1998-1999\n");
1761 printf("BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
1764 printf("MiNT port by Guido Flohr, 1997-1999\n");
1766 #ifdef BINARY_BUILD_NOTICE
1767 BINARY_BUILD_NOTICE;
1770 Perl may be copied only under the terms of either the Artistic License or the\n\
1771 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n\
1772 Complete documentation for Perl, including FAQ lists, should be found on\n\
1773 this system using `man perl' or `perldoc perl'. If you have access to the\n\
1774 Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
1777 if (! (PL_dowarn & G_WARN_ALL_MASK))
1778 PL_dowarn |= G_WARN_ON;
1782 PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
1783 PL_compiling.cop_warnings = WARN_ALL ;
1787 PL_dowarn = G_WARN_ALL_OFF;
1788 PL_compiling.cop_warnings = WARN_NONE ;
1793 if (s[1] == '-') /* Additional switches on #! line. */
1798 #if defined(WIN32) || !defined(PERL_STRICT_CR)
1804 #ifdef ALTERNATE_SHEBANG
1805 case 'S': /* OS/2 needs -S on "extproc" line. */
1813 Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
1818 /* compliments of Tom Christiansen */
1820 /* unexec() can be found in the Gnu emacs distribution */
1821 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
1824 Perl_my_unexec(pTHX)
1832 prog = newSVpv(BIN_EXP, 0);
1833 sv_catpv(prog, "/perl");
1834 file = newSVpv(PL_origfilename, 0);
1835 sv_catpv(file, ".perldump");
1837 unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
1838 /* unexec prints msg to stderr in case of failure */
1839 PerlProc_exit(status);
1842 # include <lib$routines.h>
1843 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
1845 ABORT(); /* for use with undump */
1850 /* initialize curinterp */
1855 #ifdef PERL_OBJECT /* XXX kludge */
1858 PL_chopset = " \n-"; \
1859 PL_copline = NOLINE; \
1860 PL_curcop = &PL_compiling;\
1861 PL_curcopdb = NULL; \
1864 PL_dumpindent = 4; \
1865 PL_laststatval = -1; \
1866 PL_laststype = OP_STAT; \
1867 PL_maxscream = -1; \
1868 PL_maxsysfd = MAXSYSFD; \
1869 PL_statname = Nullsv; \
1870 PL_tmps_floor = -1; \
1872 PL_op_mask = NULL; \
1874 PL_laststatval = -1; \
1875 PL_laststype = OP_STAT; \
1876 PL_mess_sv = Nullsv; \
1877 PL_splitstr = " "; \
1878 PL_generation = 100; \
1879 PL_exitlist = NULL; \
1880 PL_exitlistlen = 0; \
1882 PL_in_clean_objs = FALSE; \
1883 PL_in_clean_all = FALSE; \
1884 PL_profiledata = NULL; \
1886 PL_rsfp_filters = Nullav; \
1891 # ifdef MULTIPLICITY
1892 # define PERLVAR(var,type)
1893 # if defined(PERL_IMPLICIT_CONTEXT)
1894 # define PERLVARI(var,type,init) my_perl->var = init;
1895 # define PERLVARIC(var,type,init) my_perl->var = init;
1897 # define PERLVARI(var,type,init) PL_curinterp->var = init;
1898 # define PERLVARIC(var,type,init) PL_curinterp->var = init;
1900 # include "intrpvar.h"
1901 # ifndef USE_THREADS
1902 # include "thrdvar.h"
1908 # define PERLVAR(var,type)
1909 # define PERLVARI(var,type,init) PL_##var = init;
1910 # define PERLVARIC(var,type,init) PL_##var = init;
1911 # include "intrpvar.h"
1912 # ifndef USE_THREADS
1913 # include "thrdvar.h"
1924 S_init_main_stash(pTHX)
1929 /* Note that strtab is a rather special HV. Assumptions are made
1930 about not iterating on it, and not adding tie magic to it.
1931 It is properly deallocated in perl_destruct() */
1932 PL_strtab = newHV();
1934 MUTEX_INIT(&PL_strtab_mutex);
1936 HvSHAREKEYS_off(PL_strtab); /* mandatory */
1937 hv_ksplit(PL_strtab, 512);
1939 PL_curstash = PL_defstash = newHV();
1940 PL_curstname = newSVpvn("main",4);
1941 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1942 SvREFCNT_dec(GvHV(gv));
1943 GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
1945 HvNAME(PL_defstash) = savepv("main");
1946 PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1947 GvMULTI_on(PL_incgv);
1948 PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
1949 GvMULTI_on(PL_hintgv);
1950 PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1951 PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1952 GvMULTI_on(PL_errgv);
1953 PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
1954 GvMULTI_on(PL_replgv);
1955 (void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */
1956 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
1957 sv_setpvn(ERRSV, "", 0);
1958 PL_curstash = PL_defstash;
1959 PL_compiling.cop_stash = PL_defstash;
1960 PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
1961 PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
1962 /* We must init $/ before switches are processed. */
1963 sv_setpvn(get_sv("/", TRUE), "\n", 1);
1967 S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
1975 PL_origfilename = savepv("-e");
1978 /* if find_script() returns, it returns a malloc()-ed value */
1979 PL_origfilename = scriptname = find_script(scriptname, dosearch, NULL, 1);
1981 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
1982 char *s = scriptname + 8;
1983 *fdscript = atoi(s);
1987 scriptname = savepv(s + 1);
1988 Safefree(PL_origfilename);
1989 PL_origfilename = scriptname;
1994 PL_curcop->cop_filegv = gv_fetchfile(PL_origfilename);
1995 if (strEQ(PL_origfilename,"-"))
1997 if (*fdscript >= 0) {
1998 PL_rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE);
1999 #if defined(HAS_FCNTL) && defined(F_SETFD)
2001 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); /* ensure close-on-exec */
2004 else if (PL_preprocess) {
2005 char *cpp_cfg = CPPSTDIN;
2006 SV *cpp = newSVpvn("",0);
2007 SV *cmd = NEWSV(0,0);
2009 if (strEQ(cpp_cfg, "cppstdin"))
2010 Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
2011 sv_catpv(cpp, cpp_cfg);
2014 sv_catpv(sv,PRIVLIB_EXP);
2017 Perl_sv_setpvf(aTHX_ cmd, "\
2018 sed %s -e \"/^[^#]/b\" \
2019 -e \"/^#[ ]*include[ ]/b\" \
2020 -e \"/^#[ ]*define[ ]/b\" \
2021 -e \"/^#[ ]*if[ ]/b\" \
2022 -e \"/^#[ ]*ifdef[ ]/b\" \
2023 -e \"/^#[ ]*ifndef[ ]/b\" \
2024 -e \"/^#[ ]*else/b\" \
2025 -e \"/^#[ ]*elif[ ]/b\" \
2026 -e \"/^#[ ]*undef[ ]/b\" \
2027 -e \"/^#[ ]*endif/b\" \
2030 (PL_doextract ? "-e \"1,/^#/d\n\"" : ""),
2033 Perl_sv_setpvf(aTHX_ cmd, "\
2034 %s %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' \
2047 Perl_sv_setpvf(aTHX_ cmd, "\
2048 %s %s -e '/^[^#]/b' \
2049 -e '/^#[ ]*include[ ]/b' \
2050 -e '/^#[ ]*define[ ]/b' \
2051 -e '/^#[ ]*if[ ]/b' \
2052 -e '/^#[ ]*ifdef[ ]/b' \
2053 -e '/^#[ ]*ifndef[ ]/b' \
2054 -e '/^#[ ]*else/b' \
2055 -e '/^#[ ]*elif[ ]/b' \
2056 -e '/^#[ ]*undef[ ]/b' \
2057 -e '/^#[ ]*endif/b' \
2066 (PL_doextract ? "-e '1,/^#/d\n'" : ""),
2068 scriptname, cpp, sv, CPPMINUS);
2069 PL_doextract = FALSE;
2070 #ifdef IAMSUID /* actually, this is caught earlier */
2071 if (PL_euid != PL_uid && !PL_euid) { /* if running suidperl */
2073 (void)seteuid(PL_uid); /* musn't stay setuid root */
2076 (void)setreuid((Uid_t)-1, PL_uid);
2078 #ifdef HAS_SETRESUID
2079 (void)setresuid((Uid_t)-1, PL_uid, (Uid_t)-1);
2081 PerlProc_setuid(PL_uid);
2085 if (PerlProc_geteuid() != PL_uid)
2086 Perl_croak(aTHX_ "Can't do seteuid!\n");
2088 #endif /* IAMSUID */
2089 PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
2093 else if (!*scriptname) {
2094 forbid_setid("program input from stdin");
2095 PL_rsfp = PerlIO_stdin();
2098 PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
2099 #if defined(HAS_FCNTL) && defined(F_SETFD)
2101 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); /* ensure close-on-exec */
2106 #ifndef IAMSUID /* in case script is not readable before setuid */
2108 PerlLIO_stat(SvPVX(GvSV(PL_curcop->cop_filegv)),&PL_statbuf) >= 0 &&
2109 PL_statbuf.st_mode & (S_ISUID|S_ISGID))
2112 PerlProc_execv(Perl_form(aTHX_ "%s/sperl%s", BIN_EXP, PL_patchlevel), PL_origargv);
2113 Perl_croak(aTHX_ "Can't do setuid\n");
2117 Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
2118 SvPVX(GvSV(PL_curcop->cop_filegv)), Strerror(errno));
2123 * I_SYSSTATVFS HAS_FSTATVFS
2125 * I_STATFS HAS_FSTATFS
2126 * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT
2127 * here so that metaconfig picks them up. */
2131 S_fd_on_nosuid_fs(pTHX_ int fd)
2136 * Preferred order: fstatvfs(), fstatfs(), getmntent().
2137 * fstatvfs() is UNIX98.
2139 * getmntent() is O(number-of-mounted-filesystems) and can hang.
2142 # ifdef HAS_FSTATVFS
2143 struct statvfs stfs;
2144 check_okay = fstatvfs(fd, &stfs) == 0;
2145 on_nosuid = check_okay && (stfs.f_flag & ST_NOSUID);
2147 # if defined(HAS_FSTATFS) && defined(HAS_STRUCT_STATFS_FLAGS)
2149 check_okay = fstatfs(fd, &stfs) == 0;
2150 # undef PERL_MOUNT_NOSUID
2151 # if !defined(PERL_MOUNT_NOSUID) && defined(MNT_NOSUID)
2152 # define PERL_MOUNT_NOSUID MNT_NOSUID
2154 # if !defined(PERL_MOUNT_NOSUID) && defined(MS_NOSUID)
2155 # define PERL_MOUNT_NOSUID MS_NOSUID
2157 # if !defined(PERL_MOUNT_NOSUID) && defined(M_NOSUID)
2158 # define PERL_MOUNT_NOSUID M_NOSUID
2160 # ifdef PERL_MOUNT_NOSUID
2161 on_nosuid = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
2164 # if defined(HAS_GETMNTENT) && defined(HAS_HASMNTOPT) && defined(MNTOPT_NOSUID)
2165 FILE *mtab = fopen("/etc/mtab", "r");
2166 struct mntent *entry;
2167 struct stat stb, fsb;
2169 if (mtab && (fstat(fd, &stb) == 0)) {
2170 while (entry = getmntent(mtab)) {
2171 if (stat(entry->mnt_dir, &fsb) == 0
2172 && fsb.st_dev == stb.st_dev)
2174 /* found the filesystem */
2176 if (hasmntopt(entry, MNTOPT_NOSUID))
2179 } /* A single fs may well fail its stat(). */
2184 # endif /* mntent */
2185 # endif /* statfs */
2186 # endif /* statvfs */
2188 Perl_croak(aTHX_ "Can't check filesystem of script \"%s\"", PL_origfilename);
2191 #endif /* IAMSUID */
2194 S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript)
2198 /* do we need to emulate setuid on scripts? */
2200 /* This code is for those BSD systems that have setuid #! scripts disabled
2201 * in the kernel because of a security problem. Merely defining DOSUID
2202 * in perl will not fix that problem, but if you have disabled setuid
2203 * scripts in the kernel, this will attempt to emulate setuid and setgid
2204 * on scripts that have those now-otherwise-useless bits set. The setuid
2205 * root version must be called suidperl or sperlN.NNN. If regular perl
2206 * discovers that it has opened a setuid script, it calls suidperl with
2207 * the same argv that it had. If suidperl finds that the script it has
2208 * just opened is NOT setuid root, it sets the effective uid back to the
2209 * uid. We don't just make perl setuid root because that loses the
2210 * effective uid we had before invoking perl, if it was different from the
2213 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
2214 * be defined in suidperl only. suidperl must be setuid root. The
2215 * Configure script will set this up for you if you want it.
2222 if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */
2223 Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
2224 if (fdscript < 0 && PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
2229 #ifndef HAS_SETREUID
2230 /* On this access check to make sure the directories are readable,
2231 * there is actually a small window that the user could use to make
2232 * filename point to an accessible directory. So there is a faint
2233 * chance that someone could execute a setuid script down in a
2234 * non-accessible directory. I don't know what to do about that.
2235 * But I don't think it's too important. The manual lies when
2236 * it says access() is useful in setuid programs.
2238 if (PerlLIO_access(SvPVX(GvSV(PL_curcop->cop_filegv)),1)) /*double check*/
2239 Perl_croak(aTHX_ "Permission denied");
2241 /* If we can swap euid and uid, then we can determine access rights
2242 * with a simple stat of the file, and then compare device and
2243 * inode to make sure we did stat() on the same file we opened.
2244 * Then we just have to make sure he or she can execute it.
2247 struct stat tmpstatbuf;
2251 setreuid(PL_euid,PL_uid) < 0
2254 setresuid(PL_euid,PL_uid,(Uid_t)-1) < 0
2257 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
2258 Perl_croak(aTHX_ "Can't swap uid and euid"); /* really paranoid */
2259 if (PerlLIO_stat(SvPVX(GvSV(PL_curcop->cop_filegv)),&tmpstatbuf) < 0)
2260 Perl_croak(aTHX_ "Permission denied"); /* testing full pathname here */
2261 #if defined(IAMSUID) && !defined(NO_NOSUID_CHECK)
2262 if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp)))
2263 Perl_croak(aTHX_ "Permission denied");
2265 if (tmpstatbuf.st_dev != PL_statbuf.st_dev ||
2266 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
2267 (void)PerlIO_close(PL_rsfp);
2268 if (PL_rsfp = PerlProc_popen("/bin/mail root","w")) { /* heh, heh */
2269 PerlIO_printf(PL_rsfp,
2270 "User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2271 (Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
2272 (long)PL_uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
2273 (long)PL_statbuf.st_dev, (long)PL_statbuf.st_ino,
2274 SvPVX(GvSV(PL_curcop->cop_filegv)),
2275 (long)PL_statbuf.st_uid, (long)PL_statbuf.st_gid);
2276 (void)PerlProc_pclose(PL_rsfp);
2278 Perl_croak(aTHX_ "Permission denied\n");
2282 setreuid(PL_uid,PL_euid) < 0
2284 # if defined(HAS_SETRESUID)
2285 setresuid(PL_uid,PL_euid,(Uid_t)-1) < 0
2288 || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
2289 Perl_croak(aTHX_ "Can't reswap uid and euid");
2290 if (!cando(S_IXUSR,FALSE,&PL_statbuf)) /* can real uid exec? */
2291 Perl_croak(aTHX_ "Permission denied\n");
2293 #endif /* HAS_SETREUID */
2294 #endif /* IAMSUID */
2296 if (!S_ISREG(PL_statbuf.st_mode))
2297 Perl_croak(aTHX_ "Permission denied");
2298 if (PL_statbuf.st_mode & S_IWOTH)
2299 Perl_croak(aTHX_ "Setuid/gid script is writable by world");
2300 PL_doswitches = FALSE; /* -s is insecure in suid */
2301 PL_curcop->cop_line++;
2302 if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
2303 strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */
2304 Perl_croak(aTHX_ "No #! line");
2305 s = SvPV(PL_linestr,n_a)+2;
2307 while (!isSPACE(*s)) s++;
2308 for (s2 = s; (s2 > SvPV(PL_linestr,n_a)+2 &&
2309 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
2310 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
2311 Perl_croak(aTHX_ "Not a perl script");
2312 while (*s == ' ' || *s == '\t') s++;
2314 * #! arg must be what we saw above. They can invoke it by
2315 * mentioning suidperl explicitly, but they may not add any strange
2316 * arguments beyond what #! says if they do invoke suidperl that way.
2318 len = strlen(validarg);
2319 if (strEQ(validarg," PHOOEY ") ||
2320 strnNE(s,validarg,len) || !isSPACE(s[len]))
2321 Perl_croak(aTHX_ "Args must match #! line");
2324 if (PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
2325 PL_euid == PL_statbuf.st_uid)
2327 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2328 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2329 #endif /* IAMSUID */
2331 if (PL_euid) { /* oops, we're not the setuid root perl */
2332 (void)PerlIO_close(PL_rsfp);
2335 PerlProc_execv(Perl_form(aTHX_ "%s/sperl%s", BIN_EXP, PL_patchlevel), PL_origargv);
2337 Perl_croak(aTHX_ "Can't do setuid\n");
2340 if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
2342 (void)setegid(PL_statbuf.st_gid);
2345 (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
2347 #ifdef HAS_SETRESGID
2348 (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
2350 PerlProc_setgid(PL_statbuf.st_gid);
2354 if (PerlProc_getegid() != PL_statbuf.st_gid)
2355 Perl_croak(aTHX_ "Can't do setegid!\n");
2357 if (PL_statbuf.st_mode & S_ISUID) {
2358 if (PL_statbuf.st_uid != PL_euid)
2360 (void)seteuid(PL_statbuf.st_uid); /* all that for this */
2363 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
2365 #ifdef HAS_SETRESUID
2366 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
2368 PerlProc_setuid(PL_statbuf.st_uid);
2372 if (PerlProc_geteuid() != PL_statbuf.st_uid)
2373 Perl_croak(aTHX_ "Can't do seteuid!\n");
2375 else if (PL_uid) { /* oops, mustn't run as root */
2377 (void)seteuid((Uid_t)PL_uid);
2380 (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
2382 #ifdef HAS_SETRESUID
2383 (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
2385 PerlProc_setuid((Uid_t)PL_uid);
2389 if (PerlProc_geteuid() != PL_uid)
2390 Perl_croak(aTHX_ "Can't do seteuid!\n");
2393 if (!cando(S_IXUSR,TRUE,&PL_statbuf))
2394 Perl_croak(aTHX_ "Permission denied\n"); /* they can't do this */
2397 else if (PL_preprocess)
2398 Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
2399 else if (fdscript >= 0)
2400 Perl_croak(aTHX_ "fd script not allowed in suidperl\n");
2402 Perl_croak(aTHX_ "Script is not setuid/setgid in suidperl\n");
2404 /* We absolutely must clear out any saved ids here, so we */
2405 /* exec the real perl, substituting fd script for scriptname. */
2406 /* (We pass script name as "subdir" of fd, which perl will grok.) */
2407 PerlIO_rewind(PL_rsfp);
2408 PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0); /* just in case rewind didn't */
2409 for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
2410 if (!PL_origargv[which])
2411 Perl_croak(aTHX_ "Permission denied");
2412 PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
2413 PerlIO_fileno(PL_rsfp), PL_origargv[which]));
2414 #if defined(HAS_FCNTL) && defined(F_SETFD)
2415 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */
2417 PerlProc_execv(Perl_form(aTHX_ "%s/perl%s", BIN_EXP, PL_patchlevel), PL_origargv);/* try again */
2418 Perl_croak(aTHX_ "Can't do setuid\n");
2419 #endif /* IAMSUID */
2421 if (PL_euid != PL_uid || PL_egid != PL_gid) { /* (suidperl doesn't exist, in fact) */
2422 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2424 PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf); /* may be either wrapped or real suid */
2425 if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
2427 (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
2430 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2431 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2432 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2433 /* not set-id, must be wrapped */
2439 S_find_beginning(pTHX)
2441 register char *s, *s2;
2443 /* skip forward in input to the real script? */
2446 while (PL_doextract) {
2447 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
2448 Perl_croak(aTHX_ "No Perl script found in input\n");
2449 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2450 PerlIO_ungetc(PL_rsfp, '\n'); /* to keep line count right */
2451 PL_doextract = FALSE;
2452 while (*s && !(isSPACE (*s) || *s == '#')) s++;
2454 while (*s == ' ' || *s == '\t') s++;
2456 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2457 if (strnEQ(s2-4,"perl",4))
2459 while (s = moreswitches(s)) ;
2461 if (PL_cddir && PerlDir_chdir(PL_cddir) < 0)
2462 Perl_croak(aTHX_ "Can't chdir to %s",PL_cddir);
2471 PL_uid = (int)PerlProc_getuid();
2472 PL_euid = (int)PerlProc_geteuid();
2473 PL_gid = (int)PerlProc_getgid();
2474 PL_egid = (int)PerlProc_getegid();
2476 PL_uid |= PL_gid << 16;
2477 PL_euid |= PL_egid << 16;
2479 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2483 S_forbid_setid(pTHX_ char *s)
2485 if (PL_euid != PL_uid)
2486 Perl_croak(aTHX_ "No %s allowed while running setuid", s);
2487 if (PL_egid != PL_gid)
2488 Perl_croak(aTHX_ "No %s allowed while running setgid", s);
2492 S_init_debugger(pTHX)
2495 PL_curstash = PL_debstash;
2496 PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2497 AvREAL_off(PL_dbargs);
2498 PL_DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2499 PL_DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2500 PL_DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2501 PL_DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2502 sv_setiv(PL_DBsingle, 0);
2503 PL_DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2504 sv_setiv(PL_DBtrace, 0);
2505 PL_DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2506 sv_setiv(PL_DBsignal, 0);
2507 PL_curstash = PL_defstash;
2510 #ifndef STRESS_REALLOC
2511 #define REASONABLE(size) (size)
2513 #define REASONABLE(size) (1) /* unreasonable */
2517 Perl_init_stacks(pTHX)
2519 /* start with 128-item stack and 8K cxstack */
2520 PL_curstackinfo = new_stackinfo(REASONABLE(128),
2521 REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
2522 PL_curstackinfo->si_type = PERLSI_MAIN;
2523 PL_curstack = PL_curstackinfo->si_stack;
2524 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
2526 PL_stack_base = AvARRAY(PL_curstack);
2527 PL_stack_sp = PL_stack_base;
2528 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
2530 New(50,PL_tmps_stack,REASONABLE(128),SV*);
2533 PL_tmps_max = REASONABLE(128);
2535 New(54,PL_markstack,REASONABLE(32),I32);
2536 PL_markstack_ptr = PL_markstack;
2537 PL_markstack_max = PL_markstack + REASONABLE(32);
2541 New(54,PL_scopestack,REASONABLE(32),I32);
2542 PL_scopestack_ix = 0;
2543 PL_scopestack_max = REASONABLE(32);
2545 New(54,PL_savestack,REASONABLE(128),ANY);
2546 PL_savestack_ix = 0;
2547 PL_savestack_max = REASONABLE(128);
2549 New(54,PL_retstack,REASONABLE(16),OP*);
2551 PL_retstack_max = REASONABLE(16);
2560 while (PL_curstackinfo->si_next)
2561 PL_curstackinfo = PL_curstackinfo->si_next;
2562 while (PL_curstackinfo) {
2563 PERL_SI *p = PL_curstackinfo->si_prev;
2564 /* curstackinfo->si_stack got nuked by sv_free_arenas() */
2565 Safefree(PL_curstackinfo->si_cxstack);
2566 Safefree(PL_curstackinfo);
2567 PL_curstackinfo = p;
2569 Safefree(PL_tmps_stack);
2570 Safefree(PL_markstack);
2571 Safefree(PL_scopestack);
2572 Safefree(PL_savestack);
2573 Safefree(PL_retstack);
2575 Safefree(PL_debname);
2576 Safefree(PL_debdelim);
2581 static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
2592 lex_start(PL_linestr);
2594 PL_subname = newSVpvn("main",4);
2598 S_init_predump_symbols(pTHX)
2604 sv_setpvn(get_sv("\"", TRUE), " ", 1);
2605 PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2606 GvMULTI_on(PL_stdingv);
2607 IoIFP(GvIOp(PL_stdingv)) = PerlIO_stdin();
2608 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2610 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(PL_stdingv));
2612 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2614 IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
2616 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2618 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(PL_defoutgv));
2620 othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2621 GvMULTI_on(othergv);
2622 IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr();
2623 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2625 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
2627 PL_statname = NEWSV(66,0); /* last filename we did stat on */
2630 PL_osname = savepv(OSNAME);
2634 S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
2641 argc--,argv++; /* skip name of script */
2642 if (PL_doswitches) {
2643 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2646 if (argv[0][1] == '-') {
2650 if (s = strchr(argv[0], '=')) {
2652 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2655 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2658 PL_toptarget = NEWSV(0,0);
2659 sv_upgrade(PL_toptarget, SVt_PVFM);
2660 sv_setpvn(PL_toptarget, "", 0);
2661 PL_bodytarget = NEWSV(0,0);
2662 sv_upgrade(PL_bodytarget, SVt_PVFM);
2663 sv_setpvn(PL_bodytarget, "", 0);
2664 PL_formtarget = PL_bodytarget;
2667 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2668 sv_setpv(GvSV(tmpgv),PL_origfilename);
2669 magicname("0", "0", 1);
2671 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2672 sv_setpv(GvSV(tmpgv),PL_origargv[0]);
2673 if (PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2674 GvMULTI_on(PL_argvgv);
2675 (void)gv_AVadd(PL_argvgv);
2676 av_clear(GvAVn(PL_argvgv));
2677 for (; argc > 0; argc--,argv++) {
2678 av_push(GvAVn(PL_argvgv),newSVpv(argv[0],0));
2681 if (PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2683 GvMULTI_on(PL_envgv);
2684 hv = GvHVn(PL_envgv);
2685 hv_magic(hv, PL_envgv, 'E');
2686 #ifndef VMS /* VMS doesn't have environ array */
2687 /* Note that if the supplied env parameter is actually a copy
2688 of the global environ then it may now point to free'd memory
2689 if the environment has been modified since. To avoid this
2690 problem we treat env==NULL as meaning 'use the default'
2695 environ[0] = Nullch;
2696 for (; *env; env++) {
2697 if (!(s = strchr(*env,'=')))
2703 sv = newSVpv(s--,0);
2704 (void)hv_store(hv, *env, s - *env, sv, 0);
2706 #if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
2707 /* Sins of the RTL. See note in my_setenv(). */
2708 (void)PerlEnv_putenv(savepv(*env));
2712 #ifdef DYNAMIC_ENV_FETCH
2713 HvNAME(hv) = savepv(ENV_HV_NAME);
2717 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2718 sv_setiv(GvSV(tmpgv), (IV)getpid());
2722 S_init_perllib(pTHX)
2727 s = PerlEnv_getenv("PERL5LIB");
2731 incpush(PerlEnv_getenv("PERLLIB"), FALSE);
2733 /* Treat PERL5?LIB as a possible search list logical name -- the
2734 * "natural" VMS idiom for a Unix path string. We allow each
2735 * element to be a set of |-separated directories for compatibility.
2739 if (my_trnlnm("PERL5LIB",buf,0))
2740 do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2742 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2746 /* Use the ~-expanded versions of APPLLIB (undocumented),
2747 ARCHLIB PRIVLIB SITEARCH and SITELIB
2750 incpush(APPLLIB_EXP, TRUE);
2754 incpush(ARCHLIB_EXP, FALSE);
2757 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2760 incpush(PRIVLIB_EXP, TRUE);
2762 incpush(PRIVLIB_EXP, FALSE);
2766 incpush(SITEARCH_EXP, FALSE);
2770 incpush(SITELIB_EXP, TRUE);
2772 incpush(SITELIB_EXP, FALSE);
2776 incpush(".", FALSE);
2780 # define PERLLIB_SEP ';'
2783 # define PERLLIB_SEP '|'
2785 # define PERLLIB_SEP ':'
2788 #ifndef PERLLIB_MANGLE
2789 # define PERLLIB_MANGLE(s,n) (s)
2793 S_incpush(pTHX_ char *p, int addsubdirs)
2795 SV *subdir = Nullsv;
2801 subdir = sv_newmortal();
2802 if (!PL_archpat_auto) {
2803 STRLEN len = (sizeof(ARCHNAME) + strlen(PL_patchlevel)
2804 + sizeof("//auto"));
2805 New(55, PL_archpat_auto, len, char);
2806 sprintf(PL_archpat_auto, "/%s/%s/auto", ARCHNAME, PL_patchlevel);
2808 for (len = sizeof(ARCHNAME) + 2;
2809 PL_archpat_auto[len] != '\0' && PL_archpat_auto[len] != '/'; len++)
2810 if (PL_archpat_auto[len] == '.') PL_archpat_auto[len] = '_';
2815 /* Break at all separators */
2817 SV *libdir = NEWSV(55,0);
2820 /* skip any consecutive separators */
2821 while ( *p == PERLLIB_SEP ) {
2822 /* Uncomment the next line for PATH semantics */
2823 /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */
2827 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2828 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2833 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2834 p = Nullch; /* break out */
2838 * BEFORE pushing libdir onto @INC we may first push version- and
2839 * archname-specific sub-directories.
2842 struct stat tmpstatbuf;
2847 if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) {
2849 while (unix[len-1] == '/') len--; /* Cosmetic */
2850 sv_usepvn(libdir,unix,len);
2853 PerlIO_printf(PerlIO_stderr(),
2854 "Failed to unixify @INC element \"%s\"\n",
2857 /* .../archname/version if -d .../archname/version/auto */
2858 sv_setsv(subdir, libdir);
2859 sv_catpv(subdir, PL_archpat_auto);
2860 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2861 S_ISDIR(tmpstatbuf.st_mode))
2862 av_push(GvAVn(PL_incgv),
2863 newSVpvn(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2865 /* .../archname if -d .../archname/auto */
2866 sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
2867 strlen(PL_patchlevel) + 1, "", 0);
2868 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2869 S_ISDIR(tmpstatbuf.st_mode))
2870 av_push(GvAVn(PL_incgv),
2871 newSVpvn(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2874 /* finally push this lib directory on the end of @INC */
2875 av_push(GvAVn(PL_incgv), libdir);
2880 STATIC struct perl_thread *
2881 S_init_main_thread(pTHX)
2883 #ifndef PERL_IMPLICIT_CONTEXT
2884 struct perl_thread *thr;
2888 Newz(53, thr, 1, struct perl_thread);
2889 PL_curcop = &PL_compiling;
2890 thr->cvcache = newHV();
2891 thr->threadsv = newAV();
2892 /* thr->threadsvp is set when find_threadsv is called */
2893 thr->specific = newAV();
2894 thr->errhv = newHV();
2895 thr->flags = THRf_R_JOINABLE;
2896 MUTEX_INIT(&thr->mutex);
2897 /* Handcraft thrsv similarly to mess_sv */
2898 New(53, PL_thrsv, 1, SV);
2899 Newz(53, xpv, 1, XPV);
2900 SvFLAGS(PL_thrsv) = SVt_PV;
2901 SvANY(PL_thrsv) = (void*)xpv;
2902 SvREFCNT(PL_thrsv) = 1 << 30; /* practically infinite */
2903 SvPVX(PL_thrsv) = (char*)thr;
2904 SvCUR_set(PL_thrsv, sizeof(thr));
2905 SvLEN_set(PL_thrsv, sizeof(thr));
2906 *SvEND(PL_thrsv) = '\0'; /* in the trailing_nul field */
2907 thr->oursv = PL_thrsv;
2908 PL_chopset = " \n-";
2911 MUTEX_LOCK(&PL_threads_mutex);
2916 MUTEX_UNLOCK(&PL_threads_mutex);
2918 #ifdef HAVE_THREAD_INTERN
2919 Perl_init_thread_intern(thr);
2922 #ifdef SET_THREAD_SELF
2923 SET_THREAD_SELF(thr);
2925 thr->self = pthread_self();
2926 #endif /* SET_THREAD_SELF */
2930 * These must come after the SET_THR because sv_setpvn does
2931 * SvTAINT and the taint fields require dTHR.
2933 PL_toptarget = NEWSV(0,0);
2934 sv_upgrade(PL_toptarget, SVt_PVFM);
2935 sv_setpvn(PL_toptarget, "", 0);
2936 PL_bodytarget = NEWSV(0,0);
2937 sv_upgrade(PL_bodytarget, SVt_PVFM);
2938 sv_setpvn(PL_bodytarget, "", 0);
2939 PL_formtarget = PL_bodytarget;
2940 thr->errsv = newSVpvn("", 0);
2941 (void) find_threadsv("@"); /* Ensure $@ is initialised early */
2944 PL_regcompp = FUNC_NAME_TO_PTR(Perl_pregcomp);
2945 PL_regexecp = FUNC_NAME_TO_PTR(Perl_regexec_flags);
2947 PL_reginterp_cnt = 0;
2951 #endif /* USE_THREADS */
2954 Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
2958 line_t oldline = PL_curcop->cop_line;
2963 while (AvFILL(paramList) >= 0) {
2964 cv = (CV*)av_shift(paramList);
2966 CALLPROTECT(aTHX_ &ret, FUNC_NAME_TO_PTR(S_call_list_body), cv);
2969 (void)SvPV(atsv, len);
2971 PL_curcop = &PL_compiling;
2972 PL_curcop->cop_line = oldline;
2973 if (paramList == PL_beginav)
2974 sv_catpv(atsv, "BEGIN failed--compilation aborted");
2976 sv_catpv(atsv, "END failed--cleanup aborted");
2977 while (PL_scopestack_ix > oldscope)
2979 Perl_croak(aTHX_ "%s", SvPVX(atsv));
2986 /* my_exit() was called */
2987 while (PL_scopestack_ix > oldscope)
2990 PL_curstash = PL_defstash;
2992 call_list(oldscope, PL_endav);
2993 PL_curcop = &PL_compiling;
2994 PL_curcop->cop_line = oldline;
2995 if (PL_statusvalue) {
2996 if (paramList == PL_beginav)
2997 Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
2999 Perl_croak(aTHX_ "END failed--cleanup aborted");
3005 PL_curcop = &PL_compiling;
3006 PL_curcop->cop_line = oldline;
3009 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
3017 S_call_list_body(pTHX_ va_list args)
3020 CV *cv = va_arg(args, CV*);
3022 PUSHMARK(PL_stack_sp);
3023 call_sv((SV*)cv, G_EVAL|G_DISCARD);
3028 Perl_my_exit(pTHX_ U32 status)
3032 DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
3033 thr, (unsigned long) status));
3042 STATUS_NATIVE_SET(status);
3049 Perl_my_failure_exit(pTHX)
3052 if (vaxc$errno & 1) {
3053 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
3054 STATUS_NATIVE_SET(44);
3057 if (!vaxc$errno && errno) /* unlikely */
3058 STATUS_NATIVE_SET(44);
3060 STATUS_NATIVE_SET(vaxc$errno);
3065 STATUS_POSIX_SET(errno);
3067 exitstatus = STATUS_POSIX >> 8;
3068 if (exitstatus & 255)
3069 STATUS_POSIX_SET(exitstatus);
3071 STATUS_POSIX_SET(255);
3078 S_my_exit_jump(pTHX)
3081 register PERL_CONTEXT *cx;
3086 SvREFCNT_dec(PL_e_script);
3087 PL_e_script = Nullsv;
3090 POPSTACK_TO(PL_mainstack);
3091 if (cxstack_ix >= 0) {
3094 POPBLOCK(cx,PL_curpm);
3103 #endif /* PERL_OBJECT */
3108 S_read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen)
3111 p = SvPVX(PL_e_script);
3112 nl = strchr(p, '\n');
3113 nl = (nl) ? nl+1 : SvEND(PL_e_script);
3115 filter_del(S_read_e_script);
3118 sv_catpvn(buf_sv, p, nl-p);
3119 sv_chop(PL_e_script, nl);