From fbad620423ae33a33b12a0276b4da41bd40f59d7 Mon Sep 17 00:00:00 2001 From: Gianni Ceccarelli Date: Thu, 10 Nov 2011 11:33:52 +0000 Subject: refactoring the traits --- .../lib/Data/MultiValued/AttributeAccessors.pm | 34 ++-- .../lib/Data/MultiValued/AttributeTrait.pm | 210 ++++++++++++++++++++ .../lib/Data/MultiValued/AttributeTrait/Tagged.pm | 213 --------------------- .../lib/Data/MultiValued/AttributeTrait/Tags.pm | 12 ++ Data-MultiValued/t/json.t | 14 +- Data-MultiValued/t/moose-tagged.t | 18 +- 6 files changed, 255 insertions(+), 246 deletions(-) create mode 100644 Data-MultiValued/lib/Data/MultiValued/AttributeTrait.pm delete mode 100644 Data-MultiValued/lib/Data/MultiValued/AttributeTrait/Tagged.pm create mode 100644 Data-MultiValued/lib/Data/MultiValued/AttributeTrait/Tags.pm diff --git a/Data-MultiValued/lib/Data/MultiValued/AttributeAccessors.pm b/Data-MultiValued/lib/Data/MultiValued/AttributeAccessors.pm index e6fec67..cac3538 100644 --- a/Data-MultiValued/lib/Data/MultiValued/AttributeAccessors.pm +++ b/Data-MultiValued/lib/Data/MultiValued/AttributeAccessors.pm @@ -12,9 +12,9 @@ sub _generate_accessor_method { return sub { if (@_ >= 2) { - $attr->set_tagged_value($_[0], {}, $_[1]); + $attr->set_multi_value($_[0], {}, $_[1]); } - $attr->get_tagged_value($_[0], {}); + $attr->get_multi_value($_[0], {}); } } @@ -25,7 +25,7 @@ sub _generate_reader_method { return sub { confess "Cannot assign a value to a read-only accessor" if @_ > 1; - $attr->get_tagged_value($_[0], {}); + $attr->get_multi_value($_[0], {}); }; } @@ -34,7 +34,7 @@ sub _generate_writer_method { my $attr = $self->associated_attribute; return sub { - $attr->set_tagged_value($_[0], {}, $_[1]); + $attr->set_multi_value($_[0], {}, $_[1]); }; } @@ -43,7 +43,7 @@ sub _generate_predicate_method { my $attr = $self->associated_attribute; return sub { - $attr->has_tagged_value($_[0], {}) + $attr->has_multi_value($_[0], {}) }; } @@ -52,57 +52,57 @@ sub _generate_clearer_method { my $attr = $self->associated_attribute; return sub { - $attr->clear_tagged_value($_[0], {}) + $attr->clear_multi_value($_[0], {}) }; } -sub _generate_tagged_accessor_method { +sub _generate_multi_accessor_method { my $self = shift; my $attr = $self->associated_attribute; return sub { if (@_ >= 3) { - $attr->set_tagged_value($_[0], $_[1], $_[2]); + $attr->set_multi_value($_[0], $_[1], $_[2]); } - $attr->get_tagged_value($_[0],$_[1]); + $attr->get_multi_value($_[0],$_[1]); } } -sub _generate_tagged_reader_method { +sub _generate_multi_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]); + $attr->get_multi_value($_[0],$_[1]); }; } -sub _generate_tagged_writer_method { +sub _generate_multi_writer_method { my $self = shift; my $attr = $self->associated_attribute; return sub { - $attr->set_tagged_value($_[0], $_[1], $_[2]); + $attr->set_multi_value($_[0], $_[1], $_[2]); }; } -sub _generate_tagged_predicate_method { +sub _generate_multi_predicate_method { my $self = shift; my $attr = $self->associated_attribute; return sub { - $attr->has_tagged_value($_[0],$_[1]) + $attr->has_multi_value($_[0],$_[1]) }; } -sub _generate_tagged_clearer_method { +sub _generate_multi_clearer_method { my $self = shift; my $attr = $self->associated_attribute; return sub { - $attr->clear_tagged_value($_[0],$_[1]) + $attr->clear_multi_value($_[0],$_[1]) }; } diff --git a/Data-MultiValued/lib/Data/MultiValued/AttributeTrait.pm b/Data-MultiValued/lib/Data/MultiValued/AttributeTrait.pm new file mode 100644 index 0000000..263ce55 --- /dev/null +++ b/Data-MultiValued/lib/Data/MultiValued/AttributeTrait.pm @@ -0,0 +1,210 @@ +package Data::MultiValued::AttributeTrait; +use Moose::Role; +use Data::MultiValued::AttributeAccessors; +use MooseX::Types::Moose qw(Str); +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__' } + +requires 'multivalue_storage_class'; + +around slots => sub { + my ($orig, $self) = @_; + return ($self->$orig(), $self->full_storage_slot); +}; + +sub set_full_storage { + my ($self,$instance) = @_; + + my $ret = $self->multivalue_storage_class->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 = "multi_$meth"; + my $basename = $self->$meth; + + die 'MultiValued attribute trait is not compatible with subref accessors' + if ref($basename); + + my $name = "${basename}_multi"; + + $class->add_method( + $self->_process_accessors($type => $name,0) + ); + } +}; + +sub load_multi_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_multi_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_multi_value($instance,$dyn_opts); +}; + +sub get_multi_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_multi_value($instance,$dyn_opts); +}; + +after set_value => sub { + my ($self,$instance,$value) = @_; + + $self->store_multi_value($instance,$dyn_opts); +}; + +sub set_multi_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_multi_value($instance,$dyn_opts); +}; + +sub has_multi_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_multi_value { + my ($self,$instance,$opts) = @_; + + local $dyn_opts = $opts; + + return $self->clear_value($instance); +} + +sub get_multi_read_method { + my $self = shift; + return $self->get_read_method . '_multi'; +} + +sub get_multi_write_method { + my $self = shift; + return $self->get_write_method . '_multi'; +} + +sub _rebless_slot { + my ($self,$instance) = @_; + + my $st = $self->get_full_storage($instance); + return unless $st; + + bless $st, $self->multivalue_storage_class; + $st->_rebless_storage; +} + +sub _as_hash { + my ($self,$instance) = @_; + + my $st = $self->get_full_storage($instance); + return unless $st; + + return $st->_as_hash; +} + +1; diff --git a/Data-MultiValued/lib/Data/MultiValued/AttributeTrait/Tagged.pm b/Data-MultiValued/lib/Data/MultiValued/AttributeTrait/Tagged.pm deleted file mode 100644 index 2a45506..0000000 --- a/Data-MultiValued/lib/Data/MultiValued/AttributeTrait/Tagged.pm +++ /dev/null @@ -1,213 +0,0 @@ -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; - - die 'MultiValued attribute trait is not compatible with subref accessors' - if ref($basename); - - 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); -} - -sub get_tagged_read_method { - my $self = shift; - return $self->get_read_method . '_tagged'; -} - -sub get_tagged_write_method { - my $self = shift; - return $self->get_write_method . '_tagged'; -} - -sub _rebless_slot { - my ($self,$instance) = @_; - - my $st = $self->get_full_storage($instance); - return unless $st; - - bless $st, 'Data::MultiValued::Tags'; - $st->_rebless_storage; -} - -sub _as_hash { - my ($self,$instance) = @_; - - my $st = $self->get_full_storage($instance); - return unless $st; - - return $st->_as_hash; -} - -package Moose::Meta::Attribute::Custom::Trait::MultiValued::Tagged;{ -sub register_implementation { 'Data::MultiValued::AttributeTrait::Tagged' } -} - -1; diff --git a/Data-MultiValued/lib/Data/MultiValued/AttributeTrait/Tags.pm b/Data-MultiValued/lib/Data/MultiValued/AttributeTrait/Tags.pm new file mode 100644 index 0000000..fff5776 --- /dev/null +++ b/Data-MultiValued/lib/Data/MultiValued/AttributeTrait/Tags.pm @@ -0,0 +1,12 @@ +package Data::MultiValued::AttributeTrait::Tags; +use Moose::Role; +use Data::MultiValued::Tags; +with 'Data::MultiValued::AttributeTrait'; + +sub multivalue_storage_class { 'Data::MultiValued::Tags' }; + +package Moose::Meta::Attribute::Custom::Trait::MultiValued::Tags;{ +sub register_implementation { 'Data::MultiValued::AttributeTrait::Tags' } +} + +1; diff --git a/Data-MultiValued/t/json.t b/Data-MultiValued/t/json.t index 09664bf..ca7986b 100644 --- a/Data-MultiValued/t/json.t +++ b/Data-MultiValued/t/json.t @@ -3,13 +3,13 @@ use strict; use warnings; package Foo;{ use Moose; -use Data::MultiValued::AttributeTrait::Tagged; +use Data::MultiValued::AttributeTrait::Tags; use Data::Printer; has stuff => ( is => 'rw', isa => 'Int', - traits => ['MultiValued::Tagged'], + traits => ['MultiValued::Tags'], default => 3, predicate => 'has_stuff', clearer => 'clear_stuff', @@ -18,7 +18,7 @@ has stuff => ( has other => ( is => 'rw', isa => 'Str', - traits => ['MultiValued::Tagged'], + traits => ['MultiValued::Tags'], predicate => 'has_other', clearer => 'clear_other', ); @@ -31,7 +31,7 @@ sub new_in_place { p $self; for my $attr ($class->meta->get_all_attributes) { - if ($attr->does('MultiValued::Tagged')) { + if ($attr->does('MultiValued::Tags')) { $attr->_rebless_slot($self); } } @@ -43,7 +43,7 @@ sub as_hash { my %ret = %$self; for my $attr ($self->meta->get_all_attributes) { - if ($attr->does('MultiValued::Tagged')) { + if ($attr->does('MultiValued::Tags')) { my $st = $attr->_as_hash($self); if ($st) { $ret{$attr->full_storage_slot} = $st; @@ -66,7 +66,7 @@ my $opts={tag=>'something'}; my $json = JSON::XS->new->utf8; my $obj = Foo->new(other=>'foo'); -$obj->stuff_tagged($opts,1234); +$obj->stuff_multi($opts,1234); my $hash = $obj->as_hash; note p $hash; my $str = $json->encode($hash); @@ -78,7 +78,7 @@ note p $obj; note p $obj2; is($obj2->stuff,$obj->stuff,'stuff'); -is($obj2->stuff_tagged($opts),$obj->stuff_tagged($opts),'stuff tagged'); +is($obj2->stuff_multi($opts),$obj->stuff_multi($opts),'stuff tagged'); is($obj2->other,$obj->other,'other'); done_testing; diff --git a/Data-MultiValued/t/moose-tagged.t b/Data-MultiValued/t/moose-tagged.t index 86fb8b9..6e1ac7a 100644 --- a/Data-MultiValued/t/moose-tagged.t +++ b/Data-MultiValued/t/moose-tagged.t @@ -4,12 +4,12 @@ use warnings; package Foo;{ use Moose; -use Data::MultiValued::AttributeTrait::Tagged; +use Data::MultiValued::AttributeTrait::Tags; has stuff => ( is => 'rw', isa => 'Int', - traits => ['MultiValued::Tagged'], + traits => ['MultiValued::Tags'], default => 3, predicate => 'has_stuff', clearer => 'clear_stuff', @@ -18,7 +18,7 @@ has stuff => ( has other => ( is => 'rw', isa => 'Str', - traits => ['MultiValued::Tagged'], + traits => ['MultiValued::Tags'], predicate => 'has_other', clearer => 'clear_other', ); @@ -52,16 +52,16 @@ subtest 'with tags' => sub { my $opts = {tag=>'one'}; ok($obj->has_stuff,'has stuff'); - ok(!$obj->has_stuff_tagged($opts),'not has stuff tagged'); + ok(!$obj->has_stuff_multi($opts),'not has stuff tagged'); ok(!$obj->has_other,'not has other'); - ok(!$obj->has_other_tagged($opts),'not has other tagged'); + ok(!$obj->has_other_multi($opts),'not has other tagged'); - $obj->stuff_tagged($opts,7); - $obj->other_tagged($opts,'foo'); + $obj->stuff_multi($opts,7); + $obj->other_multi($opts,'foo'); is($obj->stuff,3,'default'); - is($obj->stuff_tagged($opts),7,'stuff tagged'); - is($obj->other_tagged($opts),'foo','other tagged'); + is($obj->stuff_multi($opts),7,'stuff tagged'); + is($obj->other_multi($opts),'foo','other tagged'); }; done_testing(); -- cgit v1.2.3