Commit | Line | Data |
3fea05b9 |
1 | #!/usr/bin/perl |
2 | |
3 | package MooseX::Clone::Meta::Attribute::Trait::Clone; |
4 | use Moose::Role; |
5 | |
6 | use Carp qw(croak); |
7 | |
8 | use namespace::clean -except => 'meta'; |
9 | |
10 | with qw(MooseX::Clone::Meta::Attribute::Trait::Clone::Base); |
11 | |
12 | sub Moose::Meta::Attribute::Custom::Trait::Clone::register_implementation { __PACKAGE__ } |
13 | |
14 | has clone_only_objects => ( |
15 | isa => "Bool", |
16 | is => "rw", |
17 | default => 0, |
18 | ); |
19 | |
20 | has clone_visitor => ( |
21 | isa => "Data::Visitor", |
22 | is => "rw", |
23 | lazy_build => 1, |
24 | ); |
25 | |
26 | has clone_visitor_config => ( |
27 | isa => "HashRef", |
28 | is => "ro", |
29 | default => sub { { } }, |
30 | ); |
31 | |
32 | sub _build_clone_visitor { |
33 | my $self = shift; |
34 | |
35 | require Data::Visitor::Callback; |
36 | |
37 | Data::Visitor::Callback->new( |
38 | object => sub { $self->clone_object_value($_[1]) }, |
39 | tied_as_objects => 1, |
40 | %{ $self->clone_visitor_config }, |
41 | ); |
42 | } |
43 | |
44 | sub clone_value { |
45 | my ( $self, $target, $proto, @args ) = @_; |
46 | |
47 | if ( $self->has_value($proto) ) { |
48 | my $clone = $self->clone_value_data( scalar($self->get_value($proto)), @args ); |
49 | |
50 | $self->set_value( $target, $clone ); |
51 | } else { |
52 | my %args = @args; |
53 | |
54 | if ( exists $args{init_arg} ) { |
55 | $self->set_value( $target, $args{init_arg} ); |
56 | } |
57 | } |
58 | } |
59 | |
60 | sub clone_value_data { |
61 | my ( $self, $value, @args ) = @_; |
62 | |
63 | if ( blessed($value) ) { |
64 | return $self->clone_object_value($value, @args); |
65 | } else { |
66 | my %args = @args; |
67 | |
68 | if ( exists $args{init_arg} ) { |
69 | return $args{init_arg}; |
70 | } else { |
71 | unless ( $self->clone_only_objects ) { |
72 | return $self->clone_any_value($value, @args); |
73 | } else { |
74 | return $value; |
75 | } |
76 | } |
77 | } |
78 | } |
79 | |
80 | sub clone_object_value { |
81 | my ( $self, $value, %args ) = @_; |
82 | |
83 | if ( $value->can("clone") ) { |
84 | my @clone_args; |
85 | |
86 | if ( exists $args{init_arg} ) { |
87 | my $init_arg = $args{init_arg}; |
88 | |
89 | if ( ref $init_arg ) { |
90 | if ( ref $init_arg eq 'HASH' ) { @clone_args = %$init_arg } |
91 | elsif ( ref $init_arg eq 'ARRAY' ) { @clone_args = @$init_arg } |
92 | else { |
93 | croak "Arguments to a sub clone should be given in a hash or array reference"; |
94 | } |
95 | } else { |
96 | croak "Arguments to a sub clone should be given in a hash or array reference"; |
97 | } |
98 | } |
99 | |
100 | return $value->clone(@clone_args); |
101 | } else { |
102 | croak "Cannot recursively clone a retarded object $value (" . overload::StrVal($value) . ") in " . $args{attr}->name . ". Try something better."; |
103 | } |
104 | } |
105 | |
106 | sub clone_any_value { |
107 | my ( $self, $value, %args ) = @_; |
108 | $self->clone_visitor->visit($value); |
109 | } |
110 | |
111 | __PACKAGE__ |
112 | |
113 | __END__ |
114 | |
115 | =pod |
116 | |
117 | =encoding utf8 |
118 | |
119 | =head1 NAME |
120 | |
121 | MooseX::Clone::Meta::Attribute::Trait::Clone - The L<Moose::Meta::Attribute> |
122 | trait for deeply cloning attributes. |
123 | |
124 | =head1 SYNOPSIS |
125 | |
126 | # see MooseX::Clone |
127 | |
128 | has foo => ( |
129 | traits => [qw(Clone)], |
130 | isa => "Something", |
131 | ); |
132 | |
133 | $object->clone; # will recursively call $object->foo->clone and set the value properly |
134 | |
135 | =head1 DESCRIPTION |
136 | |
137 | This meta attribute trait provides a C<clone_value> method, in the spirit of |
138 | C<get_value> and C<set_value>. This allows clone methods such as the one in |
139 | L<MooseX::Clone> to make use of this per-attribute cloning behavior. |
140 | |
141 | =head1 DERIVATION |
142 | |
143 | Deriving this role for your own cloning purposes is encouraged. |
144 | |
145 | This will allow your fine grained cloning semantics to interact with |
146 | L<MooseX::Clone> in the Rightâ„¢ way. |
147 | |
148 | =head1 ATTRIBUTES |
149 | |
150 | =over 4 |
151 | |
152 | =item clone_only_objects |
153 | |
154 | Whether or not L<Data::Visitor> should be used to clone arbitrary structures. |
155 | Objects found in these structures will be cloned using L<clone_object_value>. |
156 | |
157 | If true then non object values will be copied over in shallow cloning semantics |
158 | (shared reference). |
159 | |
160 | Defaults to false (all reference will be cloned). |
161 | |
162 | =item clone_visitor_config |
163 | |
164 | A hash ref used to construct C<clone_visitor>. Defaults to the empty ref. |
165 | |
166 | This can be used to alter the cloning behavior for non object values. |
167 | |
168 | =item clone_visitor |
169 | |
170 | The L<Data::Visitor::Callback> object that will be used to clone. |
171 | |
172 | It has an C<object> handler that delegates to C<clone_object_value> and sets |
173 | C<tied_as_objects> to true in order to deeply clone tied structures while |
174 | retaining magic. |
175 | |
176 | Only used if C<clone_only_objects> is false and the value of the attribute is |
177 | not an object. |
178 | |
179 | =back |
180 | |
181 | =head1 METHODS |
182 | |
183 | =over 4 |
184 | |
185 | =item clone_value $target, $proto, %args |
186 | |
187 | Clones the value the attribute encapsulates from C<$proto> into C<$target>. |
188 | |
189 | =item clone_value_data $value, %args |
190 | |
191 | Does the actual cloning of the value data by delegating to a C<clone> method on |
192 | the object if any. |
193 | |
194 | If the object does not support a C<clone> method an error is thrown. |
195 | |
196 | If the value is not an object then it will not be cloned. |
197 | |
198 | In the future support for deep cloning of simple refs will be added too. |
199 | |
200 | =item clone_object_value $object, %args |
201 | |
202 | This is the actual workhorse of C<clone_value_data>. |
203 | |
204 | =item clone_any_value $value, %args |
205 | |
206 | Uses C<clone_visitor> to clone all non object values. |
207 | |
208 | Called from C<clone_value_data> if the value is not an object and |
209 | C<clone_only_objects> is false. |
210 | |
211 | =back |
212 | |
213 | =cut |