moose traits for tags

1 files changed, 180 insertions, 0 deletions

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;