From 14cff046956f10a7d57017bbf8e8aa3450c45b04 Mon Sep 17 00:00:00 2001
From: Gianni Ceccarelli <dakkar@thenautilus.net>
Date: Mon, 14 Nov 2011 16:10:25 +0000
Subject: allow (and test) custom-named multi accessors

---
 lib/Data/MultiValued/AttributeTrait.pm | 29 +++++++++++++++++++++--------
 t/moose-tagged.t                       |  8 +++++---
 2 files changed, 26 insertions(+), 11 deletions(-)

diff --git a/lib/Data/MultiValued/AttributeTrait.pm b/lib/Data/MultiValued/AttributeTrait.pm
index 91e1b13..cd81c33 100644
--- a/lib/Data/MultiValued/AttributeTrait.pm
+++ b/lib/Data/MultiValued/AttributeTrait.pm
@@ -9,7 +9,6 @@ has 'full_storage_slot' => (
     is => 'ro',
     isa => Str,
     lazy_build => 1,
-    init_arg => undef,
 );
 sub _build_full_storage_slot { shift->name . '__MULTIVALUED_STORAGE__' }
 
@@ -17,6 +16,16 @@ requires 'multivalue_storage_class';
 requires 'opts_to_pass_set';
 requires 'opts_to_pass_get';
 
+my @accs_to_multiply=qw(accessor reader writer predicate clearer);
+
+for my $acc (@accs_to_multiply) {
+    has "multi_$acc" => (
+        is => 'ro',
+        isa => Str,
+        predicate => "has_multi_$acc",
+    );
+}
+
 around slots => sub {
     my ($orig, $self) = @_;
     return ($self->$orig(), $self->full_storage_slot);
@@ -58,17 +67,21 @@ after install_accessors => sub {
 
     my $class  = $self->associated_class;
 
-    for my $meth (qw(accessor reader writer predicate clearer)) {
+    for my $meth (@accs_to_multiply) {
+        my $type = "multi_$meth";
         my $check = "has_$meth";
-        next unless $self->$check;
+        my $multi_check = "has_$type";
+        next unless $self->$check || $self->$multi_check;
 
-        my $type = "multi_$meth";
-        my $basename = $self->$meth;
+        my $name = $self->$type;
+        if (!$name) {
+            my $basename = $self->$meth;
 
-        die 'MultiValued attribute trait is not compatible with subref accessors'
-            if ref($basename);
+            die 'MultiValued attribute trait is not compatible with subref accessors'
+                if ref($basename);
 
-        my $name = "${basename}_multi";
+            $name = "${basename}_multi";
+        }
 
         $class->add_method(
             $self->_process_accessors($type => $name,0)
diff --git a/t/moose-tagged.t b/t/moose-tagged.t
index 6e1ac7a..2493aff 100644
--- a/t/moose-tagged.t
+++ b/t/moose-tagged.t
@@ -13,6 +13,8 @@ has stuff => (
     default => 3,
     predicate => 'has_stuff',
     clearer => 'clear_stuff',
+    multi_accessor => 'stuff_tagged',
+    multi_predicate => 'has_stuff_tagged',
 );
 
 has other => (
@@ -52,15 +54,15 @@ subtest 'with tags' => sub {
     my $opts = {tag=>'one'};
 
     ok($obj->has_stuff,'has stuff');
-    ok(!$obj->has_stuff_multi($opts),'not has stuff tagged');
+    ok(!$obj->has_stuff_tagged($opts),'not has stuff tagged');
     ok(!$obj->has_other,'not has other');
     ok(!$obj->has_other_multi($opts),'not has other tagged');
 
-    $obj->stuff_multi($opts,7);
+    $obj->stuff_tagged($opts,7);
     $obj->other_multi($opts,'foo');
 
     is($obj->stuff,3,'default');
-    is($obj->stuff_multi($opts),7,'stuff tagged');
+    is($obj->stuff_tagged($opts),7,'stuff tagged');
     is($obj->other_multi($opts),'foo','other tagged');
 };
 
-- 
cgit v1.2.3