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