X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=universal.c;h=3df8321f9cf586a1274f805851d9b06afdaf643f;hb=716b4790df6f17d149d5436bbd66ba94395be359;hp=1a76cfd8848973493965ded3610e2dc80ada80f6;hpb=85a79b09b8bc5e91d2e64794fda42d63aa8f1f2f;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/universal.c b/universal.c
index 1a76cfd..3df8321 100644
--- a/universal.c
+++ b/universal.c
@@ -172,8 +172,10 @@ Perl_sv_does(pTHX_ SV *sv, const char *const name)
     SvGETMAGIC(sv);
 
     if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
-		|| (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
+	    || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv)))) {
+	LEAVE;
 	return FALSE;
+    }
 
     if (sv_isobject(sv)) {
 	classname = sv_reftype(SvRV(sv),TRUE);
@@ -181,8 +183,10 @@ Perl_sv_does(pTHX_ SV *sv, const char *const name)
 	classname = SvPV_nolen(sv);
     }
 
-    if (strEQ(name,classname))
+    if (strEQ(name,classname)) {
+	LEAVE;
 	return TRUE;
+    }
 
     PUSHMARK(SP);
     XPUSHs(sv);
@@ -204,120 +208,6 @@ Perl_sv_does(pTHX_ SV *sv, const char *const name)
     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);
-XS(XS_version_numify);
-XS(XS_version_normal);
-XS(XS_version_vcmp);
-XS(XS_version_boolean);
-#ifdef HASATTRIBUTE_NORETURN
-XS(XS_version_noop) __attribute__noreturn__;
-#else
-XS(XS_version_noop);
-#endif
-XS(XS_version_is_alpha);
-XS(XS_version_qv);
-XS(XS_utf8_is_utf8);
-XS(XS_utf8_valid);
-XS(XS_utf8_encode);
-XS(XS_utf8_decode);
-XS(XS_utf8_upgrade);
-XS(XS_utf8_downgrade);
-XS(XS_utf8_unicode_to_native);
-XS(XS_utf8_native_to_unicode);
-XS(XS_Internals_SvREADONLY);
-XS(XS_Internals_SvREFCNT);
-XS(XS_Internals_hv_clear_placehold);
-XS(XS_PerlIO_get_layers);
-XS(XS_Internals_hash_seed);
-XS(XS_Internals_rehash_seed);
-XS(XS_Internals_HvREHASH);
-XS(XS_re_is_regexp); 
-XS(XS_re_regname);
-XS(XS_re_regnames);
-XS(XS_re_regnames_count);
-XS(XS_re_regexp_pattern);
-XS(XS_Tie_Hash_NamedCapture_FETCH);
-XS(XS_Tie_Hash_NamedCapture_STORE);
-XS(XS_Tie_Hash_NamedCapture_DELETE);
-XS(XS_Tie_Hash_NamedCapture_CLEAR);
-XS(XS_Tie_Hash_NamedCapture_EXISTS);
-XS(XS_Tie_Hash_NamedCapture_FIRSTK);
-XS(XS_Tie_Hash_NamedCapture_NEXTK);
-XS(XS_Tie_Hash_NamedCapture_SCALAR);
-XS(XS_Tie_Hash_NamedCapture_flags);
-
-void
-Perl_boot_core_UNIVERSAL(pTHX)
-{
-    dVAR;
-    static const char file[] = __FILE__;
-
-    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 */
-	PL_amagic_generation++;
-	/* Make it findable via fetchmethod */
-	newXS("version::()", XS_version_noop, file);
-	newXS("version::new", XS_version_new, file);
-	newXS("version::(\"\"", XS_version_stringify, file);
-	newXS("version::stringify", XS_version_stringify, file);
-	newXS("version::(0+", XS_version_numify, file);
-	newXS("version::numify", XS_version_numify, file);
-	newXS("version::normal", XS_version_normal, file);
-	newXS("version::(cmp", XS_version_vcmp, file);
-	newXS("version::(<=>", XS_version_vcmp, file);
-	newXS("version::vcmp", XS_version_vcmp, file);
-	newXS("version::(bool", XS_version_boolean, file);
-	newXS("version::boolean", XS_version_boolean, file);
-	newXS("version::(nomethod", XS_version_noop, file);
-	newXS("version::noop", XS_version_noop, file);
-	newXS("version::is_alpha", XS_version_is_alpha, file);
-	newXS("version::qv", XS_version_qv, file);
-    }
-    newXS("utf8::is_utf8", XS_utf8_is_utf8, file);
-    newXS("utf8::valid", XS_utf8_valid, file);
-    newXS("utf8::encode", XS_utf8_encode, file);
-    newXS("utf8::decode", XS_utf8_decode, file);
-    newXS("utf8::upgrade", XS_utf8_upgrade, file);
-    newXS("utf8::downgrade", XS_utf8_downgrade, file);
-    newXS("utf8::native_to_unicode", XS_utf8_native_to_unicode, file);
-    newXS("utf8::unicode_to_native", XS_utf8_unicode_to_native, file);
-    newXSproto("Internals::SvREADONLY",XS_Internals_SvREADONLY, file, "\\[$%@];$");
-    newXSproto("Internals::SvREFCNT",XS_Internals_SvREFCNT, file, "\\[$%@];$");
-    newXSproto("Internals::hv_clear_placeholders",
-               XS_Internals_hv_clear_placehold, file, "\\%");
-    newXSproto("PerlIO::get_layers",
-               XS_PerlIO_get_layers, file, "*;@");
-    /* Providing a Regexp::DESTROY fixes #21347. See test in t/op/ref.t  */
-    CvFILE(newCONSTSUB(get_hv("Regexp::", GV_ADD), "DESTROY", NULL))
-	= (char *)file;
-    newXSproto("Internals::hash_seed",XS_Internals_hash_seed, file, "");
-    newXSproto("Internals::rehash_seed",XS_Internals_rehash_seed, file, "");
-    newXSproto("Internals::HvREHASH", XS_Internals_HvREHASH, file, "\\%");
-    newXSproto("re::is_regexp", XS_re_is_regexp, file, "$");
-    newXSproto("re::regname", XS_re_regname, file, ";$$");
-    newXSproto("re::regnames", XS_re_regnames, file, ";$");
-    newXSproto("re::regnames_count", XS_re_regnames_count, file, "");
-    newXSproto("re::regexp_pattern", XS_re_regexp_pattern, file, "$");
-    newXS("Tie::Hash::NamedCapture::FETCH", XS_Tie_Hash_NamedCapture_FETCH, file);
-    newXS("Tie::Hash::NamedCapture::STORE", XS_Tie_Hash_NamedCapture_STORE, file);
-    newXS("Tie::Hash::NamedCapture::DELETE", XS_Tie_Hash_NamedCapture_DELETE, file);
-    newXS("Tie::Hash::NamedCapture::CLEAR", XS_Tie_Hash_NamedCapture_CLEAR, file);
-    newXS("Tie::Hash::NamedCapture::EXISTS", XS_Tie_Hash_NamedCapture_EXISTS, file);
-    newXS("Tie::Hash::NamedCapture::FIRSTKEY", XS_Tie_Hash_NamedCapture_FIRSTK, file);
-    newXS("Tie::Hash::NamedCapture::NEXTKEY", XS_Tie_Hash_NamedCapture_NEXTK, file);
-    newXS("Tie::Hash::NamedCapture::SCALAR", XS_Tie_Hash_NamedCapture_SCALAR, file);
-    newXS("Tie::Hash::NamedCapture::flags", XS_Tie_Hash_NamedCapture_flags, file);
-}
-
 /*
 =for apidoc croak_xs_usage
 
@@ -328,7 +218,7 @@ A specialised variant of C<croak()> for emitting the usage message for xsubs
 works out the package name and subroutine name from C<cv>, and then calls
 C<croak()>. Hence if C<cv> is C<&ouch::awk>, it would call C<croak> as:
 
-    Perl_croak(aTHX_ "Usage %s::%s(%s)", "ouch" "awk", "eee_yow");
+    Perl_croak(aTHX_ "Usage: %s::%s(%s)", "ouch" "awk", "eee_yow");
 
 =cut
 */
@@ -538,10 +428,10 @@ XS(XS_version_new)
 		? HvNAME(SvSTASH(SvRV(ST(0))))
 		: (char *)SvPV_nolen(ST(0));
 
-	if ( items == 1 || vs == &PL_sv_undef ) { /* no param or explicit undef */
+	if ( items == 1 || ! SvOK(vs) ) { /* no param or explicit undef */
 	    /* create empty object */
 	    vs = sv_newmortal();
-	    sv_setpvs(vs,"");
+	    sv_setpvs(vs, "0");
 	}
 	else if ( items == 3 ) {
 	    vs = sv_newmortal();
@@ -651,7 +541,7 @@ XS(XS_version_vcmp)
 
 	       if ( ! sv_derived_from(robj, "version") )
 	       {
-		    robj = new_version(robj);
+		    robj = new_version(SvOK(robj) ? robj : newSVpvs("0"));
 	       }
 	       rvs = SvRV(robj);
 
@@ -729,25 +619,54 @@ XS(XS_version_qv)
 {
     dVAR;
     dXSARGS;
-    if (items != 1)
-	croak_xs_usage(cv, "ver");
+    PERL_UNUSED_ARG(cv);
     SP -= items;
     {
-	SV *	ver = ST(0);
-	if ( !SvVOK(ver) ) { /* only need to do with if not already v-string */
-	    SV * const rv = sv_newmortal();
+	SV * ver = ST(0);
+	SV * rv;
+	const char * classname = "";
+	if ( items == 2 && SvOK(ST(1)) ) {
+	    /* getting called as object or class method */
+	    ver = ST(1);
+	    classname = 
+		sv_isobject(ST(0)) /* class called as an object method */
+		    ? HvNAME_get(SvSTASH(SvRV(ST(0))))
+		    : (char *)SvPV_nolen(ST(0));
+	}
+	if ( !SvVOK(ver) ) { /* not already a v-string */
+	    rv = sv_newmortal();
 	    sv_setsv(rv,ver); /* make a duplicate */
 	    upg_version(rv, TRUE);
-	    PUSHs(rv);
+	} else {
+	    rv = sv_2mortal(new_version(ver));
 	}
-	else
-	{
-	    mPUSHs(new_version(ver));
+	if ( items == 2 && strcmp(classname,"version") ) { /* inherited new() */
+	    sv_bless(rv, gv_stashpv(classname, GV_ADD));
 	}
+	PUSHs(rv);
+    }
+    PUTBACK;
+    return;
+}
 
+XS(XS_version_is_qv)
+{
+    dVAR;
+    dXSARGS;
+    if (items != 1)
+	croak_xs_usage(cv, "lobj");
+    SP -= items;
+    if (sv_derived_from(ST(0), "version")) {
+	SV * const lobj = ST(0);
+	if ( hv_exists(MUTABLE_HV(SvRV(lobj)), "qv", 2 ) )
+	    XSRETURN_YES;
+	else
+	    XSRETURN_NO;
 	PUTBACK;
 	return;
     }
+    else
+	Perl_croak(aTHX_ "lobj is not of type version");
 }
 
 XS(XS_utf8_is_utf8)
@@ -757,7 +676,8 @@ XS(XS_utf8_is_utf8)
      if (items != 1)
 	 croak_xs_usage(cv, "sv");
      else {
-	const SV * const sv = ST(0);
+	SV * const sv = ST(0);
+	SvGETMAGIC(sv);
 	    if (SvUTF8(sv))
 		XSRETURN_YES;
 	    else
@@ -1252,10 +1172,10 @@ XS(XS_re_regexp_pattern)
 
     if ((re = SvRX(ST(0)))) /* assign deliberate */
     {
-        /* Housten, we have a regex! */
+        /* Houston, we have a regex! */
         SV *pattern;
         STRLEN left = 0;
-        char reflags[6];
+        char reflags[sizeof(INT_PAT_MODS)];
 
         if ( GIMME_V == G_ARRAY ) {
             /*
@@ -1331,7 +1251,7 @@ XS(XS_Tie_Hash_NamedCapture_FETCH)
 
     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
 
-    if (!rx)
+    if (!rx || !SvROK(ST(0)))
         XSRETURN_UNDEF;
 
     SP -= items;
@@ -1361,7 +1281,7 @@ XS(XS_Tie_Hash_NamedCapture_STORE)
 
     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
 
-    if (!rx) {
+    if (!rx || !SvROK(ST(0))) {
         if (!PL_localizing)
             Perl_croak(aTHX_ "%s", PL_no_modify);
         else
@@ -1384,7 +1304,7 @@ XS(XS_Tie_Hash_NamedCapture_DELETE)
     if (items != 2)
 	croak_xs_usage(cv, "$key, $flags");
 
-    if (!rx)
+    if (!rx || !SvROK(ST(0)))
         Perl_croak(aTHX_ "%s", PL_no_modify);
 
     SP -= items;
@@ -1405,7 +1325,7 @@ XS(XS_Tie_Hash_NamedCapture_CLEAR)
 
     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
 
-    if (!rx)
+    if (!rx || !SvROK(ST(0)))
         Perl_croak(aTHX_ "%s", PL_no_modify);
 
     SP -= items;
@@ -1427,7 +1347,7 @@ XS(XS_Tie_Hash_NamedCapture_EXISTS)
 
     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
 
-    if (!rx)
+    if (!rx || !SvROK(ST(0)))
         XSRETURN_UNDEF;
 
     SP -= items;
@@ -1455,7 +1375,7 @@ XS(XS_Tie_Hash_NamedCapture_FIRSTK)
 
     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
 
-    if (!rx)
+    if (!rx || !SvROK(ST(0)))
         XSRETURN_UNDEF;
 
     SP -= items;
@@ -1487,7 +1407,7 @@ XS(XS_Tie_Hash_NamedCapture_NEXTK)
 
     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
 
-    if (!rx)
+    if (!rx || !SvROK(ST(0)))
         XSRETURN_UNDEF;
 
     SP -= items;
@@ -1518,7 +1438,7 @@ XS(XS_Tie_Hash_NamedCapture_SCALAR)
 
     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
 
-    if (!rx)
+    if (!rx || !SvROK(ST(0)))
         XSRETURN_UNDEF;
 
     SP -= items;
@@ -1551,6 +1471,87 @@ XS(XS_Tie_Hash_NamedCapture_flags)
 	return;
 }
 
+struct xsub_details {
+    const char *name;
+    XSUBADDR_t xsub;
+    const char *proto;
+};
+
+struct xsub_details details[] = {
+    {"UNIVERSAL::isa", XS_UNIVERSAL_isa, NULL},
+    {"UNIVERSAL::can", XS_UNIVERSAL_can, NULL},
+    {"UNIVERSAL::DOES", XS_UNIVERSAL_DOES, NULL},
+    {"UNIVERSAL::VERSION", XS_UNIVERSAL_VERSION, NULL},
+    {"version::()", XS_version_noop, NULL},
+    {"version::new", XS_version_new, NULL},
+    {"version::parse", XS_version_new, NULL},
+    {"version::(\"\"", XS_version_stringify, NULL},
+    {"version::stringify", XS_version_stringify, NULL},
+    {"version::(0+", XS_version_numify, NULL},
+    {"version::numify", XS_version_numify, NULL},
+    {"version::normal", XS_version_normal, NULL},
+    {"version::(cmp", XS_version_vcmp, NULL},
+    {"version::(<=>", XS_version_vcmp, NULL},
+    {"version::vcmp", XS_version_vcmp, NULL},
+    {"version::(bool", XS_version_boolean, NULL},
+    {"version::boolean", XS_version_boolean, NULL},
+    {"version::(nomethod", XS_version_noop, NULL},
+    {"version::noop", XS_version_noop, NULL},
+    {"version::is_alpha", XS_version_is_alpha, NULL},
+    {"version::qv", XS_version_qv, NULL},
+    {"version::declare", XS_version_qv, NULL},
+    {"version::is_qv", XS_version_is_qv, NULL},
+    {"utf8::is_utf8", XS_utf8_is_utf8, NULL},
+    {"utf8::valid", XS_utf8_valid, NULL},
+    {"utf8::encode", XS_utf8_encode, NULL},
+    {"utf8::decode", XS_utf8_decode, NULL},
+    {"utf8::upgrade", XS_utf8_upgrade, NULL},
+    {"utf8::downgrade", XS_utf8_downgrade, NULL},
+    {"utf8::native_to_unicode", XS_utf8_native_to_unicode, NULL},
+    {"utf8::unicode_to_native", XS_utf8_unicode_to_native, NULL},
+    {"Internals::SvREADONLY", XS_Internals_SvREADONLY, "\\[$%@];$"},
+    {"Internals::SvREFCNT", XS_Internals_SvREFCNT, "\\[$%@];$"},
+    {"Internals::hv_clear_placeholders", XS_Internals_hv_clear_placehold, "\\%"},
+    {"PerlIO::get_layers", XS_PerlIO_get_layers, "*;@"},
+    {"Internals::hash_seed", XS_Internals_hash_seed, ""},
+    {"Internals::rehash_seed", XS_Internals_rehash_seed, ""},
+    {"Internals::HvREHASH", XS_Internals_HvREHASH, "\\%"},
+    {"re::is_regexp", XS_re_is_regexp, "$"},
+    {"re::regname", XS_re_regname, ";$$"},
+    {"re::regnames", XS_re_regnames, ";$"},
+    {"re::regnames_count", XS_re_regnames_count, ""},
+    {"re::regexp_pattern", XS_re_regexp_pattern, "$"},
+    {"Tie::Hash::NamedCapture::FETCH", XS_Tie_Hash_NamedCapture_FETCH, NULL},
+    {"Tie::Hash::NamedCapture::STORE", XS_Tie_Hash_NamedCapture_STORE, NULL},
+    {"Tie::Hash::NamedCapture::DELETE", XS_Tie_Hash_NamedCapture_DELETE, NULL},
+    {"Tie::Hash::NamedCapture::CLEAR", XS_Tie_Hash_NamedCapture_CLEAR, NULL},
+    {"Tie::Hash::NamedCapture::EXISTS", XS_Tie_Hash_NamedCapture_EXISTS, NULL},
+    {"Tie::Hash::NamedCapture::FIRSTKEY", XS_Tie_Hash_NamedCapture_FIRSTK, NULL},
+    {"Tie::Hash::NamedCapture::NEXTKEY", XS_Tie_Hash_NamedCapture_NEXTK, NULL},
+    {"Tie::Hash::NamedCapture::SCALAR", XS_Tie_Hash_NamedCapture_SCALAR, NULL},
+    {"Tie::Hash::NamedCapture::flags", XS_Tie_Hash_NamedCapture_flags, NULL}
+};
+
+void
+Perl_boot_core_UNIVERSAL(pTHX)
+{
+    dVAR;
+    static const char file[] = __FILE__;
+    struct xsub_details *xsub = details;
+    const struct xsub_details *end
+	= details + sizeof(details) / sizeof(details[0]);
+
+    do {
+	newXS_flags(xsub->name, xsub->xsub, file, xsub->proto, 0);
+    } while (++xsub < end);
+
+    /* register the overloading (type 'A') magic */
+    PL_amagic_generation++;
+
+    /* Providing a Regexp::DESTROY fixes #21347. See test in t/op/ref.t  */
+    CvFILE(newCONSTSUB(get_hv("Regexp::", GV_ADD), "DESTROY", NULL))
+	= (char *)file;
+}
 
 /*
  * Local variables: