3 * Copyright (c) 1987-1998 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
16 #include "patchlevel.h"
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 static I32 read_e_script _((CPerlObj* pPerl, int idx, SV *buf_sv, int maxlen));
49 static void find_beginning _((void));
50 static void forbid_setid _((char *));
51 static void incpush _((char *, int));
52 static void init_interp _((void));
53 static void init_ids _((void));
54 static void init_debugger _((void));
55 static void init_lexer _((void));
56 static void init_main_stash _((void));
58 static struct perl_thread * init_main_thread _((void));
59 #endif /* USE_THREADS */
60 static void init_perllib _((void));
61 static void init_postdump_symbols _((int, char **, char **));
62 static void init_predump_symbols _((void));
63 static void my_exit_jump _((void)) __attribute__((noreturn));
64 static void nuke_stacks _((void));
65 static void open_script _((char *, bool, SV *, int *fd));
66 static void usage _((char *));
67 static void validate_suid _((char *, char*, int));
68 static I32 read_e_script _((int idx, SV *buf_sv, int maxlen));
72 CPerlObj* perl_alloc(IPerlMem* ipM, IPerlEnv* ipE, IPerlStdIO* ipStd,
73 IPerlLIO* ipLIO, IPerlDir* ipD, IPerlSock* ipS, IPerlProc* ipP)
75 CPerlObj* pPerl = new(ipM) CPerlObj(ipM, ipE, ipStd, ipLIO, ipD, ipS, ipP);
85 PerlInterpreter *sv_interp;
88 New(53, sv_interp, 1, PerlInterpreter);
91 #endif /* PERL_OBJECT */
95 CPerlObj::perl_construct(void)
97 perl_construct(register PerlInterpreter *sv_interp)
103 struct perl_thread *thr;
104 #endif /* FAKE_THREADS */
105 #endif /* USE_THREADS */
108 if (!(PL_curinterp = sv_interp))
114 Zero(sv_interp, 1, PerlInterpreter);
117 /* Init the real globals (and main thread)? */
122 #ifdef ALLOC_THREAD_KEY
125 if (pthread_key_create(&PL_thr_key, 0))
126 croak("panic: pthread_key_create");
128 MUTEX_INIT(&PL_sv_mutex);
130 * Safe to use basic SV functions from now on (though
131 * not things like mortals or tainting yet).
133 MUTEX_INIT(&PL_eval_mutex);
134 COND_INIT(&PL_eval_cond);
135 MUTEX_INIT(&PL_threads_mutex);
136 COND_INIT(&PL_nthreads_cond);
137 #ifdef EMULATE_ATOMIC_REFCOUNTS
138 MUTEX_INIT(&PL_svref_mutex);
139 #endif /* EMULATE_ATOMIC_REFCOUNTS */
141 thr = init_main_thread();
142 #endif /* USE_THREADS */
144 PL_linestr = NEWSV(65,79);
145 sv_upgrade(PL_linestr,SVt_PVIV);
147 if (!SvREADONLY(&PL_sv_undef)) {
148 /* set read-only and try to insure than we wont see REFCNT==0
151 SvREADONLY_on(&PL_sv_undef);
152 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
154 sv_setpv(&PL_sv_no,PL_No);
156 SvREADONLY_on(&PL_sv_no);
157 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
159 sv_setpv(&PL_sv_yes,PL_Yes);
161 SvREADONLY_on(&PL_sv_yes);
162 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
167 /* PL_sighandlerp = sighandler; */
169 PL_sighandlerp = sighandler;
171 PL_pidstatus = newHV();
175 * There is no way we can refer to them from Perl so close them to save
176 * space. The other alternative would be to provide STDAUX and STDPRN
179 (void)fclose(stdaux);
180 (void)fclose(stdprn);
184 PL_nrs = newSVpv("\n", 1);
185 PL_rs = SvREFCNT_inc(PL_nrs);
190 PL_perl_destruct_level = 1;
192 if (PL_perl_destruct_level > 0)
197 PL_lex_state = LEX_NOTPARSING;
199 PL_start_env.je_prev = NULL;
200 PL_start_env.je_ret = -1;
201 PL_start_env.je_mustcatch = TRUE;
202 PL_top_env = &PL_start_env;
205 SET_NUMERIC_STANDARD();
206 #if defined(SUBVERSION) && SUBVERSION > 0
207 sprintf(PL_patchlevel, "%7.5f", (double) 5
208 + ((double) PATCHLEVEL / (double) 1000)
209 + ((double) SUBVERSION / (double) 100000));
211 sprintf(PL_patchlevel, "%5.3f", (double) 5 +
212 ((double) PATCHLEVEL / (double) 1000));
215 #if defined(LOCAL_PATCH_COUNT)
216 PL_localpatches = local_patches; /* For possible -v */
219 PerlIO_init(); /* Hook to IO system */
221 PL_fdpid = newAV(); /* for remembering popen pids by fd */
222 PL_modglobal = newHV(); /* pointers to per-interpreter module globals */
225 New(51,PL_debname,128,char);
226 New(52,PL_debdelim,128,char);
234 CPerlObj::perl_destruct(void)
236 perl_destruct(register PerlInterpreter *sv_interp)
240 int destruct_level; /* 0=none, 1=full, 2=full with checks */
245 #endif /* USE_THREADS */
248 if (!(PL_curinterp = sv_interp))
254 /* Pass 1 on any remaining threads: detach joinables, join zombies */
256 MUTEX_LOCK(&PL_threads_mutex);
257 DEBUG_S(PerlIO_printf(PerlIO_stderr(),
258 "perl_destruct: waiting for %d threads...\n",
260 for (t = thr->next; t != thr; t = t->next) {
261 MUTEX_LOCK(&t->mutex);
262 switch (ThrSTATE(t)) {
265 DEBUG_S(PerlIO_printf(PerlIO_stderr(),
266 "perl_destruct: joining zombie %p\n", t));
267 ThrSETSTATE(t, THRf_DEAD);
268 MUTEX_UNLOCK(&t->mutex);
271 * The SvREFCNT_dec below may take a long time (e.g. av
272 * may contain an object scalar whose destructor gets
273 * called) so we have to unlock threads_mutex and start
276 MUTEX_UNLOCK(&PL_threads_mutex);
278 SvREFCNT_dec((SV*)av);
279 DEBUG_S(PerlIO_printf(PerlIO_stderr(),
280 "perl_destruct: joined zombie %p OK\n", t));
282 case THRf_R_JOINABLE:
283 DEBUG_S(PerlIO_printf(PerlIO_stderr(),
284 "perl_destruct: detaching thread %p\n", t));
285 ThrSETSTATE(t, THRf_R_DETACHED);
287 * We unlock threads_mutex and t->mutex in the opposite order
288 * from which we locked them just so that DETACH won't
289 * deadlock if it panics. It's only a breach of good style
290 * not a bug since they are unlocks not locks.
292 MUTEX_UNLOCK(&PL_threads_mutex);
294 MUTEX_UNLOCK(&t->mutex);
297 DEBUG_S(PerlIO_printf(PerlIO_stderr(),
298 "perl_destruct: ignoring %p (state %u)\n",
300 MUTEX_UNLOCK(&t->mutex);
301 /* fall through and out */
304 /* We leave the above "Pass 1" loop with threads_mutex still locked */
306 /* Pass 2 on remaining threads: wait for the thread count to drop to one */
307 while (PL_nthreads > 1)
309 DEBUG_S(PerlIO_printf(PerlIO_stderr(),
310 "perl_destruct: final wait for %d threads\n",
312 COND_WAIT(&PL_nthreads_cond, &PL_threads_mutex);
314 /* At this point, we're the last thread */
315 MUTEX_UNLOCK(&PL_threads_mutex);
316 DEBUG_S(PerlIO_printf(PerlIO_stderr(), "perl_destruct: armageddon has arrived\n"));
317 MUTEX_DESTROY(&PL_threads_mutex);
318 COND_DESTROY(&PL_nthreads_cond);
319 #endif /* !defined(FAKE_THREADS) */
320 #endif /* USE_THREADS */
322 destruct_level = PL_perl_destruct_level;
326 if (s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL")) {
328 if (destruct_level < i)
341 /* We must account for everything. */
343 /* Destroy the main CV and syntax tree */
345 PL_curpad = AvARRAY(PL_comppad);
346 op_free(PL_main_root);
347 PL_main_root = Nullop;
349 PL_curcop = &PL_compiling;
350 PL_main_start = Nullop;
351 SvREFCNT_dec(PL_main_cv);
354 if (PL_sv_objcount) {
356 * Try to destruct global references. We do this first so that the
357 * destructors and destructees still exist. Some sv's might remain.
358 * Non-referenced objects are on their own.
365 /* unhook hooks which will soon be, or use, destroyed data */
366 SvREFCNT_dec(PL_warnhook);
367 PL_warnhook = Nullsv;
368 SvREFCNT_dec(PL_diehook);
370 SvREFCNT_dec(PL_parsehook);
371 PL_parsehook = Nullsv;
373 /* call exit list functions */
374 while (PL_exitlistlen-- > 0)
375 PL_exitlist[PL_exitlistlen].fn(PERL_OBJECT_THIS_ PL_exitlist[PL_exitlistlen].ptr);
377 Safefree(PL_exitlist);
379 if (destruct_level == 0){
381 DEBUG_P(debprofdump());
383 /* The exit() function will do everything that needs doing. */
387 /* loosen bonds of global variables */
390 (void)PerlIO_close(PL_rsfp);
394 /* Filters for program text */
395 SvREFCNT_dec(PL_rsfp_filters);
396 PL_rsfp_filters = Nullav;
399 PL_preprocess = FALSE;
405 PL_doswitches = FALSE;
407 PL_doextract = FALSE;
408 PL_sawampersand = FALSE; /* must save all match strings */
409 PL_sawstudy = FALSE; /* do fbm_instr on all strings */
413 Safefree(PL_inplace);
417 SvREFCNT_dec(PL_e_script);
418 PL_e_script = Nullsv;
421 /* magical thingies */
423 Safefree(PL_ofs); /* $, */
426 Safefree(PL_ors); /* $\ */
429 SvREFCNT_dec(PL_rs); /* $/ */
432 SvREFCNT_dec(PL_nrs); /* $/ helper */
435 PL_multiline = 0; /* $* */
437 SvREFCNT_dec(PL_statname);
438 PL_statname = Nullsv;
441 /* defgv, aka *_ should be taken care of elsewhere */
443 /* clean up after study() */
444 SvREFCNT_dec(PL_lastscream);
445 PL_lastscream = Nullsv;
446 Safefree(PL_screamfirst);
448 Safefree(PL_screamnext);
451 /* startup and shutdown function lists */
452 SvREFCNT_dec(PL_beginav);
453 SvREFCNT_dec(PL_endav);
454 SvREFCNT_dec(PL_initav);
459 /* shortcuts just get cleared */
466 PL_argvoutgv = Nullgv;
468 PL_last_in_gv = Nullgv;
471 /* reset so print() ends up where we expect */
474 /* Prepare to destruct main symbol table. */
481 if (destruct_level >= 2) {
482 if (PL_scopestack_ix != 0)
483 warn("Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
484 (long)PL_scopestack_ix);
485 if (PL_savestack_ix != 0)
486 warn("Unbalanced saves: %ld more saves than restores\n",
487 (long)PL_savestack_ix);
488 if (PL_tmps_floor != -1)
489 warn("Unbalanced tmps: %ld more allocs than frees\n",
490 (long)PL_tmps_floor + 1);
491 if (cxstack_ix != -1)
492 warn("Unbalanced context: %ld more PUSHes than POPs\n",
493 (long)cxstack_ix + 1);
496 /* Now absolutely destruct everything, somehow or other, loops or no. */
498 SvFLAGS(PL_strtab) |= SVTYPEMASK; /* don't clean out strtab now */
499 while (PL_sv_count != 0 && PL_sv_count != last_sv_count) {
500 last_sv_count = PL_sv_count;
503 SvFLAGS(PL_strtab) &= ~SVTYPEMASK;
504 SvFLAGS(PL_strtab) |= SVt_PVHV;
506 /* Destruct the global string table. */
508 /* Yell and reset the HeVAL() slots that are still holding refcounts,
509 * so that sv_free() won't fail on them.
517 max = HvMAX(PL_strtab);
518 array = HvARRAY(PL_strtab);
522 warn("Unbalanced string table refcount: (%d) for \"%s\"",
523 HeVAL(hent) - Nullsv, HeKEY(hent));
524 HeVAL(hent) = Nullsv;
534 SvREFCNT_dec(PL_strtab);
536 if (PL_sv_count != 0)
537 warn("Scalars leaked: %ld\n", (long)PL_sv_count);
541 /* No SVs have survived, need to clean out */
543 PL_pidstatus = Nullhv;
544 Safefree(PL_origfilename);
545 Safefree(PL_archpat_auto);
546 Safefree(PL_reg_start_tmp);
547 Safefree(HeKEY_hek(&PL_hv_fetch_ent_mh));
548 Safefree(PL_op_mask);
550 PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */
552 DEBUG_P(debprofdump());
554 MUTEX_DESTROY(&PL_sv_mutex);
555 MUTEX_DESTROY(&PL_eval_mutex);
556 COND_DESTROY(&PL_eval_cond);
558 /* As the penultimate thing, free the non-arena SV for thrsv */
559 Safefree(SvPVX(PL_thrsv));
560 Safefree(SvANY(PL_thrsv));
563 #endif /* USE_THREADS */
565 /* As the absolutely last thing, free the non-arena SV for mess() */
568 /* it could have accumulated taint magic */
569 if (SvTYPE(PL_mess_sv) >= SVt_PVMG) {
572 for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) {
573 moremagic = mg->mg_moremagic;
574 if (mg->mg_ptr && mg->mg_type != 'g' && mg->mg_len >= 0)
575 Safefree(mg->mg_ptr);
579 /* we know that type >= SVt_PV */
580 SvOOK_off(PL_mess_sv);
581 Safefree(SvPVX(PL_mess_sv));
582 Safefree(SvANY(PL_mess_sv));
583 Safefree(PL_mess_sv);
590 CPerlObj::perl_free(void)
592 perl_free(PerlInterpreter *sv_interp)
598 if (!(PL_curinterp = sv_interp))
606 CPerlObj::perl_atexit(void (*fn) (CPerlObj*,void *), void *ptr)
608 perl_atexit(void (*fn) (void *), void *ptr)
611 Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry);
612 PL_exitlist[PL_exitlistlen].fn = fn;
613 PL_exitlist[PL_exitlistlen].ptr = ptr;
619 CPerlObj::perl_parse(void (*xsinit) (CPerlObj*), int argc, char **argv, char **env)
621 perl_parse(PerlInterpreter *sv_interp, void (*xsinit) (void), int argc, char **argv, char **env)
627 char *scriptname = NULL;
628 VOL bool dosearch = FALSE;
636 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
639 croak("suidperl is no longer needed since the kernel can now execute\n\
640 setuid perl scripts securely.\n");
645 if (!(PL_curinterp = sv_interp))
649 #if defined(NeXT) && defined(__DYNAMIC__)
650 _dyld_lookup_and_bind
651 ("__environ", (unsigned long *) &environ_pointer, NULL);
656 #ifndef VMS /* VMS doesn't have environ array */
657 PL_origenviron = environ;
662 /* Come here if running an undumped a.out. */
664 PL_origfilename = savepv(argv[0]);
665 PL_do_undump = FALSE;
666 cxstack_ix = -1; /* start label stack again */
668 init_postdump_symbols(argc,argv,env);
673 PL_curpad = AvARRAY(PL_comppad);
674 op_free(PL_main_root);
675 PL_main_root = Nullop;
677 PL_main_start = Nullop;
678 SvREFCNT_dec(PL_main_cv);
682 oldscope = PL_scopestack_ix;
690 /* my_exit() was called */
691 while (PL_scopestack_ix > oldscope)
694 PL_curstash = PL_defstash;
696 call_list(oldscope, PL_endav);
698 return STATUS_NATIVE_EXPORT;
701 PerlIO_printf(PerlIO_stderr(), "panic: top_env\n");
705 sv_setpvn(PL_linestr,"",0);
706 sv = newSVpv("",0); /* first used for -I flags */
710 for (argc--,argv++; argc > 0; argc--,argv++) {
711 if (argv[0][0] != '-' || !argv[0][1])
715 validarg = " PHOOEY ";
741 if (s = moreswitches(s))
751 if (PL_euid != PL_uid || PL_egid != PL_gid)
752 croak("No -e allowed in setuid scripts");
754 PL_e_script = newSVpv("",0);
755 filter_add(read_e_script, NULL);
758 sv_catpv(PL_e_script, s);
760 sv_catpv(PL_e_script, argv[1]);
764 croak("No code specified for -e");
765 sv_catpv(PL_e_script, "\n");
768 case 'I': /* -I handled both here and in moreswitches() */
770 if (!*++s && (s=argv[1]) != Nullch) {
773 while (s && isSPACE(*s))
777 for (e = s; *e && !isSPACE(*e); e++) ;
784 } /* XXX else croak? */
788 PL_preprocess = TRUE;
798 PL_preambleav = newAV();
799 av_push(PL_preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
801 PL_Sv = newSVpv("print myconfig();",0);
803 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
805 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
807 #if defined(DEBUGGING) || defined(NO_EMBED) || defined(MULTIPLICITY)
808 sv_catpv(PL_Sv,"\" Compile-time options:");
810 sv_catpv(PL_Sv," DEBUGGING");
813 sv_catpv(PL_Sv," NO_EMBED");
816 sv_catpv(PL_Sv," MULTIPLICITY");
818 sv_catpv(PL_Sv,"\\n\",");
820 #if defined(LOCAL_PATCH_COUNT)
821 if (LOCAL_PATCH_COUNT > 0) {
823 sv_catpv(PL_Sv,"\" Locally applied patches:\\n\",");
824 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
825 if (PL_localpatches[i])
826 sv_catpvf(PL_Sv,"\" \\t%s\\n\",",PL_localpatches[i]);
830 sv_catpvf(PL_Sv,"\" Built under %s\\n\"",OSNAME);
833 sv_catpvf(PL_Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
835 sv_catpvf(PL_Sv,",\" Compiled on %s\\n\"",__DATE__);
840 @env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; \
841 print \" \\%ENV:\\n @env\\n\" if @env; \
842 print \" \\@INC:\\n @INC\\n\";");
845 PL_Sv = newSVpv("config_vars(qw(",0);
846 sv_catpv(PL_Sv, ++s);
847 sv_catpv(PL_Sv, "))");
850 av_push(PL_preambleav, PL_Sv);
851 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
857 PL_cddir = savepv(s);
862 if (!*++s || isSPACE(*s)) {
866 /* catch use of gnu style long options */
867 if (strEQ(s, "version")) {
871 if (strEQ(s, "help")) {
878 croak("Unrecognized switch: -%s (-h will show valid options)",s);
883 if (!PL_tainting && (s = PerlEnv_getenv("PERL5OPT"))) {
894 if (!strchr("DIMUdmw", *s))
895 croak("Illegal switch in PERL5OPT: -%c", *s);
901 scriptname = argv[0];
904 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
906 else if (scriptname == Nullch) {
908 if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
916 open_script(scriptname,dosearch,sv,&fdscript);
918 validate_suid(validarg, scriptname,fdscript);
923 PL_main_cv = PL_compcv = (CV*)NEWSV(1104,0);
924 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
925 CvUNIQUE_on(PL_compcv);
927 PL_comppad = newAV();
928 av_push(PL_comppad, Nullsv);
929 PL_curpad = AvARRAY(PL_comppad);
930 PL_comppad_name = newAV();
931 PL_comppad_name_fill = 0;
932 PL_min_intro_pending = 0;
935 av_store(PL_comppad_name, 0, newSVpv("@_", 2));
936 PL_curpad[0] = (SV*)newAV();
937 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
938 CvOWNER(PL_compcv) = 0;
939 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
940 MUTEX_INIT(CvMUTEXP(PL_compcv));
941 #endif /* USE_THREADS */
943 comppadlist = newAV();
944 AvREAL_off(comppadlist);
945 av_store(comppadlist, 0, (SV*)PL_comppad_name);
946 av_store(comppadlist, 1, (SV*)PL_comppad);
947 CvPADLIST(PL_compcv) = comppadlist;
949 boot_core_UNIVERSAL();
952 (*xsinit)(PERL_OBJECT_THIS); /* in case linked C routines want magical variables */
953 #if defined(VMS) || defined(WIN32) || defined(DJGPP)
957 init_predump_symbols();
958 /* init_postdump_symbols not currently designed to be called */
959 /* more than once (ENV isn't cleared first, for example) */
960 /* But running with -u leaves %ENV & @ARGV undefined! XXX */
962 init_postdump_symbols(argc,argv,env);
966 /* now parse the script */
968 SETERRNO(0,SS$_NORMAL);
970 if (yyparse() || PL_error_count) {
972 croak("%s had compilation errors.\n", PL_origfilename);
974 croak("Execution of %s aborted due to compilation errors.\n",
978 PL_curcop->cop_line = 0;
979 PL_curstash = PL_defstash;
980 PL_preprocess = FALSE;
982 SvREFCNT_dec(PL_e_script);
983 PL_e_script = Nullsv;
986 /* now that script is parsed, we can modify record separator */
988 PL_rs = SvREFCNT_inc(PL_nrs);
989 sv_setsv(perl_get_sv("/", TRUE), PL_rs);
994 gv_check(PL_defstash);
1000 if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
1001 dump_mstats("after compilation:");
1012 CPerlObj::perl_run(void)
1014 perl_run(PerlInterpreter *sv_interp)
1023 if (!(PL_curinterp = sv_interp))
1027 oldscope = PL_scopestack_ix;
1032 cxstack_ix = -1; /* start context stack again */
1035 /* my_exit() was called */
1036 while (PL_scopestack_ix > oldscope)
1039 PL_curstash = PL_defstash;
1041 call_list(oldscope, PL_endav);
1043 if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
1044 dump_mstats("after execution: ");
1047 return STATUS_NATIVE_EXPORT;
1049 if (!PL_restartop) {
1050 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
1055 POPSTACK_TO(PL_mainstack);
1059 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
1060 PL_sawampersand ? "Enabling" : "Omitting"));
1062 if (!PL_restartop) {
1063 DEBUG_x(dump_all());
1064 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
1065 DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%lx\n",
1066 (unsigned long) thr));
1069 PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", PL_origfilename);
1072 if (PERLDB_SINGLE && PL_DBsingle)
1073 sv_setiv(PL_DBsingle, 1);
1075 call_list(oldscope, PL_initav);
1081 PL_op = PL_restartop;
1085 else if (PL_main_start) {
1086 CvDEPTH(PL_main_cv) = 1;
1087 PL_op = PL_main_start;
1097 perl_get_sv(char *name, I32 create)
1101 if (name[1] == '\0' && !isALPHA(name[0])) {
1102 PADOFFSET tmp = find_threadsv(name);
1103 if (tmp != NOT_IN_PAD) {
1105 return THREADSV(tmp);
1108 #endif /* USE_THREADS */
1109 gv = gv_fetchpv(name, create, SVt_PV);
1116 perl_get_av(char *name, I32 create)
1118 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1127 perl_get_hv(char *name, I32 create)
1129 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1138 perl_get_cv(char *name, I32 create)
1140 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
1141 if (create && !GvCVu(gv))
1142 return newSUB(start_subparse(FALSE, 0),
1143 newSVOP(OP_CONST, 0, newSVpv(name,0)),
1151 /* Be sure to refetch the stack pointer after calling these routines. */
1154 perl_call_argv(char *sub_name, I32 flags, register char **argv)
1156 /* See G_* flags in cop.h */
1157 /* null terminated arg list */
1164 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
1169 return perl_call_pv(sub_name, flags);
1173 perl_call_pv(char *sub_name, I32 flags)
1174 /* name of the subroutine */
1175 /* See G_* flags in cop.h */
1177 return perl_call_sv((SV*)perl_get_cv(sub_name, TRUE), flags);
1181 perl_call_method(char *methname, I32 flags)
1182 /* name of the subroutine */
1183 /* See G_* flags in cop.h */
1189 XPUSHs(sv_2mortal(newSVpv(methname,0)));
1194 return perl_call_sv(*PL_stack_sp--, flags);
1197 /* May be called with any of a CV, a GV, or an SV containing the name. */
1199 perl_call_sv(SV *sv, I32 flags)
1201 /* See G_* flags in cop.h */
1204 LOGOP myop; /* fake syntax tree node */
1208 bool oldcatch = CATCH_GET;
1213 if (flags & G_DISCARD) {
1218 Zero(&myop, 1, LOGOP);
1219 myop.op_next = Nullop;
1220 if (!(flags & G_NOARGS))
1221 myop.op_flags |= OPf_STACKED;
1222 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1223 (flags & G_ARRAY) ? OPf_WANT_LIST :
1228 EXTEND(PL_stack_sp, 1);
1229 *++PL_stack_sp = sv;
1231 oldscope = PL_scopestack_ix;
1233 if (PERLDB_SUB && PL_curstash != PL_debstash
1234 /* Handle first BEGIN of -d. */
1235 && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
1236 /* Try harder, since this may have been a sighandler, thus
1237 * curstash may be meaningless. */
1238 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != PL_debstash)
1239 && !(flags & G_NODEBUG))
1240 PL_op->op_private |= OPpENTERSUB_DB;
1242 if (flags & G_EVAL) {
1243 cLOGOP->op_other = PL_op;
1245 /* we're trying to emulate pp_entertry() here */
1247 register PERL_CONTEXT *cx;
1248 I32 gimme = GIMME_V;
1253 push_return(PL_op->op_next);
1254 PUSHBLOCK(cx, CXt_EVAL, PL_stack_sp);
1256 PL_eval_root = PL_op; /* Only needed so that goto works right. */
1259 if (flags & G_KEEPERR)
1274 /* my_exit() was called */
1275 PL_curstash = PL_defstash;
1279 croak("Callback called exit");
1284 PL_op = PL_restartop;
1288 PL_stack_sp = PL_stack_base + oldmark;
1289 if (flags & G_ARRAY)
1293 *++PL_stack_sp = &PL_sv_undef;
1301 if (PL_op == (OP*)&myop)
1302 PL_op = pp_entersub(ARGS);
1305 retval = PL_stack_sp - (PL_stack_base + oldmark);
1306 if ((flags & G_EVAL) && !(flags & G_KEEPERR))
1310 if (flags & G_EVAL) {
1311 if (PL_scopestack_ix > oldscope) {
1315 register PERL_CONTEXT *cx;
1327 CATCH_SET(oldcatch);
1329 if (flags & G_DISCARD) {
1330 PL_stack_sp = PL_stack_base + oldmark;
1339 /* Eval a string. The G_EVAL flag is always assumed. */
1342 perl_eval_sv(SV *sv, I32 flags)
1344 /* See G_* flags in cop.h */
1347 UNOP myop; /* fake syntax tree node */
1348 I32 oldmark = SP - PL_stack_base;
1355 if (flags & G_DISCARD) {
1362 Zero(PL_op, 1, UNOP);
1363 EXTEND(PL_stack_sp, 1);
1364 *++PL_stack_sp = sv;
1365 oldscope = PL_scopestack_ix;
1367 if (!(flags & G_NOARGS))
1368 myop.op_flags = OPf_STACKED;
1369 myop.op_next = Nullop;
1370 myop.op_type = OP_ENTEREVAL;
1371 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1372 (flags & G_ARRAY) ? OPf_WANT_LIST :
1374 if (flags & G_KEEPERR)
1375 myop.op_flags |= OPf_SPECIAL;
1385 /* my_exit() was called */
1386 PL_curstash = PL_defstash;
1390 croak("Callback called exit");
1395 PL_op = PL_restartop;
1399 PL_stack_sp = PL_stack_base + oldmark;
1400 if (flags & G_ARRAY)
1404 *++PL_stack_sp = &PL_sv_undef;
1409 if (PL_op == (OP*)&myop)
1410 PL_op = pp_entereval(ARGS);
1413 retval = PL_stack_sp - (PL_stack_base + oldmark);
1414 if (!(flags & G_KEEPERR))
1419 if (flags & G_DISCARD) {
1420 PL_stack_sp = PL_stack_base + oldmark;
1430 perl_eval_pv(char *p, I32 croak_on_error)
1433 SV* sv = newSVpv(p, 0);
1436 perl_eval_sv(sv, G_SCALAR);
1443 if (croak_on_error && SvTRUE(ERRSV))
1444 croak(SvPVx(ERRSV, PL_na));
1449 /* Require a module. */
1452 perl_require_pv(char *pv)
1456 PUSHSTACKi(PERLSI_REQUIRE);
1458 sv = sv_newmortal();
1459 sv_setpv(sv, "require '");
1462 perl_eval_sv(sv, G_DISCARD);
1468 magicname(char *sym, char *name, I32 namlen)
1472 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1473 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1477 usage(char *name) /* XXX move this out into a module ? */
1480 /* This message really ought to be max 23 lines.
1481 * Removed -h because the user already knows that opton. Others? */
1483 static char *usage_msg[] = {
1484 "-0[octal] specify record separator (\\0, if no argument)",
1485 "-a autosplit mode with -n or -p (splits $_ into @F)",
1486 "-c check syntax only (runs BEGIN and END blocks)",
1487 "-d[:debugger] run scripts under debugger",
1488 "-D[number/list] set debugging flags (argument is a bit mask or flags)",
1489 "-e 'command' one line of script. Several -e's allowed. Omit [programfile].",
1490 "-F/pattern/ split() pattern for autosplit (-a). The //'s are optional.",
1491 "-i[extension] edit <> files in place (make backup if extension supplied)",
1492 "-Idirectory specify @INC/#include directory (may be used more than once)",
1493 "-l[octal] enable line ending processing, specifies line terminator",
1494 "-[mM][-]module.. executes `use/no module...' before executing your script.",
1495 "-n assume 'while (<>) { ... }' loop around your script",
1496 "-p assume loop like -n but print line also like sed",
1497 "-P run script through C preprocessor before compilation",
1498 "-s enable some switch parsing for switches after script name",
1499 "-S look for the script using PATH environment variable",
1500 "-T turn on tainting checks",
1501 "-u dump core after parsing script",
1502 "-U allow unsafe operations",
1503 "-v print version number, patchlevel plus VERY IMPORTANT perl info",
1504 "-V[:variable] print perl configuration information",
1505 "-w TURN WARNINGS ON FOR COMPILATION OF YOUR SCRIPT. Recommended.",
1506 "-x[directory] strip off text before #!perl line and perhaps cd to directory",
1510 char **p = usage_msg;
1512 printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1514 printf("\n %s", *p++);
1517 /* This routine handles any switches that can be given during run */
1520 moreswitches(char *s)
1529 rschar = scan_oct(s, 4, &numlen);
1530 SvREFCNT_dec(PL_nrs);
1531 if (rschar & ~((U8)~0))
1532 PL_nrs = &PL_sv_undef;
1533 else if (!rschar && numlen >= 2)
1534 PL_nrs = newSVpv("", 0);
1537 PL_nrs = newSVpv(&ch, 1);
1543 PL_splitstr = savepv(s + 1);
1557 if (*s == ':' || *s == '=') {
1558 my_setenv("PERL5DB", form("use Devel::%s;", ++s));
1562 PL_perldb = PERLDB_ALL;
1569 if (isALPHA(s[1])) {
1570 static char debopts[] = "psltocPmfrxuLHXDS";
1573 for (s++; *s && (d = strchr(debopts,*s)); s++)
1574 PL_debug |= 1 << (d - debopts);
1577 PL_debug = atoi(s+1);
1578 for (s++; isDIGIT(*s); s++) ;
1580 PL_debug |= 0x80000000;
1582 warn("Recompile perl with -DDEBUGGING to use -D switch\n");
1583 for (s++; isALNUM(*s); s++) ;
1588 usage(PL_origargv[0]);
1592 Safefree(PL_inplace);
1593 PL_inplace = savepv(s+1);
1595 for (s = PL_inplace; *s && !isSPACE(*s); s++) ;
1598 if (*s == '-') /* Additional switches on #! line. */
1602 case 'I': /* -I handled both here and in parse_perl() */
1605 while (*s && isSPACE(*s))
1609 for (e = s; *e && !isSPACE(*e); e++) ;
1610 p = savepvn(s, e-s);
1616 croak("No space allowed after -I");
1624 PL_ors = savepv("\n");
1626 *PL_ors = scan_oct(s, 3 + (*s == '0'), &numlen);
1631 if (RsPARA(PL_nrs)) {
1636 PL_ors = SvPV(PL_nrs, PL_orslen);
1637 PL_ors = savepvn(PL_ors, PL_orslen);
1641 forbid_setid("-M"); /* XXX ? */
1644 forbid_setid("-m"); /* XXX ? */
1649 /* -M-foo == 'no foo' */
1650 if (*s == '-') { use = "no "; ++s; }
1651 sv = newSVpv(use,0);
1653 /* We allow -M'Module qw(Foo Bar)' */
1654 while(isALNUM(*s) || *s==':') ++s;
1656 sv_catpv(sv, start);
1657 if (*(start-1) == 'm') {
1659 croak("Can't use '%c' after -mname", *s);
1660 sv_catpv( sv, " ()");
1663 sv_catpvn(sv, start, s-start);
1664 sv_catpv(sv, " split(/,/,q{");
1669 if (PL_preambleav == NULL)
1670 PL_preambleav = newAV();
1671 av_push(PL_preambleav, sv);
1674 croak("No space allowed after -%c", *(s-1));
1686 PL_doswitches = TRUE;
1691 croak("Too late for \"-T\" option");
1695 PL_do_undump = TRUE;
1703 #if defined(SUBVERSION) && SUBVERSION > 0
1704 printf("\nThis is perl, version 5.%03d_%02d built for %s",
1705 PATCHLEVEL, SUBVERSION, ARCHNAME);
1707 printf("\nThis is perl, version %s built for %s",
1708 PL_patchlevel, ARCHNAME);
1710 #if defined(LOCAL_PATCH_COUNT)
1711 if (LOCAL_PATCH_COUNT > 0)
1712 printf("\n(with %d registered patch%s, see perl -V for more detail)",
1713 LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : "");
1716 printf("\n\nCopyright 1987-1998, Larry Wall\n");
1718 printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1721 printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
1722 printf("djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1998\n");
1725 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1726 "Version 5 port Copyright (c) 1994-1998, Andreas Kaiser, Ilya Zakharevich\n");
1729 printf("atariST series port, ++jrb bammi@cadence.com\n");
1732 printf("BeOS port Copyright Tom Spindler, 1997-1998\n");
1735 printf("MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-1998\n");
1738 printf("MVS (OS390) port by Mortice Kern Systems, 1997-1998\n");
1740 #ifdef BINARY_BUILD_NOTICE
1741 BINARY_BUILD_NOTICE;
1744 Perl may be copied only under the terms of either the Artistic License or the\n\
1745 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n\
1746 Complete documentation for Perl, including FAQ lists, should be found on\n\
1747 this system using `man perl' or `perldoc perl'. If you have access to the\n\
1748 Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
1756 if (s[1] == '-') /* Additional switches on #! line. */
1767 #ifdef ALTERNATE_SHEBANG
1768 case 'S': /* OS/2 needs -S on "extproc" line. */
1776 croak("Can't emulate -%.1s on #! line",s);
1781 /* compliments of Tom Christiansen */
1783 /* unexec() can be found in the Gnu emacs distribution */
1784 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
1795 prog = newSVpv(BIN_EXP, 0);
1796 sv_catpv(prog, "/perl");
1797 file = newSVpv(PL_origfilename, 0);
1798 sv_catpv(file, ".perldump");
1800 unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
1801 /* unexec prints msg to stderr in case of failure */
1802 PerlProc_exit(status);
1805 # include <lib$routines.h>
1806 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
1808 ABORT(); /* for use with undump */
1813 /* initialize curinterp */
1818 #ifdef PERL_OBJECT /* XXX kludge */
1821 PL_chopset = " \n-"; \
1822 PL_copline = NOLINE; \
1823 PL_curcop = &PL_compiling;\
1824 PL_curcopdb = NULL; \
1827 PL_laststatval = -1; \
1828 PL_laststype = OP_STAT; \
1829 PL_maxscream = -1; \
1830 PL_maxsysfd = MAXSYSFD; \
1831 PL_statname = Nullsv; \
1832 PL_tmps_floor = -1; \
1834 PL_op_mask = NULL; \
1836 PL_laststatval = -1; \
1837 PL_laststype = OP_STAT; \
1838 PL_mess_sv = Nullsv; \
1839 PL_splitstr = " "; \
1840 PL_generation = 100; \
1841 PL_exitlist = NULL; \
1842 PL_exitlistlen = 0; \
1844 PL_in_clean_objs = FALSE; \
1845 PL_in_clean_all = FALSE; \
1846 PL_profiledata = NULL; \
1848 PL_rsfp_filters = Nullav; \
1852 # ifdef MULTIPLICITY
1853 # define PERLVAR(var,type)
1854 # define PERLVARI(var,type,init) PL_curinterp->var = init;
1855 # define PERLVARIC(var,type,init) PL_curinterp->var = init;
1856 # include "intrpvar.h"
1857 # ifndef USE_THREADS
1858 # include "thrdvar.h"
1864 # define PERLVAR(var,type)
1865 # define PERLVARI(var,type,init) PL_##var = init;
1866 # define PERLVARIC(var,type,init) PL_##var = init;
1867 # include "intrpvar.h"
1868 # ifndef USE_THREADS
1869 # include "thrdvar.h"
1880 init_main_stash(void)
1885 /* Note that strtab is a rather special HV. Assumptions are made
1886 about not iterating on it, and not adding tie magic to it.
1887 It is properly deallocated in perl_destruct() */
1888 PL_strtab = newHV();
1889 HvSHAREKEYS_off(PL_strtab); /* mandatory */
1890 hv_ksplit(PL_strtab, 512);
1892 PL_curstash = PL_defstash = newHV();
1893 PL_curstname = newSVpv("main",4);
1894 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1895 SvREFCNT_dec(GvHV(gv));
1896 GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
1898 HvNAME(PL_defstash) = savepv("main");
1899 PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1900 GvMULTI_on(PL_incgv);
1901 PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
1902 GvMULTI_on(PL_hintgv);
1903 PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1904 PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1905 GvMULTI_on(PL_errgv);
1906 PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
1907 GvMULTI_on(PL_replgv);
1908 (void)form("%240s",""); /* Preallocate temp - for immediate signals. */
1909 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
1910 sv_setpvn(ERRSV, "", 0);
1911 PL_curstash = PL_defstash;
1912 PL_compiling.cop_stash = PL_defstash;
1913 PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
1914 PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
1915 /* We must init $/ before switches are processed. */
1916 sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1);
1920 open_script(char *scriptname, bool dosearch, SV *sv, int *fdscript)
1928 PL_origfilename = savepv("-e");
1931 /* if find_script() returns, it returns a malloc()-ed value */
1932 PL_origfilename = scriptname = find_script(scriptname, dosearch, NULL, 1);
1934 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
1935 char *s = scriptname + 8;
1936 *fdscript = atoi(s);
1940 scriptname = savepv(s + 1);
1941 Safefree(PL_origfilename);
1942 PL_origfilename = scriptname;
1947 PL_curcop->cop_filegv = gv_fetchfile(PL_origfilename);
1948 if (strEQ(PL_origfilename,"-"))
1950 if (*fdscript >= 0) {
1951 PL_rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE);
1952 #if defined(HAS_FCNTL) && defined(F_SETFD)
1954 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); /* ensure close-on-exec */
1957 else if (PL_preprocess) {
1958 char *cpp_cfg = CPPSTDIN;
1959 SV *cpp = newSVpv("",0);
1960 SV *cmd = NEWSV(0,0);
1962 if (strEQ(cpp_cfg, "cppstdin"))
1963 sv_catpvf(cpp, "%s/", BIN_EXP);
1964 sv_catpv(cpp, cpp_cfg);
1967 sv_catpv(sv,PRIVLIB_EXP);
1971 sed %s -e \"/^[^#]/b\" \
1972 -e \"/^#[ ]*include[ ]/b\" \
1973 -e \"/^#[ ]*define[ ]/b\" \
1974 -e \"/^#[ ]*if[ ]/b\" \
1975 -e \"/^#[ ]*ifdef[ ]/b\" \
1976 -e \"/^#[ ]*ifndef[ ]/b\" \
1977 -e \"/^#[ ]*else/b\" \
1978 -e \"/^#[ ]*elif[ ]/b\" \
1979 -e \"/^#[ ]*undef[ ]/b\" \
1980 -e \"/^#[ ]*endif/b\" \
1983 (PL_doextract ? "-e \"1,/^#/d\n\"" : ""),
1986 %s %s -e '/^[^#]/b' \
1987 -e '/^#[ ]*include[ ]/b' \
1988 -e '/^#[ ]*define[ ]/b' \
1989 -e '/^#[ ]*if[ ]/b' \
1990 -e '/^#[ ]*ifdef[ ]/b' \
1991 -e '/^#[ ]*ifndef[ ]/b' \
1992 -e '/^#[ ]*else/b' \
1993 -e '/^#[ ]*elif[ ]/b' \
1994 -e '/^#[ ]*undef[ ]/b' \
1995 -e '/^#[ ]*endif/b' \
2003 (PL_doextract ? "-e '1,/^#/d\n'" : ""),
2005 scriptname, cpp, sv, CPPMINUS);
2006 PL_doextract = FALSE;
2007 #ifdef IAMSUID /* actually, this is caught earlier */
2008 if (PL_euid != PL_uid && !PL_euid) { /* if running suidperl */
2010 (void)seteuid(PL_uid); /* musn't stay setuid root */
2013 (void)setreuid((Uid_t)-1, PL_uid);
2015 #ifdef HAS_SETRESUID
2016 (void)setresuid((Uid_t)-1, PL_uid, (Uid_t)-1);
2018 PerlProc_setuid(PL_uid);
2022 if (PerlProc_geteuid() != PL_uid)
2023 croak("Can't do seteuid!\n");
2025 #endif /* IAMSUID */
2026 PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
2030 else if (!*scriptname) {
2031 forbid_setid("program input from stdin");
2032 PL_rsfp = PerlIO_stdin();
2035 PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
2036 #if defined(HAS_FCNTL) && defined(F_SETFD)
2038 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); /* ensure close-on-exec */
2043 #ifndef IAMSUID /* in case script is not readable before setuid */
2045 PerlLIO_stat(SvPVX(GvSV(PL_curcop->cop_filegv)),&PL_statbuf) >= 0 &&
2046 PL_statbuf.st_mode & (S_ISUID|S_ISGID))
2049 PerlProc_execv(form("%s/sperl%s", BIN_EXP, PL_patchlevel), PL_origargv);
2050 croak("Can't do setuid\n");
2054 croak("Can't open perl script \"%s\": %s\n",
2055 SvPVX(GvSV(PL_curcop->cop_filegv)), Strerror(errno));
2060 validate_suid(char *validarg, char *scriptname, int fdscript)
2064 /* do we need to emulate setuid on scripts? */
2066 /* This code is for those BSD systems that have setuid #! scripts disabled
2067 * in the kernel because of a security problem. Merely defining DOSUID
2068 * in perl will not fix that problem, but if you have disabled setuid
2069 * scripts in the kernel, this will attempt to emulate setuid and setgid
2070 * on scripts that have those now-otherwise-useless bits set. The setuid
2071 * root version must be called suidperl or sperlN.NNN. If regular perl
2072 * discovers that it has opened a setuid script, it calls suidperl with
2073 * the same argv that it had. If suidperl finds that the script it has
2074 * just opened is NOT setuid root, it sets the effective uid back to the
2075 * uid. We don't just make perl setuid root because that loses the
2076 * effective uid we had before invoking perl, if it was different from the
2079 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
2080 * be defined in suidperl only. suidperl must be setuid root. The
2081 * Configure script will set this up for you if you want it.
2088 if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */
2089 croak("Can't stat script \"%s\"",PL_origfilename);
2090 if (fdscript < 0 && PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
2094 #ifndef HAS_SETREUID
2095 /* On this access check to make sure the directories are readable,
2096 * there is actually a small window that the user could use to make
2097 * filename point to an accessible directory. So there is a faint
2098 * chance that someone could execute a setuid script down in a
2099 * non-accessible directory. I don't know what to do about that.
2100 * But I don't think it's too important. The manual lies when
2101 * it says access() is useful in setuid programs.
2103 if (PerlLIO_access(SvPVX(GvSV(PL_curcop->cop_filegv)),1)) /*double check*/
2104 croak("Permission denied");
2106 /* If we can swap euid and uid, then we can determine access rights
2107 * with a simple stat of the file, and then compare device and
2108 * inode to make sure we did stat() on the same file we opened.
2109 * Then we just have to make sure he or she can execute it.
2112 struct stat tmpstatbuf;
2116 setreuid(PL_euid,PL_uid) < 0
2119 setresuid(PL_euid,PL_uid,(Uid_t)-1) < 0
2122 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
2123 croak("Can't swap uid and euid"); /* really paranoid */
2124 if (PerlLIO_stat(SvPVX(GvSV(PL_curcop->cop_filegv)),&tmpstatbuf) < 0)
2125 croak("Permission denied"); /* testing full pathname here */
2126 if (tmpstatbuf.st_dev != PL_statbuf.st_dev ||
2127 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
2128 (void)PerlIO_close(PL_rsfp);
2129 if (PL_rsfp = PerlProc_popen("/bin/mail root","w")) { /* heh, heh */
2130 PerlIO_printf(PL_rsfp,
2131 "User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2132 (Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
2133 (long)PL_uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
2134 (long)PL_statbuf.st_dev, (long)PL_statbuf.st_ino,
2135 SvPVX(GvSV(PL_curcop->cop_filegv)),
2136 (long)PL_statbuf.st_uid, (long)PL_statbuf.st_gid);
2137 (void)PerlProc_pclose(PL_rsfp);
2139 croak("Permission denied\n");
2143 setreuid(PL_uid,PL_euid) < 0
2145 # if defined(HAS_SETRESUID)
2146 setresuid(PL_uid,PL_euid,(Uid_t)-1) < 0
2149 || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
2150 croak("Can't reswap uid and euid");
2151 if (!cando(S_IXUSR,FALSE,&PL_statbuf)) /* can real uid exec? */
2152 croak("Permission denied\n");
2154 #endif /* HAS_SETREUID */
2155 #endif /* IAMSUID */
2157 if (!S_ISREG(PL_statbuf.st_mode))
2158 croak("Permission denied");
2159 if (PL_statbuf.st_mode & S_IWOTH)
2160 croak("Setuid/gid script is writable by world");
2161 PL_doswitches = FALSE; /* -s is insecure in suid */
2162 PL_curcop->cop_line++;
2163 if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
2164 strnNE(SvPV(PL_linestr,PL_na),"#!",2) ) /* required even on Sys V */
2165 croak("No #! line");
2166 s = SvPV(PL_linestr,PL_na)+2;
2168 while (!isSPACE(*s)) s++;
2169 for (s2 = s; (s2 > SvPV(PL_linestr,PL_na)+2 &&
2170 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
2171 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
2172 croak("Not a perl script");
2173 while (*s == ' ' || *s == '\t') s++;
2175 * #! arg must be what we saw above. They can invoke it by
2176 * mentioning suidperl explicitly, but they may not add any strange
2177 * arguments beyond what #! says if they do invoke suidperl that way.
2179 len = strlen(validarg);
2180 if (strEQ(validarg," PHOOEY ") ||
2181 strnNE(s,validarg,len) || !isSPACE(s[len]))
2182 croak("Args must match #! line");
2185 if (PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
2186 PL_euid == PL_statbuf.st_uid)
2188 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2189 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2190 #endif /* IAMSUID */
2192 if (PL_euid) { /* oops, we're not the setuid root perl */
2193 (void)PerlIO_close(PL_rsfp);
2196 PerlProc_execv(form("%s/sperl%s", BIN_EXP, PL_patchlevel), PL_origargv);
2198 croak("Can't do setuid\n");
2201 if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
2203 (void)setegid(PL_statbuf.st_gid);
2206 (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
2208 #ifdef HAS_SETRESGID
2209 (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
2211 PerlProc_setgid(PL_statbuf.st_gid);
2215 if (PerlProc_getegid() != PL_statbuf.st_gid)
2216 croak("Can't do setegid!\n");
2218 if (PL_statbuf.st_mode & S_ISUID) {
2219 if (PL_statbuf.st_uid != PL_euid)
2221 (void)seteuid(PL_statbuf.st_uid); /* all that for this */
2224 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
2226 #ifdef HAS_SETRESUID
2227 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
2229 PerlProc_setuid(PL_statbuf.st_uid);
2233 if (PerlProc_geteuid() != PL_statbuf.st_uid)
2234 croak("Can't do seteuid!\n");
2236 else if (PL_uid) { /* oops, mustn't run as root */
2238 (void)seteuid((Uid_t)PL_uid);
2241 (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
2243 #ifdef HAS_SETRESUID
2244 (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
2246 PerlProc_setuid((Uid_t)PL_uid);
2250 if (PerlProc_geteuid() != PL_uid)
2251 croak("Can't do seteuid!\n");
2254 if (!cando(S_IXUSR,TRUE,&PL_statbuf))
2255 croak("Permission denied\n"); /* they can't do this */
2258 else if (PL_preprocess)
2259 croak("-P not allowed for setuid/setgid script\n");
2260 else if (fdscript >= 0)
2261 croak("fd script not allowed in suidperl\n");
2263 croak("Script is not setuid/setgid in suidperl\n");
2265 /* We absolutely must clear out any saved ids here, so we */
2266 /* exec the real perl, substituting fd script for scriptname. */
2267 /* (We pass script name as "subdir" of fd, which perl will grok.) */
2268 PerlIO_rewind(PL_rsfp);
2269 PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0); /* just in case rewind didn't */
2270 for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
2271 if (!PL_origargv[which])
2272 croak("Permission denied");
2273 PL_origargv[which] = savepv(form("/dev/fd/%d/%s",
2274 PerlIO_fileno(PL_rsfp), PL_origargv[which]));
2275 #if defined(HAS_FCNTL) && defined(F_SETFD)
2276 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */
2278 PerlProc_execv(form("%s/perl%s", BIN_EXP, PL_patchlevel), PL_origargv);/* try again */
2279 croak("Can't do setuid\n");
2280 #endif /* IAMSUID */
2282 if (PL_euid != PL_uid || PL_egid != PL_gid) { /* (suidperl doesn't exist, in fact) */
2283 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2285 PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf); /* may be either wrapped or real suid */
2286 if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
2288 (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
2291 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2292 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2293 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2294 /* not set-id, must be wrapped */
2300 find_beginning(void)
2302 register char *s, *s2;
2304 /* skip forward in input to the real script? */
2307 while (PL_doextract) {
2308 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
2309 croak("No Perl script found in input\n");
2310 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2311 PerlIO_ungetc(PL_rsfp, '\n'); /* to keep line count right */
2312 PL_doextract = FALSE;
2313 while (*s && !(isSPACE (*s) || *s == '#')) s++;
2315 while (*s == ' ' || *s == '\t') s++;
2317 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2318 if (strnEQ(s2-4,"perl",4))
2320 while (s = moreswitches(s)) ;
2322 if (PL_cddir && PerlDir_chdir(PL_cddir) < 0)
2323 croak("Can't chdir to %s",PL_cddir);
2332 PL_uid = (int)PerlProc_getuid();
2333 PL_euid = (int)PerlProc_geteuid();
2334 PL_gid = (int)PerlProc_getgid();
2335 PL_egid = (int)PerlProc_getegid();
2337 PL_uid |= PL_gid << 16;
2338 PL_euid |= PL_egid << 16;
2340 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2344 forbid_setid(char *s)
2346 if (PL_euid != PL_uid)
2347 croak("No %s allowed while running setuid", s);
2348 if (PL_egid != PL_gid)
2349 croak("No %s allowed while running setgid", s);
2356 PL_curstash = PL_debstash;
2357 PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2358 AvREAL_off(PL_dbargs);
2359 PL_DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2360 PL_DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2361 PL_DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2362 PL_DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2363 sv_setiv(PL_DBsingle, 0);
2364 PL_DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2365 sv_setiv(PL_DBtrace, 0);
2366 PL_DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2367 sv_setiv(PL_DBsignal, 0);
2368 PL_curstash = PL_defstash;
2371 #ifndef STRESS_REALLOC
2372 #define REASONABLE(size) (size)
2374 #define REASONABLE(size) (1) /* unreasonable */
2378 init_stacks(ARGSproto)
2380 /* start with 128-item stack and 8K cxstack */
2381 PL_curstackinfo = new_stackinfo(REASONABLE(128),
2382 REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
2383 PL_curstackinfo->si_type = PERLSI_MAIN;
2384 PL_curstack = PL_curstackinfo->si_stack;
2385 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
2387 PL_stack_base = AvARRAY(PL_curstack);
2388 PL_stack_sp = PL_stack_base;
2389 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
2391 New(50,PL_tmps_stack,REASONABLE(128),SV*);
2394 PL_tmps_max = REASONABLE(128);
2396 New(54,PL_markstack,REASONABLE(32),I32);
2397 PL_markstack_ptr = PL_markstack;
2398 PL_markstack_max = PL_markstack + REASONABLE(32);
2402 New(54,PL_scopestack,REASONABLE(32),I32);
2403 PL_scopestack_ix = 0;
2404 PL_scopestack_max = REASONABLE(32);
2406 New(54,PL_savestack,REASONABLE(128),ANY);
2407 PL_savestack_ix = 0;
2408 PL_savestack_max = REASONABLE(128);
2410 New(54,PL_retstack,REASONABLE(16),OP*);
2412 PL_retstack_max = REASONABLE(16);
2421 while (PL_curstackinfo->si_next)
2422 PL_curstackinfo = PL_curstackinfo->si_next;
2423 while (PL_curstackinfo) {
2424 PERL_SI *p = PL_curstackinfo->si_prev;
2425 /* curstackinfo->si_stack got nuked by sv_free_arenas() */
2426 Safefree(PL_curstackinfo->si_cxstack);
2427 Safefree(PL_curstackinfo);
2428 PL_curstackinfo = p;
2430 Safefree(PL_tmps_stack);
2431 Safefree(PL_markstack);
2432 Safefree(PL_scopestack);
2433 Safefree(PL_savestack);
2434 Safefree(PL_retstack);
2436 Safefree(PL_debname);
2437 Safefree(PL_debdelim);
2442 static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
2453 lex_start(PL_linestr);
2455 PL_subname = newSVpv("main",4);
2459 init_predump_symbols(void)
2465 sv_setpvn(perl_get_sv("\"", TRUE), " ", 1);
2466 PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2467 GvMULTI_on(PL_stdingv);
2468 IoIFP(GvIOp(PL_stdingv)) = PerlIO_stdin();
2469 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2471 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(PL_stdingv));
2473 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2475 IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
2477 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2479 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(PL_defoutgv));
2481 othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2482 GvMULTI_on(othergv);
2483 IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr();
2484 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2486 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
2488 PL_statname = NEWSV(66,0); /* last filename we did stat on */
2491 PL_osname = savepv(OSNAME);
2495 init_postdump_symbols(register int argc, register char **argv, register char **env)
2502 argc--,argv++; /* skip name of script */
2503 if (PL_doswitches) {
2504 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2507 if (argv[0][1] == '-') {
2511 if (s = strchr(argv[0], '=')) {
2513 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2516 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2519 PL_toptarget = NEWSV(0,0);
2520 sv_upgrade(PL_toptarget, SVt_PVFM);
2521 sv_setpvn(PL_toptarget, "", 0);
2522 PL_bodytarget = NEWSV(0,0);
2523 sv_upgrade(PL_bodytarget, SVt_PVFM);
2524 sv_setpvn(PL_bodytarget, "", 0);
2525 PL_formtarget = PL_bodytarget;
2528 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2529 sv_setpv(GvSV(tmpgv),PL_origfilename);
2530 magicname("0", "0", 1);
2532 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2533 sv_setpv(GvSV(tmpgv),PL_origargv[0]);
2534 if (PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2535 GvMULTI_on(PL_argvgv);
2536 (void)gv_AVadd(PL_argvgv);
2537 av_clear(GvAVn(PL_argvgv));
2538 for (; argc > 0; argc--,argv++) {
2539 av_push(GvAVn(PL_argvgv),newSVpv(argv[0],0));
2542 if (PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2544 GvMULTI_on(PL_envgv);
2545 hv = GvHVn(PL_envgv);
2546 hv_magic(hv, PL_envgv, 'E');
2547 #ifndef VMS /* VMS doesn't have environ array */
2548 /* Note that if the supplied env parameter is actually a copy
2549 of the global environ then it may now point to free'd memory
2550 if the environment has been modified since. To avoid this
2551 problem we treat env==NULL as meaning 'use the default'
2556 environ[0] = Nullch;
2557 for (; *env; env++) {
2558 if (!(s = strchr(*env,'=')))
2564 sv = newSVpv(s--,0);
2565 (void)hv_store(hv, *env, s - *env, sv, 0);
2567 #if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
2568 /* Sins of the RTL. See note in my_setenv(). */
2569 (void)PerlEnv_putenv(savepv(*env));
2573 #ifdef DYNAMIC_ENV_FETCH
2574 HvNAME(hv) = savepv(ENV_HV_NAME);
2578 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2579 sv_setiv(GvSV(tmpgv), (IV)getpid());
2588 s = PerlEnv_getenv("PERL5LIB");
2592 incpush(PerlEnv_getenv("PERLLIB"), FALSE);
2594 /* Treat PERL5?LIB as a possible search list logical name -- the
2595 * "natural" VMS idiom for a Unix path string. We allow each
2596 * element to be a set of |-separated directories for compatibility.
2600 if (my_trnlnm("PERL5LIB",buf,0))
2601 do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2603 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2607 /* Use the ~-expanded versions of APPLLIB (undocumented),
2608 ARCHLIB PRIVLIB SITEARCH and SITELIB
2611 incpush(APPLLIB_EXP, TRUE);
2615 incpush(ARCHLIB_EXP, FALSE);
2618 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2621 incpush(PRIVLIB_EXP, TRUE);
2623 incpush(PRIVLIB_EXP, FALSE);
2627 incpush(SITEARCH_EXP, FALSE);
2631 incpush(SITELIB_EXP, TRUE);
2633 incpush(SITELIB_EXP, FALSE);
2637 incpush(".", FALSE);
2641 # define PERLLIB_SEP ';'
2644 # define PERLLIB_SEP '|'
2646 # define PERLLIB_SEP ':'
2649 #ifndef PERLLIB_MANGLE
2650 # define PERLLIB_MANGLE(s,n) (s)
2654 incpush(char *p, int addsubdirs)
2656 SV *subdir = Nullsv;
2662 subdir = sv_newmortal();
2663 if (!PL_archpat_auto) {
2664 STRLEN len = (sizeof(ARCHNAME) + strlen(PL_patchlevel)
2665 + sizeof("//auto"));
2666 New(55, PL_archpat_auto, len, char);
2667 sprintf(PL_archpat_auto, "/%s/%s/auto", ARCHNAME, PL_patchlevel);
2669 for (len = sizeof(ARCHNAME) + 2;
2670 PL_archpat_auto[len] != '\0' && PL_archpat_auto[len] != '/'; len++)
2671 if (PL_archpat_auto[len] == '.') PL_archpat_auto[len] = '_';
2676 /* Break at all separators */
2678 SV *libdir = NEWSV(55,0);
2681 /* skip any consecutive separators */
2682 while ( *p == PERLLIB_SEP ) {
2683 /* Uncomment the next line for PATH semantics */
2684 /* av_push(GvAVn(PL_incgv), newSVpv(".", 1)); */
2688 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2689 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2694 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2695 p = Nullch; /* break out */
2699 * BEFORE pushing libdir onto @INC we may first push version- and
2700 * archname-specific sub-directories.
2703 struct stat tmpstatbuf;
2708 if ((unix = tounixspec_ts(SvPV(libdir,PL_na),Nullch)) != Nullch) {
2710 while (unix[len-1] == '/') len--; /* Cosmetic */
2711 sv_usepvn(libdir,unix,len);
2714 PerlIO_printf(PerlIO_stderr(),
2715 "Failed to unixify @INC element \"%s\"\n",
2716 SvPV(libdir,PL_na));
2718 /* .../archname/version if -d .../archname/version/auto */
2719 sv_setsv(subdir, libdir);
2720 sv_catpv(subdir, PL_archpat_auto);
2721 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2722 S_ISDIR(tmpstatbuf.st_mode))
2723 av_push(GvAVn(PL_incgv),
2724 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2726 /* .../archname if -d .../archname/auto */
2727 sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
2728 strlen(PL_patchlevel) + 1, "", 0);
2729 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2730 S_ISDIR(tmpstatbuf.st_mode))
2731 av_push(GvAVn(PL_incgv),
2732 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2735 /* finally push this lib directory on the end of @INC */
2736 av_push(GvAVn(PL_incgv), libdir);
2741 STATIC struct perl_thread *
2744 struct perl_thread *thr;
2747 Newz(53, thr, 1, struct perl_thread);
2748 PL_curcop = &PL_compiling;
2749 thr->cvcache = newHV();
2750 thr->threadsv = newAV();
2751 /* thr->threadsvp is set when find_threadsv is called */
2752 thr->specific = newAV();
2753 thr->errhv = newHV();
2754 thr->flags = THRf_R_JOINABLE;
2755 MUTEX_INIT(&thr->mutex);
2756 /* Handcraft thrsv similarly to mess_sv */
2757 New(53, PL_thrsv, 1, SV);
2758 Newz(53, xpv, 1, XPV);
2759 SvFLAGS(PL_thrsv) = SVt_PV;
2760 SvANY(PL_thrsv) = (void*)xpv;
2761 SvREFCNT(PL_thrsv) = 1 << 30; /* practically infinite */
2762 SvPVX(PL_thrsv) = (char*)thr;
2763 SvCUR_set(PL_thrsv, sizeof(thr));
2764 SvLEN_set(PL_thrsv, sizeof(thr));
2765 *SvEND(PL_thrsv) = '\0'; /* in the trailing_nul field */
2766 thr->oursv = PL_thrsv;
2767 PL_chopset = " \n-";
2769 MUTEX_LOCK(&PL_threads_mutex);
2774 MUTEX_UNLOCK(&PL_threads_mutex);
2776 #ifdef HAVE_THREAD_INTERN
2777 init_thread_intern(thr);
2780 #ifdef SET_THREAD_SELF
2781 SET_THREAD_SELF(thr);
2783 thr->self = pthread_self();
2784 #endif /* SET_THREAD_SELF */
2788 * These must come after the SET_THR because sv_setpvn does
2789 * SvTAINT and the taint fields require dTHR.
2791 PL_toptarget = NEWSV(0,0);
2792 sv_upgrade(PL_toptarget, SVt_PVFM);
2793 sv_setpvn(PL_toptarget, "", 0);
2794 PL_bodytarget = NEWSV(0,0);
2795 sv_upgrade(PL_bodytarget, SVt_PVFM);
2796 sv_setpvn(PL_bodytarget, "", 0);
2797 PL_formtarget = PL_bodytarget;
2798 thr->errsv = newSVpv("", 0);
2799 (void) find_threadsv("@"); /* Ensure $@ is initialised early */
2802 PL_regcompp = FUNC_NAME_TO_PTR(pregcomp);
2803 PL_regexecp = FUNC_NAME_TO_PTR(regexec_flags);
2805 PL_reginterp_cnt = 0;
2809 #endif /* USE_THREADS */
2812 call_list(I32 oldscope, AV *paramList)
2815 line_t oldline = PL_curcop->cop_line;
2820 while (AvFILL(paramList) >= 0) {
2821 CV *cv = (CV*)av_shift(paramList);
2829 PUSHMARK(PL_stack_sp);
2830 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
2831 (void)SvPV(atsv, len);
2834 PL_curcop = &PL_compiling;
2835 PL_curcop->cop_line = oldline;
2836 if (paramList == PL_beginav)
2837 sv_catpv(atsv, "BEGIN failed--compilation aborted");
2839 sv_catpv(atsv, "END failed--cleanup aborted");
2840 while (PL_scopestack_ix > oldscope)
2842 croak("%s", SvPVX(atsv));
2850 /* my_exit() was called */
2851 while (PL_scopestack_ix > oldscope)
2854 PL_curstash = PL_defstash;
2856 call_list(oldscope, PL_endav);
2858 PL_curcop = &PL_compiling;
2859 PL_curcop->cop_line = oldline;
2860 if (PL_statusvalue) {
2861 if (paramList == PL_beginav)
2862 croak("BEGIN failed--compilation aborted");
2864 croak("END failed--cleanup aborted");
2869 if (!PL_restartop) {
2870 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
2875 PL_curcop = &PL_compiling;
2876 PL_curcop->cop_line = oldline;
2888 DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
2889 thr, (unsigned long) status));
2898 STATUS_NATIVE_SET(status);
2905 my_failure_exit(void)
2908 if (vaxc$errno & 1) {
2909 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
2910 STATUS_NATIVE_SET(44);
2913 if (!vaxc$errno && errno) /* unlikely */
2914 STATUS_NATIVE_SET(44);
2916 STATUS_NATIVE_SET(vaxc$errno);
2921 STATUS_POSIX_SET(errno);
2923 exitstatus = STATUS_POSIX >> 8;
2924 if (exitstatus & 255)
2925 STATUS_POSIX_SET(exitstatus);
2927 STATUS_POSIX_SET(255);
2937 register PERL_CONTEXT *cx;
2942 SvREFCNT_dec(PL_e_script);
2943 PL_e_script = Nullsv;
2946 POPSTACK_TO(PL_mainstack);
2947 if (cxstack_ix >= 0) {
2950 POPBLOCK(cx,PL_curpm);
2959 #endif /* PERL_OBJECT */
2965 read_e_script(CPerlObj *pPerl, int idx, SV *buf_sv, int maxlen)
2967 read_e_script(int idx, SV *buf_sv, int maxlen)
2971 p = SvPVX(PL_e_script);
2972 nl = strchr(p, '\n');
2973 nl = (nl) ? nl+1 : SvEND(PL_e_script);
2975 filter_del(read_e_script);
2978 sv_catpvn(buf_sv, p, nl-p);
2979 sv_chop(PL_e_script, nl);