From: chromatic Date: Tue, 30 May 2006 17:41:08 +0000 (-0700) Subject: Add the new method UNIVERSAL::DOES() and the API function sv_does() X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=cbc021f9c76c5db718d993d3cc885284fbbff80f;p=p5sagit%2Fp5-mst-13.2.git Add the new method UNIVERSAL::DOES() and the API function sv_does() Subject: Re: [PROPOSED PATCH: universal.c, t/op/universal.t] Add does() Message-Id: <200605301741.08363.chromatic@wgz.org> p4raw-id: //depot/perl@28387 --- diff --git a/embed.fnc b/embed.fnc index 4ffa057..ed7d397 100644 --- a/embed.fnc +++ b/embed.fnc @@ -809,6 +809,7 @@ Apd |int |getcwd_sv |NN SV* sv Apd |void |sv_dec |NN SV* sv Ap |void |sv_dump |NN SV* sv ApdR |bool |sv_derived_from|NN SV* sv|NN const char* name +ApdR |bool |sv_does |NN SV* sv|NN const char* name Apd |I32 |sv_eq |NULLOK SV* sv1|NULLOK SV* sv2 Apd |void |sv_free |NULLOK SV* sv poMX |void |sv_free2 |NN SV* sv diff --git a/embed.h b/embed.h index 95b2de2..d2de6e9 100644 --- a/embed.h +++ b/embed.h @@ -842,6 +842,7 @@ #define sv_dec Perl_sv_dec #define sv_dump Perl_sv_dump #define sv_derived_from Perl_sv_derived_from +#define sv_does Perl_sv_does #define sv_eq Perl_sv_eq #define sv_free Perl_sv_free #ifdef PERL_CORE @@ -3027,6 +3028,7 @@ #define sv_dec(a) Perl_sv_dec(aTHX_ a) #define sv_dump(a) Perl_sv_dump(aTHX_ a) #define sv_derived_from(a,b) Perl_sv_derived_from(aTHX_ a,b) +#define sv_does(a,b) Perl_sv_does(aTHX_ a,b) #define sv_eq(a,b) Perl_sv_eq(aTHX_ a,b) #define sv_free(a) Perl_sv_free(aTHX_ a) #ifdef PERL_CORE diff --git a/global.sym b/global.sym index e1ce974..bf8b843 100644 --- a/global.sym +++ b/global.sym @@ -484,6 +484,7 @@ Perl_getcwd_sv Perl_sv_dec Perl_sv_dump Perl_sv_derived_from +Perl_sv_does Perl_sv_eq Perl_sv_free Perl_sv_free2 diff --git a/pod/perlapi.pod b/pod/perlapi.pod index ca9dfa3..dad3072 100644 --- a/pod/perlapi.pod +++ b/pod/perlapi.pod @@ -4637,6 +4637,17 @@ normal Perl method. =for hackers Found in file universal.c +=item sv_does +X + +Returns a boolean indicating whether the SV performs a specific, named role. +The SV can be a Perl object or the name of a Perl class. + + bool sv_does(SV* sv, const char* name) + +=for hackers +Found in file universal.c + =item sv_report_used X diff --git a/proto.h b/proto.h index a0d5dec..e1ba341 100644 --- a/proto.h +++ b/proto.h @@ -2212,6 +2212,11 @@ PERL_CALLCONV bool Perl_sv_derived_from(pTHX_ SV* sv, const char* name) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); +PERL_CALLCONV bool Perl_sv_does(pTHX_ SV* sv, const char* name) + __attribute__warn_unused_result__ + __attribute__nonnull__(pTHX_1) + __attribute__nonnull__(pTHX_2); + PERL_CALLCONV I32 Perl_sv_eq(pTHX_ SV* sv1, SV* sv2); PERL_CALLCONV void Perl_sv_free(pTHX_ SV* sv); PERL_CALLCONV void Perl_sv_free2(pTHX_ SV* sv) diff --git a/t/op/universal.t b/t/op/universal.t index 1850127..e37bfc7 100755 --- a/t/op/universal.t +++ b/t/op/universal.t @@ -10,7 +10,7 @@ BEGIN { require "./test.pl"; } -plan tests => 104; +plan tests => 109; $a = {}; bless $a, "Bob"; @@ -123,9 +123,9 @@ my $subs = join ' ', sort grep { defined &{"UNIVERSAL::$_"} } keys %UNIVERSAL::; ## The test for import here is *not* because we want to ensure that UNIVERSAL ## can always import; it is an historical accident that UNIVERSAL can import. if ('a' lt 'A') { - is $subs, "can import isa VERSION"; + is $subs, "can does import isa VERSION"; } else { - is $subs, "VERSION can import isa"; + is $subs, "VERSION can does import isa"; } ok $a->isa("UNIVERSAL"); @@ -146,9 +146,9 @@ ok $a->isa("UNIVERSAL"); my $sub2 = join ' ', sort grep { defined &{"UNIVERSAL::$_"} } keys %UNIVERSAL::; # XXX import being here is really a bug if ('a' lt 'A') { - is $sub2, "can import isa VERSION"; + is $sub2, "can does import isa VERSION"; } else { - is $sub2, "VERSION can import isa"; + is $sub2, "VERSION can does import isa"; } eval 'sub UNIVERSAL::sleep {}'; @@ -200,3 +200,19 @@ is $@, ''; # This segfaulted in a blead. fresh_perl_is('package Foo; Foo->VERSION; print "ok"', 'ok'); +package Foo; + +sub does { 1 } + +package Bar; + +@Bar::ISA = 'Foo'; + +package Baz; + +package main; +ok( Foo->does( 'bar' ), 'does() should call does() on class' ); +ok( Bar->does( 'Bar' ), '... and should fall back to isa()' ); +ok( Bar->does( 'Foo' ), '... even when inherited' ); +ok( Baz->does( 'Baz' ), '... even without inheriting any other does()' ); +ok( ! Baz->does( 'Foo' ), '... returning true or false appropriately' ); diff --git a/universal.c b/universal.c index a1e91b7..7cbaaf7 100644 --- a/universal.c +++ b/universal.c @@ -166,10 +166,60 @@ Perl_sv_derived_from(pTHX_ SV *sv, const char *name) } +/* +=for apidoc sv_does + +Returns a boolean indicating whether the SV performs a specific, named role. +The SV can be a Perl object or the name of a Perl class. + +=cut +*/ + #include "XSUB.h" +bool +Perl_sv_does(pTHX_ SV *sv, const char *name) +{ + const char *classname; + bool does_it; + + dSP; + ENTER; + SAVETMPS; + + SvGETMAGIC(sv); + + if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv)) + || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv)))) + return FALSE; + + if (sv_isobject(sv)) { + classname = sv_reftype(SvRV(sv),TRUE); + } else { + classname = SvPV(sv,PL_na); + } + + if (strEQ(name,classname)) + return TRUE; + + PUSHMARK(SP); + XPUSHs(sv); + XPUSHs(sv_2mortal(newSVpv(name, 0))); + PUTBACK; + + call_method("isa", G_SCALAR); + SPAGAIN; + + does_it = SvTRUE( TOPs ); + FREETMPS; + LEAVE; + + return does_it; +} + PERL_XS_EXPORT_C void XS_UNIVERSAL_isa(pTHX_ CV *cv); PERL_XS_EXPORT_C void XS_UNIVERSAL_can(pTHX_ CV *cv); +PERL_XS_EXPORT_C void XS_UNIVERSAL_DOES(pTHX_ CV *cv); PERL_XS_EXPORT_C void XS_UNIVERSAL_VERSION(pTHX_ CV *cv); XS(XS_version_new); XS(XS_version_stringify); @@ -210,6 +260,7 @@ Perl_boot_core_UNIVERSAL(pTHX) newXS("UNIVERSAL::isa", XS_UNIVERSAL_isa, file); newXS("UNIVERSAL::can", XS_UNIVERSAL_can, file); + newXS("UNIVERSAL::DOES", XS_UNIVERSAL_DOES, file); newXS("UNIVERSAL::VERSION", XS_UNIVERSAL_VERSION, file); { /* register the overloading (type 'A') magic */ @@ -321,6 +372,25 @@ XS(XS_UNIVERSAL_can) XSRETURN(1); } +XS(XS_UNIVERSAL_DOES) +{ + dVAR; + dXSARGS; + + if (items != 2) + Perl_croak(aTHX_ "Usage: invocant->does(kind)"); + else { + SV * const sv = ST(0); + const char *name; + + name = SvPV_nolen_const(ST(1)); + if (sv_does( sv, name )) + XSRETURN_YES; + + XSRETURN_NO; + } +} + XS(XS_UNIVERSAL_VERSION) { dVAR;