moose traits for tags

3 files changed, 356 insertions, 0 deletions

diff --git a/Data-MultiValued/lib/Data/MultiValued/AttributeAccessors.pm b/Data-MultiValued/lib/Data/MultiValued/AttributeAccessors.pm
new file mode 100644
index 0000000..e6fec67
--- /dev/null
+++ b/Data-MultiValued/lib/Data/MultiValued/AttributeAccessors.pm
@@ -0,0 +1,109 @@
+package Data::MultiValued::AttributeAccessors;
+use strict;
+use warnings;
+use base 'Moose::Meta::Method::Accessor';
+use Carp 'confess';
+
+sub _instance_is_inlinable { 0 }
+
+sub _generate_accessor_method {
+    my $self = shift;
+    my $attr = $self->associated_attribute;
+
+    return sub {
+        if (@_ >= 2) {
+            $attr->set_tagged_value($_[0], {}, $_[1]);
+        }
+        $attr->get_tagged_value($_[0], {});
+    }
+}
+
+sub _generate_reader_method {
+    my $self = shift;
+    my $attr = $self->associated_attribute;
+
+    return sub {
+        confess "Cannot assign a value to a read-only accessor"
+            if @_ > 1;
+        $attr->get_tagged_value($_[0], {});
+    };
+}
+
+sub _generate_writer_method {
+    my $self = shift;
+    my $attr = $self->associated_attribute;
+
+    return sub {
+        $attr->set_tagged_value($_[0], {}, $_[1]);
+    };
+}
+
+sub _generate_predicate_method {
+    my $self = shift;
+    my $attr = $self->associated_attribute;
+
+    return sub {
+        $attr->has_tagged_value($_[0], {})
+    };
+}
+
+sub _generate_clearer_method {
+    my $self = shift;
+    my $attr = $self->associated_attribute;
+
+    return sub {
+        $attr->clear_tagged_value($_[0], {})
+    };
+}
+
+sub _generate_tagged_accessor_method {
+    my $self = shift;
+    my $attr = $self->associated_attribute;
+
+    return sub {
+        if (@_ >= 3) {
+            $attr->set_tagged_value($_[0], $_[1], $_[2]);
+        }
+        $attr->get_tagged_value($_[0],$_[1]);
+    }
+}
+
+sub _generate_tagged_reader_method {
+    my $self = shift;
+    my $attr = $self->associated_attribute;
+
+    return sub {
+        confess "Cannot assign a value to a read-only accessor"
+            if @_ > 2;
+        $attr->get_tagged_value($_[0],$_[1]);
+    };
+}
+
+sub _generate_tagged_writer_method {
+    my $self = shift;
+    my $attr = $self->associated_attribute;
+
+    return sub {
+        $attr->set_tagged_value($_[0], $_[1], $_[2]);
+    };
+}
+
+sub _generate_tagged_predicate_method {
+    my $self = shift;
+    my $attr = $self->associated_attribute;
+
+    return sub {
+        $attr->has_tagged_value($_[0],$_[1])
+    };
+}
+
+sub _generate_tagged_clearer_method {
+    my $self = shift;
+    my $attr = $self->associated_attribute;
+
+    return sub {
+        $attr->clear_tagged_value($_[0],$_[1])
+    };
+}
+
+1;
diff --git a/Data-MultiValued/lib/Data/MultiValued/AttributeTrait/Tagged.pm b/Data-MultiValued/lib/Data/MultiValued/AttributeTrait/Tagged.pm
new file mode 100644
index 0000000..a1f33fc
--- /dev/null
+++ b/Data-MultiValued/lib/Data/MultiValued/AttributeTrait/Tagged.pm
@@ -0,0 +1,180 @@
+package Data::MultiValued::AttributeTrait::Tagged;
+use Moose::Role;
+use Data::MultiValued::Tags;
+use Data::MultiValued::AttributeAccessors;
+use MooseX::Types::Moose qw(Str HashRef);
+use Try::Tiny;
+use namespace::autoclean;
+
+has 'full_storage_slot' => (
+    is => 'ro',
+    isa => Str,
+    lazy_build => 1,
+    init_arg => undef,
+);
+sub _build_full_storage_slot { shift->name . '__MULTIVALUED_STORAGE__' }
+
+around slots => sub {
+    my ($orig, $self) = @_;
+    return ($self->$orig(), $self->full_storage_slot);
+};
+
+sub set_full_storage {
+    my ($self,$instance) = @_;
+
+    my $ret = Data::MultiValued::Tags->new();
+    $self->associated_class->get_meta_instance->set_slot_value(
+        $instance,
+        $self->full_storage_slot,
+        $ret,
+    );
+    return $ret;
+}
+
+sub get_full_storage {
+    my ($self,$instance) = @_;
+
+    return $self->associated_class->get_meta_instance
+        ->get_slot_value(
+            $instance,
+            $self->full_storage_slot,
+        );
+}
+
+sub full_storage {
+    my ($self,$instance) = @_;
+
+    return $self->get_full_storage($instance)
+        || $self->set_full_storage($instance);
+}
+
+sub accessor_metaclass { 'Data::MultiValued::AttributeAccessors' }
+
+after install_accessors => sub {
+    my ($self) = @_;
+
+    my $class  = $self->associated_class;
+
+    for my $meth (qw(accessor reader writer predicate clearer)) {
+        my $check = "has_$meth";
+        next unless $self->$check;
+
+        my $type = "tagged_$meth";
+        my $basename = $self->$meth;
+        my $name = "${basename}_tagged";
+
+        $class->add_method(
+            $self->_process_accessors($type => $name,0)
+        );
+    }
+};
+
+sub load_tagged_value {
+    my ($self,$instance,$opts) = @_;
+
+    my $value;my $found=1;
+    try {
+        $value = $self->full_storage($instance)->get($opts);
+    }
+    catch {
+        unless (ref($_) && $_->isa('Data::MultiValued::Exceptions::NotFound')) {
+            die $_;
+        }
+        $found = 0;
+    };
+
+    if ($found) {
+        $self->set_raw_value($instance,$value);
+    }
+    else {
+        $self->raw_clear_value($instance);
+    }
+}
+
+sub raw_clear_value {
+    my ($self,$instance) = @_;
+
+    $self->associated_class->get_meta_instance
+        ->deinitialize_slot(
+            $instance,
+            $self->name,
+        );
+}
+
+sub store_tagged_value {
+    my ($self,$instance,$opts) = @_;
+
+    my $value = $self->get_raw_value($instance);
+    $self->full_storage($instance)->set({%$opts,value=>$value});
+}
+
+our $dyn_opts = {};
+
+before get_value => sub {
+    my ($self,$instance) = @_;
+
+    $self->load_tagged_value($instance,$dyn_opts);
+};
+
+sub get_tagged_value {
+    my ($self,$instance,$opts,$value) = @_;
+
+    local $dyn_opts = $opts;
+
+    return $self->get_value($instance,$value);
+}
+
+after set_initial_value => sub {
+    my ($self,$instance,$value) = @_;
+
+    $self->store_tagged_value($instance,$dyn_opts);
+};
+
+after set_value => sub {
+    my ($self,$instance,$value) = @_;
+
+    $self->store_tagged_value($instance,$dyn_opts);
+};
+
+sub set_tagged_value {
+    my ($self,$instance,$opts,$value) = @_;
+
+    local $dyn_opts = $opts;
+
+    return $self->set_value($instance,$value);
+}
+
+before has_value => sub {
+    my ($self,$instance) = @_;
+
+    $self->load_tagged_value($instance,$dyn_opts);
+};
+
+sub has_tagged_value {
+    my ($self,$instance,$opts) = @_;
+
+    local $dyn_opts = $opts;
+
+    return $self->has_value($instance);
+}
+
+after clear_value => sub {
+    my ($self,$instance) = @_;
+
+    # XXX NIY
+    $self->full_storage($instance)->clear($dyn_opts);
+};
+
+sub clear_tagged_value {
+    my ($self,$instance,$opts) = @_;
+
+    local $dyn_opts = $opts;
+
+    return $self->clear_value($instance);
+}
+
+package Moose::Meta::Attribute::Custom::Trait::MultiValued::Tagged;{
+sub register_implementation { 'Data::MultiValued::AttributeTrait::Tagged' }
+}
+
+1;
diff --git a/Data-MultiValued/t/moose-tagged.t b/Data-MultiValued/t/moose-tagged.t
new file mode 100644
index 0000000..86fb8b9
--- /dev/null
+++ b/Data-MultiValued/t/moose-tagged.t
@@ -0,0 +1,67 @@
+#!perl
+use strict;
+use warnings;
+
+package Foo;{
+use Moose;
+use Data::MultiValued::AttributeTrait::Tagged;
+
+has stuff => (
+    is => 'rw',
+    isa => 'Int',
+    traits => ['MultiValued::Tagged'],
+    default => 3,
+    predicate => 'has_stuff',
+    clearer => 'clear_stuff',
+);
+
+has other => (
+    is => 'rw',
+    isa => 'Str',
+    traits => ['MultiValued::Tagged'],
+    predicate => 'has_other',
+    clearer => 'clear_other',
+);
+}
+package main;
+use Test::Most 'die';
+use Data::Printer;
+
+subtest 'default' => sub {
+    my $obj = Foo->new();
+
+    ok(!$obj->has_other,'not has other');
+    ok($obj->has_stuff,'has stuff');
+
+    is($obj->stuff,3,'default');
+};
+
+subtest 'constructor param' => sub {
+    my $obj = Foo->new({stuff=>12,other=>'bar'});
+
+    ok($obj->has_other,'has other');
+    ok($obj->has_stuff,'has stuff');
+
+    is($obj->stuff,12,'param');
+    is($obj->other,'bar','param');
+};
+
+subtest 'with tags' => sub {
+    my $obj = Foo->new();
+
+    my $opts = {tag=>'one'};
+
+    ok($obj->has_stuff,'has stuff');
+    ok(!$obj->has_stuff_tagged($opts),'not has stuff tagged');
+    ok(!$obj->has_other,'not has other');
+    ok(!$obj->has_other_tagged($opts),'not has other tagged');
+
+    $obj->stuff_tagged($opts,7);
+    $obj->other_tagged($opts,'foo');
+
+    is($obj->stuff,3,'default');
+    is($obj->stuff_tagged($opts),7,'stuff tagged');
+    is($obj->other_tagged($opts),'foo','other tagged');
+};
+
+done_testing();