r37122 - in /branches/upstream/libmoosex-clone-perl: ./ current/ current/lib/ current/lib/MooseX/ current/lib/MooseX/Clone/ current/lib/MooseX/Clone/Meta/ current/lib/MooseX/Clone/Meta/Attribute/ current/lib/MooseX/Clone/Meta/Attribute/Trait/ current/lib/MooseX/Clone/Meta/Attribute/Trait/Clone/ current/t/
franck-guest at users.alioth.debian.org
franck-guest at users.alioth.debian.org
Mon Jun 1 08:57:34 UTC 2009
Author: franck-guest
Date: Mon Jun 1 08:57:25 2009
New Revision: 37122
URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=37122
Log:
[svn-inject] Installing original source of libmoosex-clone-perl
Added:
branches/upstream/libmoosex-clone-perl/
branches/upstream/libmoosex-clone-perl/current/
branches/upstream/libmoosex-clone-perl/current/Changes
branches/upstream/libmoosex-clone-perl/current/MANIFEST
branches/upstream/libmoosex-clone-perl/current/MANIFEST.SKIP
branches/upstream/libmoosex-clone-perl/current/META.yml
branches/upstream/libmoosex-clone-perl/current/Makefile.PL
branches/upstream/libmoosex-clone-perl/current/SIGNATURE
branches/upstream/libmoosex-clone-perl/current/lib/
branches/upstream/libmoosex-clone-perl/current/lib/MooseX/
branches/upstream/libmoosex-clone-perl/current/lib/MooseX/Clone/
branches/upstream/libmoosex-clone-perl/current/lib/MooseX/Clone.pm
branches/upstream/libmoosex-clone-perl/current/lib/MooseX/Clone/Meta/
branches/upstream/libmoosex-clone-perl/current/lib/MooseX/Clone/Meta/Attribute/
branches/upstream/libmoosex-clone-perl/current/lib/MooseX/Clone/Meta/Attribute/Trait/
branches/upstream/libmoosex-clone-perl/current/lib/MooseX/Clone/Meta/Attribute/Trait/Clone/
branches/upstream/libmoosex-clone-perl/current/lib/MooseX/Clone/Meta/Attribute/Trait/Clone.pm
branches/upstream/libmoosex-clone-perl/current/lib/MooseX/Clone/Meta/Attribute/Trait/Clone/Base.pm
branches/upstream/libmoosex-clone-perl/current/lib/MooseX/Clone/Meta/Attribute/Trait/Clone/Std.pm
branches/upstream/libmoosex-clone-perl/current/lib/MooseX/Clone/Meta/Attribute/Trait/Copy.pm
branches/upstream/libmoosex-clone-perl/current/lib/MooseX/Clone/Meta/Attribute/Trait/NoClone.pm
branches/upstream/libmoosex-clone-perl/current/lib/MooseX/Clone/Meta/Attribute/Trait/StorableClone.pm
branches/upstream/libmoosex-clone-perl/current/t/
branches/upstream/libmoosex-clone-perl/current/t/basic.t
Added: branches/upstream/libmoosex-clone-perl/current/Changes
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libmoosex-clone-perl/current/Changes?rev=37122&op=file
==============================================================================
--- branches/upstream/libmoosex-clone-perl/current/Changes (added)
+++ branches/upstream/libmoosex-clone-perl/current/Changes Mon Jun 1 08:57:25 2009
@@ -1,0 +1,15 @@
+0.04
+ - update code to call get_all_attributes instead of compute_all_applicable_attributes
+ - more tests
+ - add the StorableClone trait
+
+0.03
+ - Add the Copy trait (simple 1 level cloning of hashes and array refs)
+ - namespace::clean all over
+
+0.02
+ - Add deep cloning support using Data::Visitor
+ - Add the NoClone trait
+
+0.01
+ - Initial release
Added: branches/upstream/libmoosex-clone-perl/current/MANIFEST
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libmoosex-clone-perl/current/MANIFEST?rev=37122&op=file
==============================================================================
--- branches/upstream/libmoosex-clone-perl/current/MANIFEST (added)
+++ branches/upstream/libmoosex-clone-perl/current/MANIFEST Mon Jun 1 08:57:25 2009
@@ -1,0 +1,14 @@
+Changes
+lib/MooseX/Clone.pm
+lib/MooseX/Clone/Meta/Attribute/Trait/Clone.pm
+lib/MooseX/Clone/Meta/Attribute/Trait/Clone/Base.pm
+lib/MooseX/Clone/Meta/Attribute/Trait/Clone/Std.pm
+lib/MooseX/Clone/Meta/Attribute/Trait/Copy.pm
+lib/MooseX/Clone/Meta/Attribute/Trait/NoClone.pm
+lib/MooseX/Clone/Meta/Attribute/Trait/StorableClone.pm
+Makefile.PL
+MANIFEST This list of files
+MANIFEST.SKIP
+t/basic.t
+META.yml Module meta-data (added by MakeMaker)
+SIGNATURE Public-key signature (added by MakeMaker)
Added: branches/upstream/libmoosex-clone-perl/current/MANIFEST.SKIP
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libmoosex-clone-perl/current/MANIFEST.SKIP?rev=37122&op=file
==============================================================================
--- branches/upstream/libmoosex-clone-perl/current/MANIFEST.SKIP (added)
+++ branches/upstream/libmoosex-clone-perl/current/MANIFEST.SKIP Mon Jun 1 08:57:25 2009
@@ -1,0 +1,44 @@
+# Avoid version control files.
+\bRCS\b
+\bCVS\b
+\bSCCS\b
+,v$
+\B\.svn\b
+\B\.git\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$
+
+\.prove$
+
+# XS shit
+\.(?:bs|c|o)$
Added: branches/upstream/libmoosex-clone-perl/current/META.yml
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libmoosex-clone-perl/current/META.yml?rev=37122&op=file
==============================================================================
--- branches/upstream/libmoosex-clone-perl/current/META.yml (added)
+++ branches/upstream/libmoosex-clone-perl/current/META.yml Mon Jun 1 08:57:25 2009
@@ -1,0 +1,23 @@
+--- #YAML:1.0
+name: MooseX-Clone
+version: 0.04
+abstract: ~
+author: []
+license: unknown
+distribution_type: module
+configure_requires:
+ ExtUtils::MakeMaker: 0
+requires:
+ Data::Visitor: 0.24
+ Hash::Util::FieldHash::Compat: 0
+ Moose: 0.74
+ namespace::clean: 0.08
+ Test::use::ok: 0
+no_index:
+ directory:
+ - t
+ - inc
+generated_by: ExtUtils::MakeMaker version 6.48
+meta-spec:
+ url: http://module-build.sourceforge.net/META-spec-v1.4.html
+ version: 1.4
Added: branches/upstream/libmoosex-clone-perl/current/Makefile.PL
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libmoosex-clone-perl/current/Makefile.PL?rev=37122&op=file
==============================================================================
--- branches/upstream/libmoosex-clone-perl/current/Makefile.PL (added)
+++ branches/upstream/libmoosex-clone-perl/current/Makefile.PL Mon Jun 1 08:57:25 2009
@@ -1,0 +1,21 @@
+#!/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.74",
+ 'Data::Visitor' => '0.24',
+ 'namespace::clean' => '0.08',
+ },
+);
+
Added: branches/upstream/libmoosex-clone-perl/current/SIGNATURE
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libmoosex-clone-perl/current/SIGNATURE?rev=37122&op=file
==============================================================================
--- branches/upstream/libmoosex-clone-perl/current/SIGNATURE (added)
+++ branches/upstream/libmoosex-clone-perl/current/SIGNATURE Mon Jun 1 08:57:25 2009
@@ -1,0 +1,36 @@
+This file contains message digests of all files listed in MANIFEST,
+signed via the Module::Signature module, version 0.55.
+
+To verify the content in this distribution, first make sure you have
+Module::Signature installed, then type:
+
+ % cpansign -v
+
+It will check each file's integrity, as well as the signature's
+validity. If "==> Signature verified OK! <==" is not displayed,
+the distribution may already have been compromised, and you should
+not run its Makefile.PL or Build.PL.
+
+-----BEGIN PGP SIGNED MESSAGE-----
+Hash: SHA1
+
+SHA1 b36f3898dd9358e3e5b76b62e58d6a8d32247812 Changes
+SHA1 7a31a27495af5eae99be90988845c48bf6029858 MANIFEST
+SHA1 190e9058eb9c6446a1a3f3ddf15b082f1ecde152 MANIFEST.SKIP
+SHA1 0a9a49d66956c876ace1c8ff28af274119862c91 META.yml
+SHA1 c2d2e660d73bc6dc4f78da56245cb9fb25647193 Makefile.PL
+SHA1 cda3f1decabbbdab02965c393e16aa59f8384354 lib/MooseX/Clone.pm
+SHA1 c62288b14873bcf3c0f28430b796bda209da9e96 lib/MooseX/Clone/Meta/Attribute/Trait/Clone.pm
+SHA1 e91991fef9bc32c3ec9062f4584b27f248534cee lib/MooseX/Clone/Meta/Attribute/Trait/Clone/Base.pm
+SHA1 1f32bf8a2e43675f8e1e74c2962f2491e2aeac52 lib/MooseX/Clone/Meta/Attribute/Trait/Clone/Std.pm
+SHA1 4a2a6440466154abd02b09b72e7759d3d724ab84 lib/MooseX/Clone/Meta/Attribute/Trait/Copy.pm
+SHA1 8d4bd7f05e74d25115c1558f6ef5f97ffe8ce0ab lib/MooseX/Clone/Meta/Attribute/Trait/NoClone.pm
+SHA1 d4a8de859dccee4a2f90f02e3af857562f765133 lib/MooseX/Clone/Meta/Attribute/Trait/StorableClone.pm
+SHA1 96c97f40ff26f572bccbb05bd7b2ddde9b908214 t/basic.t
+-----BEGIN PGP SIGNATURE-----
+Version: GnuPG v1.4.7 (Darwin)
+
+iD8DBQFJ7LGyVCwRwOvSdBgRAmK4AJ0SUuwN4874Df9a1xpTlV64hhZ/rACfVjn4
+kmnIcG/IqB7F9YRfVpuVPqw=
+=9OFe
+-----END PGP SIGNATURE-----
Added: branches/upstream/libmoosex-clone-perl/current/lib/MooseX/Clone.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libmoosex-clone-perl/current/lib/MooseX/Clone.pm?rev=37122&op=file
==============================================================================
--- branches/upstream/libmoosex-clone-perl/current/lib/MooseX/Clone.pm (added)
+++ branches/upstream/libmoosex-clone-perl/current/lib/MooseX/Clone.pm Mon Jun 1 08:57:25 2009
@@ -1,0 +1,179 @@
+#!/usr/bin/perl
+
+package MooseX::Clone;
+use Moose::Role;
+
+our $VERSION = "0.04";
+
+use Hash::Util::FieldHash::Compat qw(idhash);
+
+use MooseX::Clone::Meta::Attribute::Trait::Clone;
+use MooseX::Clone::Meta::Attribute::Trait::StorableClone;
+use MooseX::Clone::Meta::Attribute::Trait::NoClone;
+use MooseX::Clone::Meta::Attribute::Trait::Copy;
+
+use namespace::clean -except => 'meta';
+
+sub clone {
+ my ( $self, %params ) = @_;
+
+ my $meta = $self->meta;
+
+ my @cloning;
+
+ idhash my %clone_args;
+
+ attr: foreach my $attr ($meta->get_all_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::Base") ) {
+ 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 with the C<Clone> trait will handle
+cloning of data within the object, typically delegating to the attribute
+value's own C<clone> method.
+
+=head1 TRAITS
+
+=over 4
+
+=item Clone
+
+By default Moose objects are cloned like this:
+
+ bless { %$old }, ref $old;
+
+By specifying the L<Clone> trait for certain attributes custom behavior the
+value's own C<clone> method will be invoked.
+
+By extending this trait you can create custom cloning for certain attributes.
+
+
+By creating C<clone> methods for your objects (e.g. by composing
+L<MooseX::Compile>) you can make them interact with this trait.
+
+=item NoClone
+
+Specifies attributes that should be skipped entirely while cloning.
+
+=back
+
+=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 at 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
Added: branches/upstream/libmoosex-clone-perl/current/lib/MooseX/Clone/Meta/Attribute/Trait/Clone.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libmoosex-clone-perl/current/lib/MooseX/Clone/Meta/Attribute/Trait/Clone.pm?rev=37122&op=file
==============================================================================
--- branches/upstream/libmoosex-clone-perl/current/lib/MooseX/Clone/Meta/Attribute/Trait/Clone.pm (added)
+++ branches/upstream/libmoosex-clone-perl/current/lib/MooseX/Clone/Meta/Attribute/Trait/Clone.pm Mon Jun 1 08:57:25 2009
@@ -1,0 +1,194 @@
+#!/usr/bin/perl
+
+package MooseX::Clone::Meta::Attribute::Trait::Clone;
+use Moose::Role;
+
+use Carp qw(croak);
+
+use namespace::clean -except => 'meta';
+
+with qw(MooseX::Clone::Meta::Attribute::Trait::Clone::Std);
+
+sub Moose::Meta::Attribute::Custom::Trait::Clone::register_implementation { __PACKAGE__ }
+
+has clone_only_objects => (
+ isa => "Bool",
+ is => "rw",
+ default => 0,
+);
+
+has clone_visitor => (
+ isa => "Data::Visitor",
+ is => "rw",
+ lazy_build => 1,
+);
+
+has clone_visitor_config => (
+ isa => "HashRef",
+ is => "ro",
+ default => sub { { } },
+);
+
+sub _build_clone_visitor {
+ my $self = shift;
+
+ require Data::Visitor::Callback;
+
+ Data::Visitor::Callback->new(
+ object => sub { $self->clone_object_value($_[1]) },
+ tied_as_objects => 1,
+ %{ $self->clone_visitor_config },
+ );
+}
+
+sub clone_value_data {
+ my ( $self, $value, @args ) = @_;
+
+ if ( blessed($value) ) {
+ $self->clone_object_value($value, @args);
+ } else {
+ unless ( $self->clone_only_objects ) {
+ $self->clone_any_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 $value (" . overload::StrVal($value) . ") in " . $args{attr}->name . ". Try something better.";
+ }
+}
+
+sub clone_any_value {
+ my ( $self, $value, @args ) = @_;
+ $self->clone_visitor->visit($value);
+}
+
+__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 ATTRIBUTES
+
+=over 4
+
+=item clone_only_objects
+
+Whether or not L<Data::Visitor> should be used to clone arbitrary structures.
+Objects found in these structures will be cloned using L<clone_object_value>.
+
+If true then non object values will be copied over in shallow cloning semantics
+(shared reference).
+
+Defaults to false (all reference will be cloned).
+
+=item clone_visitor_config
+
+A hash ref used to construct C<clone_visitor>. Defaults to the empty ref.
+
+This can be used to alter the cloning behavior for non object values.
+
+=item clone_visitor
+
+The L<Data::Visitor::Callback> object that will be used to clone.
+
+It has an C<object> handler that delegates to C<clone_object_value> and sets
+C<tied_as_objects> to true in order to deeply clone tied structures while
+retaining magic.
+
+Only used if C<clone_only_objects> is false and the value of the attribute is
+not an object.
+
+=back
+
+=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>.
+
+=item clone_any_value $value, %args
+
+Uses C<clone_visitor> to clone all non object values.
+
+Called from C<clone_value_data> if the value is not an object and
+C<clone_only_objects> is false.
+
+=back
+
+=cut
Added: branches/upstream/libmoosex-clone-perl/current/lib/MooseX/Clone/Meta/Attribute/Trait/Clone/Base.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libmoosex-clone-perl/current/lib/MooseX/Clone/Meta/Attribute/Trait/Clone/Base.pm?rev=37122&op=file
==============================================================================
--- branches/upstream/libmoosex-clone-perl/current/lib/MooseX/Clone/Meta/Attribute/Trait/Clone/Base.pm (added)
+++ branches/upstream/libmoosex-clone-perl/current/lib/MooseX/Clone/Meta/Attribute/Trait/Clone/Base.pm Mon Jun 1 08:57:25 2009
@@ -1,0 +1,12 @@
+#!/usr/bin/perl
+
+package MooseX::Clone::Meta::Attribute::Trait::Clone::Base;
+use Moose::Role;
+
+use namespace::clean -except => [qw(meta)];
+
+requires "clone_value";
+
+__PACKAGE__
+
+__END__
Added: branches/upstream/libmoosex-clone-perl/current/lib/MooseX/Clone/Meta/Attribute/Trait/Clone/Std.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libmoosex-clone-perl/current/lib/MooseX/Clone/Meta/Attribute/Trait/Clone/Std.pm?rev=37122&op=file
==============================================================================
--- branches/upstream/libmoosex-clone-perl/current/lib/MooseX/Clone/Meta/Attribute/Trait/Clone/Std.pm (added)
+++ branches/upstream/libmoosex-clone-perl/current/lib/MooseX/Clone/Meta/Attribute/Trait/Clone/Std.pm Mon Jun 1 08:57:25 2009
@@ -1,0 +1,22 @@
+package MooseX::Clone::Meta::Attribute::Trait::Clone::Std;
+use Moose::Role;
+
+use namespace::clean -except => 'meta';
+
+with qw(MooseX::Clone::Meta::Attribute::Trait::Clone::Base);
+
+requires qw(clone_value_data);
+
+sub clone_value {
+ my ( $self, $target, $proto, @args ) = @_;
+
+ return unless $self->has_value($proto);
+
+ my $clone = $self->clone_value_data( $self->get_value($proto), @args );
+
+ $self->set_value( $target, $clone );
+}
+
+__PACKAGE__
+
+__END__
Added: branches/upstream/libmoosex-clone-perl/current/lib/MooseX/Clone/Meta/Attribute/Trait/Copy.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libmoosex-clone-perl/current/lib/MooseX/Clone/Meta/Attribute/Trait/Copy.pm?rev=37122&op=file
==============================================================================
--- branches/upstream/libmoosex-clone-perl/current/lib/MooseX/Clone/Meta/Attribute/Trait/Copy.pm (added)
+++ branches/upstream/libmoosex-clone-perl/current/lib/MooseX/Clone/Meta/Attribute/Trait/Copy.pm Mon Jun 1 08:57:25 2009
@@ -1,0 +1,66 @@
+#!/usr/bin/perl
+
+package MooseX::Clone::Meta::Attribute::Trait::Copy;
+use Moose::Role;
+
+use Carp qw(croak);
+
+use namespace::clean -except => 'meta';
+
+with qw(MooseX::Clone::Meta::Attribute::Trait::Clone::Base);
+
+sub Moose::Meta::Attribute::Custom::Trait::Copy::register_implementation { __PACKAGE__ }
+
+sub clone_value {
+ my ( $self, $target, $proto, %args ) = @_;
+
+ return unless $self->has_value($proto);
+
+ my $clone = exists $args{init_arg} ? $args{init_arg} : $self->_copy_ref($self->get_value($proto));
+
+ $self->set_value( $target, $clone );
+}
+
+sub _copy_ref {
+ my ( $self, $value ) = @_;
+
+ if ( not ref $value ) {
+ return $value;
+ } elsif ( ref $value eq 'ARRAY' ) {
+ return [@$value];
+ } elsif ( ref $value eq 'HASH' ) {
+ return {%$value};
+ } else {
+ croak "The Copy trait is for arrays and hashes. Use the Clone trait for objects";
+ }
+}
+
+__PACKAGE__
+
+__END__
+
+=pod
+
+=head1 NAME
+
+MooseX::Clone::Meta::Attribute::Trait::Copy - Simple copying of arrays and
+hashes for L<MooseX::Clone>
+
+=head1 SYNOPSIS
+
+ has foo => (
+ isa => "ArrayRef",
+ traits => [qw(Copy)],
+ );
+
+=head1 DESCRIPTION
+
+Unlike the C<Clone> trait, which does deep copying of almost anything, this
+trait will only do one additional level of copying of arrays and hashes.
+
+This is both simpler and faster when you don't need a real deep copy of the
+entire structure, and probably more correct.
+
+=cut
+
+
Added: branches/upstream/libmoosex-clone-perl/current/lib/MooseX/Clone/Meta/Attribute/Trait/NoClone.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libmoosex-clone-perl/current/lib/MooseX/Clone/Meta/Attribute/Trait/NoClone.pm?rev=37122&op=file
==============================================================================
--- branches/upstream/libmoosex-clone-perl/current/lib/MooseX/Clone/Meta/Attribute/Trait/NoClone.pm (added)
+++ branches/upstream/libmoosex-clone-perl/current/lib/MooseX/Clone/Meta/Attribute/Trait/NoClone.pm Mon Jun 1 08:57:25 2009
@@ -1,0 +1,69 @@
+#!/usr/bin/perl
+
+package MooseX::Clone::Meta::Attribute::Trait::NoClone;
+use Moose::Role;
+
+use namespace::clean -except => [qw(meta)];
+
+with qw(MooseX::Clone::Meta::Attribute::Trait::Clone::Base);
+
+sub Moose::Meta::Attribute::Custom::Trait::NoClone::register_implementation { __PACKAGE__ }
+
+sub clone_value {
+ my ( $self, $target, $proto, %args ) = @_;
+
+ # FIXME default cloning behavior works like this
+ #if ( exists $args{init_arg} ) {
+ # $self->set_value($args{init_arg});
+ #} else {
+ # but i think this is more correct
+
+ $self->clear_value($target);
+ $self->initialize_instance_slot(
+ $self->meta->get_meta_instance,
+ $target,
+ { exists $args{init_arg} ? ( $self->init_arg => $args{init_arg} ) : () },
+ );
+}
+
+__PACKAGE__
+
+__END__
+
+=pod
+
+=head1 NAME
+
+MooseX::Clone::Meta::Attribute::Trait::NoClone - A trait for attrs that should
+not be copied while cloning.
+
+=head1 SYNOPSIS
+
+ with qw(MooseX::Clone);
+
+ has _some_special_thingy => (
+ traits => [qw(NoClone)],
+ );
+
+=head1 DESCRIPTION
+
+Sometimes certain values should not be carried over when cloning an object.
+
+This attribute trait implements just that.
+
+=head1 METHODS
+
+=over 4
+
+=item clone_value
+
+If the C<init_arg> param is set (that means an explicit value was given to
+C<clone>) sets the attribute to that value.
+
+Otherwise calls C<clear_value> and C<initialize_instance_slot>.
+
+=back
+
+=cut
+
+
Added: branches/upstream/libmoosex-clone-perl/current/lib/MooseX/Clone/Meta/Attribute/Trait/StorableClone.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libmoosex-clone-perl/current/lib/MooseX/Clone/Meta/Attribute/Trait/StorableClone.pm?rev=37122&op=file
==============================================================================
--- branches/upstream/libmoosex-clone-perl/current/lib/MooseX/Clone/Meta/Attribute/Trait/StorableClone.pm (added)
+++ branches/upstream/libmoosex-clone-perl/current/lib/MooseX/Clone/Meta/Attribute/Trait/StorableClone.pm Mon Jun 1 08:57:25 2009
@@ -1,0 +1,127 @@
+#!/usr/bin/perl
+
+package MooseX::Clone::Meta::Attribute::Trait::StrableClone;
+use Moose::Role;
+
+use Carp qw(croak);
+
+use namespace::clean -except => 'meta';
+
+with qw(MooseX::Clone::Meta::Attribute::Trait::Clone::Std);
+
+sub Moose::Meta::Attribute::Custom::Trait::StorableClone::register_implementation { __PACKAGE__ }
+
+sub clone_value_data {
+ my ( $self, $value, @args ) = @_;
+
+ if ( ref($value) ) {
+ require Storable;
+ return Storable::dclone($value);
+ } else {
+ return $value;
+ }
+}
+
+__PACKAGE__
+
+__END__
+
+=pod
+
+=encoding utf8
+
+=head1 NAME
+
+MooseX::Clone::Meta::Attribute::Trait::StorableClone - The L<Moose::Meta::Attribute>
+trait for deeply cloning attributes using L<Storable>.
+
+=head1 SYNOPSIS
+
+ # see MooseX::Clone
+
+ has foo => (
+ traits => [qw(StorableClone)],
+ isa => "Something",
+ );
+
+ my $clone = $object->clone; # $clone->foo will equal Storable::dclone($object->foo)
+
+=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 ATTRIBUTES
+
+=over 4
+
+=item clone_only_objects
+
+Whether or not L<Data::Visitor> should be used to clone arbitrary structures.
+Objects found in these structures will be cloned using L<clone_object_value>.
+
+If true then non object values will be copied over in shallow cloning semantics
+(shared reference).
+
+Defaults to false (all reference will be cloned).
+
+=item clone_visitor_config
+
+A hash ref used to construct C<clone_visitor>. Defaults to the empty ref.
+
+This can be used to alter the cloning behavior for non object values.
+
+=item clone_visitor
+
+The L<Data::Visitor::Callback> object that will be used to clone.
+
+It has an C<object> handler that delegates to C<clone_object_value> and sets
+C<tied_as_objects> to true in order to deeply clone tied structures while
+retaining magic.
+
+Only used if C<clone_only_objects> is false and the value of the attribute is
+not an object.
+
+=back
+
+=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>.
+
+=item clone_any_value $value, %args
+
+Uses C<clone_visitor> to clone all non object values.
+
+Called from C<clone_value_data> if the value is not an object and
+C<clone_only_objects> is false.
+
+=back
+
+=cut
Added: branches/upstream/libmoosex-clone-perl/current/t/basic.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libmoosex-clone-perl/current/t/basic.t?rev=37122&op=file
==============================================================================
--- branches/upstream/libmoosex-clone-perl/current/t/basic.t (added)
+++ branches/upstream/libmoosex-clone-perl/current/t/basic.t Mon Jun 1 08:57:25 2009
@@ -1,0 +1,122 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More 'no_plan';
+
+use Scalar::Util qw(refaddr);
+
+{
+ package Bar;
+ use Moose;
+
+ with qw(MooseX::Clone);
+
+ has foo => (
+ traits => [qw(Clone)],
+ isa => "Foo|HashRef",
+ is => "rw",
+ default => sub { Foo->new },
+ );
+
+ has same => (
+ isa => "Foo",
+ is => "rw",
+ default => sub { Foo->new },
+ );
+
+ has floo => (
+ traits => [qw(NoClone)],
+ isa => "Int",
+ is => "rw",
+ );
+
+ has flar => (
+ traits => [qw(Copy)],
+ isa => "HashRef",
+ is => "rw",
+ );
+
+ has blorg => (
+ traits => [qw(StorableClone)],
+ is => "rw",
+ );
+
+ package Foo;
+ use Moose;
+
+ has copy_number => (
+ isa => "Int",
+ is => "ro",
+ default => 0,
+ );
+
+ has some_attr => ( is => "rw", default => "def" );
+
+ sub clone {
+ my ( $self, %params ) = @_;
+
+ $self->meta->clone_object( $self, %params, copy_number => $self->copy_number + 1 );
+ }
+}
+
+
+my $bar = Bar->new( floo => 3 );
+
+isa_ok( $bar, "Bar" );
+isa_ok( $bar->foo, "Foo" );
+isa_ok( $bar->same, "Foo" );
+
+is( $bar->floo, 3, "explicit init_arg" );
+
+is( $bar->foo->copy_number, 0, "first copy" );
+is( $bar->same->copy_number, 0, "first copy" );
+
+is( $bar->foo->some_attr, 'def', "default value for other attr" );
+
+my $copy = $bar->clone;
+
+isnt( refaddr($bar), refaddr($copy), "copy" );
+
+is( $copy->floo, undef, "NoClone" );
+
+is( $copy->foo->copy_number, 1, "copy number incremented" );
+is( $copy->same->copy_number, 0, "not incremented for uncloned attr" );
+
+is( $copy->foo->some_attr, 'def', "default value for other attr" );
+
+isnt( refaddr($bar->foo), refaddr($copy->foo), "copy" );
+is( refaddr($bar->same), refaddr($copy->same), "copy" );
+
+is( $copy->clone( foo => { some_attr => "laaa" } )->foo->some_attr, "laaa", "Value carried over to recursive call to clone" );
+
+{
+ my $hash = { foo => Foo->new };
+ my $hash_copy = Bar->new( foo => $hash )->clone->foo;
+
+ isnt( refaddr($hash), refaddr($hash_copy), "hash copied" );
+ is_deeply( [ sort keys %$hash ], [ sort keys %$hash_copy ], "hash keys exist in clone" );
+ isa_ok($hash_copy->{foo}, "Foo");
+ isnt( refaddr($hash->{foo}), refaddr($hash_copy->{foo}), "foo inside hash cloned too" );
+ is( $hash_copy->{foo}->copy_number, 1, "copy number" );
+}
+
+{
+ my $hash = { foo => Foo->new, bar => [] };
+ my $hash_copy = Bar->new( flar => $hash )->clone->flar;
+
+ isnt( refaddr($hash), refaddr($hash_copy), "hash copied" );
+ is_deeply( [ sort keys %$hash ], [ sort keys %$hash_copy ], "hash keys exist in clone" );
+ isa_ok($hash_copy->{foo}, "Foo");
+ is( refaddr($hash->{foo}), refaddr($hash_copy->{foo}), "foo inside hash not cloned" );
+ is( refaddr($hash->{bar}), refaddr($hash_copy->{bar}), "array inside hash not cloned" );
+}
+
+{
+ my $foo = Foo->new;
+ my $foo_copy = Bar->new( blorg => $foo )->clone->blorg;
+
+ isnt( refaddr($foo), refaddr($foo_copy), "foo copied" );
+ is( $foo_copy->copy_number, $foo->copy_number, "but not using ->clone");
+}
More information about the Pkg-perl-cvs-commits
mailing list