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
17 #include "patchlevel.h" /* for local_patches */
19 /* XXX If this causes problems, set i_unistd=undef in the hint file. */
24 #if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE)
25 char *getenv (char *); /* Usually in <stdlib.h> */
28 static I32 read_e_script(pTHXo_ int idx, SV *buf_sv, int maxlen);
43 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
51 perl_alloc(struct IPerlMem* ipM, struct IPerlEnv* ipE,
52 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
53 struct IPerlDir* ipD, struct IPerlSock* ipS,
54 struct IPerlProc* ipP)
56 CPerlObj* pPerl = new(ipM) CPerlObj(ipM, ipE, ipStd, ipLIO, ipD, ipS, ipP);
64 #ifdef PERL_IMPLICIT_SYS
66 perl_alloc_using(struct IPerlMem* ipM, struct IPerlEnv* ipE,
67 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
68 struct IPerlDir* ipD, struct IPerlSock* ipS,
69 struct IPerlProc* ipP)
71 PerlInterpreter *my_perl;
73 /* New() needs interpreter, so call malloc() instead */
74 my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
75 PERL_SET_INTERP(my_perl);
76 Zero(my_perl, 1, PerlInterpreter);
90 PerlInterpreter *my_perl;
92 /* New() needs interpreter, so call malloc() instead */
93 my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
94 PERL_SET_INTERP(my_perl);
97 #endif /* PERL_IMPLICIT_SYS */
98 #endif /* PERL_OBJECT */
101 perl_construct(pTHXx)
106 struct perl_thread *thr = NULL;
107 #endif /* FAKE_THREADS */
108 #endif /* USE_THREADS */
112 PL_perl_destruct_level = 1;
114 if (PL_perl_destruct_level > 0)
118 /* Init the real globals (and main thread)? */
123 #ifdef ALLOC_THREAD_KEY
126 if (pthread_key_create(&PL_thr_key, 0))
127 Perl_croak(aTHX_ "panic: pthread_key_create");
129 MUTEX_INIT(&PL_sv_mutex);
131 * Safe to use basic SV functions from now on (though
132 * not things like mortals or tainting yet).
134 MUTEX_INIT(&PL_eval_mutex);
135 COND_INIT(&PL_eval_cond);
136 MUTEX_INIT(&PL_threads_mutex);
137 COND_INIT(&PL_nthreads_cond);
138 #ifdef EMULATE_ATOMIC_REFCOUNTS
139 MUTEX_INIT(&PL_svref_mutex);
140 #endif /* EMULATE_ATOMIC_REFCOUNTS */
142 MUTEX_INIT(&PL_cred_mutex);
144 thr = init_main_thread();
145 #endif /* USE_THREADS */
147 PL_protect = MEMBER_TO_FPTR(Perl_default_protect); /* for exceptions */
149 PL_curcop = &PL_compiling; /* needed by ckWARN, right away */
151 PL_linestr = NEWSV(65,79);
152 sv_upgrade(PL_linestr,SVt_PVIV);
154 if (!SvREADONLY(&PL_sv_undef)) {
155 /* set read-only and try to insure than we wont see REFCNT==0
158 SvREADONLY_on(&PL_sv_undef);
159 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
161 sv_setpv(&PL_sv_no,PL_No);
163 SvREADONLY_on(&PL_sv_no);
164 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
166 sv_setpv(&PL_sv_yes,PL_Yes);
168 SvREADONLY_on(&PL_sv_yes);
169 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
174 /* PL_sighandlerp = sighandler; */
176 PL_sighandlerp = Perl_sighandler;
178 PL_pidstatus = newHV();
182 * There is no way we can refer to them from Perl so close them to save
183 * space. The other alternative would be to provide STDAUX and STDPRN
186 (void)fclose(stdaux);
187 (void)fclose(stdprn);
191 PL_nrs = newSVpvn("\n", 1);
192 PL_rs = SvREFCNT_inc(PL_nrs);
197 PL_lex_state = LEX_NOTPARSING;
203 SET_NUMERIC_STANDARD();
204 #if defined(PERL_SUBVERSION) && PERL_SUBVERSION > 0
205 sprintf(PL_patchlevel, "%7.5f", (double) PERL_REVISION
206 + ((double) PERL_VERSION / (double) 1000)
207 + ((double) PERL_SUBVERSION / (double) 100000));
209 sprintf(PL_patchlevel, "%5.3f", (double) PERL_REVISION +
210 ((double) PERL_VERSION / (double) 1000));
213 #if defined(LOCAL_PATCH_COUNT)
214 PL_localpatches = local_patches; /* For possible -v */
217 PerlIO_init(); /* Hook to IO system */
219 PL_fdpid = newAV(); /* for remembering popen pids by fd */
220 PL_modglobal = newHV(); /* pointers to per-interpreter module globals */
223 New(51,PL_debname,128,char);
224 New(52,PL_debdelim,128,char);
234 int destruct_level; /* 0=none, 1=full, 2=full with checks */
240 #endif /* USE_THREADS */
244 /* Pass 1 on any remaining threads: detach joinables, join zombies */
246 MUTEX_LOCK(&PL_threads_mutex);
247 DEBUG_S(PerlIO_printf(Perl_debug_log,
248 "perl_destruct: waiting for %d threads...\n",
250 for (t = thr->next; t != thr; t = t->next) {
251 MUTEX_LOCK(&t->mutex);
252 switch (ThrSTATE(t)) {
255 DEBUG_S(PerlIO_printf(Perl_debug_log,
256 "perl_destruct: joining zombie %p\n", t));
257 ThrSETSTATE(t, THRf_DEAD);
258 MUTEX_UNLOCK(&t->mutex);
261 * The SvREFCNT_dec below may take a long time (e.g. av
262 * may contain an object scalar whose destructor gets
263 * called) so we have to unlock threads_mutex and start
266 MUTEX_UNLOCK(&PL_threads_mutex);
268 SvREFCNT_dec((SV*)av);
269 DEBUG_S(PerlIO_printf(Perl_debug_log,
270 "perl_destruct: joined zombie %p OK\n", t));
272 case THRf_R_JOINABLE:
273 DEBUG_S(PerlIO_printf(Perl_debug_log,
274 "perl_destruct: detaching thread %p\n", t));
275 ThrSETSTATE(t, THRf_R_DETACHED);
277 * We unlock threads_mutex and t->mutex in the opposite order
278 * from which we locked them just so that DETACH won't
279 * deadlock if it panics. It's only a breach of good style
280 * not a bug since they are unlocks not locks.
282 MUTEX_UNLOCK(&PL_threads_mutex);
284 MUTEX_UNLOCK(&t->mutex);
287 DEBUG_S(PerlIO_printf(Perl_debug_log,
288 "perl_destruct: ignoring %p (state %u)\n",
290 MUTEX_UNLOCK(&t->mutex);
291 /* fall through and out */
294 /* We leave the above "Pass 1" loop with threads_mutex still locked */
296 /* Pass 2 on remaining threads: wait for the thread count to drop to one */
297 while (PL_nthreads > 1)
299 DEBUG_S(PerlIO_printf(Perl_debug_log,
300 "perl_destruct: final wait for %d threads\n",
302 COND_WAIT(&PL_nthreads_cond, &PL_threads_mutex);
304 /* At this point, we're the last thread */
305 MUTEX_UNLOCK(&PL_threads_mutex);
306 DEBUG_S(PerlIO_printf(Perl_debug_log, "perl_destruct: armageddon has arrived\n"));
307 MUTEX_DESTROY(&PL_threads_mutex);
308 COND_DESTROY(&PL_nthreads_cond);
309 #endif /* !defined(FAKE_THREADS) */
310 #endif /* USE_THREADS */
312 destruct_level = PL_perl_destruct_level;
316 if (s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL")) {
318 if (destruct_level < i)
327 /* We must account for everything. */
329 /* Destroy the main CV and syntax tree */
331 PL_curpad = AvARRAY(PL_comppad);
332 op_free(PL_main_root);
333 PL_main_root = Nullop;
335 PL_curcop = &PL_compiling;
336 PL_main_start = Nullop;
337 SvREFCNT_dec(PL_main_cv);
341 if (PL_sv_objcount) {
343 * Try to destruct global references. We do this first so that the
344 * destructors and destructees still exist. Some sv's might remain.
345 * Non-referenced objects are on their own.
350 /* unhook hooks which will soon be, or use, destroyed data */
351 SvREFCNT_dec(PL_warnhook);
352 PL_warnhook = Nullsv;
353 SvREFCNT_dec(PL_diehook);
356 /* call exit list functions */
357 while (PL_exitlistlen-- > 0)
358 PL_exitlist[PL_exitlistlen].fn(aTHXo_ PL_exitlist[PL_exitlistlen].ptr);
360 Safefree(PL_exitlist);
362 if (destruct_level == 0){
364 DEBUG_P(debprofdump());
366 /* The exit() function will do everything that needs doing. */
370 /* loosen bonds of global variables */
373 (void)PerlIO_close(PL_rsfp);
377 /* Filters for program text */
378 SvREFCNT_dec(PL_rsfp_filters);
379 PL_rsfp_filters = Nullav;
382 PL_preprocess = FALSE;
388 PL_doswitches = FALSE;
389 PL_dowarn = G_WARN_OFF;
390 PL_doextract = FALSE;
391 PL_sawampersand = FALSE; /* must save all match strings */
392 PL_sawstudy = FALSE; /* do fbm_instr on all strings */
396 Safefree(PL_inplace);
400 SvREFCNT_dec(PL_e_script);
401 PL_e_script = Nullsv;
404 /* magical thingies */
406 Safefree(PL_ofs); /* $, */
409 Safefree(PL_ors); /* $\ */
412 SvREFCNT_dec(PL_rs); /* $/ */
415 SvREFCNT_dec(PL_nrs); /* $/ helper */
418 PL_multiline = 0; /* $* */
420 SvREFCNT_dec(PL_statname);
421 PL_statname = Nullsv;
424 /* defgv, aka *_ should be taken care of elsewhere */
426 /* clean up after study() */
427 SvREFCNT_dec(PL_lastscream);
428 PL_lastscream = Nullsv;
429 Safefree(PL_screamfirst);
431 Safefree(PL_screamnext);
435 Safefree(PL_efloatbuf);
436 PL_efloatbuf = Nullch;
439 /* startup and shutdown function lists */
440 SvREFCNT_dec(PL_beginav);
441 SvREFCNT_dec(PL_endav);
442 SvREFCNT_dec(PL_initav);
447 /* shortcuts just get cleared */
454 PL_argvoutgv = Nullgv;
456 PL_stderrgv = Nullgv;
457 PL_last_in_gv = Nullgv;
460 /* reset so print() ends up where we expect */
463 /* Prepare to destruct main symbol table. */
469 /* clear queued errors */
470 SvREFCNT_dec(PL_errors);
474 if (destruct_level >= 2 && ckWARN_d(WARN_INTERNAL)) {
475 if (PL_scopestack_ix != 0)
476 Perl_warner(aTHX_ WARN_INTERNAL,
477 "Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
478 (long)PL_scopestack_ix);
479 if (PL_savestack_ix != 0)
480 Perl_warner(aTHX_ WARN_INTERNAL,
481 "Unbalanced saves: %ld more saves than restores\n",
482 (long)PL_savestack_ix);
483 if (PL_tmps_floor != -1)
484 Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced tmps: %ld more allocs than frees\n",
485 (long)PL_tmps_floor + 1);
486 if (cxstack_ix != -1)
487 Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced context: %ld more PUSHes than POPs\n",
488 (long)cxstack_ix + 1);
491 /* Now absolutely destruct everything, somehow or other, loops or no. */
493 SvFLAGS(PL_strtab) |= SVTYPEMASK; /* don't clean out strtab now */
494 while (PL_sv_count != 0 && PL_sv_count != last_sv_count) {
495 last_sv_count = PL_sv_count;
498 SvFLAGS(PL_strtab) &= ~SVTYPEMASK;
499 SvFLAGS(PL_strtab) |= SVt_PVHV;
501 /* Destruct the global string table. */
503 /* Yell and reset the HeVAL() slots that are still holding refcounts,
504 * so that sv_free() won't fail on them.
512 max = HvMAX(PL_strtab);
513 array = HvARRAY(PL_strtab);
516 if (hent && ckWARN_d(WARN_INTERNAL)) {
517 Perl_warner(aTHX_ WARN_INTERNAL,
518 "Unbalanced string table refcount: (%d) for \"%s\"",
519 HeVAL(hent) - Nullsv, HeKEY(hent));
520 HeVAL(hent) = Nullsv;
530 SvREFCNT_dec(PL_strtab);
532 if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL))
533 Perl_warner(aTHX_ WARN_INTERNAL,"Scalars leaked: %ld\n", (long)PL_sv_count);
537 /* No SVs have survived, need to clean out */
539 PL_pidstatus = Nullhv;
540 Safefree(PL_origfilename);
541 Safefree(PL_archpat_auto);
542 Safefree(PL_reg_start_tmp);
544 Safefree(PL_reg_curpm);
545 Safefree(PL_reg_poscache);
546 Safefree(HeKEY_hek(&PL_hv_fetch_ent_mh));
547 Safefree(PL_op_mask);
549 PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */
551 DEBUG_P(debprofdump());
553 MUTEX_DESTROY(&PL_strtab_mutex);
554 MUTEX_DESTROY(&PL_sv_mutex);
555 MUTEX_DESTROY(&PL_eval_mutex);
556 MUTEX_DESTROY(&PL_cred_mutex);
557 COND_DESTROY(&PL_eval_cond);
558 #ifdef EMULATE_ATOMIC_REFCOUNTS
559 MUTEX_DESTROY(&PL_svref_mutex);
560 #endif /* EMULATE_ATOMIC_REFCOUNTS */
562 /* As the penultimate thing, free the non-arena SV for thrsv */
563 Safefree(SvPVX(PL_thrsv));
564 Safefree(SvANY(PL_thrsv));
567 #endif /* USE_THREADS */
569 /* As the absolutely last thing, free the non-arena SV for mess() */
572 /* it could have accumulated taint magic */
573 if (SvTYPE(PL_mess_sv) >= SVt_PVMG) {
576 for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) {
577 moremagic = mg->mg_moremagic;
578 if (mg->mg_ptr && mg->mg_type != 'g' && mg->mg_len >= 0)
579 Safefree(mg->mg_ptr);
583 /* we know that type >= SVt_PV */
584 SvOOK_off(PL_mess_sv);
585 Safefree(SvPVX(PL_mess_sv));
586 Safefree(SvANY(PL_mess_sv));
587 Safefree(PL_mess_sv);
595 #if defined(PERL_OBJECT)
603 Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
605 Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry);
606 PL_exitlist[PL_exitlistlen].fn = fn;
607 PL_exitlist[PL_exitlistlen].ptr = ptr;
612 perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
622 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
625 Perl_croak(aTHX_ "suidperl is no longer needed since the kernel can now execute\n\
626 setuid perl scripts securely.\n");
630 #if defined(__DYNAMIC__) && (defined(NeXT) || defined(__NeXT__))
631 _dyld_lookup_and_bind
632 ("__environ", (unsigned long *) &environ_pointer, NULL);
637 #ifndef VMS /* VMS doesn't have environ array */
638 PL_origenviron = environ;
643 /* Come here if running an undumped a.out. */
645 PL_origfilename = savepv(argv[0]);
646 PL_do_undump = FALSE;
647 cxstack_ix = -1; /* start label stack again */
649 init_postdump_symbols(argc,argv,env);
654 PL_curpad = AvARRAY(PL_comppad);
655 op_free(PL_main_root);
656 PL_main_root = Nullop;
658 PL_main_start = Nullop;
659 SvREFCNT_dec(PL_main_cv);
663 oldscope = PL_scopestack_ix;
664 PL_dowarn = G_WARN_OFF;
666 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_parse_body),
675 /* my_exit() was called */
676 while (PL_scopestack_ix > oldscope)
679 PL_curstash = PL_defstash;
680 if (PL_endav && !PL_minus_c)
681 call_list(oldscope, PL_endav);
682 return STATUS_NATIVE_EXPORT;
684 PerlIO_printf(Perl_error_log, "panic: top_env\n");
691 S_parse_body(pTHX_ va_list args)
694 int argc = PL_origargc;
695 char **argv = PL_origargv;
696 char **env = va_arg(args, char**);
697 char *scriptname = NULL;
699 VOL bool dosearch = FALSE;
705 XSINIT_t xsinit = va_arg(args, XSINIT_t);
707 sv_setpvn(PL_linestr,"",0);
708 sv = newSVpvn("",0); /* first used for -I flags */
712 for (argc--,argv++; argc > 0; argc--,argv++) {
713 if (argv[0][0] != '-' || !argv[0][1])
717 validarg = " PHOOEY ";
724 #ifndef PERL_STRICT_CR
748 if (s = moreswitches(s))
758 if (PL_euid != PL_uid || PL_egid != PL_gid)
759 Perl_croak(aTHX_ "No -e allowed in setuid scripts");
761 PL_e_script = newSVpvn("",0);
762 filter_add(read_e_script, NULL);
765 sv_catpv(PL_e_script, s);
767 sv_catpv(PL_e_script, argv[1]);
771 Perl_croak(aTHX_ "No code specified for -e");
772 sv_catpv(PL_e_script, "\n");
775 case 'I': /* -I handled both here and in moreswitches() */
777 if (!*++s && (s=argv[1]) != Nullch) {
780 while (s && isSPACE(*s))
784 for (e = s; *e && !isSPACE(*e); e++) ;
791 } /* XXX else croak? */
795 PL_preprocess = TRUE;
805 PL_preambleav = newAV();
806 av_push(PL_preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
808 PL_Sv = newSVpv("print myconfig();",0);
810 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
812 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
814 #if defined(DEBUGGING) || defined(MULTIPLICITY)
815 sv_catpv(PL_Sv,"\" Compile-time options:");
817 sv_catpv(PL_Sv," DEBUGGING");
820 sv_catpv(PL_Sv," MULTIPLICITY");
822 sv_catpv(PL_Sv,"\\n\",");
824 #if defined(LOCAL_PATCH_COUNT)
825 if (LOCAL_PATCH_COUNT > 0) {
827 sv_catpv(PL_Sv,"\" Locally applied patches:\\n\",");
828 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
829 if (PL_localpatches[i])
830 Perl_sv_catpvf(aTHX_ PL_Sv,"q\" \t%s\n\",",PL_localpatches[i]);
834 Perl_sv_catpvf(aTHX_ PL_Sv,"\" Built under %s\\n\"",OSNAME);
837 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
839 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled on %s\\n\"",__DATE__);
844 @env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; \
845 print \" \\%ENV:\\n @env\\n\" if @env; \
846 print \" \\@INC:\\n @INC\\n\";");
849 PL_Sv = newSVpv("config_vars(qw(",0);
850 sv_catpv(PL_Sv, ++s);
851 sv_catpv(PL_Sv, "))");
854 av_push(PL_preambleav, PL_Sv);
855 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
861 PL_cddir = savepv(s);
866 if (!*++s || isSPACE(*s)) {
870 /* catch use of gnu style long options */
871 if (strEQ(s, "version")) {
875 if (strEQ(s, "help")) {
882 Perl_croak(aTHX_ "Unrecognized switch: -%s (-h will show valid options)",s);
888 #ifndef SECURE_INTERNAL_GETENV
891 (s = PerlEnv_getenv("PERL5OPT"))) {
894 if (*s == '-' && *(s+1) == 'T')
907 if (!strchr("DIMUdmw", *s))
908 Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
915 scriptname = argv[0];
918 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
920 else if (scriptname == Nullch) {
922 if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
930 open_script(scriptname,dosearch,sv,&fdscript);
932 validate_suid(validarg, scriptname,fdscript);
937 PL_main_cv = PL_compcv = (CV*)NEWSV(1104,0);
938 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
939 CvUNIQUE_on(PL_compcv);
941 PL_comppad = newAV();
942 av_push(PL_comppad, Nullsv);
943 PL_curpad = AvARRAY(PL_comppad);
944 PL_comppad_name = newAV();
945 PL_comppad_name_fill = 0;
946 PL_min_intro_pending = 0;
949 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
950 PL_curpad[0] = (SV*)newAV();
951 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
952 CvOWNER(PL_compcv) = 0;
953 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
954 MUTEX_INIT(CvMUTEXP(PL_compcv));
955 #endif /* USE_THREADS */
957 comppadlist = newAV();
958 AvREAL_off(comppadlist);
959 av_store(comppadlist, 0, (SV*)PL_comppad_name);
960 av_store(comppadlist, 1, (SV*)PL_comppad);
961 CvPADLIST(PL_compcv) = comppadlist;
963 boot_core_UNIVERSAL();
967 (*xsinit)(aTHXo); /* in case linked C routines want magical variables */
968 #if defined(VMS) || defined(WIN32) || defined(DJGPP)
976 init_predump_symbols();
977 /* init_postdump_symbols not currently designed to be called */
978 /* more than once (ENV isn't cleared first, for example) */
979 /* But running with -u leaves %ENV & @ARGV undefined! XXX */
981 init_postdump_symbols(argc,argv,env);
985 /* now parse the script */
987 SETERRNO(0,SS$_NORMAL);
989 if (yyparse() || PL_error_count) {
991 Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
993 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
997 PL_curcop->cop_line = 0;
998 PL_curstash = PL_defstash;
999 PL_preprocess = FALSE;
1001 SvREFCNT_dec(PL_e_script);
1002 PL_e_script = Nullsv;
1005 /* now that script is parsed, we can modify record separator */
1006 SvREFCNT_dec(PL_rs);
1007 PL_rs = SvREFCNT_inc(PL_nrs);
1008 sv_setsv(get_sv("/", TRUE), PL_rs);
1013 gv_check(PL_defstash);
1019 if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
1020 dump_mstats("after compilation:");
1039 oldscope = PL_scopestack_ix;
1042 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_run_body), oldscope);
1045 cxstack_ix = -1; /* start context stack again */
1047 case 0: /* normal completion */
1048 case 2: /* my_exit() */
1049 while (PL_scopestack_ix > oldscope)
1052 PL_curstash = PL_defstash;
1053 if (PL_endav && !PL_minus_c)
1054 call_list(oldscope, PL_endav);
1056 if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
1057 dump_mstats("after execution: ");
1059 return STATUS_NATIVE_EXPORT;
1062 POPSTACK_TO(PL_mainstack);
1065 PerlIO_printf(Perl_error_log, "panic: restartop\n");
1075 S_run_body(pTHX_ va_list args)
1078 I32 oldscope = va_arg(args, I32);
1080 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
1081 PL_sawampersand ? "Enabling" : "Omitting"));
1083 if (!PL_restartop) {
1084 DEBUG_x(dump_all());
1085 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
1086 DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%lx\n",
1087 (unsigned long) thr));
1090 PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
1093 if (PERLDB_SINGLE && PL_DBsingle)
1094 sv_setiv(PL_DBsingle, 1);
1096 call_list(oldscope, PL_initav);
1102 PL_op = PL_restartop;
1106 else if (PL_main_start) {
1107 CvDEPTH(PL_main_cv) = 1;
1108 PL_op = PL_main_start;
1118 Perl_get_sv(pTHX_ const char *name, I32 create)
1122 if (name[1] == '\0' && !isALPHA(name[0])) {
1123 PADOFFSET tmp = find_threadsv(name);
1124 if (tmp != NOT_IN_PAD) {
1126 return THREADSV(tmp);
1129 #endif /* USE_THREADS */
1130 gv = gv_fetchpv(name, create, SVt_PV);
1137 Perl_get_av(pTHX_ const char *name, I32 create)
1139 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1148 Perl_get_hv(pTHX_ const char *name, I32 create)
1150 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1159 Perl_get_cv(pTHX_ const char *name, I32 create)
1161 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
1162 /* XXX unsafe for threads if eval_owner isn't held */
1163 /* XXX this is probably not what they think they're getting.
1164 * It has the same effect as "sub name;", i.e. just a forward
1166 if (create && !GvCVu(gv))
1167 return newSUB(start_subparse(FALSE, 0),
1168 newSVOP(OP_CONST, 0, newSVpv(name,0)),
1176 /* Be sure to refetch the stack pointer after calling these routines. */
1179 Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv)
1181 /* See G_* flags in cop.h */
1182 /* null terminated arg list */
1189 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
1194 return call_pv(sub_name, flags);
1198 Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
1199 /* name of the subroutine */
1200 /* See G_* flags in cop.h */
1202 return call_sv((SV*)get_cv(sub_name, TRUE), flags);
1206 Perl_call_method(pTHX_ const char *methname, I32 flags)
1207 /* name of the subroutine */
1208 /* See G_* flags in cop.h */
1214 XPUSHs(sv_2mortal(newSVpv(methname,0)));
1219 return call_sv(*PL_stack_sp--, flags);
1222 /* May be called with any of a CV, a GV, or an SV containing the name. */
1224 Perl_call_sv(pTHX_ SV *sv, I32 flags)
1226 /* See G_* flags in cop.h */
1229 LOGOP myop; /* fake syntax tree node */
1233 bool oldcatch = CATCH_GET;
1238 if (flags & G_DISCARD) {
1243 Zero(&myop, 1, LOGOP);
1244 myop.op_next = Nullop;
1245 if (!(flags & G_NOARGS))
1246 myop.op_flags |= OPf_STACKED;
1247 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1248 (flags & G_ARRAY) ? OPf_WANT_LIST :
1253 EXTEND(PL_stack_sp, 1);
1254 *++PL_stack_sp = sv;
1256 oldscope = PL_scopestack_ix;
1258 if (PERLDB_SUB && PL_curstash != PL_debstash
1259 /* Handle first BEGIN of -d. */
1260 && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
1261 /* Try harder, since this may have been a sighandler, thus
1262 * curstash may be meaningless. */
1263 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != PL_debstash)
1264 && !(flags & G_NODEBUG))
1265 PL_op->op_private |= OPpENTERSUB_DB;
1267 if (!(flags & G_EVAL)) {
1269 call_xbody((OP*)&myop, FALSE);
1270 retval = PL_stack_sp - (PL_stack_base + oldmark);
1271 CATCH_SET(oldcatch);
1274 cLOGOP->op_other = PL_op;
1276 /* we're trying to emulate pp_entertry() here */
1278 register PERL_CONTEXT *cx;
1279 I32 gimme = GIMME_V;
1284 push_return(PL_op->op_next);
1285 PUSHBLOCK(cx, CXt_EVAL, PL_stack_sp);
1287 PL_eval_root = PL_op; /* Only needed so that goto works right. */
1289 PL_in_eval = EVAL_INEVAL;
1290 if (flags & G_KEEPERR)
1291 PL_in_eval |= EVAL_KEEPERR;
1298 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_body),
1302 retval = PL_stack_sp - (PL_stack_base + oldmark);
1303 if (!(flags & G_KEEPERR))
1310 /* my_exit() was called */
1311 PL_curstash = PL_defstash;
1314 Perl_croak(aTHX_ "Callback called exit");
1319 PL_op = PL_restartop;
1323 PL_stack_sp = PL_stack_base + oldmark;
1324 if (flags & G_ARRAY)
1328 *++PL_stack_sp = &PL_sv_undef;
1333 if (PL_scopestack_ix > oldscope) {
1337 register PERL_CONTEXT *cx;
1348 if (flags & G_DISCARD) {
1349 PL_stack_sp = PL_stack_base + oldmark;
1359 S_call_body(pTHX_ va_list args)
1361 OP *myop = va_arg(args, OP*);
1362 int is_eval = va_arg(args, int);
1364 call_xbody(myop, is_eval);
1369 S_call_xbody(pTHX_ OP *myop, int is_eval)
1373 if (PL_op == myop) {
1375 PL_op = Perl_pp_entereval(aTHX);
1377 PL_op = Perl_pp_entersub(aTHX);
1383 /* Eval a string. The G_EVAL flag is always assumed. */
1386 Perl_eval_sv(pTHX_ SV *sv, I32 flags)
1388 /* See G_* flags in cop.h */
1391 UNOP myop; /* fake syntax tree node */
1392 I32 oldmark = SP - PL_stack_base;
1399 if (flags & G_DISCARD) {
1406 Zero(PL_op, 1, UNOP);
1407 EXTEND(PL_stack_sp, 1);
1408 *++PL_stack_sp = sv;
1409 oldscope = PL_scopestack_ix;
1411 if (!(flags & G_NOARGS))
1412 myop.op_flags = OPf_STACKED;
1413 myop.op_next = Nullop;
1414 myop.op_type = OP_ENTEREVAL;
1415 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1416 (flags & G_ARRAY) ? OPf_WANT_LIST :
1418 if (flags & G_KEEPERR)
1419 myop.op_flags |= OPf_SPECIAL;
1422 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_body),
1426 retval = PL_stack_sp - (PL_stack_base + oldmark);
1427 if (!(flags & G_KEEPERR))
1434 /* my_exit() was called */
1435 PL_curstash = PL_defstash;
1438 Perl_croak(aTHX_ "Callback called exit");
1443 PL_op = PL_restartop;
1447 PL_stack_sp = PL_stack_base + oldmark;
1448 if (flags & G_ARRAY)
1452 *++PL_stack_sp = &PL_sv_undef;
1457 if (flags & G_DISCARD) {
1458 PL_stack_sp = PL_stack_base + oldmark;
1468 Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
1471 SV* sv = newSVpv(p, 0);
1474 eval_sv(sv, G_SCALAR);
1481 if (croak_on_error && SvTRUE(ERRSV)) {
1483 Perl_croak(aTHX_ SvPVx(ERRSV, n_a));
1489 /* Require a module. */
1492 Perl_require_pv(pTHX_ const char *pv)
1496 PUSHSTACKi(PERLSI_REQUIRE);
1498 sv = sv_newmortal();
1499 sv_setpv(sv, "require '");
1502 eval_sv(sv, G_DISCARD);
1508 Perl_magicname(pTHX_ char *sym, char *name, I32 namlen)
1512 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1513 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1517 S_usage(pTHX_ char *name) /* XXX move this out into a module ? */
1519 /* This message really ought to be max 23 lines.
1520 * Removed -h because the user already knows that opton. Others? */
1522 static char *usage_msg[] = {
1523 "-0[octal] specify record separator (\\0, if no argument)",
1524 "-a autosplit mode with -n or -p (splits $_ into @F)",
1525 "-c check syntax only (runs BEGIN and END blocks)",
1526 "-d[:debugger] run program under debugger",
1527 "-D[number/list] set debugging flags (argument is a bit mask or alphabets)",
1528 "-e 'command' one line of program (several -e's allowed, omit programfile)",
1529 "-F/pattern/ split() pattern for -a switch (//'s are optional)",
1530 "-i[extension] edit <> files in place (makes backup if extension supplied)",
1531 "-Idirectory specify @INC/#include directory (several -I's allowed)",
1532 "-l[octal] enable line ending processing, specifies line terminator",
1533 "-[mM][-]module execute `use/no module...' before executing program",
1534 "-n assume 'while (<>) { ... }' loop around program",
1535 "-p assume loop like -n but print line also, like sed",
1536 "-P run program through C preprocessor before compilation",
1537 "-s enable rudimentary parsing for switches after programfile",
1538 "-S look for programfile using PATH environment variable",
1539 "-T enable tainting checks",
1540 "-u dump core after parsing program",
1541 "-U allow unsafe operations",
1542 "-v print version, subversion (includes VERY IMPORTANT perl info)",
1543 "-V[:variable] print configuration summary (or a single Config.pm variable)",
1544 "-w enable many useful warnings (RECOMMENDED)",
1545 "-x[directory] strip off text before #!perl line and perhaps cd to directory",
1549 char **p = usage_msg;
1551 printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1553 printf("\n %s", *p++);
1556 /* This routine handles any switches that can be given during run */
1559 Perl_moreswitches(pTHX_ char *s)
1568 rschar = scan_oct(s, 4, &numlen);
1569 SvREFCNT_dec(PL_nrs);
1570 if (rschar & ~((U8)~0))
1571 PL_nrs = &PL_sv_undef;
1572 else if (!rschar && numlen >= 2)
1573 PL_nrs = newSVpvn("", 0);
1576 PL_nrs = newSVpvn(&ch, 1);
1582 PL_splitstr = savepv(s + 1);
1596 if (*s == ':' || *s == '=') {
1597 my_setenv("PERL5DB", Perl_form(aTHX_ "use Devel::%s;", ++s));
1601 PL_perldb = PERLDB_ALL;
1609 if (isALPHA(s[1])) {
1610 static char debopts[] = "psltocPmfrxuLHXDS";
1613 for (s++; *s && (d = strchr(debopts,*s)); s++)
1614 PL_debug |= 1 << (d - debopts);
1617 PL_debug = atoi(s+1);
1618 for (s++; isDIGIT(*s); s++) ;
1620 PL_debug |= 0x80000000;
1623 if (ckWARN_d(WARN_DEBUGGING))
1624 Perl_warner(aTHX_ WARN_DEBUGGING,
1625 "Recompile perl with -DDEBUGGING to use -D switch\n");
1626 for (s++; isALNUM(*s); s++) ;
1632 usage(PL_origargv[0]);
1636 Safefree(PL_inplace);
1637 PL_inplace = savepv(s+1);
1639 for (s = PL_inplace; *s && !isSPACE(*s); s++) ;
1642 if (*s == '-') /* Additional switches on #! line. */
1646 case 'I': /* -I handled both here and in parse_perl() */
1649 while (*s && isSPACE(*s))
1653 for (e = s; *e && !isSPACE(*e); e++) ;
1654 p = savepvn(s, e-s);
1660 Perl_croak(aTHX_ "No space allowed after -I");
1668 PL_ors = savepv("\n");
1670 *PL_ors = scan_oct(s, 3 + (*s == '0'), &numlen);
1675 if (RsPARA(PL_nrs)) {
1680 PL_ors = SvPV(PL_nrs, PL_orslen);
1681 PL_ors = savepvn(PL_ors, PL_orslen);
1685 forbid_setid("-M"); /* XXX ? */
1688 forbid_setid("-m"); /* XXX ? */
1693 /* -M-foo == 'no foo' */
1694 if (*s == '-') { use = "no "; ++s; }
1695 sv = newSVpv(use,0);
1697 /* We allow -M'Module qw(Foo Bar)' */
1698 while(isALNUM(*s) || *s==':') ++s;
1700 sv_catpv(sv, start);
1701 if (*(start-1) == 'm') {
1703 Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
1704 sv_catpv( sv, " ()");
1707 sv_catpvn(sv, start, s-start);
1708 sv_catpv(sv, " split(/,/,q{");
1713 if (PL_preambleav == NULL)
1714 PL_preambleav = newAV();
1715 av_push(PL_preambleav, sv);
1718 Perl_croak(aTHX_ "No space allowed after -%c", *(s-1));
1730 PL_doswitches = TRUE;
1735 Perl_croak(aTHX_ "Too late for \"-T\" option");
1739 PL_do_undump = TRUE;
1747 #if defined(PERL_SUBVERSION) && PERL_SUBVERSION > 0
1748 printf("\nThis is perl, version %d.%03d_%02d built for %s",
1749 PERL_REVISION, PERL_VERSION, PERL_SUBVERSION, ARCHNAME);
1751 printf("\nThis is perl, version %s built for %s",
1752 PL_patchlevel, ARCHNAME);
1754 #if defined(LOCAL_PATCH_COUNT)
1755 if (LOCAL_PATCH_COUNT > 0)
1756 printf("\n(with %d registered patch%s, see perl -V for more detail)",
1757 LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : "");
1760 printf("\n\nCopyright 1987-1999, Larry Wall\n");
1762 printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1765 printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
1766 printf("djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
1769 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1770 "Version 5 port Copyright (c) 1994-1999, Andreas Kaiser, Ilya Zakharevich\n");
1773 printf("atariST series port, ++jrb bammi@cadence.com\n");
1776 printf("BeOS port Copyright Tom Spindler, 1997-1999\n");
1779 printf("MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-1999\n");
1782 printf("MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
1785 printf("Stratus VOS port by Paul_Green@stratus.com, 1997-1999\n");
1788 printf("VM/ESA port by Neale Ferguson, 1998-1999\n");
1791 printf("BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
1794 printf("MiNT port by Guido Flohr, 1997-1999\n");
1796 #ifdef BINARY_BUILD_NOTICE
1797 BINARY_BUILD_NOTICE;
1800 Perl may be copied only under the terms of either the Artistic License or the\n\
1801 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n\
1802 Complete documentation for Perl, including FAQ lists, should be found on\n\
1803 this system using `man perl' or `perldoc perl'. If you have access to the\n\
1804 Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
1807 if (! (PL_dowarn & G_WARN_ALL_MASK))
1808 PL_dowarn |= G_WARN_ON;
1812 PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
1813 PL_compiling.cop_warnings = WARN_ALL ;
1817 PL_dowarn = G_WARN_ALL_OFF;
1818 PL_compiling.cop_warnings = WARN_NONE ;
1823 if (s[1] == '-') /* Additional switches on #! line. */
1828 #if defined(WIN32) || !defined(PERL_STRICT_CR)
1834 #ifdef ALTERNATE_SHEBANG
1835 case 'S': /* OS/2 needs -S on "extproc" line. */
1843 Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
1848 /* compliments of Tom Christiansen */
1850 /* unexec() can be found in the Gnu emacs distribution */
1851 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
1854 Perl_my_unexec(pTHX)
1862 prog = newSVpv(BIN_EXP, 0);
1863 sv_catpv(prog, "/perl");
1864 file = newSVpv(PL_origfilename, 0);
1865 sv_catpv(file, ".perldump");
1867 unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
1868 /* unexec prints msg to stderr in case of failure */
1869 PerlProc_exit(status);
1872 # include <lib$routines.h>
1873 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
1875 ABORT(); /* for use with undump */
1880 /* initialize curinterp */
1885 #ifdef PERL_OBJECT /* XXX kludge */
1888 PL_chopset = " \n-"; \
1889 PL_copline = NOLINE; \
1890 PL_curcop = &PL_compiling;\
1891 PL_curcopdb = NULL; \
1894 PL_dumpindent = 4; \
1895 PL_laststatval = -1; \
1896 PL_laststype = OP_STAT; \
1897 PL_maxscream = -1; \
1898 PL_maxsysfd = MAXSYSFD; \
1899 PL_statname = Nullsv; \
1900 PL_tmps_floor = -1; \
1902 PL_op_mask = NULL; \
1904 PL_laststatval = -1; \
1905 PL_laststype = OP_STAT; \
1906 PL_mess_sv = Nullsv; \
1907 PL_splitstr = " "; \
1908 PL_generation = 100; \
1909 PL_exitlist = NULL; \
1910 PL_exitlistlen = 0; \
1912 PL_in_clean_objs = FALSE; \
1913 PL_in_clean_all = FALSE; \
1914 PL_profiledata = NULL; \
1916 PL_rsfp_filters = Nullav; \
1921 # ifdef MULTIPLICITY
1922 # define PERLVAR(var,type)
1923 # define PERLVARA(var,n,type)
1924 # if defined(PERL_IMPLICIT_CONTEXT)
1925 # if defined(USE_THREADS)
1926 # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
1927 # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
1928 # else /* !USE_THREADS */
1929 # define PERLVARI(var,type,init) aTHX->var = init;
1930 # define PERLVARIC(var,type,init) aTHX->var = init;
1931 # endif /* USE_THREADS */
1933 # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
1934 # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
1936 # include "intrpvar.h"
1937 # ifndef USE_THREADS
1938 # include "thrdvar.h"
1945 # define PERLVAR(var,type)
1946 # define PERLVARA(var,n,type)
1947 # define PERLVARI(var,type,init) PL_##var = init;
1948 # define PERLVARIC(var,type,init) PL_##var = init;
1949 # include "intrpvar.h"
1950 # ifndef USE_THREADS
1951 # include "thrdvar.h"
1963 S_init_main_stash(pTHX)
1968 /* Note that strtab is a rather special HV. Assumptions are made
1969 about not iterating on it, and not adding tie magic to it.
1970 It is properly deallocated in perl_destruct() */
1971 PL_strtab = newHV();
1973 MUTEX_INIT(&PL_strtab_mutex);
1975 HvSHAREKEYS_off(PL_strtab); /* mandatory */
1976 hv_ksplit(PL_strtab, 512);
1978 PL_curstash = PL_defstash = newHV();
1979 PL_curstname = newSVpvn("main",4);
1980 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1981 SvREFCNT_dec(GvHV(gv));
1982 GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
1984 HvNAME(PL_defstash) = savepv("main");
1985 PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1986 GvMULTI_on(PL_incgv);
1987 PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
1988 GvMULTI_on(PL_hintgv);
1989 PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1990 PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1991 GvMULTI_on(PL_errgv);
1992 PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
1993 GvMULTI_on(PL_replgv);
1994 (void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */
1995 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
1996 sv_setpvn(ERRSV, "", 0);
1997 PL_curstash = PL_defstash;
1998 PL_compiling.cop_stash = PL_defstash;
1999 PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
2000 PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
2001 /* We must init $/ before switches are processed. */
2002 sv_setpvn(get_sv("/", TRUE), "\n", 1);
2006 S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
2014 PL_origfilename = savepv("-e");
2017 /* if find_script() returns, it returns a malloc()-ed value */
2018 PL_origfilename = scriptname = find_script(scriptname, dosearch, NULL, 1);
2020 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
2021 char *s = scriptname + 8;
2022 *fdscript = atoi(s);
2026 scriptname = savepv(s + 1);
2027 Safefree(PL_origfilename);
2028 PL_origfilename = scriptname;
2033 PL_curcop->cop_filegv = gv_fetchfile(PL_origfilename);
2034 if (strEQ(PL_origfilename,"-"))
2036 if (*fdscript >= 0) {
2037 PL_rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE);
2038 #if defined(HAS_FCNTL) && defined(F_SETFD)
2040 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); /* ensure close-on-exec */
2043 else if (PL_preprocess) {
2044 char *cpp_cfg = CPPSTDIN;
2045 SV *cpp = newSVpvn("",0);
2046 SV *cmd = NEWSV(0,0);
2048 if (strEQ(cpp_cfg, "cppstdin"))
2049 Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
2050 sv_catpv(cpp, cpp_cfg);
2053 sv_catpv(sv,PRIVLIB_EXP);
2056 Perl_sv_setpvf(aTHX_ cmd, "\
2057 sed %s -e \"/^[^#]/b\" \
2058 -e \"/^#[ ]*include[ ]/b\" \
2059 -e \"/^#[ ]*define[ ]/b\" \
2060 -e \"/^#[ ]*if[ ]/b\" \
2061 -e \"/^#[ ]*ifdef[ ]/b\" \
2062 -e \"/^#[ ]*ifndef[ ]/b\" \
2063 -e \"/^#[ ]*else/b\" \
2064 -e \"/^#[ ]*elif[ ]/b\" \
2065 -e \"/^#[ ]*undef[ ]/b\" \
2066 -e \"/^#[ ]*endif/b\" \
2069 (PL_doextract ? "-e \"1,/^#/d\n\"" : ""),
2072 Perl_sv_setpvf(aTHX_ cmd, "\
2073 %s %s -e '/^[^#]/b' \
2074 -e '/^#[ ]*include[ ]/b' \
2075 -e '/^#[ ]*define[ ]/b' \
2076 -e '/^#[ ]*if[ ]/b' \
2077 -e '/^#[ ]*ifdef[ ]/b' \
2078 -e '/^#[ ]*ifndef[ ]/b' \
2079 -e '/^#[ ]*else/b' \
2080 -e '/^#[ ]*elif[ ]/b' \
2081 -e '/^#[ ]*undef[ ]/b' \
2082 -e '/^#[ ]*endif/b' \
2086 Perl_sv_setpvf(aTHX_ cmd, "\
2087 %s %s -e '/^[^#]/b' \
2088 -e '/^#[ ]*include[ ]/b' \
2089 -e '/^#[ ]*define[ ]/b' \
2090 -e '/^#[ ]*if[ ]/b' \
2091 -e '/^#[ ]*ifdef[ ]/b' \
2092 -e '/^#[ ]*ifndef[ ]/b' \
2093 -e '/^#[ ]*else/b' \
2094 -e '/^#[ ]*elif[ ]/b' \
2095 -e '/^#[ ]*undef[ ]/b' \
2096 -e '/^#[ ]*endif/b' \
2105 (PL_doextract ? "-e '1,/^#/d\n'" : ""),
2107 scriptname, cpp, sv, CPPMINUS);
2108 PL_doextract = FALSE;
2109 #ifdef IAMSUID /* actually, this is caught earlier */
2110 if (PL_euid != PL_uid && !PL_euid) { /* if running suidperl */
2112 (void)seteuid(PL_uid); /* musn't stay setuid root */
2115 (void)setreuid((Uid_t)-1, PL_uid);
2117 #ifdef HAS_SETRESUID
2118 (void)setresuid((Uid_t)-1, PL_uid, (Uid_t)-1);
2120 PerlProc_setuid(PL_uid);
2124 if (PerlProc_geteuid() != PL_uid)
2125 Perl_croak(aTHX_ "Can't do seteuid!\n");
2127 #endif /* IAMSUID */
2128 PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
2132 else if (!*scriptname) {
2133 forbid_setid("program input from stdin");
2134 PL_rsfp = PerlIO_stdin();
2137 PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
2138 #if defined(HAS_FCNTL) && defined(F_SETFD)
2140 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); /* ensure close-on-exec */
2145 #ifndef IAMSUID /* in case script is not readable before setuid */
2147 PerlLIO_stat(SvPVX(GvSV(PL_curcop->cop_filegv)),&PL_statbuf) >= 0 &&
2148 PL_statbuf.st_mode & (S_ISUID|S_ISGID))
2151 PerlProc_execv(Perl_form(aTHX_ "%s/sperl%s", BIN_EXP, PL_patchlevel), PL_origargv);
2152 Perl_croak(aTHX_ "Can't do setuid\n");
2156 Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
2157 SvPVX(GvSV(PL_curcop->cop_filegv)), Strerror(errno));
2162 * I_SYSSTATVFS HAS_FSTATVFS
2164 * I_STATFS HAS_FSTATFS
2165 * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT
2166 * here so that metaconfig picks them up. */
2170 S_fd_on_nosuid_fs(pTHX_ int fd)
2175 * Preferred order: fstatvfs(), fstatfs(), getmntent().
2176 * fstatvfs() is UNIX98.
2178 * getmntent() is O(number-of-mounted-filesystems) and can hang.
2181 # ifdef HAS_FSTATVFS
2182 struct statvfs stfs;
2183 check_okay = fstatvfs(fd, &stfs) == 0;
2184 on_nosuid = check_okay && (stfs.f_flag & ST_NOSUID);
2186 # if defined(HAS_FSTATFS) && defined(HAS_STRUCT_STATFS_FLAGS)
2188 check_okay = fstatfs(fd, &stfs) == 0;
2189 # undef PERL_MOUNT_NOSUID
2190 # if !defined(PERL_MOUNT_NOSUID) && defined(MNT_NOSUID)
2191 # define PERL_MOUNT_NOSUID MNT_NOSUID
2193 # if !defined(PERL_MOUNT_NOSUID) && defined(MS_NOSUID)
2194 # define PERL_MOUNT_NOSUID MS_NOSUID
2196 # if !defined(PERL_MOUNT_NOSUID) && defined(M_NOSUID)
2197 # define PERL_MOUNT_NOSUID M_NOSUID
2199 # ifdef PERL_MOUNT_NOSUID
2200 on_nosuid = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
2203 # if defined(HAS_GETMNTENT) && defined(HAS_HASMNTOPT) && defined(MNTOPT_NOSUID)
2204 FILE *mtab = fopen("/etc/mtab", "r");
2205 struct mntent *entry;
2206 struct stat stb, fsb;
2208 if (mtab && (fstat(fd, &stb) == 0)) {
2209 while (entry = getmntent(mtab)) {
2210 if (stat(entry->mnt_dir, &fsb) == 0
2211 && fsb.st_dev == stb.st_dev)
2213 /* found the filesystem */
2215 if (hasmntopt(entry, MNTOPT_NOSUID))
2218 } /* A single fs may well fail its stat(). */
2223 # endif /* mntent */
2224 # endif /* statfs */
2225 # endif /* statvfs */
2227 Perl_croak(aTHX_ "Can't check filesystem of script \"%s\"", PL_origfilename);
2230 #endif /* IAMSUID */
2233 S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript)
2237 /* do we need to emulate setuid on scripts? */
2239 /* This code is for those BSD systems that have setuid #! scripts disabled
2240 * in the kernel because of a security problem. Merely defining DOSUID
2241 * in perl will not fix that problem, but if you have disabled setuid
2242 * scripts in the kernel, this will attempt to emulate setuid and setgid
2243 * on scripts that have those now-otherwise-useless bits set. The setuid
2244 * root version must be called suidperl or sperlN.NNN. If regular perl
2245 * discovers that it has opened a setuid script, it calls suidperl with
2246 * the same argv that it had. If suidperl finds that the script it has
2247 * just opened is NOT setuid root, it sets the effective uid back to the
2248 * uid. We don't just make perl setuid root because that loses the
2249 * effective uid we had before invoking perl, if it was different from the
2252 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
2253 * be defined in suidperl only. suidperl must be setuid root. The
2254 * Configure script will set this up for you if you want it.
2261 if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */
2262 Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
2263 if (fdscript < 0 && PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
2268 #ifndef HAS_SETREUID
2269 /* On this access check to make sure the directories are readable,
2270 * there is actually a small window that the user could use to make
2271 * filename point to an accessible directory. So there is a faint
2272 * chance that someone could execute a setuid script down in a
2273 * non-accessible directory. I don't know what to do about that.
2274 * But I don't think it's too important. The manual lies when
2275 * it says access() is useful in setuid programs.
2277 if (PerlLIO_access(SvPVX(GvSV(PL_curcop->cop_filegv)),1)) /*double check*/
2278 Perl_croak(aTHX_ "Permission denied");
2280 /* If we can swap euid and uid, then we can determine access rights
2281 * with a simple stat of the file, and then compare device and
2282 * inode to make sure we did stat() on the same file we opened.
2283 * Then we just have to make sure he or she can execute it.
2286 struct stat tmpstatbuf;
2290 setreuid(PL_euid,PL_uid) < 0
2293 setresuid(PL_euid,PL_uid,(Uid_t)-1) < 0
2296 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
2297 Perl_croak(aTHX_ "Can't swap uid and euid"); /* really paranoid */
2298 if (PerlLIO_stat(SvPVX(GvSV(PL_curcop->cop_filegv)),&tmpstatbuf) < 0)
2299 Perl_croak(aTHX_ "Permission denied"); /* testing full pathname here */
2300 #if defined(IAMSUID) && !defined(NO_NOSUID_CHECK)
2301 if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp)))
2302 Perl_croak(aTHX_ "Permission denied");
2304 if (tmpstatbuf.st_dev != PL_statbuf.st_dev ||
2305 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
2306 (void)PerlIO_close(PL_rsfp);
2307 if (PL_rsfp = PerlProc_popen("/bin/mail root","w")) { /* heh, heh */
2308 PerlIO_printf(PL_rsfp,
2309 "User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2310 (Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
2311 (long)PL_uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
2312 (long)PL_statbuf.st_dev, (long)PL_statbuf.st_ino,
2313 SvPVX(GvSV(PL_curcop->cop_filegv)),
2314 (long)PL_statbuf.st_uid, (long)PL_statbuf.st_gid);
2315 (void)PerlProc_pclose(PL_rsfp);
2317 Perl_croak(aTHX_ "Permission denied\n");
2321 setreuid(PL_uid,PL_euid) < 0
2323 # if defined(HAS_SETRESUID)
2324 setresuid(PL_uid,PL_euid,(Uid_t)-1) < 0
2327 || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
2328 Perl_croak(aTHX_ "Can't reswap uid and euid");
2329 if (!cando(S_IXUSR,FALSE,&PL_statbuf)) /* can real uid exec? */
2330 Perl_croak(aTHX_ "Permission denied\n");
2332 #endif /* HAS_SETREUID */
2333 #endif /* IAMSUID */
2335 if (!S_ISREG(PL_statbuf.st_mode))
2336 Perl_croak(aTHX_ "Permission denied");
2337 if (PL_statbuf.st_mode & S_IWOTH)
2338 Perl_croak(aTHX_ "Setuid/gid script is writable by world");
2339 PL_doswitches = FALSE; /* -s is insecure in suid */
2340 PL_curcop->cop_line++;
2341 if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
2342 strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */
2343 Perl_croak(aTHX_ "No #! line");
2344 s = SvPV(PL_linestr,n_a)+2;
2346 while (!isSPACE(*s)) s++;
2347 for (s2 = s; (s2 > SvPV(PL_linestr,n_a)+2 &&
2348 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
2349 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
2350 Perl_croak(aTHX_ "Not a perl script");
2351 while (*s == ' ' || *s == '\t') s++;
2353 * #! arg must be what we saw above. They can invoke it by
2354 * mentioning suidperl explicitly, but they may not add any strange
2355 * arguments beyond what #! says if they do invoke suidperl that way.
2357 len = strlen(validarg);
2358 if (strEQ(validarg," PHOOEY ") ||
2359 strnNE(s,validarg,len) || !isSPACE(s[len]))
2360 Perl_croak(aTHX_ "Args must match #! line");
2363 if (PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
2364 PL_euid == PL_statbuf.st_uid)
2366 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2367 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2368 #endif /* IAMSUID */
2370 if (PL_euid) { /* oops, we're not the setuid root perl */
2371 (void)PerlIO_close(PL_rsfp);
2374 PerlProc_execv(Perl_form(aTHX_ "%s/sperl%s", BIN_EXP, PL_patchlevel), PL_origargv);
2376 Perl_croak(aTHX_ "Can't do setuid\n");
2379 if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
2381 (void)setegid(PL_statbuf.st_gid);
2384 (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
2386 #ifdef HAS_SETRESGID
2387 (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
2389 PerlProc_setgid(PL_statbuf.st_gid);
2393 if (PerlProc_getegid() != PL_statbuf.st_gid)
2394 Perl_croak(aTHX_ "Can't do setegid!\n");
2396 if (PL_statbuf.st_mode & S_ISUID) {
2397 if (PL_statbuf.st_uid != PL_euid)
2399 (void)seteuid(PL_statbuf.st_uid); /* all that for this */
2402 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
2404 #ifdef HAS_SETRESUID
2405 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
2407 PerlProc_setuid(PL_statbuf.st_uid);
2411 if (PerlProc_geteuid() != PL_statbuf.st_uid)
2412 Perl_croak(aTHX_ "Can't do seteuid!\n");
2414 else if (PL_uid) { /* oops, mustn't run as root */
2416 (void)seteuid((Uid_t)PL_uid);
2419 (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
2421 #ifdef HAS_SETRESUID
2422 (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
2424 PerlProc_setuid((Uid_t)PL_uid);
2428 if (PerlProc_geteuid() != PL_uid)
2429 Perl_croak(aTHX_ "Can't do seteuid!\n");
2432 if (!cando(S_IXUSR,TRUE,&PL_statbuf))
2433 Perl_croak(aTHX_ "Permission denied\n"); /* they can't do this */
2436 else if (PL_preprocess)
2437 Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
2438 else if (fdscript >= 0)
2439 Perl_croak(aTHX_ "fd script not allowed in suidperl\n");
2441 Perl_croak(aTHX_ "Script is not setuid/setgid in suidperl\n");
2443 /* We absolutely must clear out any saved ids here, so we */
2444 /* exec the real perl, substituting fd script for scriptname. */
2445 /* (We pass script name as "subdir" of fd, which perl will grok.) */
2446 PerlIO_rewind(PL_rsfp);
2447 PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0); /* just in case rewind didn't */
2448 for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
2449 if (!PL_origargv[which])
2450 Perl_croak(aTHX_ "Permission denied");
2451 PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
2452 PerlIO_fileno(PL_rsfp), PL_origargv[which]));
2453 #if defined(HAS_FCNTL) && defined(F_SETFD)
2454 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */
2456 PerlProc_execv(Perl_form(aTHX_ "%s/perl%s", BIN_EXP, PL_patchlevel), PL_origargv);/* try again */
2457 Perl_croak(aTHX_ "Can't do setuid\n");
2458 #endif /* IAMSUID */
2460 if (PL_euid != PL_uid || PL_egid != PL_gid) { /* (suidperl doesn't exist, in fact) */
2461 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2463 PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf); /* may be either wrapped or real suid */
2464 if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
2466 (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
2469 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2470 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2471 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2472 /* not set-id, must be wrapped */
2478 S_find_beginning(pTHX)
2480 register char *s, *s2;
2482 /* skip forward in input to the real script? */
2485 while (PL_doextract) {
2486 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
2487 Perl_croak(aTHX_ "No Perl script found in input\n");
2488 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2489 PerlIO_ungetc(PL_rsfp, '\n'); /* to keep line count right */
2490 PL_doextract = FALSE;
2491 while (*s && !(isSPACE (*s) || *s == '#')) s++;
2493 while (*s == ' ' || *s == '\t') s++;
2495 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2496 if (strnEQ(s2-4,"perl",4))
2498 while (s = moreswitches(s)) ;
2500 if (PL_cddir && PerlDir_chdir(PL_cddir) < 0)
2501 Perl_croak(aTHX_ "Can't chdir to %s",PL_cddir);
2510 PL_uid = PerlProc_getuid();
2511 PL_euid = PerlProc_geteuid();
2512 PL_gid = PerlProc_getgid();
2513 PL_egid = PerlProc_getegid();
2515 PL_uid |= PL_gid << 16;
2516 PL_euid |= PL_egid << 16;
2518 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2522 S_forbid_setid(pTHX_ char *s)
2524 if (PL_euid != PL_uid)
2525 Perl_croak(aTHX_ "No %s allowed while running setuid", s);
2526 if (PL_egid != PL_gid)
2527 Perl_croak(aTHX_ "No %s allowed while running setgid", s);
2531 Perl_init_debugger(pTHX)
2534 HV *ostash = PL_curstash;
2536 PL_curstash = PL_debstash;
2537 PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2538 AvREAL_off(PL_dbargs);
2539 PL_DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2540 PL_DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2541 PL_DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2542 sv_upgrade(GvSV(PL_DBsub), SVt_IV); /* IVX accessed if PERLDB_SUB_NN */
2543 PL_DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2544 sv_setiv(PL_DBsingle, 0);
2545 PL_DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2546 sv_setiv(PL_DBtrace, 0);
2547 PL_DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2548 sv_setiv(PL_DBsignal, 0);
2549 PL_curstash = ostash;
2552 #ifndef STRESS_REALLOC
2553 #define REASONABLE(size) (size)
2555 #define REASONABLE(size) (1) /* unreasonable */
2559 Perl_init_stacks(pTHX)
2561 /* start with 128-item stack and 8K cxstack */
2562 PL_curstackinfo = new_stackinfo(REASONABLE(128),
2563 REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
2564 PL_curstackinfo->si_type = PERLSI_MAIN;
2565 PL_curstack = PL_curstackinfo->si_stack;
2566 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
2568 PL_stack_base = AvARRAY(PL_curstack);
2569 PL_stack_sp = PL_stack_base;
2570 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
2572 New(50,PL_tmps_stack,REASONABLE(128),SV*);
2575 PL_tmps_max = REASONABLE(128);
2577 New(54,PL_markstack,REASONABLE(32),I32);
2578 PL_markstack_ptr = PL_markstack;
2579 PL_markstack_max = PL_markstack + REASONABLE(32);
2583 New(54,PL_scopestack,REASONABLE(32),I32);
2584 PL_scopestack_ix = 0;
2585 PL_scopestack_max = REASONABLE(32);
2587 New(54,PL_savestack,REASONABLE(128),ANY);
2588 PL_savestack_ix = 0;
2589 PL_savestack_max = REASONABLE(128);
2591 New(54,PL_retstack,REASONABLE(16),OP*);
2593 PL_retstack_max = REASONABLE(16);
2602 while (PL_curstackinfo->si_next)
2603 PL_curstackinfo = PL_curstackinfo->si_next;
2604 while (PL_curstackinfo) {
2605 PERL_SI *p = PL_curstackinfo->si_prev;
2606 /* curstackinfo->si_stack got nuked by sv_free_arenas() */
2607 Safefree(PL_curstackinfo->si_cxstack);
2608 Safefree(PL_curstackinfo);
2609 PL_curstackinfo = p;
2611 Safefree(PL_tmps_stack);
2612 Safefree(PL_markstack);
2613 Safefree(PL_scopestack);
2614 Safefree(PL_savestack);
2615 Safefree(PL_retstack);
2617 Safefree(PL_debname);
2618 Safefree(PL_debdelim);
2623 static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
2634 lex_start(PL_linestr);
2636 PL_subname = newSVpvn("main",4);
2640 S_init_predump_symbols(pTHX)
2647 sv_setpvn(get_sv("\"", TRUE), " ", 1);
2648 PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2649 GvMULTI_on(PL_stdingv);
2650 io = GvIOp(PL_stdingv);
2651 IoIFP(io) = PerlIO_stdin();
2652 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2654 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
2656 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2659 IoOFP(io) = IoIFP(io) = PerlIO_stdout();
2661 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2663 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
2665 PL_stderrgv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2666 GvMULTI_on(PL_stderrgv);
2667 io = GvIOp(PL_stderrgv);
2668 IoOFP(io) = IoIFP(io) = PerlIO_stderr();
2669 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2671 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
2673 PL_statname = NEWSV(66,0); /* last filename we did stat on */
2676 PL_osname = savepv(OSNAME);
2680 S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
2687 argc--,argv++; /* skip name of script */
2688 if (PL_doswitches) {
2689 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2692 if (argv[0][1] == '-') {
2696 if (s = strchr(argv[0], '=')) {
2698 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2701 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2704 PL_toptarget = NEWSV(0,0);
2705 sv_upgrade(PL_toptarget, SVt_PVFM);
2706 sv_setpvn(PL_toptarget, "", 0);
2707 PL_bodytarget = NEWSV(0,0);
2708 sv_upgrade(PL_bodytarget, SVt_PVFM);
2709 sv_setpvn(PL_bodytarget, "", 0);
2710 PL_formtarget = PL_bodytarget;
2713 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2714 sv_setpv(GvSV(tmpgv),PL_origfilename);
2715 magicname("0", "0", 1);
2717 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2718 sv_setpv(GvSV(tmpgv),PL_origargv[0]);
2719 if (PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2720 GvMULTI_on(PL_argvgv);
2721 (void)gv_AVadd(PL_argvgv);
2722 av_clear(GvAVn(PL_argvgv));
2723 for (; argc > 0; argc--,argv++) {
2724 av_push(GvAVn(PL_argvgv),newSVpv(argv[0],0));
2727 if (PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2729 GvMULTI_on(PL_envgv);
2730 hv = GvHVn(PL_envgv);
2731 hv_magic(hv, PL_envgv, 'E');
2732 #if !defined( VMS) && !defined(EPOC) /* VMS doesn't have environ array */
2733 /* Note that if the supplied env parameter is actually a copy
2734 of the global environ then it may now point to free'd memory
2735 if the environment has been modified since. To avoid this
2736 problem we treat env==NULL as meaning 'use the default'
2741 environ[0] = Nullch;
2742 for (; *env; env++) {
2743 if (!(s = strchr(*env,'=')))
2749 sv = newSVpv(s--,0);
2750 (void)hv_store(hv, *env, s - *env, sv, 0);
2752 #if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
2753 /* Sins of the RTL. See note in my_setenv(). */
2754 (void)PerlEnv_putenv(savepv(*env));
2758 #ifdef DYNAMIC_ENV_FETCH
2759 HvNAME(hv) = savepv(ENV_HV_NAME);
2763 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2764 sv_setiv(GvSV(tmpgv), (IV)getpid());
2768 S_init_perllib(pTHX)
2773 s = PerlEnv_getenv("PERL5LIB");
2777 incpush(PerlEnv_getenv("PERLLIB"), FALSE);
2779 /* Treat PERL5?LIB as a possible search list logical name -- the
2780 * "natural" VMS idiom for a Unix path string. We allow each
2781 * element to be a set of |-separated directories for compatibility.
2785 if (my_trnlnm("PERL5LIB",buf,0))
2786 do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2788 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2792 /* Use the ~-expanded versions of APPLLIB (undocumented),
2793 ARCHLIB PRIVLIB SITEARCH and SITELIB
2796 incpush(APPLLIB_EXP, TRUE);
2800 incpush(ARCHLIB_EXP, FALSE);
2803 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2806 incpush(PRIVLIB_EXP, TRUE);
2808 incpush(PRIVLIB_EXP, FALSE);
2812 incpush(SITEARCH_EXP, FALSE);
2816 incpush(SITELIB_EXP, TRUE);
2818 incpush(SITELIB_EXP, FALSE);
2821 #if defined(PERL_VENDORLIB_EXP)
2823 incpush(PERL_VENDORLIB_EXP, TRUE);
2825 incpush(PERL_VENDORLIB_EXP, FALSE);
2829 incpush(".", FALSE);
2833 # define PERLLIB_SEP ';'
2836 # define PERLLIB_SEP '|'
2838 # define PERLLIB_SEP ':'
2841 #ifndef PERLLIB_MANGLE
2842 # define PERLLIB_MANGLE(s,n) (s)
2846 S_incpush(pTHX_ char *p, int addsubdirs)
2848 SV *subdir = Nullsv;
2854 subdir = sv_newmortal();
2855 if (!PL_archpat_auto) {
2856 STRLEN len = (sizeof(ARCHNAME) + strlen(PL_patchlevel)
2857 + sizeof("//auto"));
2858 New(55, PL_archpat_auto, len, char);
2859 sprintf(PL_archpat_auto, "/%s/%s/auto", ARCHNAME, PL_patchlevel);
2861 for (len = sizeof(ARCHNAME) + 2;
2862 PL_archpat_auto[len] != '\0' && PL_archpat_auto[len] != '/'; len++)
2863 if (PL_archpat_auto[len] == '.') PL_archpat_auto[len] = '_';
2868 /* Break at all separators */
2870 SV *libdir = NEWSV(55,0);
2873 /* skip any consecutive separators */
2874 while ( *p == PERLLIB_SEP ) {
2875 /* Uncomment the next line for PATH semantics */
2876 /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */
2880 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2881 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2886 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2887 p = Nullch; /* break out */
2891 * BEFORE pushing libdir onto @INC we may first push version- and
2892 * archname-specific sub-directories.
2895 struct stat tmpstatbuf;
2900 if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) {
2902 while (unix[len-1] == '/') len--; /* Cosmetic */
2903 sv_usepvn(libdir,unix,len);
2906 PerlIO_printf(Perl_error_log,
2907 "Failed to unixify @INC element \"%s\"\n",
2910 /* .../archname/version if -d .../archname/version/auto */
2911 sv_setsv(subdir, libdir);
2912 sv_catpv(subdir, PL_archpat_auto);
2913 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2914 S_ISDIR(tmpstatbuf.st_mode))
2915 av_push(GvAVn(PL_incgv),
2916 newSVpvn(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2918 /* .../archname if -d .../archname/auto */
2919 sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
2920 strlen(PL_patchlevel) + 1, "", 0);
2921 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2922 S_ISDIR(tmpstatbuf.st_mode))
2923 av_push(GvAVn(PL_incgv),
2924 newSVpvn(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2927 /* finally push this lib directory on the end of @INC */
2928 av_push(GvAVn(PL_incgv), libdir);
2933 STATIC struct perl_thread *
2934 S_init_main_thread(pTHX)
2936 #if !defined(PERL_IMPLICIT_CONTEXT)
2937 struct perl_thread *thr;
2941 Newz(53, thr, 1, struct perl_thread);
2942 PL_curcop = &PL_compiling;
2943 thr->interp = PERL_GET_INTERP;
2944 thr->cvcache = newHV();
2945 thr->threadsv = newAV();
2946 /* thr->threadsvp is set when find_threadsv is called */
2947 thr->specific = newAV();
2948 thr->flags = THRf_R_JOINABLE;
2949 MUTEX_INIT(&thr->mutex);
2950 /* Handcraft thrsv similarly to mess_sv */
2951 New(53, PL_thrsv, 1, SV);
2952 Newz(53, xpv, 1, XPV);
2953 SvFLAGS(PL_thrsv) = SVt_PV;
2954 SvANY(PL_thrsv) = (void*)xpv;
2955 SvREFCNT(PL_thrsv) = 1 << 30; /* practically infinite */
2956 SvPVX(PL_thrsv) = (char*)thr;
2957 SvCUR_set(PL_thrsv, sizeof(thr));
2958 SvLEN_set(PL_thrsv, sizeof(thr));
2959 *SvEND(PL_thrsv) = '\0'; /* in the trailing_nul field */
2960 thr->oursv = PL_thrsv;
2961 PL_chopset = " \n-";
2964 MUTEX_LOCK(&PL_threads_mutex);
2969 MUTEX_UNLOCK(&PL_threads_mutex);
2971 #ifdef HAVE_THREAD_INTERN
2972 Perl_init_thread_intern(thr);
2975 #ifdef SET_THREAD_SELF
2976 SET_THREAD_SELF(thr);
2978 thr->self = pthread_self();
2979 #endif /* SET_THREAD_SELF */
2983 * These must come after the SET_THR because sv_setpvn does
2984 * SvTAINT and the taint fields require dTHR.
2986 PL_toptarget = NEWSV(0,0);
2987 sv_upgrade(PL_toptarget, SVt_PVFM);
2988 sv_setpvn(PL_toptarget, "", 0);
2989 PL_bodytarget = NEWSV(0,0);
2990 sv_upgrade(PL_bodytarget, SVt_PVFM);
2991 sv_setpvn(PL_bodytarget, "", 0);
2992 PL_formtarget = PL_bodytarget;
2993 thr->errsv = newSVpvn("", 0);
2994 (void) find_threadsv("@"); /* Ensure $@ is initialised early */
2997 PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
2998 PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
2999 PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
3000 PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
3001 PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
3003 PL_reginterp_cnt = 0;
3007 #endif /* USE_THREADS */
3010 Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
3014 line_t oldline = PL_curcop->cop_line;
3020 while (AvFILL(paramList) >= 0) {
3021 cv = (CV*)av_shift(paramList);
3023 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_list_body), cv);
3026 (void)SvPV(atsv, len);
3028 PL_curcop = &PL_compiling;
3029 PL_curcop->cop_line = oldline;
3030 if (paramList == PL_beginav)
3031 sv_catpv(atsv, "BEGIN failed--compilation aborted");
3033 sv_catpv(atsv, "END failed--cleanup aborted");
3034 while (PL_scopestack_ix > oldscope)
3036 Perl_croak(aTHX_ "%s", SvPVX(atsv));
3043 /* my_exit() was called */
3044 while (PL_scopestack_ix > oldscope)
3047 PL_curstash = PL_defstash;
3048 if (PL_endav && !PL_minus_c)
3049 call_list(oldscope, PL_endav);
3050 PL_curcop = &PL_compiling;
3051 PL_curcop->cop_line = oldline;
3052 if (PL_statusvalue) {
3053 if (paramList == PL_beginav)
3054 Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
3056 Perl_croak(aTHX_ "END failed--cleanup aborted");
3062 PL_curcop = &PL_compiling;
3063 PL_curcop->cop_line = oldline;
3066 PerlIO_printf(Perl_error_log, "panic: restartop\n");
3074 S_call_list_body(pTHX_ va_list args)
3077 CV *cv = va_arg(args, CV*);
3079 PUSHMARK(PL_stack_sp);
3080 call_sv((SV*)cv, G_EVAL|G_DISCARD);
3085 Perl_my_exit(pTHX_ U32 status)
3089 DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
3090 thr, (unsigned long) status));
3099 STATUS_NATIVE_SET(status);
3106 Perl_my_failure_exit(pTHX)
3109 if (vaxc$errno & 1) {
3110 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
3111 STATUS_NATIVE_SET(44);
3114 if (!vaxc$errno && errno) /* unlikely */
3115 STATUS_NATIVE_SET(44);
3117 STATUS_NATIVE_SET(vaxc$errno);
3122 STATUS_POSIX_SET(errno);
3124 exitstatus = STATUS_POSIX >> 8;
3125 if (exitstatus & 255)
3126 STATUS_POSIX_SET(exitstatus);
3128 STATUS_POSIX_SET(255);
3135 S_my_exit_jump(pTHX)
3138 register PERL_CONTEXT *cx;
3143 SvREFCNT_dec(PL_e_script);
3144 PL_e_script = Nullsv;
3147 POPSTACK_TO(PL_mainstack);
3148 if (cxstack_ix >= 0) {
3151 POPBLOCK(cx,PL_curpm);
3164 read_e_script(pTHXo_ int idx, SV *buf_sv, int maxlen)
3167 p = SvPVX(PL_e_script);
3168 nl = strchr(p, '\n');
3169 nl = (nl) ? nl+1 : SvEND(PL_e_script);
3171 filter_del(read_e_script);
3174 sv_catpvn(buf_sv, p, nl-p);
3175 sv_chop(PL_e_script, nl);