[rt #103222] make Internals::SvREFCNT set/get consistent

[perl5.git] / universal.c

diff --git a/universal.c b/universal.c
index 2af2c2b..0599e67 100644 (file)
--- a/universal.c
+++ b/universal.c
@@ -291,7 +291,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: %"SVf"::%"SVf"(%s)", "ouch" "awk", "eee_yow");
 
 =cut
 */
@@ -304,14 +304,16 @@ Perl_croak_xs_usage(pTHX_ const CV *const cv, const char *const params)
     PERL_ARGS_ASSERT_CROAK_XS_USAGE;
 
     if (gv) {
-       const char *const gvname = GvNAME(gv);
        const HV *const stash = GvSTASH(gv);
-       const char *const hvname = stash ? HvNAME_get(stash) : NULL;
 
-       if (hvname)
-           Perl_croak(aTHX_ "Usage: %s::%s(%s)", hvname, gvname, params);
+       if (HvNAME_get(stash))
+           Perl_croak(aTHX_ "Usage: %"HEKf"::%"HEKf"(%s)",
+                                HEKfARG(HvNAME_HEK(stash)),
+                                HEKfARG(GvNAME_HEK(gv)),
+                                params);
        else
-           Perl_croak(aTHX_ "Usage: %s(%s)", gvname, params);
+           Perl_croak(aTHX_ "Usage: %"HEKf"(%s)",
+                                HEKfARG(GvNAME_HEK(gv)), params);
     } else {
        /* Pants. I don't think that it should be possible to get here. */
        Perl_croak(aTHX_ "Usage: CODE(0x%"UVxf")(%s)", PTR2UV(cv), params);
@@ -435,14 +437,15 @@ XS(XS_UNIVERSAL_VERSION)
 
        if (undef) {
            if (pkg) {
-               const char * const name = HvNAME_get(pkg);
+               const HEK * const name = HvNAME_HEK(pkg);
                Perl_croak(aTHX_
-                          "%s does not define $%s::VERSION--version check failed",
-                          name, name);
+                          "%"HEKf" does not define $%"HEKf
+                          "::VERSION--version check failed",
+                          HEKfARG(name), HEKfARG(name));
            } else {
                Perl_croak(aTHX_
-                            "%s defines neither package nor VERSION--version check failed",
-                            SvPVx_nolen_const(ST(0)) );
+                            "%"SVf" defines neither package nor VERSION--version check failed",
+                            SVfARG(ST(0)) );
             }
        }
 
@@ -456,13 +459,15 @@ XS(XS_UNIVERSAL_VERSION)
 
        if ( vcmp( req, sv ) > 0 ) {
            if ( hv_exists(MUTABLE_HV(SvRV(req)), "qv", 2 ) ) {
-               Perl_croak(aTHX_ "%s version %"SVf" required--"
-                      "this is only version %"SVf"", HvNAME_get(pkg),
+               Perl_croak(aTHX_ "%"HEKf" version %"SVf" required--"
+                      "this is only version %"SVf"",
+                       HEKfARG(HvNAME_HEK(pkg)),
                       SVfARG(sv_2mortal(vnormal(req))),
                       SVfARG(sv_2mortal(vnormal(sv))));
            } else {
-               Perl_croak(aTHX_ "%s version %"SVf" required--"
-                      "this is only version %"SVf"", HvNAME_get(pkg),
+               Perl_croak(aTHX_ "%"HEKf" version %"SVf" required--"
+                      "this is only version %"SVf,
+                       HEKfARG(HvNAME_HEK(pkg)),
                       SVfARG(sv_2mortal(vstringify(req))),
                       SVfARG(sv_2mortal(vstringify(sv))));
            }
@@ -485,10 +490,19 @@ XS(XS_version_new)
     {
         SV *vs = ST(1);
        SV *rv;
-       const char * const classname =
-           sv_isobject(ST(0)) /* get the class if called as an object method */
-               ? HvNAME(SvSTASH(SvRV(ST(0))))
-               : (char *)SvPV_nolen(ST(0));
+        STRLEN len;
+        const char *classname;
+        U32 flags;
+        if ( sv_isobject(ST(0)) ) { /* get the class if called as an object method */
+            const HV * stash = SvSTASH(SvRV(ST(0)));
+            classname = HvNAME(stash);
+            len       = HvNAMELEN(stash);
+            flags     = HvNAMEUTF8(stash) ? SVf_UTF8 : 0;
+        }
+        else {
+           classname = SvPV(ST(0), len);
+            flags     = SvUTF8(ST(0));
+        }
 
        if ( items == 1 || ! SvOK(vs) ) { /* no param or explicit undef */
            /* create empty object */
@@ -501,8 +515,8 @@ XS(XS_version_new)
        }
 
        rv = new_version(vs);
-       if ( strcmp(classname,"version") != 0 ) /* inherited new() */
-           sv_bless(rv, gv_stashpv(classname, GV_ADD));
+       if ( strnNE(classname,"version", len) ) /* inherited new() */
+           sv_bless(rv, gv_stashpvn(classname, len, GV_ADD | flags));
 
        mPUSHs(rv);
        PUTBACK;
@@ -687,15 +701,22 @@ XS(XS_version_qv)
     {
        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));
-       }
+        STRLEN len = 0;
+        const char * classname = "";
+        U32 flags = 0;
+        if ( items == 2 && SvOK(ST(1)) ) {
+            ver = ST(1);
+            if ( sv_isobject(ST(0)) ) { /* class called as an object method */
+                const HV * stash = SvSTASH(SvRV(ST(0)));
+                classname = HvNAME(stash);
+                len       = HvNAMELEN(stash);
+                flags     = HvNAMEUTF8(stash) ? SVf_UTF8 : 0;
+            }
+            else {
+              classname = SvPV(ST(0), len);
+                flags     = SvUTF8(ST(0));
+            }
+        }
        if ( !SvVOK(ver) ) { /* not already a v-string */
            rv = sv_newmortal();
            sv_setsv(rv,ver); /* make a duplicate */
@@ -703,9 +724,10 @@ XS(XS_version_qv)
        } else {
            rv = sv_2mortal(new_version(ver));
        }
-       if ( items == 2 && strcmp(classname,"version") ) { /* inherited new() */
-           sv_bless(rv, gv_stashpv(classname, GV_ADD));
-       }
+       if ( items == 2
+                && strnNE(classname,"version", len) ) { /* inherited new() */
+           sv_bless(rv, gv_stashpvn(classname, len, GV_ADD | flags));
+        }
        PUSHs(rv);
     }
     PUTBACK;
@@ -905,8 +927,8 @@ XS(XS_Internals_SvREFCNT)   /* This is dangerous stuff. */
         XSRETURN_IV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */
     else if (items == 2) {
          /* I hope you really know what you are doing. */
-        SvREFCNT(sv) = SvIV(ST(1));
-        XSRETURN_IV(SvREFCNT(sv));
+        SvREFCNT(sv) = SvIV(ST(1)) + 1; /* we free one ref on exit */
+        XSRETURN_IV(SvREFCNT(sv) - 1);
     }
     XSRETURN_UNDEF; /* Can't happen. */
 }