diff --git a/lib/MooseX/Attribute/ChainedClone.pm b/lib/MooseX/Attribute/ChainedClone.pm new file mode 100644 index 0000000..1811a55 --- /dev/null +++ b/lib/MooseX/Attribute/ChainedClone.pm @@ -0,0 +1,154 @@ +package MooseX::Attribute::ChainedClone; + +# ABSTRACT: Attribute that returns a cloned instance +use Moose::Util; +Moose::Util::meta_attribute_alias( + ChainedClone => 'MooseX::Traits::Attribute::ChainedClone' ); + +package MooseX::Traits::Attribute::ChainedClone; +use Moose::Role; + +override accessor_metaclass => sub { + 'MooseX::Attribute::ChainedClone::Method::Accessor'; +}; + +package MooseX::Attribute::ChainedClone::Method::Accessor; +use Carp qw(confess); +use Try::Tiny; +use base 'Moose::Meta::Method::Accessor'; + +sub _generate_accessor_method_inline { + my $self = shift; + my $attr = $self->associated_attribute; + my $clone + = $attr->associated_class->has_method("clone") + ? '$_[0]->clone' + : 'bless { %{$_[0]} }, ref $_[0]'; + + if ( $Moose::VERSION >= 1.9900 ) { + return try { + $self->_compile_code( + [ 'sub {', + 'if (@_ > 1) {', + 'my $clone = ' . $clone . ';', + $attr->_inline_set_value( '$clone', '$_[1]' ), + 'return $clone;', + '}', + $attr->_inline_get_value('$_[0]'), + '}', + ] + ); + } + catch { + confess "Could not generate inline accessor because : $_"; + }; + } + else { + my ( $code, $e ) = $self->_eval_closure( + {}, + join( "\n", + 'sub {', + 'if (@_ > 1) {', + 'my $clone = ' . $clone . ';', + $attr->inline_set( '$clone', '$_[1]' ), + 'return $clone;', + '}', + $attr->inline_get('$_[0]'), + '}' ), + ); + confess "Could not generate inline predicate because : $e" if $e; + return $code; + } +} + +sub _generate_writer_method_inline { + my $self = shift; + my $attr = $self->associated_attribute; + my $clone + = $attr->associated_class->has_method("clone") + ? '$_[0]->clone' + : 'bless { %{$_[0]} }, ref $_[0]'; + if ( $Moose::VERSION >= 1.9900 ) { + return try { + $self->_compile_code( + [ 'sub {', + 'my $clone = ' . $clone . ';', + $attr->_inline_set_value( '$clone', '$_[1]' ), + 'return $clone;', '}', + ] + ); + } + catch { + confess "Could not generate inline writer because : $_"; + }; + } + else { + my ( $code, $e ) = $self->_eval_closure( + {}, + join( "\n", + 'sub {', + 'my $clone = ' . $clone . ';', + $attr->inline_set( '$clone', '$_[1]' ), + 'return $clone;', '}' ), + ); + confess "Could not generate inline writer because : $e" if $e; + return $code; + } +} + +1; + +=head1 SYNOPSIS + + package Test; + use Moose; + + has debug => ( + traits => [ 'ChainedClone' ], + is => 'rw', + isa => 'Bool', + default => 0, + ); + + sub complex_method + { + my $self = shift; + + #... + + print "helper message" if $self->debug; + + #... + } + + sub clone { + my $self = shift; + # custom clone code here + # defaults to: + return bless { %$self }, ref $self; + } + + + 1; + +Which allows for: + + my $test = Test->new; + $test->debug(1)->complex_method; # debug enabled + # complex_method is called on a cloned instance + # with debug set to 1 + + $test->complex_method; # debug is still disabled on $test + + $test->debug(1); # returns a cloned $test instance with debug set to 1 + $test->debug; # returns 0 + +=head1 DESCRIPTION + +MooseX::Attribute::ChainedClone is a Moose Trait which allows for method chaining +on accessors by returning a cloned instance of C<$self> on write/set operations. + +If C<$self> has a C method, this method is invoked to clone the instance. +This allows for easy integration with L or any custom made +clone method. If no C method is available, the new instance is build +using C<< bless { %$self }, ref $self >>. \ No newline at end of file diff --git a/t/clone.t b/t/clone.t new file mode 100644 index 0000000..57e3664 --- /dev/null +++ b/t/clone.t @@ -0,0 +1,40 @@ +use strict; +use warnings; + +package MyCloned; +use Moose; +use MooseX::Attribute::ChainedClone; + +has foo => ( is => 'rw', traits => ['ChainedClone'] ); +has writer => + ( is => 'rw', writer => 'set_writer', traits => ['ChainedClone'] ); + +package main; +use Scalar::Util qw(refaddr); +use Test::More; + +is( MyCloned->meta->get_attribute("foo")->accessor_metaclass, + 'MooseX::Attribute::ChainedClone::Method::Accessor', + 'accessor metaclass set' +); + +ok( my $object = MyCloned->new( foo => "init", writer => "init" ), "build object" ); +ok( my $addr = refaddr $object, "get refaddr" ); + +{ + ok( my $clone = $object->foo("bar"), "set attribute and get clone" ); + is( $object->foo, "init", '$object keeps value' ); + is( $clone->foo, "bar", '$clone has new value' ); + ok( $clone->isa("MyCloned"), "isa object" ); + isnt( $addr, refaddr $clone, "refaddr doens't match" ); +} + +{ + ok( my $clone = $object->set_writer("bar"), "set writer attribute and get clone" ); + is( $object->writer, "init", '$object keeps value' ); + is( $clone->writer, "bar", '$clone has new value' ); + ok( $clone->isa("MyCloned"), "isa object" ); + isnt( $addr, refaddr $clone, "refaddr doens't match" ); +} + +done_testing;