Support TO_JSON serializer

See #43
perlpunk · Feb 25, 2024 · 1f8abca · 1f8abca
1 parent 8a2ccd5
commit 1f8abca
Show file tree

Hide file tree

Showing 2 changed files with 48 additions and 0 deletions.
diff --git a/lib/YAML/PP/Schema/Perl.pm b/lib/YAML/PP/Schema/Perl.pm
@@ -23,12 +23,14 @@ sub new {
     my $dumpcode = $args{dumpcode};
     $dumpcode = 1 unless defined $dumpcode;
     my $classes = $args{classes};
+    my $serializer = $args{serializer};
 
     my $self = bless {
         tags => $tags,
         loadcode => $loadcode,
         dumpcode => $dumpcode,
         classes => $classes,
+        serializer => $serializer,
     }, $class;
 }
 
@@ -40,12 +42,14 @@ sub register {
     my $loadcode = 0;
     my $dumpcode = 1;
     my $classes;
+    my $serializer;
     if (blessed($self)) {
         $tags = $self->{tags};
         @$tags = ('!perl') unless @$tags;
         $loadcode = $self->{loadcode};
         $dumpcode = $self->{dumpcode};
         $classes = $self->{classes};
+        $serializer = $self->{serializer};
     }
     else {
         my $options = $args{options};
@@ -383,6 +387,13 @@ sub register {
             my ($rep, $node) = @_;
             my $blessed = blessed $node->{value};
             my $tag_blessed = ":$blessed";
+            if (defined $serializer and $node->{value}->can($serializer)) {
+                my $data = $node->{value}->$serializer;
+                $node->{value} = $data;
+                my $r = $rep->represent_node($node);
+                return $r;
+
+            }
             if ($blessed !~ m/^$class_regex$/) {
                 $tag_blessed = '';
             }

diff --git a/t/37.schema-perl.t b/t/37.schema-perl.t
@@ -376,4 +376,41 @@ EOM
     is $yaml, $exp, "Use -loadcode";
 };
 
+subtest serializer => sub {
+    my $perl = YAML::PP::Schema::Perl->new(
+        serializer => 'TO_JSON',
+    );
+    my $yp = YAML::PP->new(
+        schema => [qw/ + /, $perl],
+    );
+    my $o = bless [3,4], "Dice";
+    my $data = { dice => $o };
+
+    *Dice::TO_JSON = sub {
+        my ($self) = @_;
+        return join 'd', @$self;
+    };
+    my $yaml = $yp->dump_string($data);
+    my $exp = <<'EOM';
+---
+dice: 3d4
+EOM
+    is $yaml, $exp, "TO_JSON returns string";
+
+    no warnings 'redefine';
+    *Dice::TO_JSON = sub {
+        my ($self) = @_;
+        return { '__dice__' => [@$self] };
+    };
+    $yaml = $yp->dump_string($data);
+    $exp = <<'EOM';
+---
+dice:
+  __dice__:
+  - 3
+  - 4
+EOM
+    is $yaml, $exp, "TO_JSON returns hash";
+};
+
 done_testing;