move version details to version::Internals and other clean up

[perl5.git] / universal.c

diff --git a/universal.c b/universal.c
index 61398fe..ce56d0b 100644 (file)
--- 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);
@@ -221,6 +225,7 @@ XS(XS_version_noop);
 #endif
 XS(XS_version_is_alpha);
 XS(XS_version_qv);
+XS(XS_version_is_qv);
 XS(XS_utf8_is_utf8);
 XS(XS_utf8_valid);
 XS(XS_utf8_encode);
@@ -233,7 +238,6 @@ XS(XS_Internals_SvREADONLY);
 XS(XS_Internals_SvREFCNT);
 XS(XS_Internals_hv_clear_placehold);
 XS(XS_PerlIO_get_layers);
-XS(XS_Regexp_DESTROY);
 XS(XS_Internals_hash_seed);
 XS(XS_Internals_rehash_seed);
 XS(XS_Internals_HvREHASH);
@@ -268,6 +272,7 @@ Perl_boot_core_UNIVERSAL(pTHX)
        /* Make it findable via fetchmethod */
        newXS("version::()", XS_version_noop, file);
        newXS("version::new", XS_version_new, file);
+       newXS("version::parse", XS_version_new, file);
        newXS("version::(\"\"", XS_version_stringify, file);
        newXS("version::stringify", XS_version_stringify, file);
        newXS("version::(0+", XS_version_numify, file);
@@ -282,6 +287,8 @@ Perl_boot_core_UNIVERSAL(pTHX)
        newXS("version::noop", XS_version_noop, file);
        newXS("version::is_alpha", XS_version_is_alpha, file);
        newXS("version::qv", XS_version_qv, file);
+       newXS("version::declare", XS_version_qv, file);
+       newXS("version::is_qv", XS_version_is_qv, file);
     }
     newXS("utf8::is_utf8", XS_utf8_is_utf8, file);
     newXS("utf8::valid", XS_utf8_valid, file);
@@ -297,7 +304,9 @@ Perl_boot_core_UNIVERSAL(pTHX)
                XS_Internals_hv_clear_placehold, file, "\\%");
     newXSproto("PerlIO::get_layers",
                XS_PerlIO_get_layers, file, "*;@");
-    newXS("Regexp::DESTROY", XS_Regexp_DESTROY, 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, "\\%");
@@ -537,10 +546,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();
@@ -650,7 +659,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);
 
@@ -728,25 +737,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)
@@ -926,12 +964,6 @@ XS(XS_Internals_hv_clear_placehold)
     }
 }
 
-XS(XS_Regexp_DESTROY)
-{
-    PERL_UNUSED_CONTEXT;
-    PERL_UNUSED_ARG(cv);
-}
-
 XS(XS_PerlIO_get_layers)
 {
     dVAR;
@@ -1336,7 +1368,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;
@@ -1366,7 +1398,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
@@ -1389,7 +1421,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;
@@ -1410,7 +1442,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;
@@ -1432,7 +1464,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;
@@ -1460,7 +1492,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;
@@ -1492,7 +1524,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;
@@ -1523,7 +1555,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;