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 *sv_interp;
63 New(53, sv_interp, 1, PerlInterpreter);
66 #endif /* PERL_OBJECT */
69 perl_construct(register PerlInterpreter *sv_interp)
74 struct perl_thread *thr;
75 #endif /* FAKE_THREADS */
76 #endif /* USE_THREADS */
79 if (!(PL_curinterp = sv_interp))
85 Zero(sv_interp, 1, PerlInterpreter);
88 /* Init the real globals (and main thread)? */
93 #ifdef ALLOC_THREAD_KEY
96 if (pthread_key_create(&PL_thr_key, 0))
97 croak("panic: pthread_key_create");
99 MUTEX_INIT(&PL_sv_mutex);
101 * Safe to use basic SV functions from now on (though
102 * not things like mortals or tainting yet).
104 MUTEX_INIT(&PL_eval_mutex);
105 COND_INIT(&PL_eval_cond);
106 MUTEX_INIT(&PL_threads_mutex);
107 COND_INIT(&PL_nthreads_cond);
108 #ifdef EMULATE_ATOMIC_REFCOUNTS
109 MUTEX_INIT(&PL_svref_mutex);
110 #endif /* EMULATE_ATOMIC_REFCOUNTS */
112 MUTEX_INIT(&PL_cred_mutex);
114 thr = init_main_thread();
115 #endif /* USE_THREADS */
117 PL_protect = FUNC_NAME_TO_PTR(default_protect); /* for exceptions */
119 PL_curcop = &PL_compiling; /* needed by ckWARN, right away */
121 PL_linestr = NEWSV(65,79);
122 sv_upgrade(PL_linestr,SVt_PVIV);
124 if (!SvREADONLY(&PL_sv_undef)) {
125 /* set read-only and try to insure than we wont see REFCNT==0
128 SvREADONLY_on(&PL_sv_undef);
129 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
131 sv_setpv(&PL_sv_no,PL_No);
133 SvREADONLY_on(&PL_sv_no);
134 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
136 sv_setpv(&PL_sv_yes,PL_Yes);
138 SvREADONLY_on(&PL_sv_yes);
139 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
144 /* PL_sighandlerp = sighandler; */
146 PL_sighandlerp = sighandler;
148 PL_pidstatus = newHV();
152 * There is no way we can refer to them from Perl so close them to save
153 * space. The other alternative would be to provide STDAUX and STDPRN
156 (void)fclose(stdaux);
157 (void)fclose(stdprn);
161 PL_nrs = newSVpvn("\n", 1);
162 PL_rs = SvREFCNT_inc(PL_nrs);
167 PL_perl_destruct_level = 1;
169 if (PL_perl_destruct_level > 0)
174 PL_lex_state = LEX_NOTPARSING;
179 SET_NUMERIC_STANDARD();
180 #if defined(PERL_SUBVERSION) && PERL_SUBVERSION > 0
181 sprintf(PL_patchlevel, "%7.5f", (double) PERL_REVISION
182 + ((double) PERL_VERSION / (double) 1000)
183 + ((double) PERL_SUBVERSION / (double) 100000));
185 sprintf(PL_patchlevel, "%5.3f", (double) PERL_REVISION +
186 ((double) PERL_VERSION / (double) 1000));
189 #if defined(LOCAL_PATCH_COUNT)
190 PL_localpatches = local_patches; /* For possible -v */
193 PerlIO_init(); /* Hook to IO system */
195 PL_fdpid = newAV(); /* for remembering popen pids by fd */
196 PL_modglobal = newHV(); /* pointers to per-interpreter module globals */
199 New(51,PL_debname,128,char);
200 New(52,PL_debdelim,128,char);
207 perl_destruct(register PerlInterpreter *sv_interp)
210 int destruct_level; /* 0=none, 1=full, 2=full with checks */
215 #endif /* USE_THREADS */
218 if (!(PL_curinterp = sv_interp))
224 /* Pass 1 on any remaining threads: detach joinables, join zombies */
226 MUTEX_LOCK(&PL_threads_mutex);
227 DEBUG_S(PerlIO_printf(PerlIO_stderr(),
228 "perl_destruct: waiting for %d threads...\n",
230 for (t = thr->next; t != thr; t = t->next) {
231 MUTEX_LOCK(&t->mutex);
232 switch (ThrSTATE(t)) {
235 DEBUG_S(PerlIO_printf(PerlIO_stderr(),
236 "perl_destruct: joining zombie %p\n", t));
237 ThrSETSTATE(t, THRf_DEAD);
238 MUTEX_UNLOCK(&t->mutex);
241 * The SvREFCNT_dec below may take a long time (e.g. av
242 * may contain an object scalar whose destructor gets
243 * called) so we have to unlock threads_mutex and start
246 MUTEX_UNLOCK(&PL_threads_mutex);
248 SvREFCNT_dec((SV*)av);
249 DEBUG_S(PerlIO_printf(PerlIO_stderr(),
250 "perl_destruct: joined zombie %p OK\n", t));
252 case THRf_R_JOINABLE:
253 DEBUG_S(PerlIO_printf(PerlIO_stderr(),
254 "perl_destruct: detaching thread %p\n", t));
255 ThrSETSTATE(t, THRf_R_DETACHED);
257 * We unlock threads_mutex and t->mutex in the opposite order
258 * from which we locked them just so that DETACH won't
259 * deadlock if it panics. It's only a breach of good style
260 * not a bug since they are unlocks not locks.
262 MUTEX_UNLOCK(&PL_threads_mutex);
264 MUTEX_UNLOCK(&t->mutex);
267 DEBUG_S(PerlIO_printf(PerlIO_stderr(),
268 "perl_destruct: ignoring %p (state %u)\n",
270 MUTEX_UNLOCK(&t->mutex);
271 /* fall through and out */
274 /* We leave the above "Pass 1" loop with threads_mutex still locked */
276 /* Pass 2 on remaining threads: wait for the thread count to drop to one */
277 while (PL_nthreads > 1)
279 DEBUG_S(PerlIO_printf(PerlIO_stderr(),
280 "perl_destruct: final wait for %d threads\n",
282 COND_WAIT(&PL_nthreads_cond, &PL_threads_mutex);
284 /* At this point, we're the last thread */
285 MUTEX_UNLOCK(&PL_threads_mutex);
286 DEBUG_S(PerlIO_printf(PerlIO_stderr(), "perl_destruct: armageddon has arrived\n"));
287 MUTEX_DESTROY(&PL_threads_mutex);
288 COND_DESTROY(&PL_nthreads_cond);
289 #endif /* !defined(FAKE_THREADS) */
290 #endif /* USE_THREADS */
292 destruct_level = PL_perl_destruct_level;
296 if (s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL")) {
298 if (destruct_level < i)
311 /* We must account for everything. */
313 /* Destroy the main CV and syntax tree */
315 PL_curpad = AvARRAY(PL_comppad);
316 op_free(PL_main_root);
317 PL_main_root = Nullop;
319 PL_curcop = &PL_compiling;
320 PL_main_start = Nullop;
321 SvREFCNT_dec(PL_main_cv);
325 if (PL_sv_objcount) {
327 * Try to destruct global references. We do this first so that the
328 * destructors and destructees still exist. Some sv's might remain.
329 * Non-referenced objects are on their own.
334 /* unhook hooks which will soon be, or use, destroyed data */
335 SvREFCNT_dec(PL_warnhook);
336 PL_warnhook = Nullsv;
337 SvREFCNT_dec(PL_diehook);
339 SvREFCNT_dec(PL_parsehook);
340 PL_parsehook = Nullsv;
342 /* call exit list functions */
343 while (PL_exitlistlen-- > 0)
344 PL_exitlist[PL_exitlistlen].fn(PERL_OBJECT_THIS_ PL_exitlist[PL_exitlistlen].ptr);
346 Safefree(PL_exitlist);
348 if (destruct_level == 0){
350 DEBUG_P(debprofdump());
352 /* The exit() function will do everything that needs doing. */
356 /* loosen bonds of global variables */
359 (void)PerlIO_close(PL_rsfp);
363 /* Filters for program text */
364 SvREFCNT_dec(PL_rsfp_filters);
365 PL_rsfp_filters = Nullav;
368 PL_preprocess = FALSE;
374 PL_doswitches = FALSE;
375 PL_dowarn = G_WARN_OFF;
376 PL_doextract = FALSE;
377 PL_sawampersand = FALSE; /* must save all match strings */
378 PL_sawstudy = FALSE; /* do fbm_instr on all strings */
382 Safefree(PL_inplace);
386 SvREFCNT_dec(PL_e_script);
387 PL_e_script = Nullsv;
390 /* magical thingies */
392 Safefree(PL_ofs); /* $, */
395 Safefree(PL_ors); /* $\ */
398 SvREFCNT_dec(PL_rs); /* $/ */
401 SvREFCNT_dec(PL_nrs); /* $/ helper */
404 PL_multiline = 0; /* $* */
406 SvREFCNT_dec(PL_statname);
407 PL_statname = Nullsv;
410 /* defgv, aka *_ should be taken care of elsewhere */
412 /* clean up after study() */
413 SvREFCNT_dec(PL_lastscream);
414 PL_lastscream = Nullsv;
415 Safefree(PL_screamfirst);
417 Safefree(PL_screamnext);
420 /* startup and shutdown function lists */
421 SvREFCNT_dec(PL_beginav);
422 SvREFCNT_dec(PL_endav);
423 SvREFCNT_dec(PL_initav);
428 /* shortcuts just get cleared */
435 PL_argvoutgv = Nullgv;
437 PL_last_in_gv = Nullgv;
440 /* reset so print() ends up where we expect */
443 /* Prepare to destruct main symbol table. */
450 if (destruct_level >= 2) {
451 if (PL_scopestack_ix != 0)
452 warn("Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
453 (long)PL_scopestack_ix);
454 if (PL_savestack_ix != 0)
455 warn("Unbalanced saves: %ld more saves than restores\n",
456 (long)PL_savestack_ix);
457 if (PL_tmps_floor != -1)
458 warn("Unbalanced tmps: %ld more allocs than frees\n",
459 (long)PL_tmps_floor + 1);
460 if (cxstack_ix != -1)
461 warn("Unbalanced context: %ld more PUSHes than POPs\n",
462 (long)cxstack_ix + 1);
465 /* Now absolutely destruct everything, somehow or other, loops or no. */
467 SvFLAGS(PL_strtab) |= SVTYPEMASK; /* don't clean out strtab now */
468 while (PL_sv_count != 0 && PL_sv_count != last_sv_count) {
469 last_sv_count = PL_sv_count;
472 SvFLAGS(PL_strtab) &= ~SVTYPEMASK;
473 SvFLAGS(PL_strtab) |= SVt_PVHV;
475 /* Destruct the global string table. */
477 /* Yell and reset the HeVAL() slots that are still holding refcounts,
478 * so that sv_free() won't fail on them.
486 max = HvMAX(PL_strtab);
487 array = HvARRAY(PL_strtab);
491 warn("Unbalanced string table refcount: (%d) for \"%s\"",
492 HeVAL(hent) - Nullsv, HeKEY(hent));
493 HeVAL(hent) = Nullsv;
503 SvREFCNT_dec(PL_strtab);
505 if (PL_sv_count != 0)
506 warn("Scalars leaked: %ld\n", (long)PL_sv_count);
510 /* No SVs have survived, need to clean out */
512 PL_pidstatus = Nullhv;
513 Safefree(PL_origfilename);
514 Safefree(PL_archpat_auto);
515 Safefree(PL_reg_start_tmp);
517 Safefree(PL_reg_curpm);
518 Safefree(HeKEY_hek(&PL_hv_fetch_ent_mh));
519 Safefree(PL_op_mask);
521 PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */
523 DEBUG_P(debprofdump());
525 MUTEX_DESTROY(&PL_strtab_mutex);
526 MUTEX_DESTROY(&PL_sv_mutex);
527 MUTEX_DESTROY(&PL_eval_mutex);
528 MUTEX_DESTROY(&PL_cred_mutex);
529 COND_DESTROY(&PL_eval_cond);
530 #ifdef EMULATE_ATOMIC_REFCOUNTS
531 MUTEX_DESTROY(&PL_svref_mutex);
532 #endif /* EMULATE_ATOMIC_REFCOUNTS */
534 /* As the penultimate thing, free the non-arena SV for thrsv */
535 Safefree(SvPVX(PL_thrsv));
536 Safefree(SvANY(PL_thrsv));
539 #endif /* USE_THREADS */
541 /* As the absolutely last thing, free the non-arena SV for mess() */
544 /* it could have accumulated taint magic */
545 if (SvTYPE(PL_mess_sv) >= SVt_PVMG) {
548 for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) {
549 moremagic = mg->mg_moremagic;
550 if (mg->mg_ptr && mg->mg_type != 'g' && mg->mg_len >= 0)
551 Safefree(mg->mg_ptr);
555 /* we know that type >= SVt_PV */
556 SvOOK_off(PL_mess_sv);
557 Safefree(SvPVX(PL_mess_sv));
558 Safefree(SvANY(PL_mess_sv));
559 Safefree(PL_mess_sv);
565 perl_free(PerlInterpreter *sv_interp)
570 if (!(PL_curinterp = sv_interp))
577 Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
579 Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry);
580 PL_exitlist[PL_exitlistlen].fn = fn;
581 PL_exitlist[PL_exitlistlen].ptr = ptr;
586 perl_parse(PerlInterpreter *sv_interp, XSINIT_t xsinit, int argc, char **argv, char **env)
592 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
595 croak("suidperl is no longer needed since the kernel can now execute\n\
596 setuid perl scripts securely.\n");
601 if (!(PL_curinterp = sv_interp))
605 #if defined(__DYNAMIC__) && (defined(NeXT) || defined(__NeXT__))
606 _dyld_lookup_and_bind
607 ("__environ", (unsigned long *) &environ_pointer, NULL);
612 #ifndef VMS /* VMS doesn't have environ array */
613 PL_origenviron = environ;
618 /* Come here if running an undumped a.out. */
620 PL_origfilename = savepv(argv[0]);
621 PL_do_undump = FALSE;
622 cxstack_ix = -1; /* start label stack again */
624 init_postdump_symbols(argc,argv,env);
629 PL_curpad = AvARRAY(PL_comppad);
630 op_free(PL_main_root);
631 PL_main_root = Nullop;
633 PL_main_start = Nullop;
634 SvREFCNT_dec(PL_main_cv);
638 oldscope = PL_scopestack_ix;
639 PL_dowarn = G_WARN_OFF;
641 CALLPROTECT(&ret, FUNC_NAME_TO_PTR(parse_body), env, xsinit);
649 /* my_exit() was called */
650 while (PL_scopestack_ix > oldscope)
653 PL_curstash = PL_defstash;
655 call_list(oldscope, PL_endav);
656 return STATUS_NATIVE_EXPORT;
658 PerlIO_printf(PerlIO_stderr(), "panic: top_env\n");
665 parse_body(pTHX_ va_list args)
668 int argc = PL_origargc;
669 char **argv = PL_origargv;
670 char **env = va_arg(args, char**);
671 char *scriptname = NULL;
673 VOL bool dosearch = FALSE;
679 XSINIT_t xsinit = va_arg(args, XSINIT_t);
681 sv_setpvn(PL_linestr,"",0);
682 sv = newSVpvn("",0); /* first used for -I flags */
686 for (argc--,argv++; argc > 0; argc--,argv++) {
687 if (argv[0][0] != '-' || !argv[0][1])
691 validarg = " PHOOEY ";
698 #ifndef PERL_STRICT_CR
722 if (s = moreswitches(s))
732 if (PL_euid != PL_uid || PL_egid != PL_gid)
733 croak("No -e allowed in setuid scripts");
735 PL_e_script = newSVpvn("",0);
736 filter_add(read_e_script, NULL);
739 sv_catpv(PL_e_script, s);
741 sv_catpv(PL_e_script, argv[1]);
745 croak("No code specified for -e");
746 sv_catpv(PL_e_script, "\n");
749 case 'I': /* -I handled both here and in moreswitches() */
751 if (!*++s && (s=argv[1]) != Nullch) {
754 while (s && isSPACE(*s))
758 for (e = s; *e && !isSPACE(*e); e++) ;
765 } /* XXX else croak? */
769 PL_preprocess = TRUE;
779 PL_preambleav = newAV();
780 av_push(PL_preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
782 PL_Sv = newSVpv("print myconfig();",0);
784 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
786 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
788 #if defined(DEBUGGING) || defined(MULTIPLICITY)
789 sv_catpv(PL_Sv,"\" Compile-time options:");
791 sv_catpv(PL_Sv," DEBUGGING");
794 sv_catpv(PL_Sv," MULTIPLICITY");
796 sv_catpv(PL_Sv,"\\n\",");
798 #if defined(LOCAL_PATCH_COUNT)
799 if (LOCAL_PATCH_COUNT > 0) {
801 sv_catpv(PL_Sv,"\" Locally applied patches:\\n\",");
802 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
803 if (PL_localpatches[i])
804 sv_catpvf(PL_Sv,"q\" \t%s\n\",",PL_localpatches[i]);
808 sv_catpvf(PL_Sv,"\" Built under %s\\n\"",OSNAME);
811 sv_catpvf(PL_Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
813 sv_catpvf(PL_Sv,",\" Compiled on %s\\n\"",__DATE__);
818 @env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; \
819 print \" \\%ENV:\\n @env\\n\" if @env; \
820 print \" \\@INC:\\n @INC\\n\";");
823 PL_Sv = newSVpv("config_vars(qw(",0);
824 sv_catpv(PL_Sv, ++s);
825 sv_catpv(PL_Sv, "))");
828 av_push(PL_preambleav, PL_Sv);
829 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
835 PL_cddir = savepv(s);
840 if (!*++s || isSPACE(*s)) {
844 /* catch use of gnu style long options */
845 if (strEQ(s, "version")) {
849 if (strEQ(s, "help")) {
856 croak("Unrecognized switch: -%s (-h will show valid options)",s);
862 #ifndef SECURE_INTERNAL_GETENV
865 (s = PerlEnv_getenv("PERL5OPT"))) {
868 if (*s == '-' && *(s+1) == 'T')
881 if (!strchr("DIMUdmw", *s))
882 croak("Illegal switch in PERL5OPT: -%c", *s);
889 scriptname = argv[0];
892 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
894 else if (scriptname == Nullch) {
896 if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
904 open_script(scriptname,dosearch,sv,&fdscript);
906 validate_suid(validarg, scriptname,fdscript);
911 PL_main_cv = PL_compcv = (CV*)NEWSV(1104,0);
912 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
913 CvUNIQUE_on(PL_compcv);
915 PL_comppad = newAV();
916 av_push(PL_comppad, Nullsv);
917 PL_curpad = AvARRAY(PL_comppad);
918 PL_comppad_name = newAV();
919 PL_comppad_name_fill = 0;
920 PL_min_intro_pending = 0;
923 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
924 PL_curpad[0] = (SV*)newAV();
925 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
926 CvOWNER(PL_compcv) = 0;
927 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
928 MUTEX_INIT(CvMUTEXP(PL_compcv));
929 #endif /* USE_THREADS */
931 comppadlist = newAV();
932 AvREAL_off(comppadlist);
933 av_store(comppadlist, 0, (SV*)PL_comppad_name);
934 av_store(comppadlist, 1, (SV*)PL_comppad);
935 CvPADLIST(PL_compcv) = comppadlist;
937 boot_core_UNIVERSAL();
940 (*xsinit)(PERL_OBJECT_THIS); /* in case linked C routines want magical variables */
941 #if defined(VMS) || defined(WIN32) || defined(DJGPP)
945 init_predump_symbols();
946 /* init_postdump_symbols not currently designed to be called */
947 /* more than once (ENV isn't cleared first, for example) */
948 /* But running with -u leaves %ENV & @ARGV undefined! XXX */
950 init_postdump_symbols(argc,argv,env);
954 /* now parse the script */
956 SETERRNO(0,SS$_NORMAL);
958 if (yyparse() || PL_error_count) {
960 croak("%s had compilation errors.\n", PL_origfilename);
962 croak("Execution of %s aborted due to compilation errors.\n",
966 PL_curcop->cop_line = 0;
967 PL_curstash = PL_defstash;
968 PL_preprocess = FALSE;
970 SvREFCNT_dec(PL_e_script);
971 PL_e_script = Nullsv;
974 /* now that script is parsed, we can modify record separator */
976 PL_rs = SvREFCNT_inc(PL_nrs);
977 sv_setsv(get_sv("/", TRUE), PL_rs);
981 if (ckWARN(WARN_ONCE))
982 gv_check(PL_defstash);
988 if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
989 dump_mstats("after compilation:");
998 perl_run(PerlInterpreter *sv_interp)
1005 if (!(PL_curinterp = sv_interp))
1009 oldscope = PL_scopestack_ix;
1012 CALLPROTECT(&ret, FUNC_NAME_TO_PTR(run_body), oldscope);
1015 cxstack_ix = -1; /* start context stack again */
1017 case 0: /* normal completion */
1018 case 2: /* my_exit() */
1019 while (PL_scopestack_ix > oldscope)
1022 PL_curstash = PL_defstash;
1024 call_list(oldscope, PL_endav);
1026 if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
1027 dump_mstats("after execution: ");
1029 return STATUS_NATIVE_EXPORT;
1032 POPSTACK_TO(PL_mainstack);
1035 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
1045 run_body(pTHX_ va_list args)
1048 I32 oldscope = va_arg(args, I32);
1050 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
1051 PL_sawampersand ? "Enabling" : "Omitting"));
1053 if (!PL_restartop) {
1054 DEBUG_x(dump_all());
1055 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
1056 DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%lx\n",
1057 (unsigned long) thr));
1060 PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", PL_origfilename);
1063 if (PERLDB_SINGLE && PL_DBsingle)
1064 sv_setiv(PL_DBsingle, 1);
1066 call_list(oldscope, PL_initav);
1072 PL_op = PL_restartop;
1076 else if (PL_main_start) {
1077 CvDEPTH(PL_main_cv) = 1;
1078 PL_op = PL_main_start;
1086 Perl_get_sv(pTHX_ const char *name, I32 create)
1090 if (name[1] == '\0' && !isALPHA(name[0])) {
1091 PADOFFSET tmp = find_threadsv(name);
1092 if (tmp != NOT_IN_PAD) {
1094 return THREADSV(tmp);
1097 #endif /* USE_THREADS */
1098 gv = gv_fetchpv(name, create, SVt_PV);
1105 Perl_get_av(pTHX_ const char *name, I32 create)
1107 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1116 Perl_get_hv(pTHX_ const char *name, I32 create)
1118 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1127 Perl_get_cv(pTHX_ const char *name, I32 create)
1129 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
1130 /* XXX unsafe for threads if eval_owner isn't held */
1131 /* XXX this is probably not what they think they're getting.
1132 * It has the same effect as "sub name;", i.e. just a forward
1134 if (create && !GvCVu(gv))
1135 return newSUB(start_subparse(FALSE, 0),
1136 newSVOP(OP_CONST, 0, newSVpv(name,0)),
1144 /* Be sure to refetch the stack pointer after calling these routines. */
1147 Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv)
1149 /* See G_* flags in cop.h */
1150 /* null terminated arg list */
1157 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
1162 return call_pv(sub_name, flags);
1166 Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
1167 /* name of the subroutine */
1168 /* See G_* flags in cop.h */
1170 return call_sv((SV*)get_cv(sub_name, TRUE), flags);
1174 Perl_call_method(pTHX_ const char *methname, I32 flags)
1175 /* name of the subroutine */
1176 /* See G_* flags in cop.h */
1182 XPUSHs(sv_2mortal(newSVpv(methname,0)));
1187 return call_sv(*PL_stack_sp--, flags);
1190 /* May be called with any of a CV, a GV, or an SV containing the name. */
1192 Perl_call_sv(pTHX_ SV *sv, I32 flags)
1194 /* See G_* flags in cop.h */
1197 LOGOP myop; /* fake syntax tree node */
1201 bool oldcatch = CATCH_GET;
1205 if (flags & G_DISCARD) {
1210 Zero(&myop, 1, LOGOP);
1211 myop.op_next = Nullop;
1212 if (!(flags & G_NOARGS))
1213 myop.op_flags |= OPf_STACKED;
1214 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1215 (flags & G_ARRAY) ? OPf_WANT_LIST :
1220 EXTEND(PL_stack_sp, 1);
1221 *++PL_stack_sp = sv;
1223 oldscope = PL_scopestack_ix;
1225 if (PERLDB_SUB && PL_curstash != PL_debstash
1226 /* Handle first BEGIN of -d. */
1227 && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
1228 /* Try harder, since this may have been a sighandler, thus
1229 * curstash may be meaningless. */
1230 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != PL_debstash)
1231 && !(flags & G_NODEBUG))
1232 PL_op->op_private |= OPpENTERSUB_DB;
1234 if (!(flags & G_EVAL)) {
1236 call_xbody((OP*)&myop, FALSE);
1237 retval = PL_stack_sp - (PL_stack_base + oldmark);
1241 cLOGOP->op_other = PL_op;
1243 /* we're trying to emulate pp_entertry() here */
1245 register PERL_CONTEXT *cx;
1246 I32 gimme = GIMME_V;
1251 push_return(PL_op->op_next);
1252 PUSHBLOCK(cx, CXt_EVAL, PL_stack_sp);
1254 PL_eval_root = PL_op; /* Only needed so that goto works right. */
1256 PL_in_eval = EVAL_INEVAL;
1257 if (flags & G_KEEPERR)
1258 PL_in_eval |= EVAL_KEEPERR;
1265 CALLPROTECT(&ret, FUNC_NAME_TO_PTR(call_body), (OP*)&myop, FALSE);
1268 retval = PL_stack_sp - (PL_stack_base + oldmark);
1269 if (!(flags & G_KEEPERR))
1276 /* my_exit() was called */
1277 PL_curstash = PL_defstash;
1280 croak("Callback called exit");
1285 PL_op = PL_restartop;
1289 PL_stack_sp = PL_stack_base + oldmark;
1290 if (flags & G_ARRAY)
1294 *++PL_stack_sp = &PL_sv_undef;
1299 if (PL_scopestack_ix > oldscope) {
1303 register PERL_CONTEXT *cx;
1314 if (flags & G_DISCARD) {
1315 PL_stack_sp = PL_stack_base + oldmark;
1325 call_body(pTHX_ va_list args)
1327 OP *myop = va_arg(args, OP*);
1328 int is_eval = va_arg(args, int);
1330 call_xbody(myop, is_eval);
1335 call_xbody(pTHX_ OP *myop, int is_eval)
1339 if (PL_op == myop) {
1341 PL_op = pp_entereval(ARGS);
1343 PL_op = pp_entersub(ARGS);
1349 /* Eval a string. The G_EVAL flag is always assumed. */
1352 Perl_eval_sv(pTHX_ SV *sv, I32 flags)
1354 /* See G_* flags in cop.h */
1357 UNOP myop; /* fake syntax tree node */
1358 I32 oldmark = SP - PL_stack_base;
1364 if (flags & G_DISCARD) {
1371 Zero(PL_op, 1, UNOP);
1372 EXTEND(PL_stack_sp, 1);
1373 *++PL_stack_sp = sv;
1374 oldscope = PL_scopestack_ix;
1376 if (!(flags & G_NOARGS))
1377 myop.op_flags = OPf_STACKED;
1378 myop.op_next = Nullop;
1379 myop.op_type = OP_ENTEREVAL;
1380 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1381 (flags & G_ARRAY) ? OPf_WANT_LIST :
1383 if (flags & G_KEEPERR)
1384 myop.op_flags |= OPf_SPECIAL;
1387 CALLPROTECT(&ret, FUNC_NAME_TO_PTR(call_body), (OP*)&myop, TRUE);
1390 retval = PL_stack_sp - (PL_stack_base + oldmark);
1391 if (!(flags & G_KEEPERR))
1398 /* my_exit() was called */
1399 PL_curstash = PL_defstash;
1402 croak("Callback called exit");
1407 PL_op = PL_restartop;
1411 PL_stack_sp = PL_stack_base + oldmark;
1412 if (flags & G_ARRAY)
1416 *++PL_stack_sp = &PL_sv_undef;
1421 if (flags & G_DISCARD) {
1422 PL_stack_sp = PL_stack_base + oldmark;
1432 Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
1435 SV* sv = newSVpv(p, 0);
1438 eval_sv(sv, G_SCALAR);
1445 if (croak_on_error && SvTRUE(ERRSV)) {
1447 croak(SvPVx(ERRSV, n_a));
1453 /* Require a module. */
1456 Perl_require_pv(pTHX_ const char *pv)
1460 PUSHSTACKi(PERLSI_REQUIRE);
1462 sv = sv_newmortal();
1463 sv_setpv(sv, "require '");
1466 eval_sv(sv, G_DISCARD);
1472 Perl_magicname(pTHX_ char *sym, char *name, I32 namlen)
1476 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1477 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1481 usage(pTHX_ char *name) /* XXX move this out into a module ? */
1483 /* This message really ought to be max 23 lines.
1484 * Removed -h because the user already knows that opton. Others? */
1486 static char *usage_msg[] = {
1487 "-0[octal] specify record separator (\\0, if no argument)",
1488 "-a autosplit mode with -n or -p (splits $_ into @F)",
1489 "-c check syntax only (runs BEGIN and END blocks)",
1490 "-d[:debugger] run program under debugger",
1491 "-D[number/list] set debugging flags (argument is a bit mask or alphabets)",
1492 "-e 'command' one line of program (several -e's allowed, omit programfile)",
1493 "-F/pattern/ split() pattern for -a switch (//'s are optional)",
1494 "-i[extension] edit <> files in place (makes backup if extension supplied)",
1495 "-Idirectory specify @INC/#include directory (several -I's allowed)",
1496 "-l[octal] enable line ending processing, specifies line terminator",
1497 "-[mM][-]module execute `use/no module...' before executing program",
1498 "-n assume 'while (<>) { ... }' loop around program",
1499 "-p assume loop like -n but print line also, like sed",
1500 "-P run program through C preprocessor before compilation",
1501 "-s enable rudimentary parsing for switches after programfile",
1502 "-S look for programfile using PATH environment variable",
1503 "-T enable tainting checks",
1504 "-u dump core after parsing program",
1505 "-U allow unsafe operations",
1506 "-v print version, subversion (includes VERY IMPORTANT perl info)",
1507 "-V[:variable] print configuration summary (or a single Config.pm variable)",
1508 "-w enable many useful warnings (RECOMMENDED)",
1509 "-x[directory] strip off text before #!perl line and perhaps cd to directory",
1513 char **p = usage_msg;
1515 printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1517 printf("\n %s", *p++);
1520 /* This routine handles any switches that can be given during run */
1523 Perl_moreswitches(pTHX_ char *s)
1532 rschar = scan_oct(s, 4, &numlen);
1533 SvREFCNT_dec(PL_nrs);
1534 if (rschar & ~((U8)~0))
1535 PL_nrs = &PL_sv_undef;
1536 else if (!rschar && numlen >= 2)
1537 PL_nrs = newSVpvn("", 0);
1540 PL_nrs = newSVpvn(&ch, 1);
1546 PL_splitstr = savepv(s + 1);
1560 if (*s == ':' || *s == '=') {
1561 my_setenv("PERL5DB", form("use Devel::%s;", ++s));
1565 PL_perldb = PERLDB_ALL;
1572 if (isALPHA(s[1])) {
1573 static char debopts[] = "psltocPmfrxuLHXDS";
1576 for (s++; *s && (d = strchr(debopts,*s)); s++)
1577 PL_debug |= 1 << (d - debopts);
1580 PL_debug = atoi(s+1);
1581 for (s++; isDIGIT(*s); s++) ;
1583 PL_debug |= 0x80000000;
1585 warn("Recompile perl with -DDEBUGGING to use -D switch\n");
1586 for (s++; isALNUM(*s); s++) ;
1591 usage(PL_origargv[0]);
1595 Safefree(PL_inplace);
1596 PL_inplace = savepv(s+1);
1598 for (s = PL_inplace; *s && !isSPACE(*s); s++) ;
1601 if (*s == '-') /* Additional switches on #! line. */
1605 case 'I': /* -I handled both here and in parse_perl() */
1608 while (*s && isSPACE(*s))
1612 for (e = s; *e && !isSPACE(*e); e++) ;
1613 p = savepvn(s, e-s);
1619 croak("No space allowed after -I");
1627 PL_ors = savepv("\n");
1629 *PL_ors = scan_oct(s, 3 + (*s == '0'), &numlen);
1634 if (RsPARA(PL_nrs)) {
1639 PL_ors = SvPV(PL_nrs, PL_orslen);
1640 PL_ors = savepvn(PL_ors, PL_orslen);
1644 forbid_setid("-M"); /* XXX ? */
1647 forbid_setid("-m"); /* XXX ? */
1652 /* -M-foo == 'no foo' */
1653 if (*s == '-') { use = "no "; ++s; }
1654 sv = newSVpv(use,0);
1656 /* We allow -M'Module qw(Foo Bar)' */
1657 while(isALNUM(*s) || *s==':') ++s;
1659 sv_catpv(sv, start);
1660 if (*(start-1) == 'm') {
1662 croak("Can't use '%c' after -mname", *s);
1663 sv_catpv( sv, " ()");
1666 sv_catpvn(sv, start, s-start);
1667 sv_catpv(sv, " split(/,/,q{");
1672 if (PL_preambleav == NULL)
1673 PL_preambleav = newAV();
1674 av_push(PL_preambleav, sv);
1677 croak("No space allowed after -%c", *(s-1));
1689 PL_doswitches = TRUE;
1694 croak("Too late for \"-T\" option");
1698 PL_do_undump = TRUE;
1706 #if defined(PERL_SUBVERSION) && PERL_SUBVERSION > 0
1707 printf("\nThis is perl, version %d.%03d_%02d built for %s",
1708 PERL_REVISION, PERL_VERSION, PERL_SUBVERSION, ARCHNAME);
1710 printf("\nThis is perl, version %s built for %s",
1711 PL_patchlevel, ARCHNAME);
1713 #if defined(LOCAL_PATCH_COUNT)
1714 if (LOCAL_PATCH_COUNT > 0)
1715 printf("\n(with %d registered patch%s, see perl -V for more detail)",
1716 LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : "");
1719 printf("\n\nCopyright 1987-1999, Larry Wall\n");
1721 printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1724 printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
1725 printf("djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
1728 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1729 "Version 5 port Copyright (c) 1994-1999, Andreas Kaiser, Ilya Zakharevich\n");
1732 printf("atariST series port, ++jrb bammi@cadence.com\n");
1735 printf("BeOS port Copyright Tom Spindler, 1997-1999\n");
1738 printf("MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-1999\n");
1741 printf("MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
1744 printf("Stratus VOS port by Paul_Green@stratus.com, 1997-1999\n");
1747 printf("VM/ESA port by Neale Ferguson, 1998-1999\n");
1750 printf("BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
1753 printf("MiNT port by Guido Flohr, 1997-1999\n");
1755 #ifdef BINARY_BUILD_NOTICE
1756 BINARY_BUILD_NOTICE;
1759 Perl may be copied only under the terms of either the Artistic License or the\n\
1760 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n\
1761 Complete documentation for Perl, including FAQ lists, should be found on\n\
1762 this system using `man perl' or `perldoc perl'. If you have access to the\n\
1763 Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
1766 if (! (PL_dowarn & G_WARN_ALL_MASK))
1767 PL_dowarn |= G_WARN_ON;
1771 PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
1772 PL_compiling.cop_warnings = WARN_ALL ;
1776 PL_dowarn = G_WARN_ALL_OFF;
1777 PL_compiling.cop_warnings = WARN_NONE ;
1782 if (s[1] == '-') /* Additional switches on #! line. */
1787 #if defined(WIN32) || !defined(PERL_STRICT_CR)
1793 #ifdef ALTERNATE_SHEBANG
1794 case 'S': /* OS/2 needs -S on "extproc" line. */
1802 croak("Can't emulate -%.1s on #! line",s);
1807 /* compliments of Tom Christiansen */
1809 /* unexec() can be found in the Gnu emacs distribution */
1810 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
1813 Perl_my_unexec(pTHX)
1821 prog = newSVpv(BIN_EXP, 0);
1822 sv_catpv(prog, "/perl");
1823 file = newSVpv(PL_origfilename, 0);
1824 sv_catpv(file, ".perldump");
1826 unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
1827 /* unexec prints msg to stderr in case of failure */
1828 PerlProc_exit(status);
1831 # include <lib$routines.h>
1832 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
1834 ABORT(); /* for use with undump */
1839 /* initialize curinterp */
1844 #ifdef PERL_OBJECT /* XXX kludge */
1847 PL_chopset = " \n-"; \
1848 PL_copline = NOLINE; \
1849 PL_curcop = &PL_compiling;\
1850 PL_curcopdb = NULL; \
1853 PL_dumpindent = 4; \
1854 PL_laststatval = -1; \
1855 PL_laststype = OP_STAT; \
1856 PL_maxscream = -1; \
1857 PL_maxsysfd = MAXSYSFD; \
1858 PL_statname = Nullsv; \
1859 PL_tmps_floor = -1; \
1861 PL_op_mask = NULL; \
1863 PL_laststatval = -1; \
1864 PL_laststype = OP_STAT; \
1865 PL_mess_sv = Nullsv; \
1866 PL_splitstr = " "; \
1867 PL_generation = 100; \
1868 PL_exitlist = NULL; \
1869 PL_exitlistlen = 0; \
1871 PL_in_clean_objs = FALSE; \
1872 PL_in_clean_all = FALSE; \
1873 PL_profiledata = NULL; \
1875 PL_rsfp_filters = Nullav; \
1880 # ifdef MULTIPLICITY
1881 # define PERLVAR(var,type)
1882 # define PERLVARI(var,type,init) PL_curinterp->var = init;
1883 # define PERLVARIC(var,type,init) PL_curinterp->var = init;
1884 # include "intrpvar.h"
1885 # ifndef USE_THREADS
1886 # include "thrdvar.h"
1892 # define PERLVAR(var,type)
1893 # define PERLVARI(var,type,init) PL_##var = init;
1894 # define PERLVARIC(var,type,init) PL_##var = init;
1895 # include "intrpvar.h"
1896 # ifndef USE_THREADS
1897 # include "thrdvar.h"
1908 init_main_stash(pTHX)
1913 /* Note that strtab is a rather special HV. Assumptions are made
1914 about not iterating on it, and not adding tie magic to it.
1915 It is properly deallocated in perl_destruct() */
1916 PL_strtab = newHV();
1918 MUTEX_INIT(&PL_strtab_mutex);
1920 HvSHAREKEYS_off(PL_strtab); /* mandatory */
1921 hv_ksplit(PL_strtab, 512);
1923 PL_curstash = PL_defstash = newHV();
1924 PL_curstname = newSVpvn("main",4);
1925 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1926 SvREFCNT_dec(GvHV(gv));
1927 GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
1929 HvNAME(PL_defstash) = savepv("main");
1930 PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1931 GvMULTI_on(PL_incgv);
1932 PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
1933 GvMULTI_on(PL_hintgv);
1934 PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1935 PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1936 GvMULTI_on(PL_errgv);
1937 PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
1938 GvMULTI_on(PL_replgv);
1939 (void)form("%240s",""); /* Preallocate temp - for immediate signals. */
1940 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
1941 sv_setpvn(ERRSV, "", 0);
1942 PL_curstash = PL_defstash;
1943 PL_compiling.cop_stash = PL_defstash;
1944 PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
1945 PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
1946 /* We must init $/ before switches are processed. */
1947 sv_setpvn(get_sv("/", TRUE), "\n", 1);
1951 open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
1959 PL_origfilename = savepv("-e");
1962 /* if find_script() returns, it returns a malloc()-ed value */
1963 PL_origfilename = scriptname = find_script(scriptname, dosearch, NULL, 1);
1965 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
1966 char *s = scriptname + 8;
1967 *fdscript = atoi(s);
1971 scriptname = savepv(s + 1);
1972 Safefree(PL_origfilename);
1973 PL_origfilename = scriptname;
1978 PL_curcop->cop_filegv = gv_fetchfile(PL_origfilename);
1979 if (strEQ(PL_origfilename,"-"))
1981 if (*fdscript >= 0) {
1982 PL_rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE);
1983 #if defined(HAS_FCNTL) && defined(F_SETFD)
1985 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); /* ensure close-on-exec */
1988 else if (PL_preprocess) {
1989 char *cpp_cfg = CPPSTDIN;
1990 SV *cpp = newSVpvn("",0);
1991 SV *cmd = NEWSV(0,0);
1993 if (strEQ(cpp_cfg, "cppstdin"))
1994 sv_catpvf(cpp, "%s/", BIN_EXP);
1995 sv_catpv(cpp, cpp_cfg);
1998 sv_catpv(sv,PRIVLIB_EXP);
2002 sed %s -e \"/^[^#]/b\" \
2003 -e \"/^#[ ]*include[ ]/b\" \
2004 -e \"/^#[ ]*define[ ]/b\" \
2005 -e \"/^#[ ]*if[ ]/b\" \
2006 -e \"/^#[ ]*ifdef[ ]/b\" \
2007 -e \"/^#[ ]*ifndef[ ]/b\" \
2008 -e \"/^#[ ]*else/b\" \
2009 -e \"/^#[ ]*elif[ ]/b\" \
2010 -e \"/^#[ ]*undef[ ]/b\" \
2011 -e \"/^#[ ]*endif/b\" \
2014 (PL_doextract ? "-e \"1,/^#/d\n\"" : ""),
2018 %s %s -e '/^[^#]/b' \
2019 -e '/^#[ ]*include[ ]/b' \
2020 -e '/^#[ ]*define[ ]/b' \
2021 -e '/^#[ ]*if[ ]/b' \
2022 -e '/^#[ ]*ifdef[ ]/b' \
2023 -e '/^#[ ]*ifndef[ ]/b' \
2024 -e '/^#[ ]*else/b' \
2025 -e '/^#[ ]*elif[ ]/b' \
2026 -e '/^#[ ]*undef[ ]/b' \
2027 -e '/^#[ ]*endif/b' \
2032 %s %s -e '/^[^#]/b' \
2033 -e '/^#[ ]*include[ ]/b' \
2034 -e '/^#[ ]*define[ ]/b' \
2035 -e '/^#[ ]*if[ ]/b' \
2036 -e '/^#[ ]*ifdef[ ]/b' \
2037 -e '/^#[ ]*ifndef[ ]/b' \
2038 -e '/^#[ ]*else/b' \
2039 -e '/^#[ ]*elif[ ]/b' \
2040 -e '/^#[ ]*undef[ ]/b' \
2041 -e '/^#[ ]*endif/b' \
2050 (PL_doextract ? "-e '1,/^#/d\n'" : ""),
2052 scriptname, cpp, sv, CPPMINUS);
2053 PL_doextract = FALSE;
2054 #ifdef IAMSUID /* actually, this is caught earlier */
2055 if (PL_euid != PL_uid && !PL_euid) { /* if running suidperl */
2057 (void)seteuid(PL_uid); /* musn't stay setuid root */
2060 (void)setreuid((Uid_t)-1, PL_uid);
2062 #ifdef HAS_SETRESUID
2063 (void)setresuid((Uid_t)-1, PL_uid, (Uid_t)-1);
2065 PerlProc_setuid(PL_uid);
2069 if (PerlProc_geteuid() != PL_uid)
2070 croak("Can't do seteuid!\n");
2072 #endif /* IAMSUID */
2073 PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
2077 else if (!*scriptname) {
2078 forbid_setid("program input from stdin");
2079 PL_rsfp = PerlIO_stdin();
2082 PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
2083 #if defined(HAS_FCNTL) && defined(F_SETFD)
2085 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); /* ensure close-on-exec */
2090 #ifndef IAMSUID /* in case script is not readable before setuid */
2092 PerlLIO_stat(SvPVX(GvSV(PL_curcop->cop_filegv)),&PL_statbuf) >= 0 &&
2093 PL_statbuf.st_mode & (S_ISUID|S_ISGID))
2096 PerlProc_execv(form("%s/sperl%s", BIN_EXP, PL_patchlevel), PL_origargv);
2097 croak("Can't do setuid\n");
2101 croak("Can't open perl script \"%s\": %s\n",
2102 SvPVX(GvSV(PL_curcop->cop_filegv)), Strerror(errno));
2107 * I_SYSSTATVFS HAS_FSTATVFS
2109 * I_STATFS HAS_FSTATFS
2110 * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT
2111 * here so that metaconfig picks them up. */
2115 fd_on_nosuid_fs(pTHX_ int fd)
2120 * Preferred order: fstatvfs(), fstatfs(), getmntent().
2121 * fstatvfs() is UNIX98.
2123 * getmntent() is O(number-of-mounted-filesystems) and can hang.
2126 # ifdef HAS_FSTATVFS
2127 struct statvfs stfs;
2128 check_okay = fstatvfs(fd, &stfs) == 0;
2129 on_nosuid = check_okay && (stfs.f_flag & ST_NOSUID);
2131 # if defined(HAS_FSTATFS) && defined(HAS_STRUCT_STATFS_FLAGS)
2133 check_okay = fstatfs(fd, &stfs) == 0;
2134 # undef PERL_MOUNT_NOSUID
2135 # if !defined(PERL_MOUNT_NOSUID) && defined(MNT_NOSUID)
2136 # define PERL_MOUNT_NOSUID MNT_NOSUID
2138 # if !defined(PERL_MOUNT_NOSUID) && defined(MS_NOSUID)
2139 # define PERL_MOUNT_NOSUID MS_NOSUID
2141 # if !defined(PERL_MOUNT_NOSUID) && defined(M_NOSUID)
2142 # define PERL_MOUNT_NOSUID M_NOSUID
2144 # ifdef PERL_MOUNT_NOSUID
2145 on_nosuid = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
2148 # if defined(HAS_GETMNTENT) && defined(HAS_HASMNTOPT) && defined(MNTOPT_NOSUID)
2149 FILE *mtab = fopen("/etc/mtab", "r");
2150 struct mntent *entry;
2151 struct stat stb, fsb;
2153 if (mtab && (fstat(fd, &stb) == 0)) {
2154 while (entry = getmntent(mtab)) {
2155 if (stat(entry->mnt_dir, &fsb) == 0
2156 && fsb.st_dev == stb.st_dev)
2158 /* found the filesystem */
2160 if (hasmntopt(entry, MNTOPT_NOSUID))
2163 } /* A single fs may well fail its stat(). */
2168 # endif /* mntent */
2169 # endif /* statfs */
2170 # endif /* statvfs */
2172 croak("Can't check filesystem of script \"%s\"", PL_origfilename);
2175 #endif /* IAMSUID */
2178 validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript)
2182 /* do we need to emulate setuid on scripts? */
2184 /* This code is for those BSD systems that have setuid #! scripts disabled
2185 * in the kernel because of a security problem. Merely defining DOSUID
2186 * in perl will not fix that problem, but if you have disabled setuid
2187 * scripts in the kernel, this will attempt to emulate setuid and setgid
2188 * on scripts that have those now-otherwise-useless bits set. The setuid
2189 * root version must be called suidperl or sperlN.NNN. If regular perl
2190 * discovers that it has opened a setuid script, it calls suidperl with
2191 * the same argv that it had. If suidperl finds that the script it has
2192 * just opened is NOT setuid root, it sets the effective uid back to the
2193 * uid. We don't just make perl setuid root because that loses the
2194 * effective uid we had before invoking perl, if it was different from the
2197 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
2198 * be defined in suidperl only. suidperl must be setuid root. The
2199 * Configure script will set this up for you if you want it.
2206 if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */
2207 croak("Can't stat script \"%s\"",PL_origfilename);
2208 if (fdscript < 0 && PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
2213 #ifndef HAS_SETREUID
2214 /* On this access check to make sure the directories are readable,
2215 * there is actually a small window that the user could use to make
2216 * filename point to an accessible directory. So there is a faint
2217 * chance that someone could execute a setuid script down in a
2218 * non-accessible directory. I don't know what to do about that.
2219 * But I don't think it's too important. The manual lies when
2220 * it says access() is useful in setuid programs.
2222 if (PerlLIO_access(SvPVX(GvSV(PL_curcop->cop_filegv)),1)) /*double check*/
2223 croak("Permission denied");
2225 /* If we can swap euid and uid, then we can determine access rights
2226 * with a simple stat of the file, and then compare device and
2227 * inode to make sure we did stat() on the same file we opened.
2228 * Then we just have to make sure he or she can execute it.
2231 struct stat tmpstatbuf;
2235 setreuid(PL_euid,PL_uid) < 0
2238 setresuid(PL_euid,PL_uid,(Uid_t)-1) < 0
2241 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
2242 croak("Can't swap uid and euid"); /* really paranoid */
2243 if (PerlLIO_stat(SvPVX(GvSV(PL_curcop->cop_filegv)),&tmpstatbuf) < 0)
2244 croak("Permission denied"); /* testing full pathname here */
2245 #if defined(IAMSUID) && !defined(NO_NOSUID_CHECK)
2246 if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp)))
2247 croak("Permission denied");
2249 if (tmpstatbuf.st_dev != PL_statbuf.st_dev ||
2250 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
2251 (void)PerlIO_close(PL_rsfp);
2252 if (PL_rsfp = PerlProc_popen("/bin/mail root","w")) { /* heh, heh */
2253 PerlIO_printf(PL_rsfp,
2254 "User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2255 (Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
2256 (long)PL_uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
2257 (long)PL_statbuf.st_dev, (long)PL_statbuf.st_ino,
2258 SvPVX(GvSV(PL_curcop->cop_filegv)),
2259 (long)PL_statbuf.st_uid, (long)PL_statbuf.st_gid);
2260 (void)PerlProc_pclose(PL_rsfp);
2262 croak("Permission denied\n");
2266 setreuid(PL_uid,PL_euid) < 0
2268 # if defined(HAS_SETRESUID)
2269 setresuid(PL_uid,PL_euid,(Uid_t)-1) < 0
2272 || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
2273 croak("Can't reswap uid and euid");
2274 if (!cando(S_IXUSR,FALSE,&PL_statbuf)) /* can real uid exec? */
2275 croak("Permission denied\n");
2277 #endif /* HAS_SETREUID */
2278 #endif /* IAMSUID */
2280 if (!S_ISREG(PL_statbuf.st_mode))
2281 croak("Permission denied");
2282 if (PL_statbuf.st_mode & S_IWOTH)
2283 croak("Setuid/gid script is writable by world");
2284 PL_doswitches = FALSE; /* -s is insecure in suid */
2285 PL_curcop->cop_line++;
2286 if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
2287 strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */
2288 croak("No #! line");
2289 s = SvPV(PL_linestr,n_a)+2;
2291 while (!isSPACE(*s)) s++;
2292 for (s2 = s; (s2 > SvPV(PL_linestr,n_a)+2 &&
2293 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
2294 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
2295 croak("Not a perl script");
2296 while (*s == ' ' || *s == '\t') s++;
2298 * #! arg must be what we saw above. They can invoke it by
2299 * mentioning suidperl explicitly, but they may not add any strange
2300 * arguments beyond what #! says if they do invoke suidperl that way.
2302 len = strlen(validarg);
2303 if (strEQ(validarg," PHOOEY ") ||
2304 strnNE(s,validarg,len) || !isSPACE(s[len]))
2305 croak("Args must match #! line");
2308 if (PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
2309 PL_euid == PL_statbuf.st_uid)
2311 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2312 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2313 #endif /* IAMSUID */
2315 if (PL_euid) { /* oops, we're not the setuid root perl */
2316 (void)PerlIO_close(PL_rsfp);
2319 PerlProc_execv(form("%s/sperl%s", BIN_EXP, PL_patchlevel), PL_origargv);
2321 croak("Can't do setuid\n");
2324 if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
2326 (void)setegid(PL_statbuf.st_gid);
2329 (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
2331 #ifdef HAS_SETRESGID
2332 (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
2334 PerlProc_setgid(PL_statbuf.st_gid);
2338 if (PerlProc_getegid() != PL_statbuf.st_gid)
2339 croak("Can't do setegid!\n");
2341 if (PL_statbuf.st_mode & S_ISUID) {
2342 if (PL_statbuf.st_uid != PL_euid)
2344 (void)seteuid(PL_statbuf.st_uid); /* all that for this */
2347 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
2349 #ifdef HAS_SETRESUID
2350 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
2352 PerlProc_setuid(PL_statbuf.st_uid);
2356 if (PerlProc_geteuid() != PL_statbuf.st_uid)
2357 croak("Can't do seteuid!\n");
2359 else if (PL_uid) { /* oops, mustn't run as root */
2361 (void)seteuid((Uid_t)PL_uid);
2364 (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
2366 #ifdef HAS_SETRESUID
2367 (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
2369 PerlProc_setuid((Uid_t)PL_uid);
2373 if (PerlProc_geteuid() != PL_uid)
2374 croak("Can't do seteuid!\n");
2377 if (!cando(S_IXUSR,TRUE,&PL_statbuf))
2378 croak("Permission denied\n"); /* they can't do this */
2381 else if (PL_preprocess)
2382 croak("-P not allowed for setuid/setgid script\n");
2383 else if (fdscript >= 0)
2384 croak("fd script not allowed in suidperl\n");
2386 croak("Script is not setuid/setgid in suidperl\n");
2388 /* We absolutely must clear out any saved ids here, so we */
2389 /* exec the real perl, substituting fd script for scriptname. */
2390 /* (We pass script name as "subdir" of fd, which perl will grok.) */
2391 PerlIO_rewind(PL_rsfp);
2392 PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0); /* just in case rewind didn't */
2393 for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
2394 if (!PL_origargv[which])
2395 croak("Permission denied");
2396 PL_origargv[which] = savepv(form("/dev/fd/%d/%s",
2397 PerlIO_fileno(PL_rsfp), PL_origargv[which]));
2398 #if defined(HAS_FCNTL) && defined(F_SETFD)
2399 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */
2401 PerlProc_execv(form("%s/perl%s", BIN_EXP, PL_patchlevel), PL_origargv);/* try again */
2402 croak("Can't do setuid\n");
2403 #endif /* IAMSUID */
2405 if (PL_euid != PL_uid || PL_egid != PL_gid) { /* (suidperl doesn't exist, in fact) */
2406 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2408 PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf); /* may be either wrapped or real suid */
2409 if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
2411 (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
2414 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2415 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2416 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2417 /* not set-id, must be wrapped */
2423 find_beginning(pTHX)
2425 register char *s, *s2;
2427 /* skip forward in input to the real script? */
2430 while (PL_doextract) {
2431 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
2432 croak("No Perl script found in input\n");
2433 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2434 PerlIO_ungetc(PL_rsfp, '\n'); /* to keep line count right */
2435 PL_doextract = FALSE;
2436 while (*s && !(isSPACE (*s) || *s == '#')) s++;
2438 while (*s == ' ' || *s == '\t') s++;
2440 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2441 if (strnEQ(s2-4,"perl",4))
2443 while (s = moreswitches(s)) ;
2445 if (PL_cddir && PerlDir_chdir(PL_cddir) < 0)
2446 croak("Can't chdir to %s",PL_cddir);
2455 PL_uid = (int)PerlProc_getuid();
2456 PL_euid = (int)PerlProc_geteuid();
2457 PL_gid = (int)PerlProc_getgid();
2458 PL_egid = (int)PerlProc_getegid();
2460 PL_uid |= PL_gid << 16;
2461 PL_euid |= PL_egid << 16;
2463 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2467 forbid_setid(pTHX_ char *s)
2469 if (PL_euid != PL_uid)
2470 croak("No %s allowed while running setuid", s);
2471 if (PL_egid != PL_gid)
2472 croak("No %s allowed while running setgid", s);
2479 PL_curstash = PL_debstash;
2480 PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2481 AvREAL_off(PL_dbargs);
2482 PL_DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2483 PL_DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2484 PL_DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2485 PL_DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2486 sv_setiv(PL_DBsingle, 0);
2487 PL_DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2488 sv_setiv(PL_DBtrace, 0);
2489 PL_DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2490 sv_setiv(PL_DBsignal, 0);
2491 PL_curstash = PL_defstash;
2494 #ifndef STRESS_REALLOC
2495 #define REASONABLE(size) (size)
2497 #define REASONABLE(size) (1) /* unreasonable */
2501 Perl_init_stacks(pTHX_ ARGSproto)
2503 /* start with 128-item stack and 8K cxstack */
2504 PL_curstackinfo = new_stackinfo(REASONABLE(128),
2505 REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
2506 PL_curstackinfo->si_type = PERLSI_MAIN;
2507 PL_curstack = PL_curstackinfo->si_stack;
2508 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
2510 PL_stack_base = AvARRAY(PL_curstack);
2511 PL_stack_sp = PL_stack_base;
2512 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
2514 New(50,PL_tmps_stack,REASONABLE(128),SV*);
2517 PL_tmps_max = REASONABLE(128);
2519 New(54,PL_markstack,REASONABLE(32),I32);
2520 PL_markstack_ptr = PL_markstack;
2521 PL_markstack_max = PL_markstack + REASONABLE(32);
2525 New(54,PL_scopestack,REASONABLE(32),I32);
2526 PL_scopestack_ix = 0;
2527 PL_scopestack_max = REASONABLE(32);
2529 New(54,PL_savestack,REASONABLE(128),ANY);
2530 PL_savestack_ix = 0;
2531 PL_savestack_max = REASONABLE(128);
2533 New(54,PL_retstack,REASONABLE(16),OP*);
2535 PL_retstack_max = REASONABLE(16);
2544 while (PL_curstackinfo->si_next)
2545 PL_curstackinfo = PL_curstackinfo->si_next;
2546 while (PL_curstackinfo) {
2547 PERL_SI *p = PL_curstackinfo->si_prev;
2548 /* curstackinfo->si_stack got nuked by sv_free_arenas() */
2549 Safefree(PL_curstackinfo->si_cxstack);
2550 Safefree(PL_curstackinfo);
2551 PL_curstackinfo = p;
2553 Safefree(PL_tmps_stack);
2554 Safefree(PL_markstack);
2555 Safefree(PL_scopestack);
2556 Safefree(PL_savestack);
2557 Safefree(PL_retstack);
2559 Safefree(PL_debname);
2560 Safefree(PL_debdelim);
2565 static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
2576 lex_start(PL_linestr);
2578 PL_subname = newSVpvn("main",4);
2582 init_predump_symbols(pTHX)
2588 sv_setpvn(get_sv("\"", TRUE), " ", 1);
2589 PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2590 GvMULTI_on(PL_stdingv);
2591 IoIFP(GvIOp(PL_stdingv)) = PerlIO_stdin();
2592 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2594 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(PL_stdingv));
2596 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2598 IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
2600 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2602 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(PL_defoutgv));
2604 othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2605 GvMULTI_on(othergv);
2606 IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr();
2607 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2609 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
2611 PL_statname = NEWSV(66,0); /* last filename we did stat on */
2614 PL_osname = savepv(OSNAME);
2618 init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
2625 argc--,argv++; /* skip name of script */
2626 if (PL_doswitches) {
2627 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2630 if (argv[0][1] == '-') {
2634 if (s = strchr(argv[0], '=')) {
2636 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2639 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2642 PL_toptarget = NEWSV(0,0);
2643 sv_upgrade(PL_toptarget, SVt_PVFM);
2644 sv_setpvn(PL_toptarget, "", 0);
2645 PL_bodytarget = NEWSV(0,0);
2646 sv_upgrade(PL_bodytarget, SVt_PVFM);
2647 sv_setpvn(PL_bodytarget, "", 0);
2648 PL_formtarget = PL_bodytarget;
2651 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2652 sv_setpv(GvSV(tmpgv),PL_origfilename);
2653 magicname("0", "0", 1);
2655 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2656 sv_setpv(GvSV(tmpgv),PL_origargv[0]);
2657 if (PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2658 GvMULTI_on(PL_argvgv);
2659 (void)gv_AVadd(PL_argvgv);
2660 av_clear(GvAVn(PL_argvgv));
2661 for (; argc > 0; argc--,argv++) {
2662 av_push(GvAVn(PL_argvgv),newSVpv(argv[0],0));
2665 if (PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2667 GvMULTI_on(PL_envgv);
2668 hv = GvHVn(PL_envgv);
2669 hv_magic(hv, PL_envgv, 'E');
2670 #ifndef VMS /* VMS doesn't have environ array */
2671 /* Note that if the supplied env parameter is actually a copy
2672 of the global environ then it may now point to free'd memory
2673 if the environment has been modified since. To avoid this
2674 problem we treat env==NULL as meaning 'use the default'
2679 environ[0] = Nullch;
2680 for (; *env; env++) {
2681 if (!(s = strchr(*env,'=')))
2687 sv = newSVpv(s--,0);
2688 (void)hv_store(hv, *env, s - *env, sv, 0);
2690 #if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
2691 /* Sins of the RTL. See note in my_setenv(). */
2692 (void)PerlEnv_putenv(savepv(*env));
2696 #ifdef DYNAMIC_ENV_FETCH
2697 HvNAME(hv) = savepv(ENV_HV_NAME);
2701 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2702 sv_setiv(GvSV(tmpgv), (IV)getpid());
2711 s = PerlEnv_getenv("PERL5LIB");
2715 incpush(PerlEnv_getenv("PERLLIB"), FALSE);
2717 /* Treat PERL5?LIB as a possible search list logical name -- the
2718 * "natural" VMS idiom for a Unix path string. We allow each
2719 * element to be a set of |-separated directories for compatibility.
2723 if (my_trnlnm("PERL5LIB",buf,0))
2724 do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2726 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2730 /* Use the ~-expanded versions of APPLLIB (undocumented),
2731 ARCHLIB PRIVLIB SITEARCH and SITELIB
2734 incpush(APPLLIB_EXP, TRUE);
2738 incpush(ARCHLIB_EXP, FALSE);
2741 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2744 incpush(PRIVLIB_EXP, TRUE);
2746 incpush(PRIVLIB_EXP, FALSE);
2750 incpush(SITEARCH_EXP, FALSE);
2754 incpush(SITELIB_EXP, TRUE);
2756 incpush(SITELIB_EXP, FALSE);
2760 incpush(".", FALSE);
2764 # define PERLLIB_SEP ';'
2767 # define PERLLIB_SEP '|'
2769 # define PERLLIB_SEP ':'
2772 #ifndef PERLLIB_MANGLE
2773 # define PERLLIB_MANGLE(s,n) (s)
2777 incpush(pTHX_ char *p, int addsubdirs)
2779 SV *subdir = Nullsv;
2785 subdir = sv_newmortal();
2786 if (!PL_archpat_auto) {
2787 STRLEN len = (sizeof(ARCHNAME) + strlen(PL_patchlevel)
2788 + sizeof("//auto"));
2789 New(55, PL_archpat_auto, len, char);
2790 sprintf(PL_archpat_auto, "/%s/%s/auto", ARCHNAME, PL_patchlevel);
2792 for (len = sizeof(ARCHNAME) + 2;
2793 PL_archpat_auto[len] != '\0' && PL_archpat_auto[len] != '/'; len++)
2794 if (PL_archpat_auto[len] == '.') PL_archpat_auto[len] = '_';
2799 /* Break at all separators */
2801 SV *libdir = NEWSV(55,0);
2804 /* skip any consecutive separators */
2805 while ( *p == PERLLIB_SEP ) {
2806 /* Uncomment the next line for PATH semantics */
2807 /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */
2811 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2812 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2817 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2818 p = Nullch; /* break out */
2822 * BEFORE pushing libdir onto @INC we may first push version- and
2823 * archname-specific sub-directories.
2826 struct stat tmpstatbuf;
2831 if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) {
2833 while (unix[len-1] == '/') len--; /* Cosmetic */
2834 sv_usepvn(libdir,unix,len);
2837 PerlIO_printf(PerlIO_stderr(),
2838 "Failed to unixify @INC element \"%s\"\n",
2841 /* .../archname/version if -d .../archname/version/auto */
2842 sv_setsv(subdir, libdir);
2843 sv_catpv(subdir, PL_archpat_auto);
2844 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2845 S_ISDIR(tmpstatbuf.st_mode))
2846 av_push(GvAVn(PL_incgv),
2847 newSVpvn(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2849 /* .../archname if -d .../archname/auto */
2850 sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
2851 strlen(PL_patchlevel) + 1, "", 0);
2852 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2853 S_ISDIR(tmpstatbuf.st_mode))
2854 av_push(GvAVn(PL_incgv),
2855 newSVpvn(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2858 /* finally push this lib directory on the end of @INC */
2859 av_push(GvAVn(PL_incgv), libdir);
2864 STATIC struct perl_thread *
2865 init_main_thread(pTHX)
2867 struct perl_thread *thr;
2870 Newz(53, thr, 1, struct perl_thread);
2871 PL_curcop = &PL_compiling;
2872 thr->cvcache = newHV();
2873 thr->threadsv = newAV();
2874 /* thr->threadsvp is set when find_threadsv is called */
2875 thr->specific = newAV();
2876 thr->errhv = newHV();
2877 thr->flags = THRf_R_JOINABLE;
2878 MUTEX_INIT(&thr->mutex);
2879 /* Handcraft thrsv similarly to mess_sv */
2880 New(53, PL_thrsv, 1, SV);
2881 Newz(53, xpv, 1, XPV);
2882 SvFLAGS(PL_thrsv) = SVt_PV;
2883 SvANY(PL_thrsv) = (void*)xpv;
2884 SvREFCNT(PL_thrsv) = 1 << 30; /* practically infinite */
2885 SvPVX(PL_thrsv) = (char*)thr;
2886 SvCUR_set(PL_thrsv, sizeof(thr));
2887 SvLEN_set(PL_thrsv, sizeof(thr));
2888 *SvEND(PL_thrsv) = '\0'; /* in the trailing_nul field */
2889 thr->oursv = PL_thrsv;
2890 PL_chopset = " \n-";
2893 MUTEX_LOCK(&PL_threads_mutex);
2898 MUTEX_UNLOCK(&PL_threads_mutex);
2900 #ifdef HAVE_THREAD_INTERN
2901 init_thread_intern(thr);
2904 #ifdef SET_THREAD_SELF
2905 SET_THREAD_SELF(thr);
2907 thr->self = pthread_self();
2908 #endif /* SET_THREAD_SELF */
2912 * These must come after the SET_THR because sv_setpvn does
2913 * SvTAINT and the taint fields require dTHR.
2915 PL_toptarget = NEWSV(0,0);
2916 sv_upgrade(PL_toptarget, SVt_PVFM);
2917 sv_setpvn(PL_toptarget, "", 0);
2918 PL_bodytarget = NEWSV(0,0);
2919 sv_upgrade(PL_bodytarget, SVt_PVFM);
2920 sv_setpvn(PL_bodytarget, "", 0);
2921 PL_formtarget = PL_bodytarget;
2922 thr->errsv = newSVpvn("", 0);
2923 (void) find_threadsv("@"); /* Ensure $@ is initialised early */
2926 PL_regcompp = FUNC_NAME_TO_PTR(pregcomp);
2927 PL_regexecp = FUNC_NAME_TO_PTR(regexec_flags);
2929 PL_reginterp_cnt = 0;
2933 #endif /* USE_THREADS */
2936 Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
2940 line_t oldline = PL_curcop->cop_line;
2945 while (AvFILL(paramList) >= 0) {
2946 cv = (CV*)av_shift(paramList);
2948 CALLPROTECT(&ret, FUNC_NAME_TO_PTR(call_list_body), cv);
2951 (void)SvPV(atsv, len);
2953 PL_curcop = &PL_compiling;
2954 PL_curcop->cop_line = oldline;
2955 if (paramList == PL_beginav)
2956 sv_catpv(atsv, "BEGIN failed--compilation aborted");
2958 sv_catpv(atsv, "END failed--cleanup aborted");
2959 while (PL_scopestack_ix > oldscope)
2961 croak("%s", SvPVX(atsv));
2968 /* my_exit() was called */
2969 while (PL_scopestack_ix > oldscope)
2972 PL_curstash = PL_defstash;
2974 call_list(oldscope, PL_endav);
2975 PL_curcop = &PL_compiling;
2976 PL_curcop->cop_line = oldline;
2977 if (PL_statusvalue) {
2978 if (paramList == PL_beginav)
2979 croak("BEGIN failed--compilation aborted");
2981 croak("END failed--cleanup aborted");
2987 PL_curcop = &PL_compiling;
2988 PL_curcop->cop_line = oldline;
2991 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
2999 call_list_body(pTHX_ va_list args)
3002 CV *cv = va_arg(args, CV*);
3004 PUSHMARK(PL_stack_sp);
3005 call_sv((SV*)cv, G_EVAL|G_DISCARD);
3010 Perl_my_exit(pTHX_ U32 status)
3014 DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
3015 thr, (unsigned long) status));
3024 STATUS_NATIVE_SET(status);
3031 Perl_my_failure_exit(pTHX)
3034 if (vaxc$errno & 1) {
3035 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
3036 STATUS_NATIVE_SET(44);
3039 if (!vaxc$errno && errno) /* unlikely */
3040 STATUS_NATIVE_SET(44);
3042 STATUS_NATIVE_SET(vaxc$errno);
3047 STATUS_POSIX_SET(errno);
3049 exitstatus = STATUS_POSIX >> 8;
3050 if (exitstatus & 255)
3051 STATUS_POSIX_SET(exitstatus);
3053 STATUS_POSIX_SET(255);
3063 register PERL_CONTEXT *cx;
3068 SvREFCNT_dec(PL_e_script);
3069 PL_e_script = Nullsv;
3072 POPSTACK_TO(PL_mainstack);
3073 if (cxstack_ix >= 0) {
3076 POPBLOCK(cx,PL_curpm);
3085 #endif /* PERL_OBJECT */
3090 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen)
3093 p = SvPVX(PL_e_script);
3094 nl = strchr(p, '\n');
3095 nl = (nl) ? nl+1 : SvEND(PL_e_script);
3097 filter_del(read_e_script);
3100 sv_catpvn(buf_sv, p, nl-p);
3101 sv_chop(PL_e_script, nl);