From: gfx Date: Fri, 26 Feb 2010 07:28:19 +0000 (+0900) Subject: Implement install_subroutines in XS X-Git-Tag: 0.50_04~7 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=d67f600df9deb0deb95616f617c1aca3fd78a2e3;p=gitmo%2FMouse.git Implement install_subroutines in XS --- diff --git a/lib/Mouse/Util.pm b/lib/Mouse/Util.pm index b24cc31..98dd137 100644 --- a/lib/Mouse/Util.pm +++ b/lib/Mouse/Util.pm @@ -60,6 +60,7 @@ BEGIN{ (my $hack_mouse_file = __FILE__) =~ s/.Util//; # .../Mouse/Util.pm -> .../Mouse.pm $xs = eval sprintf("#line %d %s\n", __LINE__, $hack_mouse_file) . q{ + local $^W = 0; # work around 'redefine' warning to &install_subroutines require XSLoader; XSLoader::load('Mouse', $VERSION); Mouse::Util->import({ into => 'Mouse::Meta::Method::Constructor::XS' }, ':meta'); diff --git a/mouse.h b/mouse.h index 01518fd..e58d8ae 100644 --- a/mouse.h +++ b/mouse.h @@ -101,6 +101,7 @@ GV* mouse_stash_fetch(pTHX_ HV* const stash, const char* const name, I32 const n #define stash_fetch(s, n, l, c) mouse_stash_fetch(aTHX_ (s), (n), (l), (c)) #define stash_fetchs(s, n, c) mouse_stash_fetch(aTHX_ (s), STR_WITH_LEN(n), (c)) +void mouse_install_sub(pTHX_ GV* const gv, SV* const code_ref); #define MOUSEf_DIE_ON_FAIL 0x01 MAGIC* mouse_mg_find(pTHX_ SV* const sv, const MGVTBL* const vtbl, I32 const flags); diff --git a/xs-src/Mouse.xs b/xs-src/Mouse.xs index 1759d04..f435464 100644 --- a/xs-src/Mouse.xs +++ b/xs-src/Mouse.xs @@ -535,42 +535,8 @@ CODE: /* *{$package . '::' . $name} -> *gv */ gv = gv_fetchpv(form("%"SVf"::%"SVf, package, name), GV_ADDMULTI, SVt_PVCV); - if(GvCVu(gv)){ /* delete *slot{gv} to work around "redefine" warning */ - SvREFCNT_dec(GvCV(gv)); - GvCV(gv) = NULL; - } - sv_setsv_mg((SV*)gv, code_ref); /* *gv = $code_ref */ - + mouse_install_sub(aTHX_ gv, code_ref); (void)set_slot(methods, name, code); /* $self->{methods}{$name} = $code */ - - /* name the CODE ref if it's anonymous */ - { - CV* const code_entity = (CV*)SvRV(code_ref); - if(CvANON(code_entity) - && CvGV(code_entity) /* a cv under construction has no gv */ ){ - HV* dbsub; - - /* update %DB::sub to make NYTProf happy */ - if((PL_perldb & (PERLDBf_SUBLINE|PERLDB_NAMEANON)) - && PL_DBsub && (dbsub = GvHV(PL_DBsub)) - ){ - /* see Perl_newATTRSUB() in op.c */ - SV* const subname = sv_newmortal(); - HE* orig; - - gv_efullname3(subname, CvGV(code_entity), NULL); - orig = hv_fetch_ent(dbsub, subname, FALSE, 0U); - if(orig){ - gv_efullname3(subname, gv, NULL); - (void)hv_store_ent(dbsub, subname, HeVAL(orig), 0U); - SvREFCNT_inc_simple_void_NN(HeVAL(orig)); - } - } - - CvGV(code_entity) = gv; - CvANON_off(code_entity); - } - } } MODULE = Mouse PACKAGE = Mouse::Meta::Class diff --git a/xs-src/MouseUtil.xs b/xs-src/MouseUtil.xs index 92fa676..aba91be 100644 --- a/xs-src/MouseUtil.xs +++ b/xs-src/MouseUtil.xs @@ -259,6 +259,49 @@ mouse_stash_fetch(pTHX_ HV* const stash, const char* const name, I32 const namel } } +void +mouse_install_sub(pTHX_ GV* const gv, SV* const code_ref) { + CV* cv; + + assert(gv != NULL); + assert(code_ref != NULL); + assert(isGV(gv)); + assert(IsCodeRef(code_ref)); + + if(GvCVu(gv)){ /* delete *slot{gv} to work around "redefine" warning */ + SvREFCNT_dec(GvCV(gv)); + GvCV(gv) = NULL; + } + sv_setsv_mg((SV*)gv, code_ref); /* *gv = $code_ref */ + + /* name the CODE ref if it's anonymous */ + cv = (CV*)SvRV(code_ref); + if(CvANON(cv) + && CvGV(cv) /* a cv under construction has no gv */ ){ + HV* dbsub; + + /* update %DB::sub to make NYTProf happy */ + if((PL_perldb & (PERLDBf_SUBLINE|PERLDB_NAMEANON)) + && PL_DBsub && (dbsub = GvHV(PL_DBsub)) + ){ + /* see Perl_newATTRSUB() in op.c */ + SV* const subname = sv_newmortal(); + HE* orig; + + gv_efullname3(subname, CvGV(cv), NULL); + orig = hv_fetch_ent(dbsub, subname, FALSE, 0U); + if(orig){ + gv_efullname3(subname, gv, NULL); + (void)hv_store_ent(dbsub, subname, HeVAL(orig), 0U); + SvREFCNT_inc_simple_void_NN(HeVAL(orig)); + } + } + + CvGV(cv) = gv; + CvANON_off(cv); + } +} + MODULE = Mouse::Util PACKAGE = Mouse::Util PROTOTYPES: DISABLE @@ -348,10 +391,10 @@ CODE: GV* gv; if(!SvOK(package)){ - croak("You must define a package name"); + croak("You must define %s", "a package name"); } if(!SvOK(name)){ - croak("You must define a subroutine name"); + croak("You must define %s", "a subroutine name"); } stash = gv_stashsv(package, FALSE); @@ -405,3 +448,44 @@ PPCODE: mXPUSHs( newRV_inc((SV*)xsub) ); } } + +# This xsub will redefine &Mouse::Util::install_subroutines() +void +install_subroutines(SV* into, ...) +CODE: +{ + HV* stash; + I32 i; + + SvGETMAGIC(into); + if(!SvOK(into)){ + croak("You must define %s", "a package name"); + } + stash = gv_stashsv(into, TRUE); + + if( ((items-1) % 2) != 0 ){ + croak_xs_usage(cv, "into, name => coderef [, other_name, other_coderef ...]"); + } + + for(i = 1; i < items; i += 2) { + SV* const name = ST(i); + SV* const code = ST(i+1); + STRLEN len; + const char* pv; + GV* gv; + + SvGETMAGIC(name); + if(!SvOK(name)){ + croak("You must define %s", "a subroutine name"); + } + SvGETMAGIC(code); + if(!IsCodeRef(code)){ + croak("You must define %s", "a CODE reference"); + } + + pv = SvPV_const(name, len); + gv = stash_fetch(stash, pv, len, TRUE); + + mouse_install_sub(aTHX_ gv, code); + } +}