chained and cloning attribute

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<clone> method, this method is invoked to clone the instance.
+This allows for easy integration with L<MooseX::Clone> or any custom made
+clone method. If no C<clone> method is available, the new instance is build
+using C<< bless { %$self }, ref $self >>.

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;