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


line stmt bran cond sub pod time code
1 4     4   2908 use strict; use warnings;
  4     4   7  
  4         140  
  4         21  
  4         6  
  4         192  
2             package JSYNC;
3             our $VERSION = '0.24';
4              
5 4     4   3031 use JSON;
  4         104909  
  4         21  
6              
7             {
8             package JSYNC;
9              
10             sub dump {
11 7     7 0 11 my ($object, $config) = @_;
12 7   50     32 $config ||= {};
13 7         31 return JSYNC::Dumper->new(%$config)->dump($object);
14             }
15              
16             sub load {
17 7     7 0 13 my ($jsync) = @_;
18 7         29 return JSYNC::Loader->new->load($jsync);
19             }
20              
21             sub info {
22 55     55 0 53 my ($kind, $id, $class);
23 55 50       152 if (ref(\$_[0]) eq 'GLOB') {
    100          
24 0 0       0 (\$_[0] . "") =~ /^(?:(.+)=)?(GLOB)\((0x.*)\)$/
25             or die "Can't get info for '$_[0]'";
26 0   0     0 ($kind, $id, $class) = ('glob', $3, $1 || '');
27             }
28             elsif (not ref($_[0])) {
29 34         43 $kind = 'scalar';
30             }
31             else {
32 21 50       148 "$_[0]" =~ /^(?:(.+)=)?(HASH|ARRAY)\((0x.*)\)$/
33             or die "Can't get info for '$_[0]'";
34 21 100 100     419 ($kind, $id, $class) =
35             (($2 eq 'HASH' ? 'map' : 'seq'), $3, $1 || '');
36             }
37 55         314 return ($kind, $id, $class);
38             }
39             };
40              
41             {
42             package JSYNC::Dumper;
43              
44 7     7   39 sub new { bless { @_[1..$#_] }, $_[0] }
45              
46             sub dump {
47 7     7   14 my ($self, $object) = @_;
48 7         21 $self->{anchor} = 1;
49 7         15 $self->{seen} = {};
50 7         21 my $graph = $self->represent($object);
51 7         47 my $json = 'JSON'->new()->canonical();
52 7 50       19 $json->pretty() if $self->{pretty};
53 7         102 return $json->encode($graph);
54             }
55              
56             sub represent {
57 32     32   43 my ($self, $node) = @_;
58 32         44 my $seen = $self->{seen};
59 32         35 my $graph;
60 32         66 my ($kind, $id, $class) = JSYNC::info($node);
61 32 100       73 if ($kind eq 'scalar') {
62 20 100       39 if (not defined $node) {
63 2         6 return undef;
64             }
65 18         36 return $self->escape($node);
66             }
67 12 100       30 if (my $info = $seen->{$id}) {
68 3 100       7 if (not $info->{anchor}) {
69 2         9 $info->{anchor} = $self->{anchor}++ . "";
70 2 50       6 if ($info->{kind} eq 'map') {
71 2         5 $info->{graph}{'&'} = $info->{anchor};
72             }
73             else {
74 0         0 unshift @{$info->{graph}}, '&' . $info->{anchor};
  0         0  
75             }
76             }
77 3         12 return "*" . $info->{anchor};
78             }
79 9         25 my $tag = $self->resolve_to_tag($kind, $class);
80 9 100       31 if ($kind eq 'seq') {
    50          
    0          
81 3         6 $graph = [];
82 3         14 $seen->{$id} = { graph => $graph, kind => $kind };
83 3         5 @$graph = map { $self->represent($_) } @$node;
  7         16  
84 3 100       9 if ($tag) {
85 1         4 unshift @$graph, "!$tag";
86             }
87             }
88             elsif ($kind eq 'map') {
89 6         12 $graph = {};
90 6         24 $seen->{$id} = { graph => $graph, kind => $kind };
91 6         19 for my $k (keys %$node) {
92 9         40 $graph->{$self->represent($k)} = $self->represent($node->{$k});
93             }
94 6 100       19 if ($tag) {
95 1         3 $graph->{'!'} = $tag;
96             }
97             }
98             # XXX glob should not be a kind.
99             elsif ($kind eq 'glob') {
100 0   0     0 $class ||= 'main';
101 0         0 $graph = {};
102 0         0 $graph->{PACKAGE} = $class;
103 0         0 $graph->{'!'} = '!perl/glob:';
104 0         0 for my $type (qw(PACKAGE NAME SCALAR ARRAY HASH CODE IO)) {
105 0         0 my $value = *{$node}{$type};
  0         0  
106 0 0       0 $value = $$value if $type eq 'SCALAR';
107 0 0       0 if (defined $value) {
108 0 0       0 if ($type eq 'IO') {
109 0         0 my @stats = qw(device inode mode links uid gid rdev size
110             atime mtime ctime blksize blocks);
111 0         0 undef $value;
112 0         0 $value->{stat} = {};
113 0         0 map {$value->{stat}{shift @stats} = $_} stat(*{$node});
  0         0  
  0         0  
114 0         0 $value->{fileno} = fileno(*{$node});
  0         0  
115             {
116 0         0 local $^W;
  0         0  
117 0         0 $value->{tell} = tell(*{$node});
  0         0  
118             }
119             }
120 0         0 $graph->{$type} = $value;
121             }
122             }
123              
124             }
125             else {
126             # XXX [$id, $kind, $class];
127 0         0 die "Can't represent kind '$kind'";
128             }
129 9         21 return $graph;
130             }
131              
132             sub escape {
133 18     18   22 my ($self, $string) = @_;
134 18         46 $string =~ s/^(\.*[\!\&\*\%])/.$1/;
135 18         69 return $string;
136             }
137              
138             my $perl_type = {
139             map => 'hash',
140             seq => 'array',
141             scalar => 'scalar',
142             };
143             sub resolve_to_tag {
144 9     9   13 my ($self, $kind, $class) = @_;
145 9   66     35 return $class && "!perl/$perl_type->{$kind}\:$class";
146             }
147             };
148              
149             {
150             package JSYNC::Loader;
151              
152 7     7   43 sub new { bless { @_[1..$#_] }, $_[0] }
153              
154             sub load {
155 7     7   13 my ($self, $jsync) = @_;
156 7         25 $self->{seen} = {};
157 7         101 my $graph = 'JSON'->new()->decode($jsync);
158 7         44 return $self->construct($graph);
159             }
160              
161              
162             sub construct {
163 23     23   35 my ($self, $graph) = @_;
164 23         33 my $seen = $self->{seen};
165 23         20 my $node;
166 23         44 my ($kind, $id, $class) = JSYNC::info($graph);
167 23 100       55 if ($kind eq 'scalar') {
168 14 100       26 if (not defined $graph) {
169 2         6 return undef;
170             }
171 12 100       32 if ($graph =~ /^\*(\S+)$/) {
172 3         11 return $seen->{$1};
173             }
174 9         19 return $self->unescape($graph);
175             }
176 9 100       29 if ($kind eq 'map') {
    50          
177 6         10 $node = {};
178 6 100       17 if ($graph->{'&'}) {
179 2         5 my $anchor = $graph->{'&'};
180 2         4 delete $graph->{'&'};
181 2         6 $seen->{$anchor} = $node;
182             }
183 6 100       17 if ($graph->{'!'}) {
184 1         7 my $class = $self->resolve_from_tag($graph->{'!'});
185 1         4 delete $graph->{'!'};
186 1         8 bless $node, $class;
187             }
188 6         17 for my $k (keys %$graph) {
189 9         31 $node->{$self->unescape($k)} = $self->construct($graph->{$k});
190             }
191             }
192             elsif ($kind eq 'seq') {
193 3         6 $node = [];
194 3 100 66     33 if (@$graph and defined $graph->[0] and $graph->[0] =~ /^!(.*)$/) {
      100        
195 1         8 my $class = $self->resolve_from_tag($1);
196 1         4 shift @$graph;
197 1         3 bless $node, $class;
198             }
199 3 50 66     28 if (@$graph and $graph->[0] and $graph->[0] =~ /^\&(\S+)$/) {
      66        
200 0         0 $seen->{$1} = $node;
201 0         0 shift @$graph;
202             }
203 3         8 @$node = map {$self->construct($_)} @$graph;
  7         18  
204             }
205 9         47 return $node;
206             }
207              
208             sub unescape {
209 18     18   26 my ($self, $string) = @_;
210 18         27 $string =~ s/^\.(\.*[\!\&\*\%])/$1/;
211 18         61 return $string;
212             }
213              
214             sub resolve_from_tag {
215 2     2   5 my ($self, $tag) = @_;
216 2 50       15 $tag =~ m{^!perl/(?:hash|array|object):(\S+)$}
217             or die "Can't resolve tag '$tag'";
218 2         7 return $1;
219             }
220             };
221              
222             1;