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