Permalink
Browse files

MooseX::Storage

  • Loading branch information...
0 parents commit 76e1f2817acee150261d8408d4bbaff79caa1db1 @nothingmuch committed Apr 24, 2008
Showing with 409 additions and 0 deletions.
  1. +38 −0 MANIFEST.SKIP
  2. +19 −0 Makefile.PL
  3. +147 −0 lib/MooseX/Clone.pm
  4. +133 −0 lib/MooseX/Clone/Meta/Attribute/Trait/Clone.pm
  5. +72 −0 t/basic.t
@@ -0,0 +1,38 @@
+# Avoid version control files.
+\bRCS\b
+\bCVS\b
+\bSCCS\b
+,v$
+\B\.svn\b
+\b_darcs\b
+
+# Avoid Makemaker generated and utility files.
+\bMANIFEST\.bak
+\bMakefile$
+\bblib/
+\bMakeMaker-\d
+\bpm_to_blib\.ts$
+\bpm_to_blib$
+\bblibdirs\.ts$ # 6.18 through 6.25 generated this
+
+# Avoid Module::Build generated and utility files.
+\bBuild$
+\b_build/
+
+# Avoid temp and backup files.
+~$
+\.old$
+\#$
+\b\.#
+\.bak$
+
+# Avoid Devel::Cover files.
+\bcover_db\b
+
+### DEFAULT MANIFEST.SKIP ENDS HERE ####
+
+\.DS_Store$
+\.sw.$
+(\w+-)*(\w+)-\d\.\d+(?:\.tar\.gz)?$
+
+\.t\.log$
@@ -0,0 +1,19 @@
+#!/usr/bin/perl -w
+
+use strict;
+
+use ExtUtils::MakeMaker;
+
+WriteMakefile(
+ NAME => 'MooseX::Clone',
+ VERSION_FROM => 'lib/MooseX/Clone.pm',
+ INSTALLDIRS => 'site',
+ SIGN => 1,
+ PL_FILES => { },
+ PREREQ_PM => {
+ 'Test::use::ok' => 0,
+ 'Hash::Util::FieldHash::Compat' => 0,
+ 'Moose' => "0.40",
+ },
+);
+
@@ -0,0 +1,147 @@
+#!/usr/bin/perl
+
+package MooseX::Clone;
+use Moose::Role;
+
+our $VERSION = "0.01";
+
+use Hash::Util::FieldHash::Compat qw(idhash);
+
+use MooseX::Clone::Meta::Attribute::Trait::Clone;
+
+sub clone {
+ my ( $self, %params ) = @_;
+
+ my $meta = $self->meta;
+
+ my @cloning;
+
+ idhash my %clone_args;
+
+ attr: foreach my $attr ($meta->compute_all_applicable_attributes()) {
+ # collect all attrs that can be cloned.
+ # if they have args in %params then those are passed to the recursive cloning op
+ if ( $attr->does("MooseX::Clone::Meta::Attribute::Trait::Clone") ) {
+ push @cloning, $attr;
+
+ if ( defined( my $init_arg = $attr->init_arg ) ) {
+ if ( exists $params{$init_arg} ) {
+ $clone_args{$attr} = delete $params{$init_arg};
+ }
+ }
+ }
+ }
+
+ my $clone = $meta->clone_object($self, %params);
+
+ foreach my $attr ( @cloning ) {
+ $clone->clone_attribute(
+ proto => $self,
+ attr => $attr,
+ ( exists $clone_args{$attr} ? ( init_arg => $clone_args{$attr} ) : () ),
+ );
+ }
+
+ return $clone;
+}
+
+sub clone_attribute {
+ my ( $self, %args ) = @_;
+
+ my ( $proto, $attr ) = @args{qw/proto attr/};
+
+ $attr->clone_value( $self, $proto, %args );
+}
+
+__PACKAGE__
+
+__END__
+
+=pod
+
+=head1 NAME
+
+MooseX::Clone - Fine grained cloning support for L<Moose> objects.
+
+=head1 SYNOPSIS
+
+ package Bar;
+ use Moose;
+
+ with qw(MooseX::Clone);
+
+ has foo => (
+ isa => "Foo",
+ traits => [qw(Clone)], # this attribute will be recursively cloned
+ );
+
+ package Foo;
+ use Moose;
+
+ # this API is used/provided by MooseX::Clone
+ sub clone {
+ my ( $self, %params ) = @_;
+
+ # ...
+ }
+
+
+ # used like this:
+
+ my $bar = Bar->new( foo => Foo->new );
+
+ my $copy = $bar->clone( foo => [ qw(Args for Foo::clone) ] );
+
+=head1 DESCRIPTION
+
+Out of the box L<Moose> only provides very barebones cloning support in order
+to maximize flexibility.
+
+This role provides a C<clone> method that makes use of the low level cloning
+support already in L<Moose> and adds selective deep cloning based on
+introspection on top of that. Attributes marked for
+
+=head1 METHODS
+
+=over 4
+
+=item clone %params
+
+Returns a clone of the object.
+
+All attributes which do the L<MooseX::Clone::Meta::Attribute::Trait::Clone>
+role will handle cloning of that attribute. All other fields are plainly copied
+over, just like in L<Class::MOP::Class/clone_object>.
+
+Attributes whose C<init_arg> is in %params and who do the C<Clone> trait will
+get that argument passed to the C<clone> method (dereferenced). If the
+attribute does not self-clone then the param is used normally by
+L<Class::MOP::Class/clone_object>, that is it will simply shadow the previous
+value, and does not have to be an array or hash reference.
+
+=back
+
+=head1 TODO
+
+Refactor to work in term of a metaclass trait so that C<<meta->clone_object>>
+will still do the right thing.
+
+=head1 THANKS
+
+clkao made the food required to write this module
+
+=head1 VERSION CONTROL
+
+L<http://code2.0beta.co.uk/moose/svn/>. Ask on #moose for commit bits.
+
+=head1 AUTHOR
+
+Yuval Kogman E<lt>nothingmuch@woobling.orgE<gt>
+
+=head1 COPYRIGHT
+
+ Copyright (c) 2008 Yuval Kogman. All rights reserved
+ This program is free software; you can redistribute
+ it and/or modify it under the same terms as Perl itself.
+
+=cut
@@ -0,0 +1,133 @@
+#!/usr/bin/perl
+
+package MooseX::Clone::Meta::Attribute::Trait::Clone;
+use Moose::Role;
+
+use Carp qw(croak);
+
+sub Moose::Meta::Attribute::Custom::Trait::Clone::register_implementation { __PACKAGE__ }
+
+has clone_refs => (
+ isa => "Bool",
+ is => "rw",
+ default => 0,
+);
+
+sub clone_value {
+ my ( $self, $target, $proto, %args ) = @_;
+
+ my $clone = $self->clone_value_data( $self->get_value($proto), %args );
+
+ $self->set_value( $target, $clone );
+}
+
+sub clone_value_data {
+ my ( $self, $value, @args ) = @_;
+
+ if ( blessed($value) ) {
+ $self->clone_object_value($value, @args);
+ } else {
+ if ( $self->clone_refs ) {
+ $self->clone_ref_value($value, @args);
+ } else {
+ my %args = @args;
+ return exists $args{init_arg}
+ ? $args{init_arg} # taken as a literal value
+ : $value;
+ }
+ }
+}
+
+sub clone_object_value {
+ my ( $self, $value, %args ) = @_;
+
+ if ( $value->can("clone") ) {
+ my @clone_args;
+
+ if ( exists $args{init_arg} ) {
+ my $init_arg = $args{init_arg};
+
+ if ( ref $init_arg ) {
+ if ( ref $init_arg eq 'HASH' ) { @clone_args = %$init_arg }
+ elsif ( ref $init_arg eq 'ARRAY' ) { @clone_args = @$init_arg }
+ else {
+ croak "Arguments to a sub clone should be given in a hash or array reference";
+ }
+ } else {
+ croak "Arguments to a sub clone should be given in a hash or array reference";
+ }
+ }
+
+ return $value->clone(@clone_args);
+ } else {
+ croak "Cannot recursively clone a retarded object in " . $args{attr}->name . ". Try something better.";
+ }
+}
+
+sub clone_value_ref {
+ die "TODO, write a Data::Visitor based deep clone for ref types that delegates to clone_value_object i suppose"
+}
+
+__PACKAGE__
+
+__END__
+
+=pod
+
+=encoding utf8
+
+=head1 NAME
+
+MooseX::Clone::Meta::Attribute::Trait::Clone - The L<Moose::Meta::Attribute>
+trait for deeply cloning attributes.
+
+=head1 SYNOPSIS
+
+ # see MooseX::Clone
+
+ has foo => (
+ traits => [qw(Clone)],
+ isa => "Something",
+ );
+
+ $object->clone; # will recursively call $object->foo->clone and set the value properly
+
+=head1 DESCRIPTION
+
+This meta attribute trait provides a C<clone_value> method, in the spirit of
+C<get_value> and C<set_value>. This allows clone methods such as the one in
+L<MooseX::Clone> to make use of this per-attribute cloning behavior.
+
+=head1 DERIVATION
+
+Deriving this role for your own cloning purposes is encouraged.
+
+This will allow your fine grained cloning semantics to interact with
+L<MooseX::Clone> in the Right™ way.
+
+=head1 METHODS
+
+=over 4
+
+=item clone_value $target, $proto, %args
+
+Clones the value the attribute encapsulates from C<$proto> into C<$target>.
+
+=item clone_value_data $value, %args
+
+Does the actual cloning of the value data by delegating to a C<clone> method on
+the object if any.
+
+If the object does not support a C<clone> method an error is thrown.
+
+If the value is not an object then it will not be cloned.
+
+In the future support for deep cloning of simple refs will be added too.
+
+=item clone_object_value $object, %args
+
+This is the actual workhorse of C<clone_value_data>.
+
+=back
+
+=cut
Oops, something went wrong.

0 comments on commit 76e1f28

Please sign in to comment.