X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=universal.c;h=251fbacca63df95accaab079a08fe846db262180;hb=fa36c1f0228e069bbe2ce9deb846c72334bb6f27;hp=705573e9f9288b6829b3d86f247d99c6cb478077;hpb=c8a14fb6c15fa7e7d9f1ce7bc6160eab4bca36af;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/universal.c b/universal.c
index 705573e..251fbac 100644
--- a/universal.c
+++ b/universal.c
@@ -32,7 +32,7 @@
  */
 
 STATIC bool
-S_isa_lookup(pTHX_ HV *stash, const char *name, HV* name_stash,
+S_isa_lookup(pTHX_ HV *stash, const char *name, const HV* const name_stash,
              int len, int level)
 {
     dVAR;
@@ -45,7 +45,7 @@ S_isa_lookup(pTHX_ HV *stash, const char *name, HV* name_stash,
 
     /* A stash/class can go by many names (ie. User == main::User), so 
        we compare the stash itself just in case */
-    if (name_stash && (stash == name_stash))
+    if (name_stash && ((const HV *)stash == name_stash))
         return TRUE;
 
     hvname = HvNAME_get(stash);
@@ -66,11 +66,14 @@ S_isa_lookup(pTHX_ HV *stash, const char *name, HV* name_stash,
 	&& (hv = GvHV(gv)))
     {
 	if (SvIV(subgen) == (IV)PL_sub_generation) {
-	    SV* sv;
 	    SV** const svp = (SV**)hv_fetch(hv, name, len, FALSE);
-	    if (svp && (sv = *svp) != (SV*)&PL_sv_undef) {
-	        DEBUG_o( Perl_deb(aTHX_ "Using cached ISA %s for package %s\n",
-				  name, hvname) );
+	    if (svp) {
+		SV * const sv = *svp;
+#ifdef DEBUGGING
+		if (sv != &PL_sv_undef)
+		    DEBUG_o( Perl_deb(aTHX_ "Using cached ISA %s for package %s\n",
+				    name, hvname) );
+#endif
 		return (sv == &PL_sv_yes);
 	    }
 	}
@@ -166,10 +169,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 +263,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 +375,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;
@@ -413,14 +486,10 @@ XS(XS_version_new)
 		? HvNAME(SvSTASH(SvRV(ST(0))))
 		: (char *)SvPV_nolen(ST(0));
 
-	if ( items == 1 ) {
-	    /* no parameter provided */
-	    if ( sv_isobject(ST(0)) )
-	    {
-		/* create empty object */
-		vs = sv_newmortal();
-		sv_setpvn(vs,"",0);
-	    }
+	if ( items == 1 || vs == &PL_sv_undef ) { /* no param or explicit undef */
+	    /* create empty object */
+	    vs = sv_newmortal();
+	    sv_setpvn(vs,"",0);
 	}
 	else if ( items == 3 ) {
 	    vs = sv_newmortal();
@@ -619,7 +688,14 @@ XS(XS_version_qv)
 	    if ( SvNOK(ver) ) /* may get too much accuracy */
 	    {
 		char tbuf[64];
-		const STRLEN len = my_snprintf(tbuf, sizeof(tbuf), "%.9"NVgf, SvNVX(ver));
+#ifdef USE_LOCALE_NUMERIC
+		char *loc = setlocale(LC_NUMERIC, "C");
+#endif
+		STRLEN len = my_snprintf(tbuf, sizeof(tbuf), "%.9"NVgf, SvNVX(ver));
+#ifdef USE_LOCALE_NUMERIC
+		setlocale(LC_NUMERIC, loc);
+#endif
+		while (tbuf[len-1] == '0' && len > 0) len--;
 		version = savepvn(tbuf, len);
 	    }
 	    else