File Coverage

blib/lib/MooseX/Blessed/Reconstruct.pm
Criterion Covered Total %
statement 41 44 93.1
branch 4 10 40.0
condition n/a
subroutine 11 11 100.0
pod 3 3 100.0
total 59 68 86.7


line stmt bran cond sub pod time code
1             package MooseX::Blessed::Reconstruct;
2             BEGIN {
3 1     1   15378 $MooseX::Blessed::Reconstruct::AUTHORITY = 'cpan:YANICK';
4             }
5             # ABSTRACT: A L<Data::Visitor> for creating Moose objects from blessed placeholders
6              
7              
8 1     1   474 use Moose;
  1         356372  
  1         8  
9              
10 1     1   5922 use Carp qw(croak);
  1         2  
  1         60  
11              
12 1     1   5 use Class::MOP;
  1         3  
  1         21  
13 1     1   4 use Class::Load;
  1         1  
  1         33  
14 1     1   795 use Data::Visitor 0.21; # n-arity visit
  1         34527  
  1         67  
15              
16 1     1   12 use Scalar::Util qw(reftype);
  1         1  
  1         77  
17              
18 1     1   6 use namespace::clean -except => 'meta';
  1         1  
  1         9  
19              
20             our $VERSION = "0.03";
21              
22             extends qw(Data::Visitor);
23              
24             has load_classes => (
25             isa => "Bool",
26             is => "rw",
27             default => 1,
28             );
29              
30             sub visit_object {
31 4     4 1 737 my ( $v, $obj ) = @_;
32              
33 4         9 my $class = ref $obj;
34              
35 4 50       147 Class::Load::load_class($class) if $v->load_classes;
36              
37 4         125 my $meta = Class::MOP::get_metaclass_by_name($class);
38              
39 4 100       18 if ( ref $meta ) {
40 1         6 return $v->visit_object_with_meta($obj, $meta);
41             } else {
42 3         15 return $v->visit_ref($obj);
43             }
44             }
45              
46             sub visit_object_with_meta {
47 1     1 1 2 my ( $v, $obj, $meta ) = @_;
48              
49 1         4 my $instance = $meta->get_meta_instance->create_instance;
50              
51 1         33 $v->_register_mapping( $obj => $instance );
52              
53 1         13 my $args = $v->prepare_args( $meta, $obj );
54              
55 1         15 $meta->new_object( %$args, __INSTANCE__ => $instance );
56              
57 1         2174 return $instance;
58             }
59              
60             sub prepare_args {
61 1     1 1 3 my ( $v, $meta, $obj ) = @_;
62              
63 1         2 my @args;
64              
65 1 50       8 if ( reftype $obj eq 'HASH' ) {
    0          
    0          
66 1         7 @args = %$obj;
67             } elsif ( reftype $obj eq 'ARRAY' ) {
68 0         0 @args = @$obj;
69             } elsif ( reftype $obj eq 'SCALAR' ) {
70 0         0 @args = $$obj;
71             } else {
72 0         0 croak "unknown ref type $obj";
73             }
74              
75 1         7 my @processed = $v->visit(@args);
76              
77 1         103 return $meta->name->BUILDARGS(@processed);
78             }
79              
80             __PACKAGE__->meta->make_immutable;
81              
82             __PACKAGE__
83              
84             __END__
85              
86             =pod
87              
88             =encoding UTF-8
89              
90             =head1 NAME
91              
92             MooseX::Blessed::Reconstruct - A L<Data::Visitor> for creating Moose objects from blessed placeholders
93              
94             =head1 VERSION
95              
96             version 0.5
97              
98             =head1 SYNOPSIS
99              
100             use MooseX::Blessed::Reconstruct;
101              
102              
103             my $obj = bless( {
104             init_arg_foo => "Blah",
105             arf => "yay",
106             }, "Foo" );
107              
108             my $proper = MooseX::Blessed::Reconstruct->new->visit($obj);
109              
110              
111              
112             # equivalent to:
113              
114             my $proper = Foo->meta->new_object(%$obj);
115              
116             # but recursive (and works with shared references)
117              
118             =head1 DESCRIPTION
119              
120             The purpose of this module is to "fix up" blessed data into a real Moose
121             object.
122              
123             This is used internally by L<MooseX::YAML> but has no implementation details
124             having to do with L<YAML> itself.
125              
126             =head1 METHODS
127              
128             See L<Data::Visitor>
129              
130             =over 4
131              
132             =item visit_object $object
133              
134             Calls L<Class::MOP/load_class> on the C<ref> of $object.
135              
136             If there's a metaclass, calls C<visit_object_with_meta>, otherwise C<visit_ref>
137             is used to walk the object brutishly.
138              
139             Returns a deep clone of the input structure with all the L<Moose> objects
140             reconstructed "properly".
141              
142             =item visit_object_with_meta $obj, $meta
143              
144             Uses the metaclass C<$meta> to create a new instance, registers the instance
145             with L<Data::Visitor>'s cycle tracking, and then inflates it using
146             L<Moose::Meta::Class/new_object>.
147              
148             =item prepare_args $obj
149              
150             Collapses $obj into key value pairs to be used as init args to
151             L<Moose::Meta::Class/new_object>.
152              
153             =back
154              
155             =head1 AUTHORS
156              
157             =over 4
158              
159             =item *
160              
161             Yuval Kogman <nothingmuch@woobling.org>
162              
163             =item *
164              
165             Jonathan Rockway <jrockway@cpan.org>
166              
167             =back
168              
169             =head1 COPYRIGHT AND LICENSE
170              
171             This software is copyright (c) 2008 by Infinity Interactive, Yuval Kogman.
172              
173             This is free software; you can redistribute it and/or modify it under
174             the same terms as the Perl 5 programming language system itself.
175              
176             =cut