X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl.c;h=9de87551d90f67221b2adc09a9bd22976b5e7df3;hb=e9a694fc69831683df9b559726b85119e227aa26;hp=a86967804864a8f9c11d45f4457d46d3fb4f0901;hpb=f6b3007c38a92f48d086a19ea8682dd935b6d4ee;p=p5sagit%2Fp5-mst-13.2.git diff --git a/perl.c b/perl.c index a869678..9de8755 100644 --- a/perl.c +++ b/perl.c @@ -61,10 +61,8 @@ perl_alloc(void) { PerlInterpreter *my_perl; -#if !defined(PERL_IMPLICIT_CONTEXT) - PL_curinterp = 0; -#endif New(53, my_perl, 1, PerlInterpreter); + PERL_SET_INTERP(my_perl); return my_perl; } #endif /* PERL_OBJECT */ @@ -79,11 +77,6 @@ perl_construct(pTHXx) #endif /* FAKE_THREADS */ #endif /* USE_THREADS */ -#ifndef PERL_OBJECT - if (!(PL_curinterp = my_perl)) - return; -#endif - #ifdef MULTIPLICITY Zero(my_perl, 1, PerlInterpreter); #endif @@ -117,7 +110,7 @@ perl_construct(pTHXx) thr = init_main_thread(); #endif /* USE_THREADS */ - PL_protect = FUNC_NAME_TO_PTR(Perl_default_protect); /* for exceptions */ + PL_protect = MEMBER_TO_FPTR(Perl_default_protect); /* for exceptions */ PL_curcop = &PL_compiling; /* needed by ckWARN, right away */ @@ -219,11 +212,6 @@ perl_destruct(pTHXx) dTHX; #endif /* USE_THREADS */ -#if !defined(PERL_OBJECT) && !defined(PERL_IMPLICIT_CONTEXT) - if (!(PL_curinterp = my_perl)) - return; -#endif - #ifdef USE_THREADS #ifndef FAKE_THREADS /* Pass 1 on any remaining threads: detach joinables, join zombies */ @@ -448,18 +436,20 @@ perl_destruct(pTHXx) SvREFCNT_dec(hv); FREETMPS; - if (destruct_level >= 2) { + if (destruct_level >= 2 && ckWARN_d(WARN_INTERNAL)) { if (PL_scopestack_ix != 0) - Perl_warn(aTHX_ "Unbalanced scopes: %ld more ENTERs than LEAVEs\n", + Perl_warner(aTHX_ WARN_INTERNAL, + "Unbalanced scopes: %ld more ENTERs than LEAVEs\n", (long)PL_scopestack_ix); if (PL_savestack_ix != 0) - Perl_warn(aTHX_ "Unbalanced saves: %ld more saves than restores\n", + Perl_warner(aTHX_ WARN_INTERNAL, + "Unbalanced saves: %ld more saves than restores\n", (long)PL_savestack_ix); if (PL_tmps_floor != -1) - Perl_warn(aTHX_ "Unbalanced tmps: %ld more allocs than frees\n", + Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced tmps: %ld more allocs than frees\n", (long)PL_tmps_floor + 1); if (cxstack_ix != -1) - Perl_warn(aTHX_ "Unbalanced context: %ld more PUSHes than POPs\n", + Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced context: %ld more PUSHes than POPs\n", (long)cxstack_ix + 1); } @@ -488,8 +478,9 @@ perl_destruct(pTHXx) array = HvARRAY(PL_strtab); hent = array[0]; for (;;) { - if (hent) { - Perl_warn(aTHX_ "Unbalanced string table refcount: (%d) for \"%s\"", + if (hent && ckWARN_d(WARN_INTERNAL)) { + Perl_warner(aTHX_ WARN_INTERNAL, + "Unbalanced string table refcount: (%d) for \"%s\"", HeVAL(hent) - Nullsv, HeKEY(hent)); HeVAL(hent) = Nullsv; hent = HeNEXT(hent); @@ -503,8 +494,8 @@ perl_destruct(pTHXx) } SvREFCNT_dec(PL_strtab); - if (PL_sv_count != 0) - Perl_warn(aTHX_ "Scalars leaked: %ld\n", (long)PL_sv_count); + if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL)) + Perl_warner(aTHX_ WARN_INTERNAL,"Scalars leaked: %ld\n", (long)PL_sv_count); sv_free_arenas(); @@ -516,6 +507,7 @@ perl_destruct(pTHXx) Safefree(PL_reg_start_tmp); if (PL_reg_curpm) Safefree(PL_reg_curpm); + Safefree(PL_reg_poscache); Safefree(HeKEY_hek(&PL_hv_fetch_ent_mh)); Safefree(PL_op_mask); nuke_stacks(); @@ -565,14 +557,10 @@ perl_destruct(pTHXx) void perl_free(pTHXx) { -#ifdef PERL_OBJECT - Safefree(this); +#if defined(PERL_OBJECT) + Safefree(this); #else -# if !defined(PERL_IMPLICIT_CONTEXT) - if (!(PL_curinterp = my_perl)) - return; -# endif - Safefree(my_perl); + Safefree(aTHXx); #endif } @@ -603,11 +591,6 @@ setuid perl scripts securely.\n"); #endif #endif -#if !defined(PERL_OBJECT) && !defined(PERL_IMPLICIT_CONTEXT) - if (!(PL_curinterp = my_perl)) - return 255; -#endif - #if defined(__DYNAMIC__) && (defined(NeXT) || defined(__NeXT__)) _dyld_lookup_and_bind ("__environ", (unsigned long *) &environ_pointer, NULL); @@ -644,7 +627,7 @@ setuid perl scripts securely.\n"); oldscope = PL_scopestack_ix; PL_dowarn = G_WARN_OFF; - CALLPROTECT(aTHX_ &ret, FUNC_NAME_TO_PTR(S_parse_body), env, xsinit); + CALLPROTECT(aTHX_ &ret, MEMBER_TO_FPTR(S_parse_body), env, xsinit); switch (ret) { case 0: return 0; @@ -945,9 +928,13 @@ print \" \\@INC:\\n @INC\\n\";"); if (xsinit) (*xsinit)(aTHXo); /* in case linked C routines want magical variables */ #if defined(VMS) || defined(WIN32) || defined(DJGPP) - init_os_extras(aTHX); + init_os_extras(); #endif +#ifdef USE_SOCKS + SOCKSinit(argv[0]); +#endif + init_predump_symbols(); /* init_postdump_symbols not currently designed to be called */ /* more than once (ENV isn't cleared first, for example) */ @@ -984,7 +971,7 @@ print \" \\@INC:\\n @INC\\n\";"); if (PL_do_undump) my_unexec(); - if (ckWARN(WARN_ONCE)) + if (isWARN_ONCE) gv_check(PL_defstash); LEAVE; @@ -1010,15 +997,10 @@ perl_run(pTHXx) dTHX; #endif -#if !defined(PERL_OBJECT) && !defined(PERL_IMPLICIT_CONTEXT) - if (!(PL_curinterp = my_perl)) - return 255; -#endif - oldscope = PL_scopestack_ix; redo_body: - CALLPROTECT(aTHX_ &ret, FUNC_NAME_TO_PTR(S_run_body), oldscope); + CALLPROTECT(aTHX_ &ret, MEMBER_TO_FPTR(S_run_body), oldscope); switch (ret) { case 1: cxstack_ix = -1; /* start context stack again */ @@ -1273,7 +1255,7 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags) PL_markstack_ptr++; redo_body: - CALLPROTECT(aTHX_ &ret, FUNC_NAME_TO_PTR(S_call_body), (OP*)&myop, FALSE); + CALLPROTECT(aTHX_ &ret, MEMBER_TO_FPTR(S_call_body), (OP*)&myop, FALSE); switch (ret) { case 0: retval = PL_stack_sp - (PL_stack_base + oldmark); @@ -1395,7 +1377,7 @@ Perl_eval_sv(pTHX_ SV *sv, I32 flags) myop.op_flags |= OPf_SPECIAL; redo_body: - CALLPROTECT(aTHX_ &ret, FUNC_NAME_TO_PTR(S_call_body), (OP*)&myop, TRUE); + CALLPROTECT(aTHX_ &ret, MEMBER_TO_FPTR(S_call_body), (OP*)&myop, TRUE); switch (ret) { case 0: retval = PL_stack_sp - (PL_stack_base + oldmark); @@ -1578,6 +1560,7 @@ Perl_moreswitches(pTHX_ char *s) } return s; case 'D': + { #ifdef DEBUGGING forbid_setid("-D"); if (isALPHA(s[1])) { @@ -1593,11 +1576,15 @@ Perl_moreswitches(pTHX_ char *s) } PL_debug |= 0x80000000; #else - Perl_warn(aTHX_ "Recompile perl with -DDEBUGGING to use -D switch\n"); + dTHR; + if (ckWARN_d(WARN_DEBUGGING)) + Perl_warner(aTHX_ WARN_DEBUGGING, + "Recompile perl with -DDEBUGGING to use -D switch\n"); for (s++; isALNUM(*s); s++) ; #endif /*SUPPRESS 530*/ return s; + } case 'h': usage(PL_origargv[0]); PerlProc_exit(0); @@ -1890,22 +1877,25 @@ S_init_interp(pTHX) #else # ifdef MULTIPLICITY # define PERLVAR(var,type) +# define PERLVARA(var,n,type) # if defined(PERL_IMPLICIT_CONTEXT) # define PERLVARI(var,type,init) my_perl->var = init; # define PERLVARIC(var,type,init) my_perl->var = init; # else -# define PERLVARI(var,type,init) PL_curinterp->var = init; -# define PERLVARIC(var,type,init) PL_curinterp->var = init; +# define PERLVARI(var,type,init) PERL_GET_INTERP->var = init; +# define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init; # endif # include "intrpvar.h" # ifndef USE_THREADS # include "thrdvar.h" # endif # undef PERLVAR +# undef PERLVARA # undef PERLVARI # undef PERLVARIC # else # define PERLVAR(var,type) +# define PERLVARA(var,n,type) # define PERLVARI(var,type,init) PL_##var = init; # define PERLVARIC(var,type,init) PL_##var = init; # include "intrpvar.h" @@ -1913,6 +1903,7 @@ S_init_interp(pTHX) # include "thrdvar.h" # endif # undef PERLVAR +# undef PERLVARA # undef PERLVARI # undef PERLVARIC # endif @@ -2468,10 +2459,10 @@ S_find_beginning(pTHX) STATIC void S_init_ids(pTHX) { - PL_uid = (int)PerlProc_getuid(); - PL_euid = (int)PerlProc_geteuid(); - PL_gid = (int)PerlProc_getgid(); - PL_egid = (int)PerlProc_getegid(); + PL_uid = PerlProc_getuid(); + PL_euid = PerlProc_geteuid(); + PL_gid = PerlProc_getgid(); + PL_egid = PerlProc_getegid(); #ifdef VMS PL_uid |= PL_gid << 16; PL_euid |= PL_egid << 16; @@ -2488,23 +2479,26 @@ S_forbid_setid(pTHX_ char *s) Perl_croak(aTHX_ "No %s allowed while running setgid", s); } -STATIC void -S_init_debugger(pTHX) +void +Perl_init_debugger(pTHX) { dTHR; + HV *ostash = PL_curstash; + PL_curstash = PL_debstash; PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV)))); AvREAL_off(PL_dbargs); PL_DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV); PL_DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV); PL_DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV)); + sv_upgrade(GvSV(PL_DBsub), SVt_IV); /* IVX accessed if PERLDB_SUB_NN */ PL_DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV))); sv_setiv(PL_DBsingle, 0); PL_DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV))); sv_setiv(PL_DBtrace, 0); PL_DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV))); sv_setiv(PL_DBsignal, 0); - PL_curstash = PL_defstash; + PL_curstash = ostash; } #ifndef STRESS_REALLOC @@ -2600,29 +2594,33 @@ S_init_predump_symbols(pTHX) dTHR; GV *tmpgv; GV *othergv; + IO *io; sv_setpvn(get_sv("\"", TRUE), " ", 1); PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO); GvMULTI_on(PL_stdingv); - IoIFP(GvIOp(PL_stdingv)) = PerlIO_stdin(); + io = GvIOp(PL_stdingv); + IoIFP(io) = PerlIO_stdin(); tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV); GvMULTI_on(tmpgv); - GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(PL_stdingv)); + GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io); tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO); GvMULTI_on(tmpgv); - IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout(); + io = GvIOp(tmpgv); + IoOFP(io) = IoIFP(io) = PerlIO_stdout(); setdefout(tmpgv); tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV); GvMULTI_on(tmpgv); - GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(PL_defoutgv)); + GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io); othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO); GvMULTI_on(othergv); - IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr(); + io = GvIOp(othergv); + IoOFP(io) = IoIFP(io) = PerlIO_stderr(); tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV); GvMULTI_on(tmpgv); - GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv)); + GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io); PL_statname = NEWSV(66,0); /* last filename we did stat on */ @@ -2772,6 +2770,13 @@ S_init_perllib(pTHX) incpush(SITELIB_EXP, FALSE); #endif #endif +#if defined(PERL_VENDORLIB_EXP) +#if defined(WIN32) + incpush(PERL_VENDORLIB_EXP, TRUE); +#else + incpush(PERL_VENDORLIB_EXP, FALSE); +#endif +#endif if (!PL_tainting) incpush(".", FALSE); } @@ -2880,13 +2885,14 @@ S_incpush(pTHX_ char *p, int addsubdirs) STATIC struct perl_thread * S_init_main_thread(pTHX) { -#ifndef PERL_IMPLICIT_CONTEXT +#if !defined(PERL_IMPLICIT_CONTEXT) struct perl_thread *thr; #endif XPV *xpv; Newz(53, thr, 1, struct perl_thread); PL_curcop = &PL_compiling; + thr->interp = PERL_GET_INTERP; thr->cvcache = newHV(); thr->threadsv = newAV(); /* thr->threadsvp is set when find_threadsv is called */ @@ -2941,8 +2947,11 @@ S_init_main_thread(pTHX) (void) find_threadsv("@"); /* Ensure $@ is initialised early */ PL_maxscream = -1; - PL_regcompp = FUNC_NAME_TO_PTR(Perl_pregcomp); - PL_regexecp = FUNC_NAME_TO_PTR(Perl_regexec_flags); + PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp); + PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags); + PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start); + PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string); + PL_regfree = MEMBER_TO_FPTR(Perl_pregfree); PL_regindent = 0; PL_reginterp_cnt = 0; @@ -2963,7 +2972,7 @@ Perl_call_list(pTHX_ I32 oldscope, AV *paramList) while (AvFILL(paramList) >= 0) { cv = (CV*)av_shift(paramList); SAVEFREESV(cv); - CALLPROTECT(aTHX_ &ret, FUNC_NAME_TO_PTR(S_call_list_body), cv); + CALLPROTECT(aTHX_ &ret, MEMBER_TO_FPTR(S_call_list_body), cv); switch (ret) { case 0: (void)SvPV(atsv, len); @@ -3100,9 +3109,8 @@ S_my_exit_jump(pTHX) #ifdef PERL_OBJECT #define NO_XSLOCKS -#endif /* PERL_OBJECT */ - #include "XSUB.h" +#endif static I32 read_e_script(pTHXo_ int idx, SV *buf_sv, int maxlen)