This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
Make utf8::encode respect magic
[perl5.git] / universal.c
diff --git a/universal.c b/universal.c
index 0599e67..676c39b 100644 (file)
--- a/universal.c
+++ b/universal.c
@@ -154,7 +154,7 @@ Perl_sv_derived_from_pvn(pTHX_ SV *sv, const char *const name, const STRLEN len,
 
     SvGETMAGIC(sv);
 
-    if (SvROK(sv)) { /* hugdo: */
+    if (SvROK(sv)) {
        const char *type;
         sv = SvRV(sv);
         type = sv_reftype(sv,0);
@@ -164,6 +164,8 @@ Perl_sv_derived_from_pvn(pTHX_ SV *sv, const char *const name, const STRLEN len,
     }
     else {
         stash = gv_stashsv(sv, 0);
+        if (!stash)
+            stash = gv_stashpv("UNIVERSAL", 0);
     }
 
     return stash ? isa_lookup(stash, name, len, flags) : FALSE;
@@ -196,8 +198,7 @@ Perl_sv_does_sv(pTHX_ SV *sv, SV *namesv, U32 flags)
 
     SvGETMAGIC(sv);
 
-    if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
-           || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv)))) {
+    if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv)))) {
        LEAVE;
        return FALSE;
     }
@@ -332,8 +333,7 @@ XS(XS_UNIVERSAL_isa)
 
        SvGETMAGIC(sv);
 
-       if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
-                   || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
+       if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))))
            XSRETURN_UNDEF;
 
        ST(0) = boolSV(sv_derived_from_sv(sv, ST(1), 0));
@@ -356,8 +356,8 @@ XS(XS_UNIVERSAL_can)
 
     SvGETMAGIC(sv);
 
-    if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
-               || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
+    if (!SvOK(sv) || !(SvROK(sv) || SvNIOK(sv) || (SvPOK(sv) && SvCUR(sv))
+       ))
        XSRETURN_UNDEF;
 
     rv = &PL_sv_undef;
@@ -369,6 +369,8 @@ XS(XS_UNIVERSAL_can)
     }
     else {
         pkg = gv_stashsv(sv, 0);
+        if (!pkg)
+            pkg = gv_stashpv("UNIVERSAL", 0);
     }
 
     if (pkg) {
@@ -406,7 +408,6 @@ XS(XS_UNIVERSAL_VERSION)
     GV **gvp;
     GV *gv;
     SV *sv;
-    SV *ret;
     const char *undef;
     PERL_UNUSED_ARG(cv);
 
@@ -423,12 +424,16 @@ XS(XS_UNIVERSAL_VERSION)
     gvp = pkg ? (GV**)hv_fetchs(pkg, "VERSION", FALSE) : NULL;
 
     if (gvp && isGV(gv = *gvp) && (sv = GvSV(gv)) && SvOK(sv)) {
-        ret = sv_newmortal();
-        sv_setsv(ret, sv);
+        SV * const nsv = sv_newmortal();
+        sv_setsv(nsv, sv);
+        sv = nsv;
+       if ( !sv_isobject(sv) || !sv_derived_from(sv, "version"))
+           upg_version(sv, FALSE);
+
         undef = NULL;
     }
     else {
-        sv = ret = &PL_sv_undef;
+        sv = &PL_sv_undef;
         undef = "(undef)";
     }
 
@@ -449,10 +454,7 @@ XS(XS_UNIVERSAL_VERSION)
             }
        }
 
-       if ( !sv_derived_from(sv, "version"))
-           upg_version(sv, FALSE);
-
-       if ( !sv_derived_from(req, "version")) {
+       if ( !sv_isobject(req) || !sv_derived_from(req, "version")) {
            /* req may very well be R/O, so create a new object */
            req = sv_2mortal( new_version(req) );
        }
@@ -475,7 +477,11 @@ XS(XS_UNIVERSAL_VERSION)
 
     }
 
-    ST(0) = ret;
+    if ( SvOK(sv) && sv_derived_from(sv, "version") ) {
+       ST(0) = sv_2mortal(vstringify(sv));
+    } else {
+       ST(0) = sv;
+    }
 
     XSRETURN(1);
 }
@@ -534,7 +540,7 @@ XS(XS_version_stringify)
      {
          SV *  lobj = ST(0);
 
-         if (sv_derived_from(lobj, "version") && SvROK(lobj)) {
+         if (sv_isobject(lobj) && sv_derived_from(lobj, "version")) {
               lobj = SvRV(lobj);
          }
          else
@@ -557,7 +563,7 @@ XS(XS_version_numify)
      {
          SV *  lobj = ST(0);
 
-         if (sv_derived_from(lobj, "version") && SvROK(lobj)) {
+         if (sv_isobject(lobj) && sv_derived_from(lobj, "version")) {
               lobj = SvRV(lobj);
          }
          else
@@ -580,7 +586,7 @@ XS(XS_version_normal)
      {
          SV *  lobj = ST(0);
 
-         if (sv_derived_from(lobj, "version") && SvROK(lobj)) {
+         if (sv_isobject(lobj) && sv_derived_from(lobj, "version")) {
               lobj = SvRV(lobj);
          }
          else
@@ -603,7 +609,7 @@ XS(XS_version_vcmp)
      {
          SV *  lobj = ST(0);
 
-         if (sv_derived_from(lobj, "version") && SvROK(lobj)) {
+         if (sv_isobject(lobj) && sv_derived_from(lobj, "version")) {
               lobj = SvRV(lobj);
          }
          else
@@ -615,7 +621,7 @@ XS(XS_version_vcmp)
               SV * robj = ST(1);
               const IV  swap = (IV)SvIV(ST(2));
 
-              if ( ! sv_derived_from(robj, "version") )
+              if ( !sv_isobject(robj) || !sv_derived_from(robj, "version") )
               {
                    robj = new_version(SvOK(robj) ? robj : newSVpvs_flags("0", SVs_TEMP));
                    sv_2mortal(robj);
@@ -646,9 +652,15 @@ XS(XS_version_boolean)
     if (items < 1)
        croak_xs_usage(cv, "lobj, ...");
     SP -= items;
-    if (sv_derived_from(ST(0), "version") && SvROK(ST(0))) {
+    if (sv_isobject(ST(0)) && sv_derived_from(ST(0), "version")) {
        SV * const lobj = SvRV(ST(0));
-       SV * const rs = newSViv( vcmp(lobj,new_version(newSVpvs("0"))) );
+       SV * const rs =
+           newSViv( vcmp(lobj,
+                         sv_2mortal(new_version(
+                                       sv_2mortal(newSVpvs("0"))
+                                   ))
+                        )
+                  );
        mPUSHs(rs);
        PUTBACK;
        return;
@@ -663,7 +675,7 @@ XS(XS_version_noop)
     dXSARGS;
     if (items < 1)
        croak_xs_usage(cv, "lobj, ...");
-    if (sv_derived_from(ST(0), "version") && SvROK(ST(0)))
+    if (sv_isobject(ST(0)) && sv_derived_from(ST(0), "version"))
        Perl_croak(aTHX_ "operation not supported with version object");
     else
        Perl_croak(aTHX_ "lobj is not of type version");
@@ -679,7 +691,7 @@ XS(XS_version_is_alpha)
     if (items != 1)
        croak_xs_usage(cv, "lobj");
     SP -= items;
-    if (sv_derived_from(ST(0), "version") && SvROK(ST(0))) {
+    if (sv_isobject(ST(0)) && sv_derived_from(ST(0), "version")) {
        SV * const lobj = ST(0);
        if ( hv_exists(MUTABLE_HV(SvRV(lobj)), "alpha", 5 ) )
            XSRETURN_YES;
@@ -741,7 +753,7 @@ XS(XS_version_is_qv)
     if (items != 1)
        croak_xs_usage(cv, "lobj");
     SP -= items;
-    if (sv_derived_from(ST(0), "version") && SvROK(ST(0))) {
+    if (sv_isobject(ST(0)) && sv_derived_from(ST(0), "version")) {
        SV * const lobj = ST(0);
        if ( hv_exists(MUTABLE_HV(SvRV(lobj)), "qv", 2 ) )
            XSRETURN_YES;
@@ -796,6 +808,7 @@ XS(XS_utf8_encode)
     if (items != 1)
        croak_xs_usage(cv, "sv");
     sv_utf8_encode(ST(0));
+    SvSETMAGIC(ST(0));
     XSRETURN_EMPTY;
 }
 
@@ -808,7 +821,7 @@ XS(XS_utf8_decode)
     else {
        SV * const sv = ST(0);
        bool RETVAL;
-       if (SvIsCOW(sv)) sv_force_normal(sv);
+       SvPV_force_nolen(sv);
        RETVAL = sv_utf8_decode(sv);
        ST(0) = boolSV(RETVAL);
     }
@@ -924,11 +937,11 @@ XS(XS_Internals_SvREFCNT) /* This is dangerous stuff. */
     sv = SvRV(svz);
 
     if (items == 1)
-        XSRETURN_IV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */
+        XSRETURN_UV(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)) + 1; /* we free one ref on exit */
-        XSRETURN_IV(SvREFCNT(sv) - 1);
+        SvREFCNT(sv) = SvUV(ST(1)) + 1; /* we free one ref on exit */
+        XSRETURN_UV(SvREFCNT(sv) - 1);
     }
     XSRETURN_UNDEF; /* Can't happen. */
 }
@@ -1000,14 +1013,10 @@ XS(XS_PerlIO_get_layers)
        }
 
        sv = POPs;
-       gv = MUTABLE_GV(sv);
+       gv = MAYBE_DEREF_GV(sv);
 
-       if (!isGV(sv)) {
-            if (SvROK(sv) && isGV(SvRV(sv)))
-                 gv = MUTABLE_GV(SvRV(sv));
-            else if (SvPOKp(sv))
-                 gv = gv_fetchsv(sv, 0, SVt_PVIO);
-       }
+       if (!gv && !SvROK(sv))
+           gv = gv_fetchsv_nomg(sv, 0, SVt_PVIO);
 
        if (gv && (io = GvIO(gv))) {
             AV* const av = PerlIO_get_layers(aTHX_ input ?
@@ -1363,6 +1372,15 @@ struct xsub_details details[] = {
     {"version::vcmp", XS_version_vcmp, NULL},
     {"version::(bool", XS_version_boolean, NULL},
     {"version::boolean", XS_version_boolean, NULL},
+    {"version::(+", XS_version_noop, NULL},
+    {"version::(-", XS_version_noop, NULL},
+    {"version::(*", XS_version_noop, NULL},
+    {"version::(/", XS_version_noop, NULL},
+    {"version::(+=", XS_version_noop, NULL},
+    {"version::(-=", XS_version_noop, NULL},
+    {"version::(*=", XS_version_noop, NULL},
+    {"version::(/=", XS_version_noop, NULL},
+    {"version::(abs", XS_version_noop, NULL},
     {"version::(nomethod", XS_version_noop, NULL},
     {"version::noop", XS_version_noop, NULL},
     {"version::is_alpha", XS_version_is_alpha, NULL},
@@ -1404,9 +1422,6 @@ Perl_boot_core_UNIVERSAL(pTHX)
        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  */
     {
        CV * const cv =
@@ -1421,8 +1436,8 @@ Perl_boot_core_UNIVERSAL(pTHX)
  * Local variables:
  * c-indentation-style: bsd
  * c-basic-offset: 4
- * indent-tabs-mode: t
+ * indent-tabs-mode: nil
  * End:
  *
- * ex: set ts=8 sts=4 sw=4 noet:
+ * ex: set ts=8 sts=4 sw=4 et:
  */
Unnamed repository; edit this file 'description' to name the repository.