File Coverage

blib/lib/JSYNC.pm

Criterion	Covered	Total	%
statement	104	134	77.6
branch	40	58	68.9
condition	14	23	60.8
subroutine	16	16	100.0
pod	0	3	0.0
total	174	234	74.3

use strict; use warnings;
package JSYNC;
our $VERSION = '0.25';

use JSON;

{
    package JSYNC;

    sub dump {
        my ($object, $config) = @_;
        $config ||= {};
        return JSYNC::Dumper->new(%$config)->dump($object);
    }

    sub load {
        my ($jsync) = @_;
        return JSYNC::Loader->new->load($jsync);
    }

    sub info {
        my ($kind, $id, $class);
        if (ref(\$_[0]) eq 'GLOB') {
            (\$_[0] . "") =~ /^(?:(.+)=)?(GLOB)\((0x.*)\)$/
                or die "Can't get info for '$_[0]'";
            ($kind, $id, $class) = ('glob', $3, $1 || '');
        }
        elsif (not ref($_[0])) {
            $kind = 'scalar';
        }
        else {
            "$_[0]" =~ /^(?:(.+)=)?(HASH|ARRAY)\((0x.*)\)$/
                or die "Can't get info for '$_[0]'";
            ($kind, $id, $class) =
                (($2 eq 'HASH' ? 'map' : 'seq'), $3, $1 || '');
        }
        return ($kind, $id, $class);
    }
};

{
    package JSYNC::Dumper;

    sub new { bless { @_[1..$#_] }, $_[0] }

    sub dump {
        my ($self, $object) = @_;
        $self->{anchor} = 1;
        $self->{seen} = {};
        my $graph = $self->represent($object);
        my $json = 'JSON'->new()->canonical();
        $json->pretty() if $self->{pretty};
        return $json->encode($graph);
    }

    sub represent {
        my ($self, $node) = @_;
        my $seen = $self->{seen};
        my $graph;
        my ($kind, $id, $class) = JSYNC::info($node);
        if ($kind eq 'scalar') {
            if (not defined $node) {
                return undef;
            }
            return $self->escape($node);
        }
        if (my $info = $seen->{$id}) {
            if (not $info->{anchor}) {
                $info->{anchor} = $self->{anchor}++ . "";
                if ($info->{kind} eq 'map') {
                    $info->{graph}{'&'} = $info->{anchor};
                }
                else {
                    unshift @{$info->{graph}}, '&' . $info->{anchor};
                }
            }
            return "*" . $info->{anchor};
        }
        my $tag = $self->resolve_to_tag($kind, $class);
        if ($kind eq 'seq') {
            $graph = [];
            $seen->{$id} = { graph => $graph, kind => $kind };
            @$graph = map { $self->represent($_) } @$node;
            if ($tag) {
                unshift @$graph, "!$tag";
            }
        }
        elsif ($kind eq 'map') {
            $graph = {};
            $seen->{$id} = { graph => $graph, kind => $kind };
            for my $k (keys %$node) {
                $graph->{$self->represent($k)} = $self->represent($node->{$k});
            }
            if ($tag) {
                $graph->{'!'} = $tag;
            }
        }
        # XXX glob should not be a kind.
        elsif ($kind eq 'glob') {
            $class ||= 'main';
            $graph = {};
            $graph->{PACKAGE} = $class;
            $graph->{'!'} = '!perl/glob:';
            for my $type (qw(PACKAGE NAME SCALAR ARRAY HASH CODE IO)) {
                my $value = *{$node}{$type};
                $value = $$value if $type eq 'SCALAR';
                if (defined $value) {
                    if ($type eq 'IO') {
                        my @stats = qw(device inode mode links uid gid rdev size
                                       atime mtime ctime blksize blocks);
                        undef $value;
                        $value->{stat} = {};
                        map {$value->{stat}{shift @stats} = $_} stat(*{$node});
                        $value->{fileno} = fileno(*{$node});
                        {
                            local $^W;
                            $value->{tell} = tell(*{$node});
                        }
                    }
                    $graph->{$type} = $value;
                }
            }

        }
        else {
            # XXX [$id, $kind, $class];
            die "Can't represent kind '$kind'";
        }
        return $graph;
    }

    sub escape {
        my ($self, $string) = @_;
        $string =~ s/^(\.*[\!\&\*\%])/.$1/;
        return $string;
    }

    my $perl_type = {
        map => 'hash',
        seq => 'array',
        scalar => 'scalar',
    };
    sub resolve_to_tag {
        my ($self, $kind, $class) = @_;
        return $class && "!perl/$perl_type->{$kind}\:$class";
    }
};

{
    package JSYNC::Loader;

    sub new { bless { @_[1..$#_] }, $_[0] }

    sub load {
        my ($self, $jsync) = @_;
        $self->{seen} = {};
        my $graph = 'JSON'->new()->decode($jsync);
        return $self->construct($graph);
    }


    sub construct {
        my ($self, $graph) = @_;
        my $seen = $self->{seen};
        my $node;
        my ($kind, $id, $class) = JSYNC::info($graph);
        if ($kind eq 'scalar') {
            if (not defined $graph) {
                return undef;
            }
            if ($graph =~ /^\*(\S+)$/) {
                return $seen->{$1};
            }
            return $self->unescape($graph);
        }
        if ($kind eq 'map') {
            $node = {};
            if ($graph->{'&'}) {
                my $anchor = $graph->{'&'};
                delete $graph->{'&'};
                $seen->{$anchor} = $node;
            }
            if ($graph->{'!'}) {
                my $class = $self->resolve_from_tag($graph->{'!'});
                delete $graph->{'!'};
                bless $node, $class;
            }
            for my $k (keys %$graph) {
                $node->{$self->unescape($k)} = $self->construct($graph->{$k});
            }
        }
        elsif ($kind eq 'seq') {
            $node = [];
            if (@$graph and defined $graph->[0] and $graph->[0] =~ /^!(.*)$/) {
                my $class = $self->resolve_from_tag($1);
                shift @$graph;
                bless $node, $class;
            }
            if (@$graph and $graph->[0] and $graph->[0] =~ /^\&(\S+)$/) {
                $seen->{$1} = $node;
                shift @$graph;
            }
            @$node = map {$self->construct($_)} @$graph;
        }
        return $node;
    }

    sub unescape {
        my ($self, $string) = @_;
        $string =~ s/^\.(\.*[\!\&\*\%])/$1/;
        return $string;
    }

    sub resolve_from_tag {
        my ($self, $tag) = @_;
        $tag =~ m{^!perl/(?:hash|array|object):(\S+)$}
          or die "Can't resolve tag '$tag'";
        return $1;
    }
};

1;