"fast" hash/bless for serialization

3 files changed, 116 insertions, 0 deletions

diff --git a/Data-MultiValued/lib/Data/MultiValued/AttributeTrait/Tagged.pm b/Data-MultiValued/lib/Data/MultiValued/AttributeTrait/Tagged.pm
index 7839e2d..2a45506 100644
--- a/Data-MultiValued/lib/Data/MultiValued/AttributeTrait/Tagged.pm
+++ b/Data-MultiValued/lib/Data/MultiValued/AttributeTrait/Tagged.pm
@@ -187,6 +187,25 @@ sub get_tagged_write_method  {
     return $self->get_write_method . '_tagged';
 }
 
+sub _rebless_slot {
+    my ($self,$instance) = @_;
+
+    my $st = $self->get_full_storage($instance);
+    return unless $st;
+
+    bless $st, 'Data::MultiValued::Tags';
+    $st->_rebless_storage;
+}
+
+sub _as_hash {
+    my ($self,$instance) = @_;
+
+    my $st = $self->get_full_storage($instance);
+    return unless $st;
+
+    return $st->_as_hash;
+}
+
 package Moose::Meta::Attribute::Custom::Trait::MultiValued::Tagged;{
 sub register_implementation { 'Data::MultiValued::AttributeTrait::Tagged' }
 }
diff --git a/Data-MultiValued/lib/Data/MultiValued/Tags.pm b/Data-MultiValued/lib/Data/MultiValued/Tags.pm
index 0325f61..2262d8a 100644
--- a/Data-MultiValued/lib/Data/MultiValued/Tags.pm
+++ b/Data-MultiValued/lib/Data/MultiValued/Tags.pm
@@ -19,6 +19,19 @@ sub _build__storage {
     Data::MultiValued::TagContainer->new();
 }
 
+sub _rebless_storage {
+    my ($self) = @_;
+
+    bless $self->{_storage},'Data::MultiValued::TagContainer';
+}
+
+sub _as_hash {
+    my ($self) = @_;
+
+    my %ret = %{$self->_storage};
+    return {_storage=>\%ret};
+}
+
 sub set {
     my ($self,%args) = validated_hash(
         \@_,
diff --git a/Data-MultiValued/t/json.t b/Data-MultiValued/t/json.t
new file mode 100644
index 0000000..09664bf
--- /dev/null
+++ b/Data-MultiValued/t/json.t
@@ -0,0 +1,84 @@
+#!perl
+use strict;
+use warnings;
+package Foo;{
+use Moose;
+use Data::MultiValued::AttributeTrait::Tagged;
+use Data::Printer;
+
+has stuff => (
+    is => 'rw',
+    isa => 'Int',
+    traits => ['MultiValued::Tagged'],
+    default => 3,
+    predicate => 'has_stuff',
+    clearer => 'clear_stuff',
+);
+
+has other => (
+    is => 'rw',
+    isa => 'Str',
+    traits => ['MultiValued::Tagged'],
+    predicate => 'has_other',
+    clearer => 'clear_other',
+);
+
+sub new_in_place {
+    my ($class,$hash) = @_;
+
+    my $self = bless $hash,$class;
+
+    p $self;
+
+    for my $attr ($class->meta->get_all_attributes) {
+        if ($attr->does('MultiValued::Tagged')) {
+            $attr->_rebless_slot($self);
+        }
+    }
+    return $self;
+}
+
+sub as_hash {
+    my ($self) = @_;
+
+    my %ret = %$self;
+    for my $attr ($self->meta->get_all_attributes) {
+        if ($attr->does('MultiValued::Tagged')) {
+            my $st = $attr->_as_hash($self);
+            if ($st) {
+                $ret{$attr->full_storage_slot} = $st;
+            }
+            else {
+                delete $ret{$attr->full_storage_slot};
+            }
+        }
+    }
+    return \%ret;
+}
+
+}
+package main;
+use Test::Most 'die';
+use Data::Printer;
+use JSON::XS;
+
+my $opts={tag=>'something'};
+
+my $json = JSON::XS->new->utf8;
+my $obj = Foo->new(other=>'foo');
+$obj->stuff_tagged($opts,1234);
+my $hash = $obj->as_hash;
+note p $hash;
+my $str = $json->encode($hash);
+
+note "rebuilding";
+my $obj2 = Foo->new_in_place($json->decode($str));
+
+note p $obj;
+note p $obj2;
+
+is($obj2->stuff,$obj->stuff,'stuff');
+is($obj2->stuff_tagged($opts),$obj->stuff_tagged($opts),'stuff tagged');
+is($obj2->other,$obj->other,'other');
+
+done_testing;