use convert_blessed not stringify_blessed

fixes for older versions: 5.12, <5.18 and 5.6
>5.18 the stash is overloaded, <5.18 the sv.

we got an already unrefed sv in encode_stringify.
temp. RV it to call AMG_CALLunary

Fixes GH #37

Changes

@@ -3,6 +3,11 @@ Revision history for Perl extension Cpanel::JSON::XS
 TODO: maybe avoid the reblessing and better support readonly objects.
 TODO: http://stevehanov.ca/blog/index.php?id=104 compression
 
+3.0202 2015-11-26 (rurban)
+       - New feature: convert_blessed for encode.
+         Stringify overloaded perl objects and with allow_blessed even without
+         string overload (#37)
+
 3.0201 2015-11-26 (rurban)
        - Simplify handling of references, removing all the complicated
          work-around for reblessing. Breaks overloaded values, but fixes

README

@@ -557,7 +557,8 @@ OBJECT-ORIENTED INTERFACE
         blessed object, will check for the availability of the "TO_JSON"
         method on the object's class. If found, it will be called in scalar
         context and the resulting scalar will be encoded instead of the
-        object. If no "TO_JSON" method is found, the value of
+        object. If no "TO_JSON" method is found, a stringification overload
+        method is tried next. If both are not found, the value of
         "allow_blessed" will decide what to do.
 
         The "TO_JSON" method may safely call die if it wants. If "TO_JSON"
@@ -1141,7 +1142,8 @@ MAPPING
         See the "allow_blessed" and "convert_blessed" methods on various
         options on how to deal with this: basically, you can choose between
         throwing an exception, encoding the reference as if it weren't
-        blessed, or provide your own serialiser method.
+        blessed, use the objects overloaded stringification method or
+        provide your own serialiser method.
 
     simple scalars
         Simple Perl scalars (any scalar that is not a reference) are the
@@ -1248,6 +1250,19 @@ MAPPING
               $uri->as_string
            }
 
+    2. "convert_blessed" is enabled and the object has a stringification
+    overload.
+        In this case, the overloaded "" method of the object is invoked in
+        scalar context. It must return a single scalar that can be directly
+        encoded into JSON. This scalar replaces the object in the JSON text.
+
+        For example, the following "" method will convert all URI objects to
+        JSON strings when serialised. The fact that these values originally
+        were URI objects is lost.
+
+            package URI;
+            use overload '""' => sub { shift->as_string };
+
     3. "allow_blessed" is enabled.
         The object will be serialised as a JSON null value.
 
@@ -1292,6 +1307,9 @@ MAPPING
           $class->new (type => $type, id => $id)
        }
 
+    See the "SECURITY CONSIDERATIONS" section below. Allowing external json
+    objects being deserialized to perl objects is usually a very bad idea.
+
 ENCODING/CODESET FLAG NOTES
     The interested reader might have seen a number of flags that signify
     encodings or codesets - "utf8", "latin1", "binary" and "ascii". There

XS.pm

@@ -159,7 +159,7 @@ B<Changes to JSON::XS>
 
 package Cpanel::JSON::XS;
 
-our $VERSION = '3.0201';
+our $VERSION = '3.0202';
 our @ISA = qw(Exporter);
 
 our @EXPORT = qw(encode_json decode_json to_json from_json);
@@ -638,7 +638,8 @@ If C<$enable> is true (or missing), then C<encode>, upon encountering a
 blessed object, will check for the availability of the C<TO_JSON> method
 on the object's class. If found, it will be called in scalar context
 and the resulting scalar will be encoded instead of the object. If no
-C<TO_JSON> method is found, the value of C<allow_blessed> will decide what
+C<TO_JSON> method is found, a stringification overload method is tried next.
+If both are not found, the value of C<allow_blessed> will decide what
 to do.
 
 The C<TO_JSON> method may safely call die if it wants. If C<TO_JSON>
@@ -1261,9 +1262,10 @@ Blessed objects are not directly representable in JSON, but
 C<Cpanel::JSON::XS> allows various optional ways of handling
 objects. See L<OBJECT SERIALISATION>, below, for details.
 
-See the C<allow_blessed> and C<convert_blessed> methods on various options on
-how to deal with this: basically, you can choose between throwing an
-exception, encoding the reference as if it weren't blessed, or provide
+See the C<allow_blessed> and C<convert_blessed> methods on various
+options on how to deal with this: basically, you can choose between
+throwing an exception, encoding the reference as if it weren't
+blessed, use the objects overloaded stringification method or provide
 your own serialiser method.
 
 =item simple scalars
@@ -1379,6 +1381,19 @@ originally were L<URI> objects is lost.
       $uri->as_string
    }
 
+=item 2. C<convert_blessed> is enabled and the object has a stringification overload.
+
+In this case, the overloaded C<""> method of the object is invoked in scalar
+context. It must return a single scalar that can be directly encoded into
+JSON. This scalar replaces the object in the JSON text.
+
+For example, the following C<""> method will convert all L<URI>
+objects to JSON strings when serialised. The fact that these values
+originally were L<URI> objects is lost.
+
+    package URI;
+    use overload '""' => sub { shift->as_string };
+
 =item 3. C<allow_blessed> is enabled.
 
 The object will be serialised as a JSON null value.
@@ -1426,6 +1441,10 @@ C<My::Object> from the C<FREEZE> example earlier:
       $class->new (type => $type, id => $id)
    }
 
+See the L</SECURITY CONSIDERATIONS> section below. Allowing external
+json objects being deserialized to perl objects is usually a very bad
+idea.
+
 
 =head1 ENCODING/CODESET FLAG NOTES
 

XS.xs

@@ -103,7 +103,6 @@
 #define F_ALLOW_UNKNOWN  0x00002000UL
 #define F_ALLOW_TAGS     0x00004000UL
 #define F_BINARY         0x00008000UL
-#define F_STRING_BLESSED 0x00010000UL
 #define F_HOOK           0x00080000UL // some hooks exist, so slow-path processing
 
 #define F_PRETTY    F_INDENT | F_SPACE_BEFORE | F_SPACE_AFTER
@@ -852,29 +851,67 @@ encode_hv (pTHX_ enc_t *enc, HV *hv)
   encode_ch (aTHX_ enc, '}');
 }
 
+/* implement convert_blessed, sv is already unref'ed here */
 static void
 encode_stringify(pTHX_ enc_t *enc, SV *sv)
 {
   char *str = NULL;
   STRLEN len;
   SV *pv = NULL;
   svtype type = SvTYPE(sv);
+  int amg = 0;
 
+/* SvAMAGIC without the ref */
+#if PERL_VERSION > 17
+#define MyAMG(sv) (SvOBJECT(sv) && HvAMAGIC(SvSTASH(sv)))
+#else
+#define MyAMG(sv) (SvOBJECT(sv) && (SvFLAGS(sv) & SVf_AMAGIC))
+#endif
+
+  /* if no string overload found, check allow_blessed */
+  if (!MyAMG(sv) && !(enc->json.flags & F_ALLOW_BLESSED)) {
+    encode_str (aTHX_ enc, "null", 4, 0);
+    return;
+  }
   /* sv_2pv_flags does not accept those types: */
   if (type != SVt_PVAV && type != SVt_PVHV && type != SVt_PVFM) {
     /* the essential of pp_stringify */
+#if PERL_VERSION > 7
     pv = newSVpvs("");
     sv_copypv(pv, sv);
+#else
+    STRLEN len;
+    char *s;
+    pv = newSVpvs("");
+    s = SvPV(sv,len);
+    sv_setpvn(pv,s,len);
+    if (SvUTF8(sv))
+	SvUTF8_on(pv);
+    else
+	SvUTF8_off(pv);
+#endif
     SvSETMAGIC(pv);
     str = SvPVutf8_force(pv, len);
   } else {
     /* manually call all possible magic on AV, HV, FM */
     if (SvGMAGICAL(sv)) mg_get(sv);
-    if (SvAMAGIC(sv)) {
-      pv = AMG_CALLunary(sv, string_amg);
+    if (MyAMG(sv)) { /* force a RV here */
+      SV* rv = newRV(SvREFCNT_inc(sv));
+#if PERL_VERSION > 13
+      pv = AMG_CALLunary(rv, string_amg);
+#else
+      pv = AMG_CALLun(rv, string);
+#endif
       TAINT_IF(pv && SvTAINTED(pv));
-      if (pv && SvPOK(pv))
+      if (pv && SvPOK(pv)) {
         str = SvPVutf8_force(pv, len);
+        encode_ch (aTHX_ enc, '"');
+        encode_str (aTHX_ enc, str, len, 0);
+        encode_ch (aTHX_ enc, '"');
+        SvREFCNT_dec(rv);
+        return;
+      }
+      SvREFCNT_dec(rv);
     }
   }
   if (!str)
@@ -883,6 +920,8 @@ encode_stringify(pTHX_ enc_t *enc, SV *sv)
     encode_str (aTHX_ enc, str, len, 0);
   if (pv) SvREFCNT_dec(pv);
 
+#undef MyAMG
+
 }
 
 /* encode objects, arrays and special \0=false and \1=true values
@@ -980,12 +1019,12 @@ encode_rv (pTHX_ enc_t *enc, SV *rv)
 
           FREETMPS; LEAVE;
         }
-      else if (enc->json.flags & F_STRING_BLESSED)
+      else if (enc->json.flags & F_CONV_BLESSED)
         encode_stringify(aTHX_ enc, sv);
       else if (enc->json.flags & F_ALLOW_BLESSED)
         encode_str (aTHX_ enc, "null", 4, 0);
       else
-        croak ("encountered object '%s', but neither allow_blessed, convert_blessed, stringify_blessed nor allow_tags settings are enabled (or TO_JSON/FREEZE method missing)",
+        croak ("encountered object '%s', but neither allow_blessed, convert_blessed nor allow_tags settings are enabled (or TO_JSON/FREEZE method missing)",
                SvPV_nolen (sv_2mortal (newRV_inc (sv))));
     }
   else if (svt == SVt_PVHV)
@@ -1001,10 +1040,10 @@ encode_rv (pTHX_ enc_t *enc, SV *rv)
         encode_str (aTHX_ enc, "true", 4, 0);
       else if (len == 1 && *pv == '0')
         encode_str (aTHX_ enc, "false", 5, 0);
+      else if (enc->json.flags & F_CONV_BLESSED)
+        encode_stringify(aTHX_ enc, sv);
       else if (enc->json.flags & F_ALLOW_UNKNOWN)
         encode_str (aTHX_ enc, "null", 4, 0);
-      else if (enc->json.flags & F_STRING_BLESSED)
-        encode_stringify(aTHX_ enc, sv);
       else
         croak ("cannot encode reference to scalar '%s' unless the scalar is 0 or 1",
                SvPV_nolen (sv_2mortal (newRV_inc (sv))));
@@ -2839,7 +2878,6 @@ void ascii (JSON *self, int enable = 1)
         shrink          = F_SHRINK
         allow_blessed   = F_ALLOW_BLESSED
         convert_blessed = F_CONV_BLESSED
-        stringify_blessed = F_STRING_BLESSED
         relaxed         = F_RELAXED
         allow_unknown   = F_ALLOW_UNKNOWN
         allow_tags      = F_ALLOW_TAGS
@@ -2867,7 +2905,6 @@ void get_ascii (JSON *self)
         get_shrink          = F_SHRINK
         get_allow_blessed   = F_ALLOW_BLESSED
         get_convert_blessed = F_CONV_BLESSED
-        get_stringify_blessed = F_STRING_BLESSED
         get_relaxed         = F_RELAXED
         get_allow_unknown   = F_ALLOW_UNKNOWN
         get_allow_tags      = F_ALLOW_TAGS

t/02_error.t

@@ -1,15 +1,9 @@
-#BEGIN { $| = 1; print "1..31\n"; }
 use Test::More tests => 36;
 
 use utf8;
 use Cpanel::JSON::XS;
 no warnings;
 
-#our $test;
-#sub ok($) {
-#   print $_[0] ? "" : "not ", "ok ", ++$test, "\n";
-#}
-
 eval { Cpanel::JSON::XS->new->encode ([\-1]) }; ok $@ =~ /cannot encode reference/;
 eval { Cpanel::JSON::XS->new->encode ([\undef]) }; ok $@ =~ /cannot encode reference/;
 eval { Cpanel::JSON::XS->new->encode ([\2]) }; ok $@ =~ /cannot encode reference/;
@@ -20,7 +14,7 @@ eval { Cpanel::JSON::XS->new->encode ([\\1]) }; ok $@ =~ /cannot encode referenc
 eval { $x = Cpanel::JSON::XS->new->ascii->decode ('croak') }; ok $@ =~ /malformed JSON/, $@;
 
 SKIP: {
-skip "5.6", 25 if $] < 5.008;
+skip "5.6 utf8 mb", 17 if $] < 5.008;
 
 eval { Cpanel::JSON::XS->new->allow_nonref (1)->decode ('"\u1234\udc00"') }; ok $@ =~ /missing high /;
 eval { Cpanel::JSON::XS->new->allow_nonref->decode ('"\ud800"') }; ok $@ =~ /missing low /;
@@ -38,6 +32,10 @@ eval { Cpanel::JSON::XS->new->allow_nonref->decode ('-0e') }; ok $@ =~ /exp sign
 eval { Cpanel::JSON::XS->new->allow_nonref (1)->decode ('-e+1') }; ok $@ =~ /initial minus/;
 eval { Cpanel::JSON::XS->new->allow_nonref->decode ("\"\n\"") }; ok $@ =~ /invalid character/;
 eval { Cpanel::JSON::XS->new->allow_nonref (1)->decode ("\"\x01\"") }; ok $@ =~ /invalid character/;
+eval { decode_json ("[\"\xa0]") }; ok $@ =~ /malformed.*character/;
+eval { decode_json ("[\"\xa0\"]") }; ok $@ =~ /malformed.*character/;
+}
+
 eval { Cpanel::JSON::XS->new->decode ('[5') }; ok $@ =~ /parsing array/;
 eval { Cpanel::JSON::XS->new->decode ('{"5"') }; ok $@ =~ /':' expected/;
 eval { Cpanel::JSON::XS->new->decode ('{"5":null') }; ok $@ =~ /parsing object/;
@@ -48,11 +46,9 @@ eval { Cpanel::JSON::XS->new->decode ([]) }; ok $@ =~ /malformed/;
 eval { Cpanel::JSON::XS->new->decode (\*STDERR) }; ok $@ =~ /malformed/;
 eval { Cpanel::JSON::XS->new->decode (*STDERR) }; ok !!$@; # cannot coerce GLOB
 
-eval { decode_json ("[\"\xa0]") }; ok $@ =~ /malformed.*character/;
-eval { decode_json ("[\"\xa0\"]") }; ok $@ =~ /malformed.*character/;
+
 eval { decode_json ("null") }; ok $@ =~ /JSON text must be an object or array/, "null";
 eval { decode_json ("true") }; ok $@ =~ /JSON text must be an object or array/, "true $@";
 eval { decode_json ("false") }; ok $@ =~ /JSON text must be an object or array/, "false $@";
 eval { decode_json ("1") }; ok $@ =~ /JSON text must be an object or array/, "wrong 1";
 
-}

t/12_blessed.t

@@ -1,10 +1,11 @@
-BEGIN { $| = 1; print "1..16\n"; }
+BEGIN { $| = 1; print "1..18\n"; }
 
 use Cpanel::JSON::XS;
 
 our $test;
 sub ok($;$) {
-   print $_[0] ? "" : "not ", "ok ", ++$test, "\n";
+  print $_[0] ? "" : "not ", "ok ", ++$test, "\n";
+  $_[0]
 }
 
 my $o1 = bless { a => 3 }, "XX";
@@ -35,9 +36,12 @@ eval { $js->encode ($o2) }; ok ($@ =~ /allow_blessed/);
 $js->allow_blessed;
 ok ($js->encode ($o1) eq "null");
 ok ($js->encode ($o2) eq "null");
-$js->convert_blessed;
+$js->allow_blessed(0)->convert_blessed;
 ok ($js->encode ($o1) eq '{"__":""}');
 ok ($js->encode ($o2) eq "null");
+$js->allow_blessed->convert_blessed;
+ok ($js->encode ($o1) eq '{"__":""}');
+ok ($js->encode ($o2) == 1) or print STDERR "# ",$js->encode ($o2),"\n";
 
 $js->filter_json_object (sub { 5 });
 $js->filter_json_single_key_object (a => sub { shift });

t/54_stringify.t

@@ -1,18 +1,24 @@
 #!perl
 use strict;
 use warnings;
-use Test::More $] < 5.008 ? (skip_all => "5.6") : (tests => 5);
-use Cpanel::JSON::XS;
+use Test::More;
+BEGIN {
+  eval "require Time::Piece;";
+  if ($@) {
+    plan skip_all => "Time::Piece required";
+    exit 0;
+  }
+}
 use Time::Piece;
+plan tests => 5;
+#$] < 5.008 ? (skip_all => "5.6") : (tests => 5);
+use Cpanel::JSON::XS;
 
 my $time = localtime;
-my $json = Cpanel::JSON::XS->new;
-if ($json->can("stringify_blessed")) {
-  $json->stringify_blessed(1);
-  diag 'stringify_blessed is enabled';
-} else {
-  diag 'stringify_blessed is simulated with convert_blessed';
-  $json->convert_blessed(1);
+my $json = Cpanel::JSON::XS->new->convert_blessed;
+
+if ($Cpanel::JSON::XS::VERSION lt '3.0202') {
+  diag 'simulate convert_blessed via TO_JSON';
   eval 'sub Foo::TO_JSON { "Foo <". shift->[0] . ">" }';
   eval 'sub main::TO_JSON { "main=REF(". $$_[0] . ")" }';
   eval 'sub Time::Piece::TO_JSON { "$time" }';
@@ -27,7 +33,7 @@ my $object = bless ["foo"], 'Foo';
 my $enc = $json->encode( { obj => $object } );
 
 TODO: {
-  local $TODO = 'Not yet ready';   
+  #local $TODO = 'Not yet ready';
   is( $enc, '{"obj":"Foo <foo>"}', "mg object stringified" )
     or diag($enc);
 }
@@ -36,13 +42,15 @@ $enc = $json->encode( { time => $time } );
 isa_ok($time, "Time::Piece");
 
 TODO: {
-  local $TODO = 'Not yet ready';   
+  #local $TODO = 'Not yet ready';
   # my $dec = $json->decode($enc);
   is( $enc, qq({"time":"$time"}), 'mg Time::Piece object was stringified' );
 }
 
 $object = bless [], 'main';
+$json->allow_blessed;
 $enc = $json->encode( \$object );
+# fails in 5.6
 like( $enc, qr/main=ARRAY\(0x[A-Fa-f0-9]+\)/, "nomg blessed array stringified" )
   or diag($enc);