X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl.c;h=d0d4e9ae172a51c997965a46c168b6a37e6caef0;hb=ae178db11db50e8d46c66980e186cfba029f0cb9;hp=a86967804864a8f9c11d45f4457d46d3fb4f0901;hpb=f6b3007c38a92f48d086a19ea8682dd935b6d4ee;p=p5sagit%2Fp5-mst-13.2.git diff --git a/perl.c b/perl.c index a869678..d0d4e9a 100644 --- a/perl.c +++ b/perl.c @@ -14,6 +14,7 @@ #include "EXTERN.h" #define PERL_IN_PERL_C #include "perl.h" +#include "patchlevel.h" /* for local_patches */ /* XXX If this causes problems, set i_unistd=undef in the hint file. */ #ifdef I_UNISTD @@ -61,10 +62,9 @@ perl_alloc(void) { PerlInterpreter *my_perl; -#if !defined(PERL_IMPLICIT_CONTEXT) - PL_curinterp = 0; -#endif - New(53, my_perl, 1, PerlInterpreter); + /* New() needs interpreter, so call malloc() instead */ + my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter)); + PERL_SET_INTERP(my_perl); return my_perl; } #endif /* PERL_OBJECT */ @@ -79,13 +79,16 @@ perl_construct(pTHXx) #endif /* FAKE_THREADS */ #endif /* USE_THREADS */ -#ifndef PERL_OBJECT - if (!(PL_curinterp = my_perl)) - return; +#ifdef MULTIPLICITY + Zero(my_perl, 1, PerlInterpreter); #endif #ifdef MULTIPLICITY - Zero(my_perl, 1, PerlInterpreter); + init_interp(); + PL_perl_destruct_level = 1; +#else + if (PL_perl_destruct_level > 0) + init_interp(); #endif /* Init the real globals (and main thread)? */ @@ -117,7 +120,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 */ @@ -165,13 +168,6 @@ perl_construct(pTHXx) PL_rs = SvREFCNT_inc(PL_nrs); init_stacks(); -#ifdef MULTIPLICITY - init_interp(); - PL_perl_destruct_level = 1; -#else - if (PL_perl_destruct_level > 0) - init_interp(); -#endif init_ids(); PL_lex_state = LEX_NOTPARSING; @@ -219,11 +215,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 */ @@ -337,8 +328,6 @@ perl_destruct(pTHXx) PL_warnhook = Nullsv; SvREFCNT_dec(PL_diehook); PL_diehook = Nullsv; - SvREFCNT_dec(PL_parsehook); - PL_parsehook = Nullsv; /* call exit list functions */ while (PL_exitlistlen-- > 0) @@ -418,6 +407,11 @@ perl_destruct(pTHXx) Safefree(PL_screamnext); PL_screamnext = 0; + /* float buffer */ + Safefree(PL_efloatbuf); + PL_efloatbuf = Nullch; + PL_efloatsize = 0; + /* startup and shutdown function lists */ SvREFCNT_dec(PL_beginav); SvREFCNT_dec(PL_endav); @@ -447,19 +441,25 @@ perl_destruct(pTHXx) PL_defstash = 0; SvREFCNT_dec(hv); + /* clear queued errors */ + SvREFCNT_dec(PL_errors); + PL_errors = Nullsv; + 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 +488,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 +504,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 +517,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 +567,10 @@ perl_destruct(pTHXx) void perl_free(pTHXx) { -#ifdef PERL_OBJECT - Safefree(this); +#if defined(PERL_OBJECT) + PerlMem_free(this); #else -# if !defined(PERL_IMPLICIT_CONTEXT) - if (!(PL_curinterp = my_perl)) - return; -# endif - Safefree(my_perl); + PerlMem_free(aTHXx); #endif } @@ -603,11 +601,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 +637,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; @@ -941,13 +934,18 @@ print \" \\@INC:\\n @INC\\n\";"); CvPADLIST(PL_compcv) = comppadlist; boot_core_UNIVERSAL(); + boot_core_xsutils(); 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 +982,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 +1008,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 */ @@ -1243,10 +1236,16 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags) PL_op->op_private |= OPpENTERSUB_DB; if (!(flags & G_EVAL)) { - CATCH_SET(TRUE); + /* G_NOCATCH is a hack for perl_vdie using this path to call + a __DIE__ handler */ + if (!(flags & G_NOCATCH)) { + CATCH_SET(TRUE); + } call_xbody((OP*)&myop, FALSE); retval = PL_stack_sp - (PL_stack_base + oldmark); - CATCH_SET(FALSE); + if (!(flags & G_NOCATCH)) { + CATCH_SET(FALSE); + } } else { cLOGOP->op_other = PL_op; @@ -1273,7 +1272,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 +1394,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 +1577,7 @@ Perl_moreswitches(pTHX_ char *s) } return s; case 'D': + { #ifdef DEBUGGING forbid_setid("-D"); if (isALPHA(s[1])) { @@ -1593,11 +1593,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 +1894,30 @@ 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; +# if defined(USE_THREADS) +# define PERLVARI(var,type,init) PERL_GET_INTERP->var = init; +# define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init; +# else /* !USE_THREADS */ +# define PERLVARI(var,type,init) aTHX->var = init; +# define PERLVARIC(var,type,init) aTHX->var = init; +# endif /* USE_THREADS */ # 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 +1925,7 @@ S_init_interp(pTHX) # include "thrdvar.h" # endif # undef PERLVAR +# undef PERLVARA # undef PERLVARI # undef PERLVARIC # endif @@ -2468,10 +2481,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 +2501,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 +2616,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 +2792,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 +2907,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 +2969,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 +2994,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 +3131,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)