File Coverage

blib/lib/Object/Serializer.pm

Criterion	Covered	Total	%
statement	55	61	90.1
branch	4	10	40.0
condition	5	18	27.7
subroutine	12	14	85.7
pod	2	3	66.6
total	78	106	73.5

# ABSTRACT: General Purpose Object Serializer
package Object::Serializer;

use utf8;
use 5.010;
use strict;
use warnings;
use Data::Dumper ();
use Scalar::Util qw(blessed refaddr);
our %TYPES;

our $VERSION = '0.000011'; # VERSION


sub new {
    bless {}, shift
}

sub _serialization {
    my ($self, $options, $reference, $class) = @_;
    my @registries = (ref($self) || $self, __PACKAGE__);

    for my $registry (@registries) {
        my $type = $TYPES{$registry};
        next unless 'HASH' eq ref $type;
        my $coercion = $type->{$class};
        return $coercion->(bless $reference, $class)
            if 'CODE' eq ref $coercion;
    }

    # tag blessed hash references
    $reference->{$options->{marker}} = $class
        if defined $options->{marker} && 'HASH' eq ref $reference;

    return $reference;
}


sub serialize {
    my ($self, $object, %options) = @_;

    local $Data::Dumper::Terse      = 1;
    local $Data::Dumper::Indent     = 0;
    local $Data::Dumper::Useqq      = 1;
    local $Data::Dumper::Deparse    = 1;
    local $Data::Dumper::Quotekeys  = 0;
    local $Data::Dumper::Sortkeys   = 1;
    local $Data::Dumper::Deepcopy   = 1;
    local $Data::Dumper::Purity     = 0;

    my $options   = {marker => '__CLASS__', %options};
    my $execution = join '::', __PACKAGE__, 'Runtime', refaddr $self;

    no strict 'refs';
    no warnings 'redefine';

    *{$execution} = sub {
        my @arguments = @_;
        Object::Serializer::_serialization($self, $options, @arguments);
    };

    (my $target = Data::Dumper::Dumper($object // $self)) =~
        s/bless(?=(?:(?:(?:[^"\\]++|\\.)*+"){2})*+(?:[^"\\]++|\\.)*+$)/$execution/g;

    my $hash = do { no strict; eval "my \$VAR1 = $target\n" } or die $@;

    undef *{$execution};
    return $hash;
}


sub serialization_strategy_for {
    my ($self, $reftype, $routine) = @_;

    die "Couldn't register reftype serialization " .
        "strategy due to invalid arguments"
            unless $self && $reftype && 'CODE' eq ref $routine;

    return $TYPES{ref($self) || $self}{$reftype} = $routine;
}


1;

__END__