local-lib5/lib/perl5/MooseX/Clone/Meta/Attribute/Trait/Clone.pm

   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