From 1f8abca0a3c8ec0c2ebce8a1335c8cc8250cbfa0 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Tina=20M=C3=BCller?= <cpan2@tinita.de>
Date: Sun, 25 Feb 2024 02:02:15 +0100
Subject: [PATCH] Support TO_JSON serializer

See #43
---
 lib/YAML/PP/Schema/Perl.pm | 11 +++++++++++
 t/37.schema-perl.t         | 37 +++++++++++++++++++++++++++++++++++++
 2 files changed, 48 insertions(+)

diff --git a/lib/YAML/PP/Schema/Perl.pm b/lib/YAML/PP/Schema/Perl.pm
index 5f0cc309..d716cdc1 100644
--- 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
index 32805caa..18231d3c 100644
--- 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;