File Coverage

blib/lib/Class/Storage.pm
Criterion Covered Total %
statement 24 94 25.5
branch 0 38 0.0
condition 0 16 0.0
subroutine 8 17 47.0
pod 2 2 100.0
total 34 167 20.3


line stmt bran cond sub pod time code
1             package Class::Storage;
2              
3             # See perldoc at bottom of this file
4              
5 2     2   32290 use 5.006;
  2         5  
  2         71  
6 2     2   10 use strict;
  2         9  
  2         60  
7 2     2   8 use warnings FATAL => 'all';
  2         10  
  2         106  
8              
9             our $VERSION = '0.02';
10              
11 2     2   9 use Scalar::Util qw(blessed reftype);
  2         2  
  2         208  
12              
13 2     2   11 use base qw(Exporter);
  2         3  
  2         243  
14             our @EXPORT_OK = qw(packObjects unpackObjects);
15              
16 2     2   13 use constant DEFAULT_TO_PACKED_METHOD_NAME => "TO_PACKED";
  2         2  
  2         138  
17 2     2   8 use constant DEFAULT_FROM_PACKED_METHOD_NAME => "FROM_PACKED";
  2         2  
  2         74  
18              
19             # MooseX::Storage uses __CLASS__ and so it is perhaps a good idea not to choose
20             # *exactly* the same magic string - then it isn't magic any more! :-)
21 2     2   7 use constant DEFAULT_MAGIC_STRING => "__class__";
  2         3  
  2         1874  
22              
23             sub packObjects {
24 0     0 1   my ($data, %options) = @_;
25              
26 0           _setDefaultOptions(\%options);
27              
28 0           my $val = _packObjects($data, \%options);
29 0   0       return $val // $data;
30             }
31              
32             sub _packObjects {
33 0     0     my ($data, $options) = @_;
34              
35 0           my $toPackedMethodName = $options->{toPackedMethodName};
36              
37 0 0 0       if (blessed $data && $data->can($toPackedMethodName)) {
38 0           my $packed = $data->$toPackedMethodName();
39 0           bless $packed, ref($data);
40 0           $data = $packed;
41             }
42              
43 0 0         if (reftype $data) {
44 0 0         if (reftype $data eq 'HASH') {
    0          
45 0           return _packObjectsHash($data, $options);
46             } elsif (reftype $data eq 'ARRAY') {
47 0           return _packObjectsArray($data, $options);
48             }
49             }
50              
51 0           return undef;
52             }
53              
54             sub _packObjectsHash {
55 0     0     my ($hash, $options) = @_;
56             # use Dbug; dbugDump(['hash', $hash]);
57 0           foreach my $key (keys %$hash) {
58 0           my $val = $hash->{$key};
59 0           my $newVal = _packObjects($val, $options);
60 0 0         if ($newVal) {
61 0           $hash->{$key} = $newVal;
62             }
63             }
64 0 0         if (blessed $hash) {
65 0 0         $hash = {
66             ( $options->{magicString} ?
67             ( $options->{magicString} => ref($hash) ) : ()),
68             %$hash
69             };
70             }
71 0           return $hash;
72             }
73              
74             sub _packObjectsArray {
75 0     0     my ($array, $options) = @_;
76             # use Dbug; dbugDump(['array', $array]);
77 0           foreach my $index (0..$#$array) {
78 0           my $val = $array->[$index];
79 0           my $newVal = _packObjects($val, $options);
80 0 0         if ($newVal) {
81 0           $array->[$index] = $newVal;
82             }
83             }
84 0 0         if (blessed $array) {
85 0 0         $array = [
86             ( $options->{magicString} ?
87             ( $options->{magicString} => ref($array) ) : ()),
88             @$array
89             ];
90             }
91 0           return $array;
92             }
93              
94             sub unpackObjects {
95 0     0 1   my ($data, %options) = @_;
96 0           _setDefaultOptions(\%options);
97 0           my $val = _unpackObjects($data, \%options);
98 0   0       return $val // $data;
99             }
100              
101             sub _unpackObjects {
102 0     0     my ($data, $options) = @_;
103 0 0         if (reftype $data eq 'HASH') {
    0          
104 0           return _unpackObjectsHash($data, $options);
105             } elsif (reftype $data eq 'ARRAY') {
106 0           return _unpackObjectsArray($data, $options);
107             }
108 0           return undef;
109             }
110              
111             sub _unpackObjectsHash {
112 0     0     my ($hash, $options) = @_;
113 0           my $class = delete $hash->{$options->{magicString}};
114 0 0         if ($class) {
115 0           my $fromPackedMethodName = $options->{fromPackedMethodName};
116 0 0         if ($class->can($fromPackedMethodName)) {
117 0           return $class->$fromPackedMethodName($hash);
118             }
119 0           bless $hash, $class;
120             }
121 0           foreach my $key (keys %$hash) {
122 0           my $newVal = _unpackObjects($hash->{$key}, $options);
123 0 0         $hash->{$key} = $newVal
124             if defined $newVal;
125             }
126 0           return undef;
127             }
128              
129             sub _unpackObjectsArray {
130 0     0     my ($array, $options) = @_;
131 0 0 0       if (scalar @$array >= 2 && $array->[0] eq $options->{magicString}) {
132 0           shift @$array;
133 0           my $class = shift @$array;
134 0           my $fromPackedMethodName = $options->{fromPackedMethodName};
135 0 0         if ($class->can($fromPackedMethodName)) {
136 0           return $class->$fromPackedMethodName($array);
137             }
138 0           bless $array, $class;
139             }
140 0           foreach my $i (0..$#$array) {
141 0           my $newVal = _unpackObjects($array->[$i], $options);
142 0 0         $array->[$i] = $newVal
143             if defined $newVal;
144             }
145 0           return undef;
146             }
147              
148             sub _setDefaultOptions {
149 0     0     my ($options) = @_;
150 0   0       $options->{toPackedMethodName} //= DEFAULT_TO_PACKED_METHOD_NAME;
151 0   0       $options->{fromPackedMethodName} //= DEFAULT_FROM_PACKED_METHOD_NAME;
152 0 0         if (! exists $options->{magicString}) {
153 0           $options->{magicString} = DEFAULT_MAGIC_STRING;
154             }
155             }
156              
157             =head1 NAME
158              
159             Class::Storage - pack objects by removing blessing so they can be unpacked back
160             into objects again later.
161              
162             Handles blessed HASHes and ARRAYs
163              
164             =head1 VERSION
165              
166             Version 0.02
167              
168             =head1 SYNOPSIS
169              
170             This module came into existence out of the need to be able to send I
171             over JSON. JSON does not allow any blessed references to be sent by default and
172             if sent, provides no generic way to resurrect these objects again after
173             decoding. This can now all be done like this:
174              
175             use JSON;
176             use Class::Storage qw(packObjects unpackObjects);
177              
178             my $object = bless { a => 1 }, 'MyModule';
179             my $packed = packObjects( $object );
180              
181             # $packed is now { __class__ => 'MyModule', a => 1 }
182              
183             print $writeHandle encode_json($packed), "\n";
184              
185             # And on the other "side":
186              
187             my $jsonString = <$readHandle>;
188             my $packed = decode_json($jsonString);
189             my $unpackedObject = unpackObjects($packed);
190              
191             # $unpacked is now bless { a => 1 }, 'MyModule'
192             # Which is_deeply the same as $object that we started with
193              
194             However, there is no JSON-specific functionality in this module whatsoever,
195             only a way to cleanly remove the bless-ing in a way that reliably can be
196             re-introduced later.
197              
198             =head1 DESCRIPTION
199              
200             =head2 Using a magic string
201              
202             As you can see from the L, we use a magic string (C<__class__> by
203             default) to store the class information for HASHes and ARRAYs.
204              
205             So C turns:
206              
207             bless { key => "value" }, "ModuleA";
208             bless [ "val1", "val2" ], "ModuleB";
209              
210             into:
211              
212             { __class__ => 'ModuleA', key => "value" }
213             [ "__class__", 'ModuleB', "val1", "val2" ]
214              
215             C converts any hashes with the magic string as a key and any
216             arrays with the magic string as the first element back to blessed references
217              
218             This "magic string" can be given as an option (see L), but if you
219             cannot live with a magic string, you can also provide
220             C<< magicString => undef >>. But then you won't be able to unpack that data and
221             turn it back into objects. If this is your itch, you may actually want
222             L instead.
223              
224             =head2 Returns packed/unpacked data + modifies input argument
225              
226             The valid data is returned. However, for speed, we also modify and re-use data
227             from the input value. So don't rely on being able to reuse the C<$data> input
228             for C and C after they've been called and don't
229             modify them either.
230              
231             If you don't want your input modified:
232              
233             use Storable qw(dclone);
234             my $pristineData = somesub();
235             my $packed = packObjects(dclone($pristineData));
236              
237             =head2 Inspiration
238              
239             Class::Storage is inspired by L but this is a generic
240             implementation that works on all plain perl classes that are implemented as
241             blessed references to HASHes and ARRAYs (B hashes and arrays).
242              
243             NOTE: L uses C<__CLASS__> as its magic string and we use
244             C<__class__> to make sure they're not the same.
245              
246             =head2 C and C
247              
248             If you want to control how internal state gets represeted when packed, then
249             provide a C instance method. It will be called like:
250              
251             my $packed = $object->TO_PACKED();
252              
253             This C<$packed> data will be used by C instead of the guts of
254             C<$object>.
255              
256             Similarly, during C, if a module has a C static
257             method it will be called like this:
258              
259             my $object = $module->FROM_PACKED($packed);
260              
261             As you can see, C and C go together as pairs.
262              
263             You can also modify the names of these methods with the C
264             and C options. See L.
265              
266             =head1 NOTE ABOUT KINDS OF BLESSED OBJECTS
267              
268             L says:
269              
270             "... it's possible to bless any type of data structure or referent, including
271             scalars, globs, and subroutines. You may see this sort of thing when looking at
272             code in the wild."
273              
274             In particular I've seen several XS modules create instances where the internal
275             state is not visible to Perl, and hence cannot be handled properly by this
276             module. Here is an example with JSON:
277              
278             use Data::Dumper;
279             use JSON;
280             print Dumper(JSON->new()->pretty(1));
281             # prints
282             # $VAR1 = bless( do{\(my $o = '')}, 'JSON' );
283              
284             Clearly a L object has internal state and other data. This is an example
285             of a blessed reference, but not a blessed HASH or ARRAY that Class::Storage can
286             handle. If you try C-ing such a JSON instance, Class::Storage will
287             just leave the JSON object altogether untouched.
288              
289             =head1 EXPORT
290              
291             our @EXPORT_OK = qw(packObjects unpackObjects);
292              
293             =head1 SUBROUTINES/METHODS
294              
295             Both C and C share the same C<%options>. See
296             L below.
297              
298             =head2 packObjects
299              
300             my $packed = packObjects($blessed, %options);
301              
302             =head2 unpackObjects
303              
304             my $unpacked = unpackObjects($unbessed, %options);
305              
306             =head1 OPTIONS
307              
308             These options are common to C and C:
309              
310             =over 4
311              
312             =item * C
313              
314             This option lets you change the name of the C method to something
315             else. Hint: C could be a good idea here!
316              
317             =item * C
318              
319             This option lets you change the name of the C method to something
320             else. Hint: C could be a good idea here, even though L
321             doesn't have such a method. Which is actually the entire Raison d'Etre of this
322             module!
323              
324             =item * C
325              
326             Change the magic string used to store the class name to something else than
327             C<__class__>.
328              
329             If this is false, don't store class information at all, in which case
330             C becomes analogous to L.
331              
332             =back
333              
334             =encoding UTF-8
335              
336             =head1 AUTHOR
337              
338             Peter Valdemar Mørch, C<< >>
339              
340             =head1 BUGS
341              
342             Please report any bugs or feature requests to
343             L. I will be notified, and
344             then you'll automatically be notified of progress on your bug as I make
345             changes.
346              
347             =head1 SUPPORT
348              
349             You can find documentation for this module with the perldoc command.
350              
351             perldoc Class::Storage
352              
353             You can also look for information at:
354              
355             =over 4
356              
357             =item * Repository and Bug Tracker on Github
358              
359             L
360              
361             =item * AnnoCPAN: Annotated CPAN documentation
362              
363             L
364              
365             =item * CPAN Ratings
366              
367             L
368              
369             =item * Search CPAN
370              
371             L
372              
373             =back
374              
375             =head1 ACKNOWLEDGEMENTS
376              
377             This has been inspired by many sources, but checkout:
378              
379             =over 4
380              
381             =item * How to convert Perl objects into JSON and vice versa - Stack Overflow
382              
383             L
384              
385             =item * How do I turn Moose objects into JSON for use in Catalyst?
386              
387             L
388              
389             =item * MooseX-Storage
390              
391             L
392              
393             =item * Brian D Foy's quick hack
394              
395             Where he defines a TO_JSON in UNIVERSAL so it applies to all objects. It makes
396             a deep copy, unblesses it, and returns the data structure.
397              
398             L
399              
400             =back
401              
402             =head1 LICENSE AND COPYRIGHT
403              
404             Copyright 2015 Peter Valdemar Mørch.
405              
406             This program is free software; you can redistribute it and/or modify it
407             under the terms of the the Artistic License (2.0). You may obtain a
408             copy of the full license at:
409              
410             L
411              
412             Any use, modification, and distribution of the Standard or Modified
413             Versions is governed by this Artistic License. By using, modifying or
414             distributing the Package, you accept this license. Do not use, modify,
415             or distribute the Package, if you do not accept this license.
416              
417             If your Modified Version has been derived from a Modified Version made
418             by someone other than you, you are nevertheless required to ensure that
419             your Modified Version complies with the requirements of this license.
420              
421             This license does not grant you the right to use any trademark, service
422             mark, tradename, or logo of the Copyright Holder.
423              
424             This license includes the non-exclusive, worldwide, free-of-charge
425             patent license to make, have made, use, offer to sell, sell, import and
426             otherwise transfer the Package with respect to any patent claims
427             licensable by the Copyright Holder that are necessarily infringed by the
428             Package. If you institute patent litigation (including a cross-claim or
429             counterclaim) against any party alleging that the Package constitutes
430             direct or contributory patent infringement, then this Artistic License
431             to you shall terminate on the date that such litigation is filed.
432              
433             Disclaimer of Warranty: THE PACKAGE IS PROVIDED BY THE COPYRIGHT HOLDER
434             AND CONTRIBUTORS "AS IS' AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES.
435             THE IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR
436             PURPOSE, OR NON-INFRINGEMENT ARE DISCLAIMED TO THE EXTENT PERMITTED BY
437             YOUR LOCAL LAW. UNLESS REQUIRED BY LAW, NO COPYRIGHT HOLDER OR
438             CONTRIBUTOR WILL BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, OR
439             CONSEQUENTIAL DAMAGES ARISING IN ANY WAY OUT OF THE USE OF THE PACKAGE,
440             EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
441              
442             =cut
443              
444             1; # End of Class::Storage