diff options
-rw-r--r-- | Data-MultiValued/lib/Data/MultiValued/AttributeAccessors.pm | 109 | ||||
-rw-r--r-- | Data-MultiValued/lib/Data/MultiValued/AttributeTrait/Tagged.pm | 180 | ||||
-rw-r--r-- | Data-MultiValued/t/moose-tagged.t | 67 |
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(); |