From dc07be4ac45756a0e664ee29e888f86b7609784a Mon Sep 17 00:00:00 2001 From: Gianni Ceccarelli Date: Thu, 10 Nov 2011 15:10:26 +0000 Subject: move up a level --- lib/Data/MultiValued/AttributeAccessors.pm | 109 ++++++++++ lib/Data/MultiValued/AttributeTrait.pm | 229 +++++++++++++++++++++ lib/Data/MultiValued/AttributeTrait/Ranges.pm | 14 ++ lib/Data/MultiValued/AttributeTrait/Tags.pm | 14 ++ .../MultiValued/AttributeTrait/TagsAndRanges.pm | 14 ++ lib/Data/MultiValued/Exceptions.pm | 57 +++++ lib/Data/MultiValued/RangeContainer.pm | 192 +++++++++++++++++ lib/Data/MultiValued/Ranges.pm | 68 ++++++ lib/Data/MultiValued/TagContainer.pm | 99 +++++++++ lib/Data/MultiValued/TagContainerForRanges.pm | 38 ++++ lib/Data/MultiValued/Tags.pm | 65 ++++++ lib/Data/MultiValued/TagsAndRanges.pm | 79 +++++++ .../MultiValued/UglySerializationHelperRole.pm | 35 ++++ 13 files changed, 1013 insertions(+) create mode 100644 lib/Data/MultiValued/AttributeAccessors.pm create mode 100644 lib/Data/MultiValued/AttributeTrait.pm create mode 100644 lib/Data/MultiValued/AttributeTrait/Ranges.pm create mode 100644 lib/Data/MultiValued/AttributeTrait/Tags.pm create mode 100644 lib/Data/MultiValued/AttributeTrait/TagsAndRanges.pm create mode 100644 lib/Data/MultiValued/Exceptions.pm create mode 100644 lib/Data/MultiValued/RangeContainer.pm create mode 100644 lib/Data/MultiValued/Ranges.pm create mode 100644 lib/Data/MultiValued/TagContainer.pm create mode 100644 lib/Data/MultiValued/TagContainerForRanges.pm create mode 100644 lib/Data/MultiValued/Tags.pm create mode 100644 lib/Data/MultiValued/TagsAndRanges.pm create mode 100644 lib/Data/MultiValued/UglySerializationHelperRole.pm (limited to 'lib') diff --git a/lib/Data/MultiValued/AttributeAccessors.pm b/lib/Data/MultiValued/AttributeAccessors.pm new file mode 100644 index 0000000..cac3538 --- /dev/null +++ b/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_multi_value($_[0], {}, $_[1]); + } + $attr->get_multi_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_multi_value($_[0], {}); + }; +} + +sub _generate_writer_method { + my $self = shift; + my $attr = $self->associated_attribute; + + return sub { + $attr->set_multi_value($_[0], {}, $_[1]); + }; +} + +sub _generate_predicate_method { + my $self = shift; + my $attr = $self->associated_attribute; + + return sub { + $attr->has_multi_value($_[0], {}) + }; +} + +sub _generate_clearer_method { + my $self = shift; + my $attr = $self->associated_attribute; + + return sub { + $attr->clear_multi_value($_[0], {}) + }; +} + +sub _generate_multi_accessor_method { + my $self = shift; + my $attr = $self->associated_attribute; + + return sub { + if (@_ >= 3) { + $attr->set_multi_value($_[0], $_[1], $_[2]); + } + $attr->get_multi_value($_[0],$_[1]); + } +} + +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_multi_value($_[0],$_[1]); + }; +} + +sub _generate_multi_writer_method { + my $self = shift; + my $attr = $self->associated_attribute; + + return sub { + $attr->set_multi_value($_[0], $_[1], $_[2]); + }; +} + +sub _generate_multi_predicate_method { + my $self = shift; + my $attr = $self->associated_attribute; + + return sub { + $attr->has_multi_value($_[0],$_[1]) + }; +} + +sub _generate_multi_clearer_method { + my $self = shift; + my $attr = $self->associated_attribute; + + return sub { + $attr->clear_multi_value($_[0],$_[1]) + }; +} + +1; diff --git a/lib/Data/MultiValued/AttributeTrait.pm b/lib/Data/MultiValued/AttributeTrait.pm new file mode 100644 index 0000000..91e1b13 --- /dev/null +++ b/lib/Data/MultiValued/AttributeTrait.pm @@ -0,0 +1,229 @@ +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'; +requires 'opts_to_pass_set'; +requires 'opts_to_pass_get'; + +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 _filter_opts { + my ($hr,@fields) = @_; + + my %ret; + for my $f (@fields) { + if (exists $hr->{$f}) { + $ret{$f}=$hr->{$f}; + } + } + return \%ret; +} + +sub load_multi_value { + my ($self,$instance,$opts) = @_; + + my $opts_passed = _filter_opts($opts, $self->opts_to_pass_get); + + my $value;my $found=1; + try { + $value = $self->full_storage($instance)->get($opts_passed); + } + 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 $opts_passed = _filter_opts($opts, $self->opts_to_pass_set); + + $opts_passed->{value} = $self->get_raw_value($instance); + + $self->full_storage($instance)->set($opts_passed); +} + +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) = @_; + + $self->full_storage($instance)->clear($dyn_opts); + return; +}; + +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/lib/Data/MultiValued/AttributeTrait/Ranges.pm b/lib/Data/MultiValued/AttributeTrait/Ranges.pm new file mode 100644 index 0000000..8d93578 --- /dev/null +++ b/lib/Data/MultiValued/AttributeTrait/Ranges.pm @@ -0,0 +1,14 @@ +package Data::MultiValued::AttributeTrait::Ranges; +use Moose::Role; +use Data::MultiValued::Ranges; +with 'Data::MultiValued::AttributeTrait'; + +sub multivalue_storage_class { 'Data::MultiValued::Ranges' }; +sub opts_to_pass_set { qw(from to) } +sub opts_to_pass_get { qw(at) } + +package Moose::Meta::Attribute::Custom::Trait::MultiValued::Ranges;{ +sub register_implementation { 'Data::MultiValued::AttributeTrait::Ranges' } +} + +1; diff --git a/lib/Data/MultiValued/AttributeTrait/Tags.pm b/lib/Data/MultiValued/AttributeTrait/Tags.pm new file mode 100644 index 0000000..7cffb33 --- /dev/null +++ b/lib/Data/MultiValued/AttributeTrait/Tags.pm @@ -0,0 +1,14 @@ +package Data::MultiValued::AttributeTrait::Tags; +use Moose::Role; +use Data::MultiValued::Tags; +with 'Data::MultiValued::AttributeTrait'; + +sub multivalue_storage_class { 'Data::MultiValued::Tags' }; +sub opts_to_pass_set { qw(tag) } +sub opts_to_pass_get { qw(tag) } + +package Moose::Meta::Attribute::Custom::Trait::MultiValued::Tags;{ +sub register_implementation { 'Data::MultiValued::AttributeTrait::Tags' } +} + +1; diff --git a/lib/Data/MultiValued/AttributeTrait/TagsAndRanges.pm b/lib/Data/MultiValued/AttributeTrait/TagsAndRanges.pm new file mode 100644 index 0000000..e0c56cd --- /dev/null +++ b/lib/Data/MultiValued/AttributeTrait/TagsAndRanges.pm @@ -0,0 +1,14 @@ +package Data::MultiValued::AttributeTrait::TagsAndRanges; +use Moose::Role; +use Data::MultiValued::TagsAndRanges; +with 'Data::MultiValued::AttributeTrait'; + +sub multivalue_storage_class { 'Data::MultiValued::TagsAndRanges' }; +sub opts_to_pass_set { qw(from to tag) } +sub opts_to_pass_get { qw(at tag) } + +package Moose::Meta::Attribute::Custom::Trait::MultiValued::TagsAndRanges;{ +sub register_implementation { 'Data::MultiValued::AttributeTrait::TagsAndRanges' } +} + +1; diff --git a/lib/Data/MultiValued/Exceptions.pm b/lib/Data/MultiValued/Exceptions.pm new file mode 100644 index 0000000..8d444c0 --- /dev/null +++ b/lib/Data/MultiValued/Exceptions.pm @@ -0,0 +1,57 @@ +package Data::MultiValued::Exceptions; +package Data::MultiValued::Exceptions::NotFound;{ +use Moose; +extends 'Throwable::Error'; + +has value => ( + is => 'ro', + required => 1, +); + +sub as_string { + my ($self) = @_; + + my $str = $self->message . ($self->value // ''); + $str .= "\n\n" . $self->stack_trace->as_string; + + return $str; +} + +} +package Data::MultiValued::Exceptions::TagNotFound;{ +use Moose; +extends 'Data::MultiValued::Exceptions::NotFound'; + +has '+message' => ( + default => 'tag not found: ', +); +} +package Data::MultiValued::Exceptions::RangeNotFound;{ +use Moose; +extends 'Data::MultiValued::Exceptions::NotFound'; + +has '+message' => ( + default => 'no range found for value ', +); +} +package Data::MultiValued::Exceptions::BadRange;{ +use Moose; +extends 'Throwable::Error'; + +has ['from','to'] => ( is => 'ro', required => 1 ); +has '+message' => ( + default => 'invalid range: ', +); + +sub as_string { + my ($self) = @_; + + my $str = $self->message . $self->from . ', ' . $self->to; + $str .= "\n\n" . $self->stack_trace->as_string; + + return $str; +} + +} + +1; diff --git a/lib/Data/MultiValued/RangeContainer.pm b/lib/Data/MultiValued/RangeContainer.pm new file mode 100644 index 0000000..474626f --- /dev/null +++ b/lib/Data/MultiValued/RangeContainer.pm @@ -0,0 +1,192 @@ +package Data::MultiValued::RangeContainer; +use Moose; +use Moose::Util::TypeConstraints; +use MooseX::Types::Moose qw(Num Str Any Undef ArrayRef); +use MooseX::Types::Structured qw(Dict); +use Data::MultiValued::Exceptions; + +has _storage => ( + is => 'rw', + isa => ArrayRef[ + Dict[ + from => Num|Undef, + to => Num|Undef, + value => Any, + ], + ], + init_arg => undef, + default => sub { [ ] }, +); + +sub get { + my ($self,$args) = @_; + + my $at = $args->{at}; + + my ($range) = $self->_get_slot_at($at); + + if (!$range) { + Data::MultiValued::Exceptions::RangeNotFound->throw({ + value => $at, + }); + } + + return $range; +} + +# Num|Undef,Num|Undef,Bool,Bool +# the bools mean "treat the undef as +inf" (-inf when omitted/false) +sub _cmp { + my ($a,$b,$sa,$sb) = @_; + + $a //= $sa ? 0+'inf' : 0-'inf'; + $b //= $sb ? 0+'inf' : 0-'inf'; + + return $a <=> $b; +} + +sub _get_slot_at { + my ($self,$at) = @_; + + for my $slot (@{$self->_storage}) { + next if _cmp($slot->{to},$at,1,0) <= 0; + last if _cmp($slot->{from},$at,0,0) > 0; + return $slot; + } + return; +} + +sub _partition_slots { + my ($self,$from,$to) = @_; + + my (@before,@overlap,@after); + my $st=$self->_storage; + + keys @$st; + + while (my ($idx,$slot) = each @$st) { + my ($sf,$st) = @$slot{'from','to'}; + + if (_cmp($st,$from,1,0) <0) { + push @before,$idx; + } + elsif (_cmp($sf,$to,0,1) >=0) { + push @after,$idx; + } + else { + push @overlap,$idx; + } + } + return \@before,\@overlap,\@after; +} + +sub set_or_create { + my ($self,$args) = @_; + + my $from = $args->{from}; + my $to = $args->{to}; + + Data::MultiValued::Exceptions::BadRange->throw({ + from => $from, + to => $to, + }) if _cmp($from,$to,0,1)>0; + + my ($range) = $self->_get_slot_at($from); + + if ($range + && _cmp($range->{from},$from,0,0)==0 + && _cmp($range->{to},$to,1,1)==0) { + return $range; + } + + $range = $self->_create_slot($from,$to); + return $range; +} + +sub clear { + my ($self,$args) = @_; + + my $from = $args->{from}; + my $to = $args->{to}; + + Data::MultiValued::Exceptions::BadRange->throw({ + from => $from, + to => $to, + }) if _cmp($from,$to,0,1)>0; + + return $self->_clear_slot($from,$to); +} + +sub _create_slot { + my ($self,$from,$to) = @_; + + $self->_splice_slot($from,$to,{ + from => $from, + to => $to, + value => undef, + }); +} + +sub _clear_slot { + my ($self,$from,$to) = @_; + + $self->_splice_slot($from,$to); +} + +sub _splice_slot { + my ($self,$from,$to,$new) = @_; + + if (!@{$self->_storage}) { # empty + push @{$self->_storage},$new if $new; + return $new; + } + + my ($before,$overlap,$after) = $self->_partition_slots($from,$to); + + if (!@$before && !@$overlap) { + unshift @{$self->_storage},$new if $new; + return $new; + } + if (!@$after && !@$overlap) { + push @{$self->_storage},$new if $new; + return $new; + } + + # by costruction, the first and the last may have to be split, all + # others must be removed + my $first_to_replace = $overlap->[0], + my $last_to_replace = $overlap->[-1], + my $how_many = @$overlap; + + my @replacement = $new ? ($new) : (); + + if ($how_many > 0) { # we have to splice + my $first = $self->_storage->[$first_to_replace]; + my $last = $self->_storage->[$last_to_replace]; + + if (_cmp($first->{from},$from,0,0)<0 + && _cmp($first->{to},$from,1,0)>=0) { + unshift @replacement, { + from => $first->{from}, + to => $from, + value => $first->{value}, + } + } + if (_cmp($last->{from},$to,0,1)<=0 + && _cmp($last->{to},$to,1,1)>0) { + push @replacement, { + from => $to, + to => $last->{to}, + value => $last->{value}, + } + } + } + + splice @{$self->_storage}, + $first_to_replace,$how_many, + @replacement; + + return $new; +} + +1; diff --git a/lib/Data/MultiValued/Ranges.pm b/lib/Data/MultiValued/Ranges.pm new file mode 100644 index 0000000..9c69626 --- /dev/null +++ b/lib/Data/MultiValued/Ranges.pm @@ -0,0 +1,68 @@ +package Data::MultiValued::Ranges; +use Moose; +use MooseX::Params::Validate; +use Moose::Util::TypeConstraints; +use MooseX::Types::Moose qw(Num Str Undef Any); +use Data::MultiValued::Exceptions; +use Data::MultiValued::RangeContainer; + +# ABSTRACT: Handle values with tags and validity ranges + +has _storage => ( + is => 'rw', + isa => class_type('Data::MultiValued::RangeContainer'), + init_arg => undef, + lazy_build => 1, +); + +sub _build__storage { + Data::MultiValued::RangeContainer->new(); +} + +sub _rebless_storage { + my ($self) = @_; + + bless $self->{_storage},'Data::MultiValued::RangeContainer'; +} + +sub _as_hash { + my ($self) = @_; + + my %ret = %{$self->_storage}; + return {_storage=>\%ret}; +} + +sub set { + my ($self,%args) = validated_hash( + \@_, + from => { isa => Num|Undef, optional => 1, }, + to => { isa => Num|Undef, optional => 1, }, + value => { isa => Any, }, + ); + + $self->_storage->set_or_create(\%args) + ->{value} = $args{value}; +} + +sub get { + my ($self,%args) = validated_hash( + \@_, + at => { isa => Num|Undef, optional => 1, }, + ); + + $self->_storage->get(\%args) + ->{value}; +} + +sub clear { + my ($self,%args) = validated_hash( + \@_, + from => { isa => Num|Undef, optional => 1, }, + to => { isa => Num|Undef, optional => 1, }, + ); + + $self->_storage->clear(\%args); +} + + +1; diff --git a/lib/Data/MultiValued/TagContainer.pm b/lib/Data/MultiValued/TagContainer.pm new file mode 100644 index 0000000..cdd0456 --- /dev/null +++ b/lib/Data/MultiValued/TagContainer.pm @@ -0,0 +1,99 @@ +package Data::MultiValued::TagContainer; +use Moose; +use Moose::Util::TypeConstraints; +use MooseX::Types::Moose qw(HashRef); +use Data::MultiValued::Exceptions; + +has _storage => ( + is => 'rw', + isa => HashRef, + init_arg => undef, + default => sub { { } }, + traits => ['Hash'], + handles => { + _has_tag => 'exists', + _get_tag => 'get', + _create_tag => 'set', + _delete_tag => 'delete', + }, +); + +has _default_tag => ( + is => 'rw', + init_arg => undef, + predicate => '_has_default_tag', + clearer => '_clear_default_tag', +); + +sub get { + my ($self,$args) = @_; + + my $tag = $args->{tag}; + + if (!defined($tag)) { + if ($self->_has_default_tag) { + return $self->_default_tag; + } + + Data::MultiValued::Exceptions::TagNotFound->throw({ + value => $tag, + }); + } + + if (!$self->_has_tag($tag)) { + Data::MultiValued::Exceptions::TagNotFound->throw({ + value => $tag, + }); + } + return $self->_get_tag($tag); +} + +sub get_or_create { + my ($self,$args) = @_; + + my $tag = $args->{tag}; + + if (!defined($tag)) { + if ($self->_has_default_tag) { + return $self->_default_tag; + } + else { + return $self->_default_tag( + $self->_create_new_inferior + ); + } + } + + if (!$self->_has_tag($tag)) { + $self->_create_tag($tag,$self->_create_new_inferior); + } + return $self->_get_tag($tag); +} + +sub _clear_storage { + my ($self) = @_; + + $self->_storage({}); +} + +sub clear { + my ($self,$args) = @_; + + my $tag = $args->{tag}; + + if (!defined($tag)) { + $self->_clear_default_tag; + $self->_clear_storage; + } + elsif ($self->_has_tag($tag)) { + $self->_delete_tag($tag); + } + return; +} + +sub _create_new_inferior { + my ($self) = @_; + return {}; +} + +1; diff --git a/lib/Data/MultiValued/TagContainerForRanges.pm b/lib/Data/MultiValued/TagContainerForRanges.pm new file mode 100644 index 0000000..d3cd4b9 --- /dev/null +++ b/lib/Data/MultiValued/TagContainerForRanges.pm @@ -0,0 +1,38 @@ +package Data::MultiValued::TagContainerForRanges; +use Moose; +use MooseX::Types::Moose qw(HashRef); +use Moose::Util::TypeConstraints; +use Data::MultiValued::RangeContainer; + +extends 'Data::MultiValued::TagContainer'; + +has '+_storage' => ( + isa => HashRef[class_type('Data::MultiValued::RangeContainer')], +); + +has '+_default_tag' => ( + isa => class_type('Data::MultiValued::RangeContainer'), +); + +sub _create_new_inferior { + Data::MultiValued::RangeContainer->new(); +} + +sub _rebless_storage { + my ($self) = @_; + bless $self->{_storage},'Data::MultiValued::RangeContainer'; + bless $self->{_default_tag},'Data::MultiValued::RangeContainer'; + return; +} + +sub _as_hash { + my ($self) = @_; + my %st = %{$self->_storage}; + my %dt = %{$self->_default_tag}; + return { + _storage => \%st, + _default_tag => \%dt, + }; +} + +1; diff --git a/lib/Data/MultiValued/Tags.pm b/lib/Data/MultiValued/Tags.pm new file mode 100644 index 0000000..fbf7948 --- /dev/null +++ b/lib/Data/MultiValued/Tags.pm @@ -0,0 +1,65 @@ +package Data::MultiValued::Tags; +use Moose; +use MooseX::Params::Validate; +use Moose::Util::TypeConstraints; +use MooseX::Types::Moose qw(Num Str Undef Any); +use Data::MultiValued::Exceptions; +use Data::MultiValued::TagContainer; + +# ABSTRACT: Handle values with tags and validity ranges + +has _storage => ( + is => 'rw', + isa => class_type('Data::MultiValued::TagContainer'), + init_arg => undef, + lazy_build => 1, +); + +sub _build__storage { + Data::MultiValued::TagContainer->new(); +} + +sub _rebless_storage { + my ($self) = @_; + + bless $self->{_storage},'Data::MultiValued::TagContainer'; +} + +sub _as_hash { + my ($self) = @_; + + my %ret = %{$self->_storage}; + return {_storage=>\%ret}; +} + +sub set { + my ($self,%args) = validated_hash( + \@_, + tag => { isa => Str, optional => 1, }, + value => { isa => Any, }, + ); + + $self->_storage->get_or_create(\%args) + ->{value} = $args{value}; +} + +sub get { + my ($self,%args) = validated_hash( + \@_, + tag => { isa => Str, optional => 1, }, + ); + + $self->_storage->get(\%args) + ->{value}; +} + +sub clear { + my ($self,%args) = validated_hash( + \@_, + tag => { isa => Str, optional => 1, }, + ); + + $self->_storage->clear(\%args); +} + +1; diff --git a/lib/Data/MultiValued/TagsAndRanges.pm b/lib/Data/MultiValued/TagsAndRanges.pm new file mode 100644 index 0000000..6208435 --- /dev/null +++ b/lib/Data/MultiValued/TagsAndRanges.pm @@ -0,0 +1,79 @@ +package Data::MultiValued::TagsAndRanges; +use Moose; +use MooseX::Params::Validate; +use Moose::Util::TypeConstraints; +use MooseX::Types::Moose qw(Num Str Undef Any); +use Data::MultiValued::Exceptions; +use Data::MultiValued::TagContainerForRanges; + +# ABSTRACT: Handle values with tags and validity ranges + +has _storage => ( + is => 'rw', + isa => class_type('Data::MultiValued::TagContainerForRanges'), + init_arg => undef, + lazy_build => 1, +); + +sub _build__storage { + Data::MultiValued::TagContainerForRanges->new(); +} + +sub _rebless_storage { + my ($self) = @_; + + bless $self->{_storage},'Data::MultiValued::TagContainerForRanges'; + $self->_storage->_rebless_storage; +} + +sub _as_hash { + my ($self) = @_; + + my $ret = $self->_storage->_as_hash; + return {_storage=>$ret}; +} + +sub set { + my ($self,%args) = validated_hash( + \@_, + from => { isa => Num|Undef, optional => 1, }, + to => { isa => Num|Undef, optional => 1, }, + tag => { isa => Str, optional => 1, }, + value => { isa => Any, }, + ); + + $self->_storage->get_or_create(\%args) + ->set_or_create(\%args) + ->{value} = $args{value}; +} + +sub get { + my ($self,%args) = validated_hash( + \@_, + at => { isa => Num|Undef, optional => 1, }, + tag => { isa => Str, optional => 1, }, + ); + + $self->_storage->get(\%args) + ->get(\%args) + ->{value}; +} + +sub clear { + my ($self,%args) = validated_hash( + \@_, + from => { isa => Num|Undef, optional => 1, }, + to => { isa => Num|Undef, optional => 1, }, + tag => { isa => Str, optional => 1, }, + ); + + if (exists $args{from} || exists $args{to}) { + $self->_storage->get(\%args) + ->clear(\%args); + } + else { + $self->_storage->clear(\%args); + } +} + +1; diff --git a/lib/Data/MultiValued/UglySerializationHelperRole.pm b/lib/Data/MultiValued/UglySerializationHelperRole.pm new file mode 100644 index 0000000..e586dec --- /dev/null +++ b/lib/Data/MultiValued/UglySerializationHelperRole.pm @@ -0,0 +1,35 @@ +package Data::MultiValued::UglySerializationHelperRole; +use Moose::Role; + +sub new_in_place { + my ($class,$hash) = @_; + + my $self = bless $hash,$class; + + for my $attr ($class->meta->get_all_attributes) { + if ($attr->does('Data::MultiValued::AttributeTrait')) { + $attr->_rebless_slot($self); + } + } + return $self; +} + +sub as_hash { + my ($self) = @_; + + my %ret = %$self; + for my $attr ($self->meta->get_all_attributes) { + if ($attr->does('Data::MultiValued::AttributeTrait')) { + my $st = $attr->_as_hash($self); + if ($st) { + $ret{$attr->full_storage_slot} = $st; + } + else { + delete $ret{$attr->full_storage_slot}; + } + } + } + return \%ret; +} + +1; -- cgit v1.2.3