File Coverage

blib/lib/Data/Plist/Writer.pm
Criterion Covered Total %
statement 49 84 58.3
branch 18 38 47.3
condition 7 9 77.7
subroutine 10 11 90.9
pod 5 5 100.0
total 89 147 60.5


line stmt bran cond sub pod time code
1             =head1 NAME
2              
3             Data::Plist::Writer - Object serializer and abstact
4             superclass for BinaryWriter and XMLWriter
5              
6             =head1 SYNOPSIS
7              
8             # Create new
9             my $write = Data::Plist::BinaryWriter->new;
10              
11             # Writing to a string ($ret is binary output)
12             my $ret = $write->write($data);
13              
14             # Writing to a file C<$filename>
15             $ret = $write->write($filename, $data);
16              
17             =head1 DESCRIPTION
18              
19             C is the abstract superclass of
20             L and L. It takes
21             perl data structures, serializes them (see L
22             DATA>), and recursively writes to a given filehandle in the desired
23             format.
24              
25             =cut
26              
27             package Data::Plist::Writer;
28              
29 5     5   28 use strict;
  5         10  
  5         155  
30 5     5   24 use warnings;
  5         8  
  5         132  
31 5     5   2268 use Storable;
  5         7475  
  5         278  
32 5     5   42 use Digest::MD5;
  5         8  
  5         164  
33 5     5   27 use Scalar::Util;
  5         12  
  5         4584  
34              
35             =head1 METHODS
36              
37             =cut
38              
39             =head2 new
40              
41             Creates a new writer. 'serialize' is set to 1 since it's
42             assumed that data being passed in will be perl data
43             structures that need to be serialized. Users may set it to
44             0 when creating a writer if they wish to use preserialized
45             data.
46              
47             =cut
48              
49             sub new {
50 37     37 1 26321 my $class = shift;
51 37         190 my %args = ( serialize => 1, @_ );
52 37         127 return bless \%args => $class;
53             }
54              
55             =head2 write $filehandle, $data
56              
57             =head2 write $filename, $data
58              
59             =head2 write $data
60              
61             Takes a perl data structure C<$data> and writes to the given
62             filehandle C<$filehandle>, or filename C<$filename>. If only the
63             C<$data> is provided, returns the data to be written, as a string.
64              
65             =cut
66              
67             sub write {
68 38     38 1 24345 my $self = shift;
69 38         55 my $object = pop;
70 38         44 my $to = shift;
71              
72 38 50       88 if ( not $to ) {
    0          
73 38         43 my $content = '';
74 38         39 my $fh;
75 38     2   5780 open( $fh, ">", \$content );
  2         35  
  2         4  
  2         71  
76 38 50       3148 $self->write_fh( $fh, $object ) or return;
77 37         307 return $content;
78             } elsif ( ref $to ) {
79 0         0 $self->write_fh( $to, $object );
80             } else {
81 0         0 my $fh;
82 0 0       0 open( $fh, ">", $to ) or die "Can't open $to for writing: $!";
83 0 0       0 $self->write_fh( $fh, $object ) or return;
84             }
85 0         0 return;
86             }
87              
88             =head2 fold_uids $data
89              
90             Takes a serialized object C<$data> (see
91             L) and rewrites it as a keyed
92             archive (see L) by folding on
93             UIDs.
94              
95             =cut
96              
97             sub fold_uids {
98 0     0 1 0 my $self = shift;
99 0         0 my $data = shift;
100              
101 0 0       0 if ( $data->[0] eq "UID" ) {
    0          
    0          
102 0         0 local $Storable::canonical = 1;
103 0         0 my $digest = Digest::MD5::md5_hex( Storable::freeze( $data->[1] ) );
104 0 0       0 if ( exists $self->{objcache}{$digest} ) {
105 0         0 return [ UID => $self->{objcache}{$digest} ];
106             }
107 0         0 push @{ $self->{objects} }, $self->fold_uids( $data->[1] );
  0         0  
108 0         0 $self->{objcache}{$digest} = @{ $self->{objects} } - 1;
  0         0  
109 0         0 return [ UID => @{ $self->{objects} } - 1 ];
  0         0  
110             } elsif ( $data->[0] eq "array" ) {
111 0         0 return [ "array", [ map { $self->fold_uids($_) } @{ $data->[1] } ] ];
  0         0  
  0         0  
112             } elsif ( $data->[0] eq "dict" ) {
113 0         0 my %dict = %{ $data->[1] };
  0         0  
114 0         0 $dict{$_} = $self->fold_uids( $dict{$_} ) for keys %dict;
115 0         0 return [ "dict", \%dict ];
116             } else {
117 0         0 return $data;
118             }
119             }
120              
121             =head2 serialize_value $data
122              
123             Takes a perl data structure C<$data> and turns it into a
124             series of nested arrays of the format [datatype => data]
125             (see L) in preparation for
126             writing. This is an internal data structure that should be
127             immediately handed off to a writer.
128              
129             =cut
130              
131             sub serialize_value {
132 332     332 1 328 my $self = shift;
133 332         291 my ($value) = @_;
134 332 50       1086 if ( not defined $value ) {
    100          
    100          
    100          
    100          
135 0         0 return [ string => '$null' ];
136             } elsif ( ref $value ) {
137 12 100 66     89 if ( ref $value eq "ARRAY" ) {
    100          
    50          
    50          
138             return [
139 5         9 array => [ map { $self->serialize_value($_) } @{$value} ] ];
  305         434  
  5         19  
140             } elsif ( ref $value and ref $value eq "HASH" ) {
141 6         8 my %hash = %{$value};
  6         23  
142 6         44 $hash{$_} = $self->serialize_value( $hash{$_} ) for keys %hash;
143 6         30 return [ dict => \%hash ];
144             } elsif ( $value->isa("Data::Plist::Foundation::NSObject") ) {
145 0         0 return $value->serialize;
146             } elsif ( $value->isa("DateTime") ) {
147 1         7 return [ date => $value->epoch - 978307200
148             + $value->nanosecond / 1e9 ];
149             } else {
150 0         0 die "Can't serialize unknown ref @{[ref $value]}\n";
  0         0  
151             }
152             } elsif ( $value =~ /^-?\d+$/ ) {
153 307         701 return [ integer => $value ];
154             } elsif ( Scalar::Util::looks_like_number($value) ) {
155 2         10 return [ real => $value ];
156             } elsif ( $value =~ /\0/ ) {
157 1         4 return [ data => $value ];
158             } else {
159 10         45 return [ string => $value ];
160             }
161             }
162              
163             =head2 serialize $data
164              
165             Takes a data structure C<$data> and determines what sort of
166             serialization it should go through.
167              
168             Objects wishing to provide their own serializations should
169             have a 'serialize' method, which should return something in
170             the internal structure mentioned above (see also
171             L).
172              
173             =cut
174              
175             sub serialize {
176 20     20 1 24 my $self = shift;
177 20         24 my $object = shift;
178              
179 20 50 100     200 return $self->serialize_value($object)
      66        
180             if not ref($object)
181             or ref($object) =~ /ARRAY|HASH/
182             or not $object->can("serialize");
183              
184 0         0 $object = $object->serialize;
185              
186 0         0 local $self->{objects} = [];
187 0         0 local $self->{objcache} = {};
188 0         0 my $top = $self->fold_uids( [ dict => { root => [ UID => $object ] } ] );
189              
190             return [
191 0         0 dict => {
192             '$archiver' => [ string => "NSKeyedArchiver" ],
193             '$version' => [ integer => 100_000 ],
194             '$top' => $top,
195             '$objects' => [ array => $self->{objects} ],
196             },
197             ];
198             }
199              
200             1;