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))
86 Zero(my_perl, 1, PerlInterpreter);
89 /* Init the real globals (and main thread)? */
94 #ifdef ALLOC_THREAD_KEY
97 if (pthread_key_create(&PL_thr_key, 0))
98 Perl_croak(aTHX_ "panic: pthread_key_create");
100 MUTEX_INIT(&PL_sv_mutex);
102 * Safe to use basic SV functions from now on (though
103 * not things like mortals or tainting yet).
105 MUTEX_INIT(&PL_eval_mutex);
106 COND_INIT(&PL_eval_cond);
107 MUTEX_INIT(&PL_threads_mutex);
108 COND_INIT(&PL_nthreads_cond);
109 #ifdef EMULATE_ATOMIC_REFCOUNTS
110 MUTEX_INIT(&PL_svref_mutex);
111 #endif /* EMULATE_ATOMIC_REFCOUNTS */
113 MUTEX_INIT(&PL_cred_mutex);
115 thr = init_main_thread();
116 #endif /* USE_THREADS */
118 PL_protect = FUNC_NAME_TO_PTR(Perl_default_protect); /* for exceptions */
120 PL_curcop = &PL_compiling; /* needed by ckWARN, right away */
122 PL_linestr = NEWSV(65,79);
123 sv_upgrade(PL_linestr,SVt_PVIV);
125 if (!SvREADONLY(&PL_sv_undef)) {
126 /* set read-only and try to insure than we wont see REFCNT==0
129 SvREADONLY_on(&PL_sv_undef);
130 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
132 sv_setpv(&PL_sv_no,PL_No);
134 SvREADONLY_on(&PL_sv_no);
135 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
137 sv_setpv(&PL_sv_yes,PL_Yes);
139 SvREADONLY_on(&PL_sv_yes);
140 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
145 /* PL_sighandlerp = sighandler; */
147 PL_sighandlerp = Perl_sighandler;
149 PL_pidstatus = newHV();
153 * There is no way we can refer to them from Perl so close them to save
154 * space. The other alternative would be to provide STDAUX and STDPRN
157 (void)fclose(stdaux);
158 (void)fclose(stdprn);
162 PL_nrs = newSVpvn("\n", 1);
163 PL_rs = SvREFCNT_inc(PL_nrs);
168 PL_perl_destruct_level = 1;
170 if (PL_perl_destruct_level > 0)
175 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)
310 /* We must account for everything. */
312 /* Destroy the main CV and syntax tree */
314 PL_curpad = AvARRAY(PL_comppad);
315 op_free(PL_main_root);
316 PL_main_root = Nullop;
318 PL_curcop = &PL_compiling;
319 PL_main_start = Nullop;
320 SvREFCNT_dec(PL_main_cv);
324 if (PL_sv_objcount) {
326 * Try to destruct global references. We do this first so that the
327 * destructors and destructees still exist. Some sv's might remain.
328 * Non-referenced objects are on their own.
333 /* unhook hooks which will soon be, or use, destroyed data */
334 SvREFCNT_dec(PL_warnhook);
335 PL_warnhook = Nullsv;
336 SvREFCNT_dec(PL_diehook);
338 SvREFCNT_dec(PL_parsehook);
339 PL_parsehook = Nullsv;
341 /* call exit list functions */
342 while (PL_exitlistlen-- > 0)
343 PL_exitlist[PL_exitlistlen].fn(aTHX_ PL_exitlist[PL_exitlistlen].ptr);
345 Safefree(PL_exitlist);
347 if (destruct_level == 0){
349 DEBUG_P(debprofdump());
351 /* The exit() function will do everything that needs doing. */
355 /* loosen bonds of global variables */
358 (void)PerlIO_close(PL_rsfp);
362 /* Filters for program text */
363 SvREFCNT_dec(PL_rsfp_filters);
364 PL_rsfp_filters = Nullav;
367 PL_preprocess = FALSE;
373 PL_doswitches = FALSE;
374 PL_dowarn = G_WARN_OFF;
375 PL_doextract = FALSE;
376 PL_sawampersand = FALSE; /* must save all match strings */
377 PL_sawstudy = FALSE; /* do fbm_instr on all strings */
381 Safefree(PL_inplace);
385 SvREFCNT_dec(PL_e_script);
386 PL_e_script = Nullsv;
389 /* magical thingies */
391 Safefree(PL_ofs); /* $, */
394 Safefree(PL_ors); /* $\ */
397 SvREFCNT_dec(PL_rs); /* $/ */
400 SvREFCNT_dec(PL_nrs); /* $/ helper */
403 PL_multiline = 0; /* $* */
405 SvREFCNT_dec(PL_statname);
406 PL_statname = Nullsv;
409 /* defgv, aka *_ should be taken care of elsewhere */
411 /* clean up after study() */
412 SvREFCNT_dec(PL_lastscream);
413 PL_lastscream = Nullsv;
414 Safefree(PL_screamfirst);
416 Safefree(PL_screamnext);
419 /* startup and shutdown function lists */
420 SvREFCNT_dec(PL_beginav);
421 SvREFCNT_dec(PL_endav);
422 SvREFCNT_dec(PL_initav);
427 /* shortcuts just get cleared */
434 PL_argvoutgv = Nullgv;
436 PL_last_in_gv = Nullgv;
439 /* reset so print() ends up where we expect */
442 /* Prepare to destruct main symbol table. */
449 if (destruct_level >= 2) {
450 if (PL_scopestack_ix != 0)
451 Perl_warn(aTHX_ "Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
452 (long)PL_scopestack_ix);
453 if (PL_savestack_ix != 0)
454 Perl_warn(aTHX_ "Unbalanced saves: %ld more saves than restores\n",
455 (long)PL_savestack_ix);
456 if (PL_tmps_floor != -1)
457 Perl_warn(aTHX_ "Unbalanced tmps: %ld more allocs than frees\n",
458 (long)PL_tmps_floor + 1);
459 if (cxstack_ix != -1)
460 Perl_warn(aTHX_ "Unbalanced context: %ld more PUSHes than POPs\n",
461 (long)cxstack_ix + 1);
464 /* Now absolutely destruct everything, somehow or other, loops or no. */
466 SvFLAGS(PL_strtab) |= SVTYPEMASK; /* don't clean out strtab now */
467 while (PL_sv_count != 0 && PL_sv_count != last_sv_count) {
468 last_sv_count = PL_sv_count;
471 SvFLAGS(PL_strtab) &= ~SVTYPEMASK;
472 SvFLAGS(PL_strtab) |= SVt_PVHV;
474 /* Destruct the global string table. */
476 /* Yell and reset the HeVAL() slots that are still holding refcounts,
477 * so that sv_free() won't fail on them.
485 max = HvMAX(PL_strtab);
486 array = HvARRAY(PL_strtab);
490 Perl_warn(aTHX_ "Unbalanced string table refcount: (%d) for \"%s\"",
491 HeVAL(hent) - Nullsv, HeKEY(hent));
492 HeVAL(hent) = Nullsv;
502 SvREFCNT_dec(PL_strtab);
504 if (PL_sv_count != 0)
505 Perl_warn(aTHX_ "Scalars leaked: %ld\n", (long)PL_sv_count);
509 /* No SVs have survived, need to clean out */
511 PL_pidstatus = Nullhv;
512 Safefree(PL_origfilename);
513 Safefree(PL_archpat_auto);
514 Safefree(PL_reg_start_tmp);
516 Safefree(PL_reg_curpm);
517 Safefree(HeKEY_hek(&PL_hv_fetch_ent_mh));
518 Safefree(PL_op_mask);
520 PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */
522 DEBUG_P(debprofdump());
524 MUTEX_DESTROY(&PL_strtab_mutex);
525 MUTEX_DESTROY(&PL_sv_mutex);
526 MUTEX_DESTROY(&PL_eval_mutex);
527 MUTEX_DESTROY(&PL_cred_mutex);
528 COND_DESTROY(&PL_eval_cond);
529 #ifdef EMULATE_ATOMIC_REFCOUNTS
530 MUTEX_DESTROY(&PL_svref_mutex);
531 #endif /* EMULATE_ATOMIC_REFCOUNTS */
533 /* As the penultimate thing, free the non-arena SV for thrsv */
534 Safefree(SvPVX(PL_thrsv));
535 Safefree(SvANY(PL_thrsv));
538 #endif /* USE_THREADS */
540 /* As the absolutely last thing, free the non-arena SV for mess() */
543 /* it could have accumulated taint magic */
544 if (SvTYPE(PL_mess_sv) >= SVt_PVMG) {
547 for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) {
548 moremagic = mg->mg_moremagic;
549 if (mg->mg_ptr && mg->mg_type != 'g' && mg->mg_len >= 0)
550 Safefree(mg->mg_ptr);
554 /* we know that type >= SVt_PV */
555 SvOOK_off(PL_mess_sv);
556 Safefree(SvPVX(PL_mess_sv));
557 Safefree(SvANY(PL_mess_sv));
558 Safefree(PL_mess_sv);
564 perl_free(PerlInterpreter *my_perl)
569 # if !defined(PERL_IMPLICIT_CONTEXT)
570 if (!(PL_curinterp = my_perl))
578 Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
580 Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry);
581 PL_exitlist[PL_exitlistlen].fn = fn;
582 PL_exitlist[PL_exitlistlen].ptr = ptr;
587 perl_parse(PerlInterpreter *my_perl, XSINIT_t xsinit, int argc, char **argv, char **env)
596 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
599 Perl_croak(aTHX_ "suidperl is no longer needed since the kernel can now execute\n\
600 setuid perl scripts securely.\n");
604 #if !defined(PERL_OBJECT) && !defined(PERL_IMPLICIT_CONTEXT)
605 if (!(PL_curinterp = my_perl))
609 #if defined(__DYNAMIC__) && (defined(NeXT) || defined(__NeXT__))
610 _dyld_lookup_and_bind
611 ("__environ", (unsigned long *) &environ_pointer, NULL);
616 #ifndef VMS /* VMS doesn't have environ array */
617 PL_origenviron = environ;
622 /* Come here if running an undumped a.out. */
624 PL_origfilename = savepv(argv[0]);
625 PL_do_undump = FALSE;
626 cxstack_ix = -1; /* start label stack again */
628 init_postdump_symbols(argc,argv,env);
633 PL_curpad = AvARRAY(PL_comppad);
634 op_free(PL_main_root);
635 PL_main_root = Nullop;
637 PL_main_start = Nullop;
638 SvREFCNT_dec(PL_main_cv);
642 oldscope = PL_scopestack_ix;
643 PL_dowarn = G_WARN_OFF;
645 CALLPROTECT(aTHX_ &ret, FUNC_NAME_TO_PTR(S_parse_body), env, xsinit);
653 /* my_exit() was called */
654 while (PL_scopestack_ix > oldscope)
657 PL_curstash = PL_defstash;
659 call_list(oldscope, PL_endav);
660 return STATUS_NATIVE_EXPORT;
662 PerlIO_printf(PerlIO_stderr(), "panic: top_env\n");
669 S_parse_body(pTHX_ va_list args)
672 int argc = PL_origargc;
673 char **argv = PL_origargv;
674 char **env = va_arg(args, char**);
675 char *scriptname = NULL;
677 VOL bool dosearch = FALSE;
683 XSINIT_t xsinit = va_arg(args, XSINIT_t);
685 sv_setpvn(PL_linestr,"",0);
686 sv = newSVpvn("",0); /* first used for -I flags */
690 for (argc--,argv++; argc > 0; argc--,argv++) {
691 if (argv[0][0] != '-' || !argv[0][1])
695 validarg = " PHOOEY ";
702 #ifndef PERL_STRICT_CR
726 if (s = moreswitches(s))
736 if (PL_euid != PL_uid || PL_egid != PL_gid)
737 Perl_croak(aTHX_ "No -e allowed in setuid scripts");
739 PL_e_script = newSVpvn("",0);
740 filter_add(S_read_e_script, NULL);
743 sv_catpv(PL_e_script, s);
745 sv_catpv(PL_e_script, argv[1]);
749 Perl_croak(aTHX_ "No code specified for -e");
750 sv_catpv(PL_e_script, "\n");
753 case 'I': /* -I handled both here and in moreswitches() */
755 if (!*++s && (s=argv[1]) != Nullch) {
758 while (s && isSPACE(*s))
762 for (e = s; *e && !isSPACE(*e); e++) ;
769 } /* XXX else croak? */
773 PL_preprocess = TRUE;
783 PL_preambleav = newAV();
784 av_push(PL_preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
786 PL_Sv = newSVpv("print myconfig();",0);
788 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
790 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
792 #if defined(DEBUGGING) || defined(MULTIPLICITY)
793 sv_catpv(PL_Sv,"\" Compile-time options:");
795 sv_catpv(PL_Sv," DEBUGGING");
798 sv_catpv(PL_Sv," MULTIPLICITY");
800 sv_catpv(PL_Sv,"\\n\",");
802 #if defined(LOCAL_PATCH_COUNT)
803 if (LOCAL_PATCH_COUNT > 0) {
805 sv_catpv(PL_Sv,"\" Locally applied patches:\\n\",");
806 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
807 if (PL_localpatches[i])
808 Perl_sv_catpvf(aTHX_ PL_Sv,"q\" \t%s\n\",",PL_localpatches[i]);
812 Perl_sv_catpvf(aTHX_ PL_Sv,"\" Built under %s\\n\"",OSNAME);
815 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
817 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled on %s\\n\"",__DATE__);
822 @env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; \
823 print \" \\%ENV:\\n @env\\n\" if @env; \
824 print \" \\@INC:\\n @INC\\n\";");
827 PL_Sv = newSVpv("config_vars(qw(",0);
828 sv_catpv(PL_Sv, ++s);
829 sv_catpv(PL_Sv, "))");
832 av_push(PL_preambleav, PL_Sv);
833 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
839 PL_cddir = savepv(s);
844 if (!*++s || isSPACE(*s)) {
848 /* catch use of gnu style long options */
849 if (strEQ(s, "version")) {
853 if (strEQ(s, "help")) {
860 Perl_croak(aTHX_ "Unrecognized switch: -%s (-h will show valid options)",s);
866 #ifndef SECURE_INTERNAL_GETENV
869 (s = PerlEnv_getenv("PERL5OPT"))) {
872 if (*s == '-' && *(s+1) == 'T')
885 if (!strchr("DIMUdmw", *s))
886 Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
893 scriptname = argv[0];
896 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
898 else if (scriptname == Nullch) {
900 if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
908 open_script(scriptname,dosearch,sv,&fdscript);
910 validate_suid(validarg, scriptname,fdscript);
915 PL_main_cv = PL_compcv = (CV*)NEWSV(1104,0);
916 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
917 CvUNIQUE_on(PL_compcv);
919 PL_comppad = newAV();
920 av_push(PL_comppad, Nullsv);
921 PL_curpad = AvARRAY(PL_comppad);
922 PL_comppad_name = newAV();
923 PL_comppad_name_fill = 0;
924 PL_min_intro_pending = 0;
927 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
928 PL_curpad[0] = (SV*)newAV();
929 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
930 CvOWNER(PL_compcv) = 0;
931 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
932 MUTEX_INIT(CvMUTEXP(PL_compcv));
933 #endif /* USE_THREADS */
935 comppadlist = newAV();
936 AvREAL_off(comppadlist);
937 av_store(comppadlist, 0, (SV*)PL_comppad_name);
938 av_store(comppadlist, 1, (SV*)PL_comppad);
939 CvPADLIST(PL_compcv) = comppadlist;
941 boot_core_UNIVERSAL();
944 (*xsinit)(aTHX); /* in case linked C routines want magical variables */
945 #if defined(VMS) || defined(WIN32) || defined(DJGPP)
946 init_os_extras(aTHX);
949 init_predump_symbols();
950 /* init_postdump_symbols not currently designed to be called */
951 /* more than once (ENV isn't cleared first, for example) */
952 /* But running with -u leaves %ENV & @ARGV undefined! XXX */
954 init_postdump_symbols(argc,argv,env);
958 /* now parse the script */
960 SETERRNO(0,SS$_NORMAL);
962 if (yyparse() || PL_error_count) {
964 Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
966 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
970 PL_curcop->cop_line = 0;
971 PL_curstash = PL_defstash;
972 PL_preprocess = FALSE;
974 SvREFCNT_dec(PL_e_script);
975 PL_e_script = Nullsv;
978 /* now that script is parsed, we can modify record separator */
980 PL_rs = SvREFCNT_inc(PL_nrs);
981 sv_setsv(get_sv("/", TRUE), PL_rs);
985 if (ckWARN(WARN_ONCE))
986 gv_check(PL_defstash);
992 if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
993 dump_mstats("after compilation:");
1002 perl_run(PerlInterpreter *my_perl)
1011 #if !defined(PERL_OBJECT) && !defined(PERL_IMPLICIT_CONTEXT)
1012 if (!(PL_curinterp = my_perl))
1016 oldscope = PL_scopestack_ix;
1019 CALLPROTECT(aTHX_ &ret, FUNC_NAME_TO_PTR(S_run_body), oldscope);
1022 cxstack_ix = -1; /* start context stack again */
1024 case 0: /* normal completion */
1025 case 2: /* my_exit() */
1026 while (PL_scopestack_ix > oldscope)
1029 PL_curstash = PL_defstash;
1031 call_list(oldscope, PL_endav);
1033 if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
1034 dump_mstats("after execution: ");
1036 return STATUS_NATIVE_EXPORT;
1039 POPSTACK_TO(PL_mainstack);
1042 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
1052 S_run_body(pTHX_ va_list args)
1055 I32 oldscope = va_arg(args, I32);
1057 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
1058 PL_sawampersand ? "Enabling" : "Omitting"));
1060 if (!PL_restartop) {
1061 DEBUG_x(dump_all());
1062 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
1063 DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%lx\n",
1064 (unsigned long) thr));
1067 PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", PL_origfilename);
1070 if (PERLDB_SINGLE && PL_DBsingle)
1071 sv_setiv(PL_DBsingle, 1);
1073 call_list(oldscope, PL_initav);
1079 PL_op = PL_restartop;
1083 else if (PL_main_start) {
1084 CvDEPTH(PL_main_cv) = 1;
1085 PL_op = PL_main_start;
1093 Perl_get_sv(pTHX_ const char *name, I32 create)
1097 if (name[1] == '\0' && !isALPHA(name[0])) {
1098 PADOFFSET tmp = find_threadsv(name);
1099 if (tmp != NOT_IN_PAD) {
1101 return THREADSV(tmp);
1104 #endif /* USE_THREADS */
1105 gv = gv_fetchpv(name, create, SVt_PV);
1112 Perl_get_av(pTHX_ const char *name, I32 create)
1114 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1123 Perl_get_hv(pTHX_ const char *name, I32 create)
1125 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1134 Perl_get_cv(pTHX_ const char *name, I32 create)
1136 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
1137 /* XXX unsafe for threads if eval_owner isn't held */
1138 /* XXX this is probably not what they think they're getting.
1139 * It has the same effect as "sub name;", i.e. just a forward
1141 if (create && !GvCVu(gv))
1142 return newSUB(start_subparse(FALSE, 0),
1143 newSVOP(OP_CONST, 0, newSVpv(name,0)),
1151 /* Be sure to refetch the stack pointer after calling these routines. */
1154 Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv)
1156 /* See G_* flags in cop.h */
1157 /* null terminated arg list */
1164 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
1169 return call_pv(sub_name, flags);
1173 Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
1174 /* name of the subroutine */
1175 /* See G_* flags in cop.h */
1177 return call_sv((SV*)get_cv(sub_name, TRUE), flags);
1181 Perl_call_method(pTHX_ const char *methname, I32 flags)
1182 /* name of the subroutine */
1183 /* See G_* flags in cop.h */
1189 XPUSHs(sv_2mortal(newSVpv(methname,0)));
1194 return call_sv(*PL_stack_sp--, flags);
1197 /* May be called with any of a CV, a GV, or an SV containing the name. */
1199 Perl_call_sv(pTHX_ SV *sv, I32 flags)
1201 /* See G_* flags in cop.h */
1204 LOGOP myop; /* fake syntax tree node */
1208 bool oldcatch = CATCH_GET;
1212 if (flags & G_DISCARD) {
1217 Zero(&myop, 1, LOGOP);
1218 myop.op_next = Nullop;
1219 if (!(flags & G_NOARGS))
1220 myop.op_flags |= OPf_STACKED;
1221 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1222 (flags & G_ARRAY) ? OPf_WANT_LIST :
1227 EXTEND(PL_stack_sp, 1);
1228 *++PL_stack_sp = sv;
1230 oldscope = PL_scopestack_ix;
1232 if (PERLDB_SUB && PL_curstash != PL_debstash
1233 /* Handle first BEGIN of -d. */
1234 && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
1235 /* Try harder, since this may have been a sighandler, thus
1236 * curstash may be meaningless. */
1237 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != PL_debstash)
1238 && !(flags & G_NODEBUG))
1239 PL_op->op_private |= OPpENTERSUB_DB;
1241 if (!(flags & G_EVAL)) {
1243 call_xbody((OP*)&myop, FALSE);
1244 retval = PL_stack_sp - (PL_stack_base + oldmark);
1248 cLOGOP->op_other = PL_op;
1250 /* we're trying to emulate pp_entertry() here */
1252 register PERL_CONTEXT *cx;
1253 I32 gimme = GIMME_V;
1258 push_return(PL_op->op_next);
1259 PUSHBLOCK(cx, CXt_EVAL, PL_stack_sp);
1261 PL_eval_root = PL_op; /* Only needed so that goto works right. */
1263 PL_in_eval = EVAL_INEVAL;
1264 if (flags & G_KEEPERR)
1265 PL_in_eval |= EVAL_KEEPERR;
1272 CALLPROTECT(aTHX_ &ret, FUNC_NAME_TO_PTR(S_call_body), (OP*)&myop, FALSE);
1275 retval = PL_stack_sp - (PL_stack_base + oldmark);
1276 if (!(flags & G_KEEPERR))
1283 /* my_exit() was called */
1284 PL_curstash = PL_defstash;
1287 Perl_croak(aTHX_ "Callback called exit");
1292 PL_op = PL_restartop;
1296 PL_stack_sp = PL_stack_base + oldmark;
1297 if (flags & G_ARRAY)
1301 *++PL_stack_sp = &PL_sv_undef;
1306 if (PL_scopestack_ix > oldscope) {
1310 register PERL_CONTEXT *cx;
1321 if (flags & G_DISCARD) {
1322 PL_stack_sp = PL_stack_base + oldmark;
1332 S_call_body(pTHX_ va_list args)
1334 OP *myop = va_arg(args, OP*);
1335 int is_eval = va_arg(args, int);
1337 call_xbody(myop, is_eval);
1342 S_call_xbody(pTHX_ OP *myop, int is_eval)
1346 if (PL_op == myop) {
1348 PL_op = Perl_pp_entereval(aTHX);
1350 PL_op = Perl_pp_entersub(aTHX);
1356 /* Eval a string. The G_EVAL flag is always assumed. */
1359 Perl_eval_sv(pTHX_ SV *sv, I32 flags)
1361 /* See G_* flags in cop.h */
1364 UNOP myop; /* fake syntax tree node */
1365 I32 oldmark = SP - PL_stack_base;
1371 if (flags & G_DISCARD) {
1378 Zero(PL_op, 1, UNOP);
1379 EXTEND(PL_stack_sp, 1);
1380 *++PL_stack_sp = sv;
1381 oldscope = PL_scopestack_ix;
1383 if (!(flags & G_NOARGS))
1384 myop.op_flags = OPf_STACKED;
1385 myop.op_next = Nullop;
1386 myop.op_type = OP_ENTEREVAL;
1387 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1388 (flags & G_ARRAY) ? OPf_WANT_LIST :
1390 if (flags & G_KEEPERR)
1391 myop.op_flags |= OPf_SPECIAL;
1394 CALLPROTECT(aTHX_ &ret, FUNC_NAME_TO_PTR(S_call_body), (OP*)&myop, TRUE);
1397 retval = PL_stack_sp - (PL_stack_base + oldmark);
1398 if (!(flags & G_KEEPERR))
1405 /* my_exit() was called */
1406 PL_curstash = PL_defstash;
1409 Perl_croak(aTHX_ "Callback called exit");
1414 PL_op = PL_restartop;
1418 PL_stack_sp = PL_stack_base + oldmark;
1419 if (flags & G_ARRAY)
1423 *++PL_stack_sp = &PL_sv_undef;
1428 if (flags & G_DISCARD) {
1429 PL_stack_sp = PL_stack_base + oldmark;
1439 Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
1442 SV* sv = newSVpv(p, 0);
1445 eval_sv(sv, G_SCALAR);
1452 if (croak_on_error && SvTRUE(ERRSV)) {
1454 Perl_croak(aTHX_ SvPVx(ERRSV, n_a));
1460 /* Require a module. */
1463 Perl_require_pv(pTHX_ const char *pv)
1467 PUSHSTACKi(PERLSI_REQUIRE);
1469 sv = sv_newmortal();
1470 sv_setpv(sv, "require '");
1473 eval_sv(sv, G_DISCARD);
1479 Perl_magicname(pTHX_ char *sym, char *name, I32 namlen)
1483 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1484 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1488 S_usage(pTHX_ char *name) /* XXX move this out into a module ? */
1490 /* This message really ought to be max 23 lines.
1491 * Removed -h because the user already knows that opton. Others? */
1493 static char *usage_msg[] = {
1494 "-0[octal] specify record separator (\\0, if no argument)",
1495 "-a autosplit mode with -n or -p (splits $_ into @F)",
1496 "-c check syntax only (runs BEGIN and END blocks)",
1497 "-d[:debugger] run program under debugger",
1498 "-D[number/list] set debugging flags (argument is a bit mask or alphabets)",
1499 "-e 'command' one line of program (several -e's allowed, omit programfile)",
1500 "-F/pattern/ split() pattern for -a switch (//'s are optional)",
1501 "-i[extension] edit <> files in place (makes backup if extension supplied)",
1502 "-Idirectory specify @INC/#include directory (several -I's allowed)",
1503 "-l[octal] enable line ending processing, specifies line terminator",
1504 "-[mM][-]module execute `use/no module...' before executing program",
1505 "-n assume 'while (<>) { ... }' loop around program",
1506 "-p assume loop like -n but print line also, like sed",
1507 "-P run program through C preprocessor before compilation",
1508 "-s enable rudimentary parsing for switches after programfile",
1509 "-S look for programfile using PATH environment variable",
1510 "-T enable tainting checks",
1511 "-u dump core after parsing program",
1512 "-U allow unsafe operations",
1513 "-v print version, subversion (includes VERY IMPORTANT perl info)",
1514 "-V[:variable] print configuration summary (or a single Config.pm variable)",
1515 "-w enable many useful warnings (RECOMMENDED)",
1516 "-x[directory] strip off text before #!perl line and perhaps cd to directory",
1520 char **p = usage_msg;
1522 printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1524 printf("\n %s", *p++);
1527 /* This routine handles any switches that can be given during run */
1530 Perl_moreswitches(pTHX_ char *s)
1539 rschar = scan_oct(s, 4, &numlen);
1540 SvREFCNT_dec(PL_nrs);
1541 if (rschar & ~((U8)~0))
1542 PL_nrs = &PL_sv_undef;
1543 else if (!rschar && numlen >= 2)
1544 PL_nrs = newSVpvn("", 0);
1547 PL_nrs = newSVpvn(&ch, 1);
1553 PL_splitstr = savepv(s + 1);
1567 if (*s == ':' || *s == '=') {
1568 my_setenv("PERL5DB", Perl_form(aTHX_ "use Devel::%s;", ++s));
1572 PL_perldb = PERLDB_ALL;
1579 if (isALPHA(s[1])) {
1580 static char debopts[] = "psltocPmfrxuLHXDS";
1583 for (s++; *s && (d = strchr(debopts,*s)); s++)
1584 PL_debug |= 1 << (d - debopts);
1587 PL_debug = atoi(s+1);
1588 for (s++; isDIGIT(*s); s++) ;
1590 PL_debug |= 0x80000000;
1592 Perl_warn(aTHX_ "Recompile perl with -DDEBUGGING to use -D switch\n");
1593 for (s++; isALNUM(*s); s++) ;
1598 usage(PL_origargv[0]);
1602 Safefree(PL_inplace);
1603 PL_inplace = savepv(s+1);
1605 for (s = PL_inplace; *s && !isSPACE(*s); s++) ;
1608 if (*s == '-') /* Additional switches on #! line. */
1612 case 'I': /* -I handled both here and in parse_perl() */
1615 while (*s && isSPACE(*s))
1619 for (e = s; *e && !isSPACE(*e); e++) ;
1620 p = savepvn(s, e-s);
1626 Perl_croak(aTHX_ "No space allowed after -I");
1634 PL_ors = savepv("\n");
1636 *PL_ors = scan_oct(s, 3 + (*s == '0'), &numlen);
1641 if (RsPARA(PL_nrs)) {
1646 PL_ors = SvPV(PL_nrs, PL_orslen);
1647 PL_ors = savepvn(PL_ors, PL_orslen);
1651 forbid_setid("-M"); /* XXX ? */
1654 forbid_setid("-m"); /* XXX ? */
1659 /* -M-foo == 'no foo' */
1660 if (*s == '-') { use = "no "; ++s; }
1661 sv = newSVpv(use,0);
1663 /* We allow -M'Module qw(Foo Bar)' */
1664 while(isALNUM(*s) || *s==':') ++s;
1666 sv_catpv(sv, start);
1667 if (*(start-1) == 'm') {
1669 Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
1670 sv_catpv( sv, " ()");
1673 sv_catpvn(sv, start, s-start);
1674 sv_catpv(sv, " split(/,/,q{");
1679 if (PL_preambleav == NULL)
1680 PL_preambleav = newAV();
1681 av_push(PL_preambleav, sv);
1684 Perl_croak(aTHX_ "No space allowed after -%c", *(s-1));
1696 PL_doswitches = TRUE;
1701 Perl_croak(aTHX_ "Too late for \"-T\" option");
1705 PL_do_undump = TRUE;
1713 #if defined(PERL_SUBVERSION) && PERL_SUBVERSION > 0
1714 printf("\nThis is perl, version %d.%03d_%02d built for %s",
1715 PERL_REVISION, PERL_VERSION, PERL_SUBVERSION, ARCHNAME);
1717 printf("\nThis is perl, version %s built for %s",
1718 PL_patchlevel, ARCHNAME);
1720 #if defined(LOCAL_PATCH_COUNT)
1721 if (LOCAL_PATCH_COUNT > 0)
1722 printf("\n(with %d registered patch%s, see perl -V for more detail)",
1723 LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : "");
1726 printf("\n\nCopyright 1987-1999, Larry Wall\n");
1728 printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1731 printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
1732 printf("djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
1735 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1736 "Version 5 port Copyright (c) 1994-1999, Andreas Kaiser, Ilya Zakharevich\n");
1739 printf("atariST series port, ++jrb bammi@cadence.com\n");
1742 printf("BeOS port Copyright Tom Spindler, 1997-1999\n");
1745 printf("MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-1999\n");
1748 printf("MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
1751 printf("Stratus VOS port by Paul_Green@stratus.com, 1997-1999\n");
1754 printf("VM/ESA port by Neale Ferguson, 1998-1999\n");
1757 printf("BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
1760 printf("MiNT port by Guido Flohr, 1997-1999\n");
1762 #ifdef BINARY_BUILD_NOTICE
1763 BINARY_BUILD_NOTICE;
1766 Perl may be copied only under the terms of either the Artistic License or the\n\
1767 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n\
1768 Complete documentation for Perl, including FAQ lists, should be found on\n\
1769 this system using `man perl' or `perldoc perl'. If you have access to the\n\
1770 Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
1773 if (! (PL_dowarn & G_WARN_ALL_MASK))
1774 PL_dowarn |= G_WARN_ON;
1778 PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
1779 PL_compiling.cop_warnings = WARN_ALL ;
1783 PL_dowarn = G_WARN_ALL_OFF;
1784 PL_compiling.cop_warnings = WARN_NONE ;
1789 if (s[1] == '-') /* Additional switches on #! line. */
1794 #if defined(WIN32) || !defined(PERL_STRICT_CR)
1800 #ifdef ALTERNATE_SHEBANG
1801 case 'S': /* OS/2 needs -S on "extproc" line. */
1809 Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
1814 /* compliments of Tom Christiansen */
1816 /* unexec() can be found in the Gnu emacs distribution */
1817 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
1820 Perl_my_unexec(pTHX)
1828 prog = newSVpv(BIN_EXP, 0);
1829 sv_catpv(prog, "/perl");
1830 file = newSVpv(PL_origfilename, 0);
1831 sv_catpv(file, ".perldump");
1833 unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
1834 /* unexec prints msg to stderr in case of failure */
1835 PerlProc_exit(status);
1838 # include <lib$routines.h>
1839 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
1841 ABORT(); /* for use with undump */
1846 /* initialize curinterp */
1851 #ifdef PERL_OBJECT /* XXX kludge */
1854 PL_chopset = " \n-"; \
1855 PL_copline = NOLINE; \
1856 PL_curcop = &PL_compiling;\
1857 PL_curcopdb = NULL; \
1860 PL_dumpindent = 4; \
1861 PL_laststatval = -1; \
1862 PL_laststype = OP_STAT; \
1863 PL_maxscream = -1; \
1864 PL_maxsysfd = MAXSYSFD; \
1865 PL_statname = Nullsv; \
1866 PL_tmps_floor = -1; \
1868 PL_op_mask = NULL; \
1870 PL_laststatval = -1; \
1871 PL_laststype = OP_STAT; \
1872 PL_mess_sv = Nullsv; \
1873 PL_splitstr = " "; \
1874 PL_generation = 100; \
1875 PL_exitlist = NULL; \
1876 PL_exitlistlen = 0; \
1878 PL_in_clean_objs = FALSE; \
1879 PL_in_clean_all = FALSE; \
1880 PL_profiledata = NULL; \
1882 PL_rsfp_filters = Nullav; \
1887 # ifdef MULTIPLICITY
1888 # define PERLVAR(var,type)
1889 # if defined(PERL_IMPLICIT_CONTEXT)
1890 # define PERLVARI(var,type,init) my_perl->var = init;
1891 # define PERLVARIC(var,type,init) my_perl->var = init;
1893 # define PERLVARI(var,type,init) PL_curinterp->var = init;
1894 # define PERLVARIC(var,type,init) PL_curinterp->var = init;
1896 # include "intrpvar.h"
1897 # ifndef USE_THREADS
1898 # include "thrdvar.h"
1904 # define PERLVAR(var,type)
1905 # define PERLVARI(var,type,init) PL_##var = init;
1906 # define PERLVARIC(var,type,init) PL_##var = init;
1907 # include "intrpvar.h"
1908 # ifndef USE_THREADS
1909 # include "thrdvar.h"
1920 S_init_main_stash(pTHX)
1925 /* Note that strtab is a rather special HV. Assumptions are made
1926 about not iterating on it, and not adding tie magic to it.
1927 It is properly deallocated in perl_destruct() */
1928 PL_strtab = newHV();
1930 MUTEX_INIT(&PL_strtab_mutex);
1932 HvSHAREKEYS_off(PL_strtab); /* mandatory */
1933 hv_ksplit(PL_strtab, 512);
1935 PL_curstash = PL_defstash = newHV();
1936 PL_curstname = newSVpvn("main",4);
1937 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1938 SvREFCNT_dec(GvHV(gv));
1939 GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
1941 HvNAME(PL_defstash) = savepv("main");
1942 PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1943 GvMULTI_on(PL_incgv);
1944 PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
1945 GvMULTI_on(PL_hintgv);
1946 PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1947 PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1948 GvMULTI_on(PL_errgv);
1949 PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
1950 GvMULTI_on(PL_replgv);
1951 (void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */
1952 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
1953 sv_setpvn(ERRSV, "", 0);
1954 PL_curstash = PL_defstash;
1955 PL_compiling.cop_stash = PL_defstash;
1956 PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
1957 PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
1958 /* We must init $/ before switches are processed. */
1959 sv_setpvn(get_sv("/", TRUE), "\n", 1);
1963 S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
1971 PL_origfilename = savepv("-e");
1974 /* if find_script() returns, it returns a malloc()-ed value */
1975 PL_origfilename = scriptname = find_script(scriptname, dosearch, NULL, 1);
1977 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
1978 char *s = scriptname + 8;
1979 *fdscript = atoi(s);
1983 scriptname = savepv(s + 1);
1984 Safefree(PL_origfilename);
1985 PL_origfilename = scriptname;
1990 PL_curcop->cop_filegv = gv_fetchfile(PL_origfilename);
1991 if (strEQ(PL_origfilename,"-"))
1993 if (*fdscript >= 0) {
1994 PL_rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE);
1995 #if defined(HAS_FCNTL) && defined(F_SETFD)
1997 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); /* ensure close-on-exec */
2000 else if (PL_preprocess) {
2001 char *cpp_cfg = CPPSTDIN;
2002 SV *cpp = newSVpvn("",0);
2003 SV *cmd = NEWSV(0,0);
2005 if (strEQ(cpp_cfg, "cppstdin"))
2006 Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
2007 sv_catpv(cpp, cpp_cfg);
2010 sv_catpv(sv,PRIVLIB_EXP);
2013 Perl_sv_setpvf(aTHX_ cmd, "\
2014 sed %s -e \"/^[^#]/b\" \
2015 -e \"/^#[ ]*include[ ]/b\" \
2016 -e \"/^#[ ]*define[ ]/b\" \
2017 -e \"/^#[ ]*if[ ]/b\" \
2018 -e \"/^#[ ]*ifdef[ ]/b\" \
2019 -e \"/^#[ ]*ifndef[ ]/b\" \
2020 -e \"/^#[ ]*else/b\" \
2021 -e \"/^#[ ]*elif[ ]/b\" \
2022 -e \"/^#[ ]*undef[ ]/b\" \
2023 -e \"/^#[ ]*endif/b\" \
2026 (PL_doextract ? "-e \"1,/^#/d\n\"" : ""),
2029 Perl_sv_setpvf(aTHX_ cmd, "\
2030 %s %s -e '/^[^#]/b' \
2031 -e '/^#[ ]*include[ ]/b' \
2032 -e '/^#[ ]*define[ ]/b' \
2033 -e '/^#[ ]*if[ ]/b' \
2034 -e '/^#[ ]*ifdef[ ]/b' \
2035 -e '/^#[ ]*ifndef[ ]/b' \
2036 -e '/^#[ ]*else/b' \
2037 -e '/^#[ ]*elif[ ]/b' \
2038 -e '/^#[ ]*undef[ ]/b' \
2039 -e '/^#[ ]*endif/b' \
2043 Perl_sv_setpvf(aTHX_ cmd, "\
2044 %s %s -e '/^[^#]/b' \
2045 -e '/^#[ ]*include[ ]/b' \
2046 -e '/^#[ ]*define[ ]/b' \
2047 -e '/^#[ ]*if[ ]/b' \
2048 -e '/^#[ ]*ifdef[ ]/b' \
2049 -e '/^#[ ]*ifndef[ ]/b' \
2050 -e '/^#[ ]*else/b' \
2051 -e '/^#[ ]*elif[ ]/b' \
2052 -e '/^#[ ]*undef[ ]/b' \
2053 -e '/^#[ ]*endif/b' \
2062 (PL_doextract ? "-e '1,/^#/d\n'" : ""),
2064 scriptname, cpp, sv, CPPMINUS);
2065 PL_doextract = FALSE;
2066 #ifdef IAMSUID /* actually, this is caught earlier */
2067 if (PL_euid != PL_uid && !PL_euid) { /* if running suidperl */
2069 (void)seteuid(PL_uid); /* musn't stay setuid root */
2072 (void)setreuid((Uid_t)-1, PL_uid);
2074 #ifdef HAS_SETRESUID
2075 (void)setresuid((Uid_t)-1, PL_uid, (Uid_t)-1);
2077 PerlProc_setuid(PL_uid);
2081 if (PerlProc_geteuid() != PL_uid)
2082 Perl_croak(aTHX_ "Can't do seteuid!\n");
2084 #endif /* IAMSUID */
2085 PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
2089 else if (!*scriptname) {
2090 forbid_setid("program input from stdin");
2091 PL_rsfp = PerlIO_stdin();
2094 PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
2095 #if defined(HAS_FCNTL) && defined(F_SETFD)
2097 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); /* ensure close-on-exec */
2102 #ifndef IAMSUID /* in case script is not readable before setuid */
2104 PerlLIO_stat(SvPVX(GvSV(PL_curcop->cop_filegv)),&PL_statbuf) >= 0 &&
2105 PL_statbuf.st_mode & (S_ISUID|S_ISGID))
2108 PerlProc_execv(Perl_form(aTHX_ "%s/sperl%s", BIN_EXP, PL_patchlevel), PL_origargv);
2109 Perl_croak(aTHX_ "Can't do setuid\n");
2113 Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
2114 SvPVX(GvSV(PL_curcop->cop_filegv)), Strerror(errno));
2119 * I_SYSSTATVFS HAS_FSTATVFS
2121 * I_STATFS HAS_FSTATFS
2122 * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT
2123 * here so that metaconfig picks them up. */
2127 S_fd_on_nosuid_fs(pTHX_ int fd)
2132 * Preferred order: fstatvfs(), fstatfs(), getmntent().
2133 * fstatvfs() is UNIX98.
2135 * getmntent() is O(number-of-mounted-filesystems) and can hang.
2138 # ifdef HAS_FSTATVFS
2139 struct statvfs stfs;
2140 check_okay = fstatvfs(fd, &stfs) == 0;
2141 on_nosuid = check_okay && (stfs.f_flag & ST_NOSUID);
2143 # if defined(HAS_FSTATFS) && defined(HAS_STRUCT_STATFS_FLAGS)
2145 check_okay = fstatfs(fd, &stfs) == 0;
2146 # undef PERL_MOUNT_NOSUID
2147 # if !defined(PERL_MOUNT_NOSUID) && defined(MNT_NOSUID)
2148 # define PERL_MOUNT_NOSUID MNT_NOSUID
2150 # if !defined(PERL_MOUNT_NOSUID) && defined(MS_NOSUID)
2151 # define PERL_MOUNT_NOSUID MS_NOSUID
2153 # if !defined(PERL_MOUNT_NOSUID) && defined(M_NOSUID)
2154 # define PERL_MOUNT_NOSUID M_NOSUID
2156 # ifdef PERL_MOUNT_NOSUID
2157 on_nosuid = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
2160 # if defined(HAS_GETMNTENT) && defined(HAS_HASMNTOPT) && defined(MNTOPT_NOSUID)
2161 FILE *mtab = fopen("/etc/mtab", "r");
2162 struct mntent *entry;
2163 struct stat stb, fsb;
2165 if (mtab && (fstat(fd, &stb) == 0)) {
2166 while (entry = getmntent(mtab)) {
2167 if (stat(entry->mnt_dir, &fsb) == 0
2168 && fsb.st_dev == stb.st_dev)
2170 /* found the filesystem */
2172 if (hasmntopt(entry, MNTOPT_NOSUID))
2175 } /* A single fs may well fail its stat(). */
2180 # endif /* mntent */
2181 # endif /* statfs */
2182 # endif /* statvfs */
2184 Perl_croak(aTHX_ "Can't check filesystem of script \"%s\"", PL_origfilename);
2187 #endif /* IAMSUID */
2190 S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript)
2194 /* do we need to emulate setuid on scripts? */
2196 /* This code is for those BSD systems that have setuid #! scripts disabled
2197 * in the kernel because of a security problem. Merely defining DOSUID
2198 * in perl will not fix that problem, but if you have disabled setuid
2199 * scripts in the kernel, this will attempt to emulate setuid and setgid
2200 * on scripts that have those now-otherwise-useless bits set. The setuid
2201 * root version must be called suidperl or sperlN.NNN. If regular perl
2202 * discovers that it has opened a setuid script, it calls suidperl with
2203 * the same argv that it had. If suidperl finds that the script it has
2204 * just opened is NOT setuid root, it sets the effective uid back to the
2205 * uid. We don't just make perl setuid root because that loses the
2206 * effective uid we had before invoking perl, if it was different from the
2209 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
2210 * be defined in suidperl only. suidperl must be setuid root. The
2211 * Configure script will set this up for you if you want it.
2218 if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */
2219 Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
2220 if (fdscript < 0 && PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
2225 #ifndef HAS_SETREUID
2226 /* On this access check to make sure the directories are readable,
2227 * there is actually a small window that the user could use to make
2228 * filename point to an accessible directory. So there is a faint
2229 * chance that someone could execute a setuid script down in a
2230 * non-accessible directory. I don't know what to do about that.
2231 * But I don't think it's too important. The manual lies when
2232 * it says access() is useful in setuid programs.
2234 if (PerlLIO_access(SvPVX(GvSV(PL_curcop->cop_filegv)),1)) /*double check*/
2235 Perl_croak(aTHX_ "Permission denied");
2237 /* If we can swap euid and uid, then we can determine access rights
2238 * with a simple stat of the file, and then compare device and
2239 * inode to make sure we did stat() on the same file we opened.
2240 * Then we just have to make sure he or she can execute it.
2243 struct stat tmpstatbuf;
2247 setreuid(PL_euid,PL_uid) < 0
2250 setresuid(PL_euid,PL_uid,(Uid_t)-1) < 0
2253 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
2254 Perl_croak(aTHX_ "Can't swap uid and euid"); /* really paranoid */
2255 if (PerlLIO_stat(SvPVX(GvSV(PL_curcop->cop_filegv)),&tmpstatbuf) < 0)
2256 Perl_croak(aTHX_ "Permission denied"); /* testing full pathname here */
2257 #if defined(IAMSUID) && !defined(NO_NOSUID_CHECK)
2258 if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp)))
2259 Perl_croak(aTHX_ "Permission denied");
2261 if (tmpstatbuf.st_dev != PL_statbuf.st_dev ||
2262 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
2263 (void)PerlIO_close(PL_rsfp);
2264 if (PL_rsfp = PerlProc_popen("/bin/mail root","w")) { /* heh, heh */
2265 PerlIO_printf(PL_rsfp,
2266 "User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2267 (Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
2268 (long)PL_uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
2269 (long)PL_statbuf.st_dev, (long)PL_statbuf.st_ino,
2270 SvPVX(GvSV(PL_curcop->cop_filegv)),
2271 (long)PL_statbuf.st_uid, (long)PL_statbuf.st_gid);
2272 (void)PerlProc_pclose(PL_rsfp);
2274 Perl_croak(aTHX_ "Permission denied\n");
2278 setreuid(PL_uid,PL_euid) < 0
2280 # if defined(HAS_SETRESUID)
2281 setresuid(PL_uid,PL_euid,(Uid_t)-1) < 0
2284 || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
2285 Perl_croak(aTHX_ "Can't reswap uid and euid");
2286 if (!cando(S_IXUSR,FALSE,&PL_statbuf)) /* can real uid exec? */
2287 Perl_croak(aTHX_ "Permission denied\n");
2289 #endif /* HAS_SETREUID */
2290 #endif /* IAMSUID */
2292 if (!S_ISREG(PL_statbuf.st_mode))
2293 Perl_croak(aTHX_ "Permission denied");
2294 if (PL_statbuf.st_mode & S_IWOTH)
2295 Perl_croak(aTHX_ "Setuid/gid script is writable by world");
2296 PL_doswitches = FALSE; /* -s is insecure in suid */
2297 PL_curcop->cop_line++;
2298 if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
2299 strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */
2300 Perl_croak(aTHX_ "No #! line");
2301 s = SvPV(PL_linestr,n_a)+2;
2303 while (!isSPACE(*s)) s++;
2304 for (s2 = s; (s2 > SvPV(PL_linestr,n_a)+2 &&
2305 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
2306 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
2307 Perl_croak(aTHX_ "Not a perl script");
2308 while (*s == ' ' || *s == '\t') s++;
2310 * #! arg must be what we saw above. They can invoke it by
2311 * mentioning suidperl explicitly, but they may not add any strange
2312 * arguments beyond what #! says if they do invoke suidperl that way.
2314 len = strlen(validarg);
2315 if (strEQ(validarg," PHOOEY ") ||
2316 strnNE(s,validarg,len) || !isSPACE(s[len]))
2317 Perl_croak(aTHX_ "Args must match #! line");
2320 if (PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
2321 PL_euid == PL_statbuf.st_uid)
2323 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2324 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2325 #endif /* IAMSUID */
2327 if (PL_euid) { /* oops, we're not the setuid root perl */
2328 (void)PerlIO_close(PL_rsfp);
2331 PerlProc_execv(Perl_form(aTHX_ "%s/sperl%s", BIN_EXP, PL_patchlevel), PL_origargv);
2333 Perl_croak(aTHX_ "Can't do setuid\n");
2336 if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
2338 (void)setegid(PL_statbuf.st_gid);
2341 (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
2343 #ifdef HAS_SETRESGID
2344 (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
2346 PerlProc_setgid(PL_statbuf.st_gid);
2350 if (PerlProc_getegid() != PL_statbuf.st_gid)
2351 Perl_croak(aTHX_ "Can't do setegid!\n");
2353 if (PL_statbuf.st_mode & S_ISUID) {
2354 if (PL_statbuf.st_uid != PL_euid)
2356 (void)seteuid(PL_statbuf.st_uid); /* all that for this */
2359 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
2361 #ifdef HAS_SETRESUID
2362 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
2364 PerlProc_setuid(PL_statbuf.st_uid);
2368 if (PerlProc_geteuid() != PL_statbuf.st_uid)
2369 Perl_croak(aTHX_ "Can't do seteuid!\n");
2371 else if (PL_uid) { /* oops, mustn't run as root */
2373 (void)seteuid((Uid_t)PL_uid);
2376 (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
2378 #ifdef HAS_SETRESUID
2379 (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
2381 PerlProc_setuid((Uid_t)PL_uid);
2385 if (PerlProc_geteuid() != PL_uid)
2386 Perl_croak(aTHX_ "Can't do seteuid!\n");
2389 if (!cando(S_IXUSR,TRUE,&PL_statbuf))
2390 Perl_croak(aTHX_ "Permission denied\n"); /* they can't do this */
2393 else if (PL_preprocess)
2394 Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
2395 else if (fdscript >= 0)
2396 Perl_croak(aTHX_ "fd script not allowed in suidperl\n");
2398 Perl_croak(aTHX_ "Script is not setuid/setgid in suidperl\n");
2400 /* We absolutely must clear out any saved ids here, so we */
2401 /* exec the real perl, substituting fd script for scriptname. */
2402 /* (We pass script name as "subdir" of fd, which perl will grok.) */
2403 PerlIO_rewind(PL_rsfp);
2404 PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0); /* just in case rewind didn't */
2405 for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
2406 if (!PL_origargv[which])
2407 Perl_croak(aTHX_ "Permission denied");
2408 PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
2409 PerlIO_fileno(PL_rsfp), PL_origargv[which]));
2410 #if defined(HAS_FCNTL) && defined(F_SETFD)
2411 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */
2413 PerlProc_execv(Perl_form(aTHX_ "%s/perl%s", BIN_EXP, PL_patchlevel), PL_origargv);/* try again */
2414 Perl_croak(aTHX_ "Can't do setuid\n");
2415 #endif /* IAMSUID */
2417 if (PL_euid != PL_uid || PL_egid != PL_gid) { /* (suidperl doesn't exist, in fact) */
2418 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2420 PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf); /* may be either wrapped or real suid */
2421 if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
2423 (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
2426 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2427 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2428 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2429 /* not set-id, must be wrapped */
2435 S_find_beginning(pTHX)
2437 register char *s, *s2;
2439 /* skip forward in input to the real script? */
2442 while (PL_doextract) {
2443 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
2444 Perl_croak(aTHX_ "No Perl script found in input\n");
2445 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2446 PerlIO_ungetc(PL_rsfp, '\n'); /* to keep line count right */
2447 PL_doextract = FALSE;
2448 while (*s && !(isSPACE (*s) || *s == '#')) s++;
2450 while (*s == ' ' || *s == '\t') s++;
2452 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2453 if (strnEQ(s2-4,"perl",4))
2455 while (s = moreswitches(s)) ;
2457 if (PL_cddir && PerlDir_chdir(PL_cddir) < 0)
2458 Perl_croak(aTHX_ "Can't chdir to %s",PL_cddir);
2467 PL_uid = (int)PerlProc_getuid();
2468 PL_euid = (int)PerlProc_geteuid();
2469 PL_gid = (int)PerlProc_getgid();
2470 PL_egid = (int)PerlProc_getegid();
2472 PL_uid |= PL_gid << 16;
2473 PL_euid |= PL_egid << 16;
2475 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2479 S_forbid_setid(pTHX_ char *s)
2481 if (PL_euid != PL_uid)
2482 Perl_croak(aTHX_ "No %s allowed while running setuid", s);
2483 if (PL_egid != PL_gid)
2484 Perl_croak(aTHX_ "No %s allowed while running setgid", s);
2488 S_init_debugger(pTHX)
2491 PL_curstash = PL_debstash;
2492 PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2493 AvREAL_off(PL_dbargs);
2494 PL_DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2495 PL_DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2496 PL_DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2497 PL_DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2498 sv_setiv(PL_DBsingle, 0);
2499 PL_DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2500 sv_setiv(PL_DBtrace, 0);
2501 PL_DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2502 sv_setiv(PL_DBsignal, 0);
2503 PL_curstash = PL_defstash;
2506 #ifndef STRESS_REALLOC
2507 #define REASONABLE(size) (size)
2509 #define REASONABLE(size) (1) /* unreasonable */
2513 Perl_init_stacks(pTHX)
2515 /* start with 128-item stack and 8K cxstack */
2516 PL_curstackinfo = new_stackinfo(REASONABLE(128),
2517 REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
2518 PL_curstackinfo->si_type = PERLSI_MAIN;
2519 PL_curstack = PL_curstackinfo->si_stack;
2520 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
2522 PL_stack_base = AvARRAY(PL_curstack);
2523 PL_stack_sp = PL_stack_base;
2524 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
2526 New(50,PL_tmps_stack,REASONABLE(128),SV*);
2529 PL_tmps_max = REASONABLE(128);
2531 New(54,PL_markstack,REASONABLE(32),I32);
2532 PL_markstack_ptr = PL_markstack;
2533 PL_markstack_max = PL_markstack + REASONABLE(32);
2537 New(54,PL_scopestack,REASONABLE(32),I32);
2538 PL_scopestack_ix = 0;
2539 PL_scopestack_max = REASONABLE(32);
2541 New(54,PL_savestack,REASONABLE(128),ANY);
2542 PL_savestack_ix = 0;
2543 PL_savestack_max = REASONABLE(128);
2545 New(54,PL_retstack,REASONABLE(16),OP*);
2547 PL_retstack_max = REASONABLE(16);
2556 while (PL_curstackinfo->si_next)
2557 PL_curstackinfo = PL_curstackinfo->si_next;
2558 while (PL_curstackinfo) {
2559 PERL_SI *p = PL_curstackinfo->si_prev;
2560 /* curstackinfo->si_stack got nuked by sv_free_arenas() */
2561 Safefree(PL_curstackinfo->si_cxstack);
2562 Safefree(PL_curstackinfo);
2563 PL_curstackinfo = p;
2565 Safefree(PL_tmps_stack);
2566 Safefree(PL_markstack);
2567 Safefree(PL_scopestack);
2568 Safefree(PL_savestack);
2569 Safefree(PL_retstack);
2571 Safefree(PL_debname);
2572 Safefree(PL_debdelim);
2577 static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
2588 lex_start(PL_linestr);
2590 PL_subname = newSVpvn("main",4);
2594 S_init_predump_symbols(pTHX)
2600 sv_setpvn(get_sv("\"", TRUE), " ", 1);
2601 PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2602 GvMULTI_on(PL_stdingv);
2603 IoIFP(GvIOp(PL_stdingv)) = PerlIO_stdin();
2604 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2606 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(PL_stdingv));
2608 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2610 IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
2612 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2614 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(PL_defoutgv));
2616 othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2617 GvMULTI_on(othergv);
2618 IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr();
2619 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2621 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
2623 PL_statname = NEWSV(66,0); /* last filename we did stat on */
2626 PL_osname = savepv(OSNAME);
2630 S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
2637 argc--,argv++; /* skip name of script */
2638 if (PL_doswitches) {
2639 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2642 if (argv[0][1] == '-') {
2646 if (s = strchr(argv[0], '=')) {
2648 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2651 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2654 PL_toptarget = NEWSV(0,0);
2655 sv_upgrade(PL_toptarget, SVt_PVFM);
2656 sv_setpvn(PL_toptarget, "", 0);
2657 PL_bodytarget = NEWSV(0,0);
2658 sv_upgrade(PL_bodytarget, SVt_PVFM);
2659 sv_setpvn(PL_bodytarget, "", 0);
2660 PL_formtarget = PL_bodytarget;
2663 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2664 sv_setpv(GvSV(tmpgv),PL_origfilename);
2665 magicname("0", "0", 1);
2667 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2668 sv_setpv(GvSV(tmpgv),PL_origargv[0]);
2669 if (PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2670 GvMULTI_on(PL_argvgv);
2671 (void)gv_AVadd(PL_argvgv);
2672 av_clear(GvAVn(PL_argvgv));
2673 for (; argc > 0; argc--,argv++) {
2674 av_push(GvAVn(PL_argvgv),newSVpv(argv[0],0));
2677 if (PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2679 GvMULTI_on(PL_envgv);
2680 hv = GvHVn(PL_envgv);
2681 hv_magic(hv, PL_envgv, 'E');
2682 #ifndef VMS /* VMS doesn't have environ array */
2683 /* Note that if the supplied env parameter is actually a copy
2684 of the global environ then it may now point to free'd memory
2685 if the environment has been modified since. To avoid this
2686 problem we treat env==NULL as meaning 'use the default'
2691 environ[0] = Nullch;
2692 for (; *env; env++) {
2693 if (!(s = strchr(*env,'=')))
2699 sv = newSVpv(s--,0);
2700 (void)hv_store(hv, *env, s - *env, sv, 0);
2702 #if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
2703 /* Sins of the RTL. See note in my_setenv(). */
2704 (void)PerlEnv_putenv(savepv(*env));
2708 #ifdef DYNAMIC_ENV_FETCH
2709 HvNAME(hv) = savepv(ENV_HV_NAME);
2713 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2714 sv_setiv(GvSV(tmpgv), (IV)getpid());
2718 S_init_perllib(pTHX)
2723 s = PerlEnv_getenv("PERL5LIB");
2727 incpush(PerlEnv_getenv("PERLLIB"), FALSE);
2729 /* Treat PERL5?LIB as a possible search list logical name -- the
2730 * "natural" VMS idiom for a Unix path string. We allow each
2731 * element to be a set of |-separated directories for compatibility.
2735 if (my_trnlnm("PERL5LIB",buf,0))
2736 do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2738 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2742 /* Use the ~-expanded versions of APPLLIB (undocumented),
2743 ARCHLIB PRIVLIB SITEARCH and SITELIB
2746 incpush(APPLLIB_EXP, TRUE);
2750 incpush(ARCHLIB_EXP, FALSE);
2753 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2756 incpush(PRIVLIB_EXP, TRUE);
2758 incpush(PRIVLIB_EXP, FALSE);
2762 incpush(SITEARCH_EXP, FALSE);
2766 incpush(SITELIB_EXP, TRUE);
2768 incpush(SITELIB_EXP, FALSE);
2772 incpush(".", FALSE);
2776 # define PERLLIB_SEP ';'
2779 # define PERLLIB_SEP '|'
2781 # define PERLLIB_SEP ':'
2784 #ifndef PERLLIB_MANGLE
2785 # define PERLLIB_MANGLE(s,n) (s)
2789 S_incpush(pTHX_ char *p, int addsubdirs)
2791 SV *subdir = Nullsv;
2797 subdir = sv_newmortal();
2798 if (!PL_archpat_auto) {
2799 STRLEN len = (sizeof(ARCHNAME) + strlen(PL_patchlevel)
2800 + sizeof("//auto"));
2801 New(55, PL_archpat_auto, len, char);
2802 sprintf(PL_archpat_auto, "/%s/%s/auto", ARCHNAME, PL_patchlevel);
2804 for (len = sizeof(ARCHNAME) + 2;
2805 PL_archpat_auto[len] != '\0' && PL_archpat_auto[len] != '/'; len++)
2806 if (PL_archpat_auto[len] == '.') PL_archpat_auto[len] = '_';
2811 /* Break at all separators */
2813 SV *libdir = NEWSV(55,0);
2816 /* skip any consecutive separators */
2817 while ( *p == PERLLIB_SEP ) {
2818 /* Uncomment the next line for PATH semantics */
2819 /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */
2823 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2824 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2829 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2830 p = Nullch; /* break out */
2834 * BEFORE pushing libdir onto @INC we may first push version- and
2835 * archname-specific sub-directories.
2838 struct stat tmpstatbuf;
2843 if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) {
2845 while (unix[len-1] == '/') len--; /* Cosmetic */
2846 sv_usepvn(libdir,unix,len);
2849 PerlIO_printf(PerlIO_stderr(),
2850 "Failed to unixify @INC element \"%s\"\n",
2853 /* .../archname/version if -d .../archname/version/auto */
2854 sv_setsv(subdir, libdir);
2855 sv_catpv(subdir, PL_archpat_auto);
2856 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2857 S_ISDIR(tmpstatbuf.st_mode))
2858 av_push(GvAVn(PL_incgv),
2859 newSVpvn(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2861 /* .../archname if -d .../archname/auto */
2862 sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
2863 strlen(PL_patchlevel) + 1, "", 0);
2864 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2865 S_ISDIR(tmpstatbuf.st_mode))
2866 av_push(GvAVn(PL_incgv),
2867 newSVpvn(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2870 /* finally push this lib directory on the end of @INC */
2871 av_push(GvAVn(PL_incgv), libdir);
2876 STATIC struct perl_thread *
2877 S_init_main_thread(pTHX)
2879 #ifndef PERL_IMPLICIT_CONTEXT
2880 struct perl_thread *thr;
2884 Newz(53, thr, 1, struct perl_thread);
2885 PL_curcop = &PL_compiling;
2886 thr->cvcache = newHV();
2887 thr->threadsv = newAV();
2888 /* thr->threadsvp is set when find_threadsv is called */
2889 thr->specific = newAV();
2890 thr->errhv = newHV();
2891 thr->flags = THRf_R_JOINABLE;
2892 MUTEX_INIT(&thr->mutex);
2893 /* Handcraft thrsv similarly to mess_sv */
2894 New(53, PL_thrsv, 1, SV);
2895 Newz(53, xpv, 1, XPV);
2896 SvFLAGS(PL_thrsv) = SVt_PV;
2897 SvANY(PL_thrsv) = (void*)xpv;
2898 SvREFCNT(PL_thrsv) = 1 << 30; /* practically infinite */
2899 SvPVX(PL_thrsv) = (char*)thr;
2900 SvCUR_set(PL_thrsv, sizeof(thr));
2901 SvLEN_set(PL_thrsv, sizeof(thr));
2902 *SvEND(PL_thrsv) = '\0'; /* in the trailing_nul field */
2903 thr->oursv = PL_thrsv;
2904 PL_chopset = " \n-";
2907 MUTEX_LOCK(&PL_threads_mutex);
2912 MUTEX_UNLOCK(&PL_threads_mutex);
2914 #ifdef HAVE_THREAD_INTERN
2915 Perl_init_thread_intern(thr);
2918 #ifdef SET_THREAD_SELF
2919 SET_THREAD_SELF(thr);
2921 thr->self = pthread_self();
2922 #endif /* SET_THREAD_SELF */
2926 * These must come after the SET_THR because sv_setpvn does
2927 * SvTAINT and the taint fields require dTHR.
2929 PL_toptarget = NEWSV(0,0);
2930 sv_upgrade(PL_toptarget, SVt_PVFM);
2931 sv_setpvn(PL_toptarget, "", 0);
2932 PL_bodytarget = NEWSV(0,0);
2933 sv_upgrade(PL_bodytarget, SVt_PVFM);
2934 sv_setpvn(PL_bodytarget, "", 0);
2935 PL_formtarget = PL_bodytarget;
2936 thr->errsv = newSVpvn("", 0);
2937 (void) find_threadsv("@"); /* Ensure $@ is initialised early */
2940 PL_regcompp = FUNC_NAME_TO_PTR(Perl_pregcomp);
2941 PL_regexecp = FUNC_NAME_TO_PTR(Perl_regexec_flags);
2943 PL_reginterp_cnt = 0;
2947 #endif /* USE_THREADS */
2950 Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
2954 line_t oldline = PL_curcop->cop_line;
2959 while (AvFILL(paramList) >= 0) {
2960 cv = (CV*)av_shift(paramList);
2962 CALLPROTECT(aTHX_ &ret, FUNC_NAME_TO_PTR(S_call_list_body), cv);
2965 (void)SvPV(atsv, len);
2967 PL_curcop = &PL_compiling;
2968 PL_curcop->cop_line = oldline;
2969 if (paramList == PL_beginav)
2970 sv_catpv(atsv, "BEGIN failed--compilation aborted");
2972 sv_catpv(atsv, "END failed--cleanup aborted");
2973 while (PL_scopestack_ix > oldscope)
2975 Perl_croak(aTHX_ "%s", SvPVX(atsv));
2982 /* my_exit() was called */
2983 while (PL_scopestack_ix > oldscope)
2986 PL_curstash = PL_defstash;
2988 call_list(oldscope, PL_endav);
2989 PL_curcop = &PL_compiling;
2990 PL_curcop->cop_line = oldline;
2991 if (PL_statusvalue) {
2992 if (paramList == PL_beginav)
2993 Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
2995 Perl_croak(aTHX_ "END failed--cleanup aborted");
3001 PL_curcop = &PL_compiling;
3002 PL_curcop->cop_line = oldline;
3005 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
3013 S_call_list_body(pTHX_ va_list args)
3016 CV *cv = va_arg(args, CV*);
3018 PUSHMARK(PL_stack_sp);
3019 call_sv((SV*)cv, G_EVAL|G_DISCARD);
3024 Perl_my_exit(pTHX_ U32 status)
3028 DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
3029 thr, (unsigned long) status));
3038 STATUS_NATIVE_SET(status);
3045 Perl_my_failure_exit(pTHX)
3048 if (vaxc$errno & 1) {
3049 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
3050 STATUS_NATIVE_SET(44);
3053 if (!vaxc$errno && errno) /* unlikely */
3054 STATUS_NATIVE_SET(44);
3056 STATUS_NATIVE_SET(vaxc$errno);
3061 STATUS_POSIX_SET(errno);
3063 exitstatus = STATUS_POSIX >> 8;
3064 if (exitstatus & 255)
3065 STATUS_POSIX_SET(exitstatus);
3067 STATUS_POSIX_SET(255);
3074 S_my_exit_jump(pTHX)
3077 register PERL_CONTEXT *cx;
3082 SvREFCNT_dec(PL_e_script);
3083 PL_e_script = Nullsv;
3086 POPSTACK_TO(PL_mainstack);
3087 if (cxstack_ix >= 0) {
3090 POPBLOCK(cx,PL_curpm);
3099 #endif /* PERL_OBJECT */
3104 S_read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen)
3107 p = SvPVX(PL_e_script);
3108 nl = strchr(p, '\n');
3109 nl = (nl) ? nl+1 : SvEND(PL_e_script);
3111 filter_del(S_read_e_script);
3114 sv_catpvn(buf_sv, p, nl-p);
3115 sv_chop(PL_e_script, nl);