File Coverage

blib/lib/Class/Serializer.pm
Criterion Covered Total %
statement 79 132 59.8
branch 9 28 32.1
condition 6 24 25.0
subroutine 14 17 82.3
pod 2 2 100.0
total 110 203 54.1


line stmt bran cond sub pod time code
1             package Class::Serializer;
2            
3 1     1   22035 use warnings;
  1     1   2  
  1         37  
  1         20790  
  1         2  
  1         30  
4 1     1   5 use strict;
  1     1   2  
  1         23  
  1         4  
  1         2  
  1         20  
5            
6             # no imports, thanks
7 1     1   5 use File::Path ();
  1     1   5  
  1         16  
  1         5  
  1         1  
  1         14  
8 1     1   1453 use Data::Dump::Streamer ();
  1     1   107570  
  1         75  
  1         1383  
  1         72734  
  1         76  
9            
10             =head1 NAME
11            
12             Class::Serializer - Serializes the in-memory state of a class into code
13            
14             =head1 VERSION
15            
16             Version 0.04
17            
18             =cut
19            
20             our $VERSION = '0.04';
21            
22             =head1 SYNOPSIS
23            
24             This module does its best efforts to serialize the in-memory state of a class
25             into runable code. For this to actually happen successfully it relies heavily
26             on L which, in turn, relies on L for
27             CODEREF deparsing and other similar tasks.
28            
29             B
30             There are no guarantees whatsoever about the generated code.>
31            
32             With that said, it should work just fine.
33            
34             Here's a little a code snippet:
35            
36             use Class::Serializer;
37            
38             # Class::Serializer is Class::Serializer safe
39             my $class_code = Class::Serializer->as_string('Class::Serializer');
40            
41             # writes directly to ClassSerializer.pm
42             Class::Serializer->as_file(Class::Serializer => 'ClassSerializer.pm');
43            
44             =head1 CLASS METHODS
45            
46             =cut
47            
48             =head2 as_string($target_class)
49            
50             Serializes C<$target_class> in-memory state (actually, symbol table entries)
51             into perl code and returns it as a string. It will also try to detect possible
52             dependencies and try to honor them through C statements in the
53             generated code.
54            
55             =cut
56             sub as_string {
57 0     0 1 0 my $class = shift;
  2     2   32  
58 0         0 my ($target) = @_;
  2         5  
59            
60 0         0 my %seen;
  2         5  
61 1     1   7 no strict 'refs';
  1     1   3  
  1         123  
  1         8  
  1         1  
  1         126  
62            
63             # loads the relevant data structures
64 0         0 while (my ($entry, $contents) = each %{"${target}::"}) {
  0         0  
  2         4  
  24         121  
65 0         0 for my $type (qw|SCALAR ARRAY HASH CODE|) {
  22         40  
66 0 0       0 if (*{$contents}{$type}) {
  0 100       0  
  88         128  
  88         306  
67 0 0 0     0 next if ($type eq 'SCALAR' && !defined ${*{$contents}{$type}});
  0 100 100     0  
  0         0  
  30         89  
  22         28  
  22         111  
68 0         0 push(@{$seen{$type}}, ["$entry", *{$contents}{$type}]);
  0         0  
  0         0  
  18         27  
  18         46  
  18         77  
69             }
70             }
71             };
72            
73 1     1   6 use strict 'refs';
  1     1   2  
  1         559  
  1         5  
  1         2  
  1         562  
74            
75             # builds up something suitable to be spoon fed to the dumper
76 0         0 my (@dump, @names);
  2         5  
77 0         0 for my $type (qw|ARRAY HASH CODE|) {
  2         4  
78 0         0 for my $entry (@{$seen{$type}}) {
  0         0  
  6         8  
  6         19  
79 0         0 push(@dump, $entry->[1]);
  8         16  
80 0         0 push(@names, '*'.$entry->[0]);
  8         23  
81             }
82             }
83            
84             # Data::Dumper messes everything up with scalars
85 0         0 for my $entry (@{$seen{SCALAR}}) {
  0         0  
  2         4  
  2         6  
86 0         0 push(@dump, ${$entry->[1]});
  0         0  
  10         14  
  10         17  
87 0         0 push(@names, '$'.$entry->[0]);
  10         29  
88             }
89            
90             my $dump =
91             "package $target;\n" .
92 0         0 Data::Dump::Streamer::DumpVars( map { $names[$_], $dump[$_] } 0..$#dump )->Declare(1)->Out() .
  0         0  
  2         9  
  18         43  
93             ';1;';
94            
95 0         0 my %required = ($target => 1);
  2         80547  
96             # tries to detect dependencies and loads them through eval 'require Pkg'
97             # (eval is used so that errors are not fatal)
98 0         0 my $require = '';
  2         112  
99 0         0 while ($dump =~ /(?:package ([\w\:]+);|'([\w\:]+)'\->)/g) {
  2         31  
100 0   0     0 my $pkg = $1 || $2;
  8   33     27  
101 0 0       0 unless ($required{$pkg}) {
  8 50       165  
102 0         0 $require .= "eval 'require $pkg';\n";
  0         0  
103 0         0 $required{$pkg} = 1;
  0         0  
104             }
105             }
106            
107 0         0 $require . $dump;
  2         77  
108            
109             }
110            
111             =head2 as_file($target_class, [$file_name, [$overwrite]])
112            
113             Serializes C<$target_class> in-memory state into perl code and saves it into
114             C<$file_name>, overwriting the file if C<$overwrite> is set to a true value.
115            
116             If C<$file_name> is not defined, it will be constructed based on the target
117             class name, relative do the current path. So C would be saved
118             in Class/Serializer.pm.
119            
120             If C<$file_name> exists and C<$overwrite> is not set, an exception is thrown.
121             An exception is also thrown if the file is not writable.
122            
123             =cut
124            
125             sub as_file {
126 0     0 1 0 my $class = shift;
  1     1   3  
127 0         0 my ($target, $file_name, $overwrite) = @_;
  1         3  
128            
129             # constructs the file name, if it's either undef or empty
130 0 0 0     0 unless (defined $file_name && length($file_name)) {
  1 50 33     11  
131 0         0 ($file_name = $target) =~ s|::|/|;
  0         0  
132 0         0 $file_name .= '.pm';
  0         0  
133             }
134            
135             # creates directories if they don't exist
136 0 0       0 if ((my $path = $file_name) =~ s|([\\/])[^\\/]+$|$1|) {
  1 50       34  
137 0         0 File::Path::mkpath($path);
  1         312  
138             }
139            
140 0 0 0     0 _croak("'$file_name' already exists")
  1 50 33     20  
141             if (-e $file_name && !$overwrite);
142            
143             # writes
144 0 0       0 open(my $fh, '>', $file_name)
  1 50       88  
145             or _croak("couldn't write to '$file_name': $!");
146            
147 0         0 print $fh $class->as_string($target);
  1         6  
148            
149 0         0 close $fh;
  1         228  
150            
151 0         0 $file_name;
  1         13  
152             }
153            
154             sub _croak {
155 0     0   0 require Carp;
156 0         0 Carp::croak(@_);
157             }
158            
159             =head1 CAVEATS
160            
161             The dependency detecting code is pretty simple and may be not very reliable.
162            
163             Closures should work just fine as of version 0.04. This feature wasn't tested
164             extensively, though (it just relies on L for that).
165            
166             =head1 AUTHOR
167            
168             Nilson Santos Figueiredo Junior, C<< >>
169            
170             =head1 BUGS
171            
172             Please report any bugs or feature requests directly to the author.
173             If you ask nicely it will probably get fixed or implemented.
174            
175             =head1 SUPPORT
176            
177             You can also look for information at:
178            
179             =over 4
180            
181             =item * AnnoCPAN: Annotated CPAN documentation
182            
183             L
184            
185             =item * CPAN Ratings
186            
187             L
188            
189             =item * Search CPAN
190            
191             L
192            
193             =back
194            
195             =head1 SEE ALSO
196            
197             L, L
198            
199             =head1 COPYRIGHT & LICENSE
200            
201             Copyright 2008 Nilson Santos Figueiredo Junior, all rights reserved.
202            
203             This program is free software; you can redistribute it and/or modify it
204             under the same terms as Perl itself.
205            
206             =cut
207            
208             1; # End of Class::Serializer