diff options
| -rw-r--r-- | embed.h | 4 | ||||
| -rwxr-xr-x | embed.pl | 1 | ||||
| -rw-r--r-- | gv.c | 44 | ||||
| -rw-r--r-- | objXSUB.h | 4 | ||||
| -rw-r--r-- | perl.h | 8 | ||||
| -rw-r--r-- | proto.h | 1 | ||||
| -rw-r--r-- | sv.c | 9 | ||||
| -rwxr-xr-x | t/pragma/overload.t | 1 |
8 files changed, 59 insertions, 13 deletions
@@ -68,6 +68,7 @@ #endif #define amagic_call Perl_amagic_call #define Gv_AMupdate Perl_Gv_AMupdate +#define gv_handler Perl_gv_handler #define append_elem Perl_append_elem #define append_list Perl_append_list #define apply Perl_apply @@ -1556,6 +1557,7 @@ #endif #define amagic_call(a,b,c,d) Perl_amagic_call(aTHX_ a,b,c,d) #define Gv_AMupdate(a) Perl_Gv_AMupdate(aTHX_ a) +#define gv_handler(a,b) Perl_gv_handler(aTHX_ a,b) #define append_elem(a,b,c) Perl_append_elem(aTHX_ a,b,c) #define append_list(a,b,c) Perl_append_list(aTHX_ a,b,c) #define apply(a,b,c) Perl_apply(aTHX_ a,b,c) @@ -3021,6 +3023,8 @@ #define amagic_call Perl_amagic_call #define Perl_Gv_AMupdate CPerlObj::Perl_Gv_AMupdate #define Gv_AMupdate Perl_Gv_AMupdate +#define Perl_gv_handler CPerlObj::Perl_gv_handler +#define gv_handler Perl_gv_handler #define Perl_append_elem CPerlObj::Perl_append_elem #define append_elem Perl_append_elem #define Perl_append_list CPerlObj::Perl_append_list @@ -1376,6 +1376,7 @@ START_EXTERN_C # include "pp_proto.h" Ap |SV* |amagic_call |SV* left|SV* right|int method|int dir Ap |bool |Gv_AMupdate |HV* stash +Ap |CV* |gv_handler |HV* stash|I32 id p |OP* |append_elem |I32 optype|OP* head|OP* tail p |OP* |append_list |I32 optype|LISTOP* first|LISTOP* last p |I32 |apply |I32 type|SV** mark|SV** sp @@ -1155,7 +1155,7 @@ Perl_Gv_AMupdate(pTHX_ HV *stash) if (mg && amtp->was_ok_am == PL_amagic_generation && amtp->was_ok_sub == PL_sub_generation) - return AMT_AMAGIC(amtp); + return AMT_OVERLOADED(amtp); if (amtp && AMT_AMAGIC(amtp)) { /* Have table. */ int i; for (i=1; i<NofAMmeth; i++) { @@ -1174,8 +1174,8 @@ Perl_Gv_AMupdate(pTHX_ HV *stash) amt.flags = 0; { - int filled = 0; - int i; + int filled = 0, have_ovl = 0; + int i, lim = 1; const char *cp; SV* sv = NULL; @@ -1187,15 +1187,18 @@ Perl_Gv_AMupdate(pTHX_ HV *stash) sv = GvSV(gv); if (!gv) - goto no_table; + lim = DESTROY_amg; /* Skip overloading entries. */ else if (SvTRUE(sv)) amt.fallback=AMGfallYES; else if (SvOK(sv)) amt.fallback=AMGfallNEVER; - for (i = 1; i < NofAMmeth; i++) { + for (i = 1; i < lim; i++) + amt.table[i] = Nullcv; + for (; i < NofAMmeth; i++) { char *cooky = PL_AMG_names[i]; - char *cp = AMG_id2name(i); /* Human-readable form, for debugging */ + /* Human-readable form, for debugging: */ + char *cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i)); STRLEN l = strlen(cooky); DEBUG_o( Perl_deb(aTHX_ "Checking overloading of `%s' in package `%.256s'\n", @@ -1231,13 +1234,17 @@ Perl_Gv_AMupdate(pTHX_ HV *stash) cp, HvNAME(stash), HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv))) ); filled = 1; + if (i < DESTROY_amg) + have_ovl = 1; } amt.table[i]=(CV*)SvREFCNT_inc(cv); } if (filled) { AMT_AMAGIC_on(&amt); + if (have_ovl) + AMT_OVERLOADED_on(&amt); sv_magic((SV*)stash, 0, 'c', (char*)&amt, sizeof(AMT)); - return TRUE; + return have_ovl; } } /* Here we have no table: */ @@ -1247,6 +1254,29 @@ Perl_Gv_AMupdate(pTHX_ HV *stash) return FALSE; } + +CV* +Perl_gv_handler(pTHX_ HV *stash, I32 id) +{ + dTHR; + MAGIC *mg = mg_find((SV*)stash,'c'); + AMT *amtp; + + if (!mg) { + do_update: + Gv_AMupdate(stash); + mg = mg_find((SV*)stash,'c'); + } + amtp = (AMT*)mg->mg_ptr; + if ( amtp->was_ok_am != PL_amagic_generation + || amtp->was_ok_sub != PL_sub_generation ) + goto do_update; + if (AMT_AMAGIC(amtp)) + return amtp->table[id]; + return Nullcv; +} + + SV* Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) { @@ -35,6 +35,10 @@ #define Perl_Gv_AMupdate pPerl->Perl_Gv_AMupdate #undef Gv_AMupdate #define Gv_AMupdate Perl_Gv_AMupdate +#undef Perl_gv_handler +#define Perl_gv_handler pPerl->Perl_gv_handler +#undef gv_handler +#define gv_handler Perl_gv_handler #undef Perl_apply_attrs_string #define Perl_apply_attrs_string pPerl->Perl_apply_attrs_string #undef apply_attrs_string @@ -3055,7 +3055,7 @@ enum { to_sv_amg, to_av_amg, to_hv_amg, to_gv_amg, to_cv_amg, iter_amg, - max_amg_code + DESTROY_amg, max_amg_code /* Do not leave a trailing comma here. C9X allows it, C89 doesn't. */ }; @@ -3101,6 +3101,7 @@ EXTCONST char * PL_AMG_names[NofAMmeth] = { "(${}", "(@{}", "(%{}", "(*{}", "(&{}", "(<>", + "DESTROY", }; #else EXTCONST char * PL_AMG_names[NofAMmeth]; @@ -3128,10 +3129,15 @@ typedef struct am_table_short AMTS; #define AMGfallYES 3 #define AMTf_AMAGIC 1 +#define AMTf_OVERLOADED 2 #define AMT_AMAGIC(amt) ((amt)->flags & AMTf_AMAGIC) #define AMT_AMAGIC_on(amt) ((amt)->flags |= AMTf_AMAGIC) #define AMT_AMAGIC_off(amt) ((amt)->flags &= ~AMTf_AMAGIC) +#define AMT_OVERLOADED(amt) ((amt)->flags & AMTf_OVERLOADED) +#define AMT_OVERLOADED_on(amt) ((amt)->flags |= AMTf_OVERLOADED) +#define AMT_OVERLOADED_off(amt) ((amt)->flags &= ~AMTf_OVERLOADED) +#define StashHANDLER(stash,meth) gv_handler((stash),CAT2(meth,_amg)) /* * some compilers like to redefine cos et alia as faster @@ -58,6 +58,7 @@ START_EXTERN_C # include "pp_proto.h" PERL_CALLCONV SV* Perl_amagic_call(pTHX_ SV* left, SV* right, int method, int dir); PERL_CALLCONV bool Perl_Gv_AMupdate(pTHX_ HV* stash); +PERL_CALLCONV CV* Perl_gv_handler(pTHX_ HV* stash, I32 id); PERL_CALLCONV OP* Perl_append_elem(pTHX_ I32 optype, OP* head, OP* tail); PERL_CALLCONV OP* Perl_append_list(pTHX_ I32 optype, LISTOP* first, LISTOP* last); PERL_CALLCONV I32 Perl_apply(pTHX_ I32 type, SV** mark, SV** sp); @@ -3721,7 +3721,7 @@ Perl_sv_clear(pTHX_ register SV *sv) if (SvOBJECT(sv)) { if (PL_defstash) { /* Still have a symbol table? */ djSP; - GV* destructor; + CV* destructor; SV tmpref; Zero(&tmpref, 1, SV); @@ -3730,9 +3730,9 @@ Perl_sv_clear(pTHX_ register SV *sv) SvREADONLY_on(&tmpref); /* DESTROY() could be naughty */ SvREFCNT(&tmpref) = 1; - do { + do { stash = SvSTASH(sv); - destructor = gv_fetchmethod(SvSTASH(sv), "DESTROY"); + destructor = StashHANDLER(stash,DESTROY); if (destructor) { ENTER; PUSHSTACKi(PERLSI_DESTROY); @@ -3741,8 +3741,7 @@ Perl_sv_clear(pTHX_ register SV *sv) PUSHMARK(SP); PUSHs(&tmpref); PUTBACK; - call_sv((SV*)GvCV(destructor), - G_DISCARD|G_EVAL|G_KEEPERR); + call_sv((SV*)destructor, G_DISCARD|G_EVAL|G_KEEPERR); SvREFCNT(sv)--; POPSTACK; SPAGAIN; diff --git a/t/pragma/overload.t b/t/pragma/overload.t index c7105dc9ca..bf24c07ec9 100755 --- a/t/pragma/overload.t +++ b/t/pragma/overload.t @@ -133,6 +133,7 @@ test ( $a eq "087"); # 29 test ( $b eq "88"); # 30 test (ref $a eq "Oscalar"); # 31 +undef $b; # Destroying updates tables too... eval q[package Oscalar; use overload ('++' => sub { $ {$_[0]} += 2; $_[0] } ) ]; |