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 --- .gitignore | 10 + Changes | 4 + Data-MultiValued/.gitignore | 13 - Data-MultiValued/Changes | 4 - Data-MultiValued/dist.ini | 59 ---- .../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 ----------- Data-MultiValued/lib/Data/MultiValued/Ranges.pm | 68 ---- .../lib/Data/MultiValued/TagContainer.pm | 99 ------ .../lib/Data/MultiValued/TagContainerForRanges.pm | 38 --- Data-MultiValued/lib/Data/MultiValued/Tags.pm | 65 ---- .../lib/Data/MultiValued/TagsAndRanges.pm | 79 ----- .../MultiValued/UglySerializationHelperRole.pm | 35 -- Data-MultiValued/t/json.t | 65 ---- Data-MultiValued/t/moose-ranges.t | 67 ---- Data-MultiValued/t/moose-tagged.t | 67 ---- Data-MultiValued/t/more-overlapping-ranges.t | 79 ----- Data-MultiValued/t/overlapping-ranges.t | 64 ---- Data-MultiValued/t/ranges-setting.t | 93 ------ Data-MultiValued/t/simple-setting.t | 46 --- Data-MultiValued/t/tags-ranges-setting.t | 85 ----- Data-MultiValued/t/tags-setting.t | 76 ----- attr.pl | 363 --------------------- dist.ini | 59 ++++ 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 ++ t/json.t | 65 ++++ t/moose-ranges.t | 67 ++++ t/moose-tagged.t | 67 ++++ t/more-overlapping-ranges.t | 79 +++++ t/overlapping-ranges.t | 64 ++++ t/ranges-setting.t | 93 ++++++ t/simple-setting.t | 46 +++ t/tags-ranges-setting.t | 85 +++++ t/tags-setting.t | 76 +++++ 51 files changed, 1728 insertions(+), 2094 deletions(-) create mode 100644 Changes delete mode 100644 Data-MultiValued/.gitignore delete mode 100644 Data-MultiValued/Changes delete mode 100644 Data-MultiValued/dist.ini delete mode 100644 Data-MultiValued/lib/Data/MultiValued/AttributeAccessors.pm delete mode 100644 Data-MultiValued/lib/Data/MultiValued/AttributeTrait.pm delete mode 100644 Data-MultiValued/lib/Data/MultiValued/AttributeTrait/Ranges.pm delete mode 100644 Data-MultiValued/lib/Data/MultiValued/AttributeTrait/Tags.pm delete mode 100644 Data-MultiValued/lib/Data/MultiValued/AttributeTrait/TagsAndRanges.pm delete mode 100644 Data-MultiValued/lib/Data/MultiValued/Exceptions.pm delete mode 100644 Data-MultiValued/lib/Data/MultiValued/RangeContainer.pm delete mode 100644 Data-MultiValued/lib/Data/MultiValued/Ranges.pm delete mode 100644 Data-MultiValued/lib/Data/MultiValued/TagContainer.pm delete mode 100644 Data-MultiValued/lib/Data/MultiValued/TagContainerForRanges.pm delete mode 100644 Data-MultiValued/lib/Data/MultiValued/Tags.pm delete mode 100644 Data-MultiValued/lib/Data/MultiValued/TagsAndRanges.pm delete mode 100644 Data-MultiValued/lib/Data/MultiValued/UglySerializationHelperRole.pm delete mode 100644 Data-MultiValued/t/json.t delete mode 100644 Data-MultiValued/t/moose-ranges.t delete mode 100644 Data-MultiValued/t/moose-tagged.t delete mode 100644 Data-MultiValued/t/more-overlapping-ranges.t delete mode 100644 Data-MultiValued/t/overlapping-ranges.t delete mode 100644 Data-MultiValued/t/ranges-setting.t delete mode 100644 Data-MultiValued/t/simple-setting.t delete mode 100644 Data-MultiValued/t/tags-ranges-setting.t delete mode 100644 Data-MultiValued/t/tags-setting.t delete mode 100644 attr.pl create mode 100644 dist.ini 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 create mode 100644 t/json.t create mode 100644 t/moose-ranges.t create mode 100644 t/moose-tagged.t create mode 100644 t/more-overlapping-ranges.t create mode 100644 t/overlapping-ranges.t create mode 100644 t/ranges-setting.t create mode 100644 t/simple-setting.t create mode 100644 t/tags-ranges-setting.t create mode 100644 t/tags-setting.t diff --git a/.gitignore b/.gitignore index 68f70d8..a916a46 100644 --- a/.gitignore +++ b/.gitignore @@ -1,3 +1,13 @@ +blib +pm_to_blib *.sw? +Makefile +Makefile.old +MANIFEST.bak *.tar.gz +/inc/ +META.yml +.prove *~ +/.build/ +/Data-/ diff --git a/Changes b/Changes new file mode 100644 index 0000000..3d14c89 --- /dev/null +++ b/Changes @@ -0,0 +1,4 @@ +Revision history for Data::MultiValued + +{{$NEXT}} + - first working version diff --git a/Data-MultiValued/.gitignore b/Data-MultiValued/.gitignore deleted file mode 100644 index a916a46..0000000 --- a/Data-MultiValued/.gitignore +++ /dev/null @@ -1,13 +0,0 @@ -blib -pm_to_blib -*.sw? -Makefile -Makefile.old -MANIFEST.bak -*.tar.gz -/inc/ -META.yml -.prove -*~ -/.build/ -/Data-/ diff --git a/Data-MultiValued/Changes b/Data-MultiValued/Changes deleted file mode 100644 index 3d14c89..0000000 --- a/Data-MultiValued/Changes +++ /dev/null @@ -1,4 +0,0 @@ -Revision history for Data::MultiValued - -{{$NEXT}} - - first working version diff --git a/Data-MultiValued/dist.ini b/Data-MultiValued/dist.ini deleted file mode 100644 index af05b71..0000000 --- a/Data-MultiValued/dist.ini +++ /dev/null @@ -1,59 +0,0 @@ -name = Data-MultiValued -author = Gianni Ceccarelli -license = Perl_5 -copyright_holder = Net-a-porter.com -copyright_year = 2011 - -version = 0.001 - -abstract = Handle values with tags and validity ranges - -[GatherDir] - -[PodWeaver] - -[PruneCruft] - -[PruneFiles] -match = ~$ - -[CheckChangeLog] - -[NextRelease] - -[AutoPrereqs] - -[PkgDist] - -[PkgVersion] - -[ManifestSkip] - -[NoTabsTests] - -[PodCoverageTests] - -[PodSyntaxTests] - -[ExtraTests] - -[MetaNoIndex] - -directory = t/lib - -[MetaYAML] - -[MetaJSON] - -[ExecDir] - -[ShareDir] - -[MakeMaker] - -[Manifest] - -[TestRelease] - -;[ConfirmRelease] -;[UploadToCPAN] diff --git a/Data-MultiValued/lib/Data/MultiValued/AttributeAccessors.pm b/Data-MultiValued/lib/Data/MultiValued/AttributeAccessors.pm deleted file mode 100644 index cac3538..0000000 --- a/Data-MultiValued/lib/Data/MultiValued/AttributeAccessors.pm +++ /dev/null @@ -1,109 +0,0 @@ -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/Data-MultiValued/lib/Data/MultiValued/AttributeTrait.pm b/Data-MultiValued/lib/Data/MultiValued/AttributeTrait.pm deleted file mode 100644 index 91e1b13..0000000 --- a/Data-MultiValued/lib/Data/MultiValued/AttributeTrait.pm +++ /dev/null @@ -1,229 +0,0 @@ -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/Data-MultiValued/lib/Data/MultiValued/AttributeTrait/Ranges.pm b/Data-MultiValued/lib/Data/MultiValued/AttributeTrait/Ranges.pm deleted file mode 100644 index 8d93578..0000000 --- a/Data-MultiValued/lib/Data/MultiValued/AttributeTrait/Ranges.pm +++ /dev/null @@ -1,14 +0,0 @@ -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/Data-MultiValued/lib/Data/MultiValued/AttributeTrait/Tags.pm b/Data-MultiValued/lib/Data/MultiValued/AttributeTrait/Tags.pm deleted file mode 100644 index 7cffb33..0000000 --- a/Data-MultiValued/lib/Data/MultiValued/AttributeTrait/Tags.pm +++ /dev/null @@ -1,14 +0,0 @@ -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/Data-MultiValued/lib/Data/MultiValued/AttributeTrait/TagsAndRanges.pm b/Data-MultiValued/lib/Data/MultiValued/AttributeTrait/TagsAndRanges.pm deleted file mode 100644 index e0c56cd..0000000 --- a/Data-MultiValued/lib/Data/MultiValued/AttributeTrait/TagsAndRanges.pm +++ /dev/null @@ -1,14 +0,0 @@ -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/Data-MultiValued/lib/Data/MultiValued/Exceptions.pm b/Data-MultiValued/lib/Data/MultiValued/Exceptions.pm deleted file mode 100644 index 8d444c0..0000000 --- a/Data-MultiValued/lib/Data/MultiValued/Exceptions.pm +++ /dev/null @@ -1,57 +0,0 @@ -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/Data-MultiValued/lib/Data/MultiValued/RangeContainer.pm b/Data-MultiValued/lib/Data/MultiValued/RangeContainer.pm deleted file mode 100644 index 474626f..0000000 --- a/Data-MultiValued/lib/Data/MultiValued/RangeContainer.pm +++ /dev/null @@ -1,192 +0,0 @@ -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/Data-MultiValued/lib/Data/MultiValued/Ranges.pm b/Data-MultiValued/lib/Data/MultiValued/Ranges.pm deleted file mode 100644 index 9c69626..0000000 --- a/Data-MultiValued/lib/Data/MultiValued/Ranges.pm +++ /dev/null @@ -1,68 +0,0 @@ -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/Data-MultiValued/lib/Data/MultiValued/TagContainer.pm b/Data-MultiValued/lib/Data/MultiValued/TagContainer.pm deleted file mode 100644 index cdd0456..0000000 --- a/Data-MultiValued/lib/Data/MultiValued/TagContainer.pm +++ /dev/null @@ -1,99 +0,0 @@ -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/Data-MultiValued/lib/Data/MultiValued/TagContainerForRanges.pm b/Data-MultiValued/lib/Data/MultiValued/TagContainerForRanges.pm deleted file mode 100644 index d3cd4b9..0000000 --- a/Data-MultiValued/lib/Data/MultiValued/TagContainerForRanges.pm +++ /dev/null @@ -1,38 +0,0 @@ -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/Data-MultiValued/lib/Data/MultiValued/Tags.pm b/Data-MultiValued/lib/Data/MultiValued/Tags.pm deleted file mode 100644 index fbf7948..0000000 --- a/Data-MultiValued/lib/Data/MultiValued/Tags.pm +++ /dev/null @@ -1,65 +0,0 @@ -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/Data-MultiValued/lib/Data/MultiValued/TagsAndRanges.pm b/Data-MultiValued/lib/Data/MultiValued/TagsAndRanges.pm deleted file mode 100644 index 6208435..0000000 --- a/Data-MultiValued/lib/Data/MultiValued/TagsAndRanges.pm +++ /dev/null @@ -1,79 +0,0 @@ -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/Data-MultiValued/lib/Data/MultiValued/UglySerializationHelperRole.pm b/Data-MultiValued/lib/Data/MultiValued/UglySerializationHelperRole.pm deleted file mode 100644 index e586dec..0000000 --- a/Data-MultiValued/lib/Data/MultiValued/UglySerializationHelperRole.pm +++ /dev/null @@ -1,35 +0,0 @@ -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; diff --git a/Data-MultiValued/t/json.t b/Data-MultiValued/t/json.t deleted file mode 100644 index 5e00080..0000000 --- a/Data-MultiValued/t/json.t +++ /dev/null @@ -1,65 +0,0 @@ -#!perl -use strict; -use warnings; -package Foo;{ -use Moose; -use Data::MultiValued::AttributeTrait::Tags; -use Data::MultiValued::AttributeTrait::Ranges; -use Data::MultiValued::AttributeTrait::TagsAndRanges; - -with 'Data::MultiValued::UglySerializationHelperRole'; - -has tt => ( - is => 'rw', - isa => 'Int', - traits => ['MultiValued::Tags'], - default => 3, - predicate => 'has_tt', - clearer => 'clear_tt', -); - -has rr => ( - is => 'rw', - isa => 'Str', - traits => ['MultiValued::Ranges'], - predicate => 'has_rr', - clearer => 'clear_rr', -); - -has ttrr => ( - is => 'rw', - isa => 'Str', - default => 'default', - traits => ['MultiValued::TagsAndRanges'], - predicate => 'has_ttrr', - clearer => 'clear_ttrr', -); - - -} -package main; -use Test::Most 'die'; -use Data::Printer; -use JSON::XS; - -my $opts={tag=>'something'}; - -my $json = JSON::XS->new->utf8; -my $obj = Foo->new(rr=>'foo'); -$obj->tt_multi($opts,1234); -my $hash = $obj->as_hash; -note p $hash; -my $str = $json->encode($hash); -note p $str; - -note "rebuilding"; -my $obj2 = Foo->new_in_place($json->decode($str)); - -note p $obj; -note p $obj2; - -is($obj2->tt,$obj->tt,'tt'); -is($obj2->tt_multi($opts),$obj->tt_multi($opts),'tt tagged'); -is($obj2->rr,$obj->rr,'rr'); - -done_testing; diff --git a/Data-MultiValued/t/moose-ranges.t b/Data-MultiValued/t/moose-ranges.t deleted file mode 100644 index 404e649..0000000 --- a/Data-MultiValued/t/moose-ranges.t +++ /dev/null @@ -1,67 +0,0 @@ -#!perl -use strict; -use warnings; - -package Foo;{ -use Moose; -use Data::MultiValued::AttributeTrait::Ranges; - -has stuff => ( - is => 'rw', - isa => 'Int', - traits => ['MultiValued::Ranges'], - default => 3, - predicate => 'has_stuff', - clearer => 'clear_stuff', -); - -has other => ( - is => 'rw', - isa => 'Str', - traits => ['MultiValued::Ranges'], - 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 ranges' => sub { - my $obj = Foo->new(); - - my $opts = {from=>10,to=>20,at=>15}; - - ok($obj->has_stuff,'has stuff'); - ok($obj->has_stuff_multi($opts),'has stuff ranged (forever)'); - ok(!$obj->has_other,'not has other'); - ok(!$obj->has_other_multi($opts),'not has other ranged'); - - $obj->stuff_multi($opts,7); - $obj->other_multi($opts,'foo'); - - is($obj->stuff,3,'default'); - is($obj->stuff_multi($opts),7,'stuff ranged'); - is($obj->other_multi($opts),'foo','other ranged'); -}; - -done_testing(); diff --git a/Data-MultiValued/t/moose-tagged.t b/Data-MultiValued/t/moose-tagged.t deleted file mode 100644 index 6e1ac7a..0000000 --- a/Data-MultiValued/t/moose-tagged.t +++ /dev/null @@ -1,67 +0,0 @@ -#!perl -use strict; -use warnings; - -package Foo;{ -use Moose; -use Data::MultiValued::AttributeTrait::Tags; - -has stuff => ( - is => 'rw', - isa => 'Int', - traits => ['MultiValued::Tags'], - default => 3, - predicate => 'has_stuff', - clearer => 'clear_stuff', -); - -has other => ( - is => 'rw', - isa => 'Str', - traits => ['MultiValued::Tags'], - 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_multi($opts),'not has stuff tagged'); - ok(!$obj->has_other,'not has other'); - ok(!$obj->has_other_multi($opts),'not has other tagged'); - - $obj->stuff_multi($opts,7); - $obj->other_multi($opts,'foo'); - - is($obj->stuff,3,'default'); - is($obj->stuff_multi($opts),7,'stuff tagged'); - is($obj->other_multi($opts),'foo','other tagged'); -}; - -done_testing(); diff --git a/Data-MultiValued/t/more-overlapping-ranges.t b/Data-MultiValued/t/more-overlapping-ranges.t deleted file mode 100644 index 19e2fe5..0000000 --- a/Data-MultiValued/t/more-overlapping-ranges.t +++ /dev/null @@ -1,79 +0,0 @@ -#!perl -use strict; -use warnings; -use Test::Most 'die'; -use Data::Printer; -use Data::MultiValued::Ranges; -use Data::MultiValued::TagsAndRanges; - -sub test_it { - my ($obj) = @_; - - $obj->set({ - from=>10, - to=>20, - value=>1, - }); - $obj->set({ - from=>30, - to => 50, - value => 2, - }); - $obj->set({ - from=>15, - to => 35, - value => 3, - }); - $obj->set({ - from => undef, - to => 12, - value => 4, - }); - $obj->set({ - from => 40, - to => undef, - value => 5, - }); - - my %points = ( - 1,4, - 9,4, - 10,4, - 11,4, - 12,1, - 13,1, - 14,1, - 15,3, - 19,3, - 20,3, - 30,3, - 34,3, - 35,2, - 39,2, - 40,5, - 50,5, - 200,5, - ); - while (my ($at,$v) = each %points) { - cmp_ok($obj->get({at=>$at}), - '==', - $v, - "value at $at"); - } -} - -subtest 'ranges' => sub { - my $obj = Data::MultiValued::Ranges->new(); - ok($obj,'constructor works'); - - test_it($obj); -}; - -subtest 'tags and ranges' => sub { - my $obj = Data::MultiValued::TagsAndRanges->new(); - ok($obj,'constructor works'); - - test_it($obj); -}; - -done_testing(); diff --git a/Data-MultiValued/t/overlapping-ranges.t b/Data-MultiValued/t/overlapping-ranges.t deleted file mode 100644 index 01bb98d..0000000 --- a/Data-MultiValued/t/overlapping-ranges.t +++ /dev/null @@ -1,64 +0,0 @@ -#!perl -use strict; -use warnings; -use Test::Most 'die'; -use Data::Printer; -use Data::MultiValued::Ranges; -use Data::MultiValued::TagsAndRanges; - -sub test_it { - my ($obj) = @_; - $obj->set({ - from=>10, - to=>20, - value=>1, - }); - $obj->set({ - from=>15, - to => 30, - value => 2, - }); - - my %points = ( - 10,1, - 12,1, - 13,1, - 14,1, - 15,2, - 17,2, - 19,2, - 20,2, - 25,2, - 29,2, - ); - while (my ($at,$v) = each %points) { - cmp_ok($obj->get({at=>$at}), - '==', - $v, - "value at $at"); - } - - dies_ok { - $obj->get({at=>30}) - } 'far end'; - dies_ok { - $obj->get({at=>9}) - } 'far end'; -} - - -subtest 'ranges' => sub { - my $obj = Data::MultiValued::Ranges->new(); - ok($obj,'constructor works'); - - test_it($obj); -}; - -subtest 'tags and ranges' => sub { - my $obj = Data::MultiValued::TagsAndRanges->new(); - ok($obj,'constructor works'); - - test_it($obj); -}; - -done_testing(); diff --git a/Data-MultiValued/t/ranges-setting.t b/Data-MultiValued/t/ranges-setting.t deleted file mode 100644 index b8d2a57..0000000 --- a/Data-MultiValued/t/ranges-setting.t +++ /dev/null @@ -1,93 +0,0 @@ -#!perl -use strict; -use warnings; -use Test::Most 'die'; -use Data::Printer; -use Data::MultiValued::Ranges; -use Data::MultiValued::TagsAndRanges; - -sub test_it { - my ($obj) = @_; - - lives_ok { - $obj->set({ - from => 10, - to => 20, - value => [1,2,3], - }); - } 'setting 10-20'; - lives_ok { - $obj->set({ - from => 30, - to => 50, - value => [4,5,6], - }); - } 'setting 30-50'; - - cmp_deeply($obj->get({at => 15}), - [1,2,3], - 'getting 15'); - cmp_deeply($obj->get({at => 10}), - [1,2,3], - 'getting 10'); - cmp_deeply($obj->get({at => 19.999}), - [1,2,3], - 'getting 19.999'); - dies_ok { - $obj->get({at => 20}) - } 'getting 20 dies'; - - cmp_deeply($obj->get({at => 40}), - [4,5,6], - 'getting 40'); - cmp_deeply($obj->get({at => 30}), - [4,5,6], - 'getting 30'); - cmp_deeply($obj->get({at => 49.999}), - [4,5,6], - 'getting 49.999'); - dies_ok { - $obj->get({at => 50}) - } 'getting 50 dies'; - - dies_ok { - $obj->get({at => 0}) - } 'getting 0 dies'; - - dies_ok { - $obj->get({}); - } 'default get dies'; - - $obj->clear({from=>10,to=>20}); - - dies_ok { - $obj->get({at => 15}) - } 'getting 15 after clearing dies'; - - cmp_deeply($obj->get({at => 30}), - [4,5,6], - 'getting 30 after clearing'); - - $obj->clear(); - - dies_ok { - $obj->get({at => 30}) - } 'getting 30 after clearing all dies'; - -} - -subtest 'ranges' => sub { - my $obj = Data::MultiValued::Ranges->new(); - ok($obj,'constructor works'); - - test_it($obj); -}; - -subtest 'tags and ranges' => sub { - my $obj = Data::MultiValued::TagsAndRanges->new(); - ok($obj,'constructor works'); - - test_it($obj); -}; - -done_testing(); diff --git a/Data-MultiValued/t/simple-setting.t b/Data-MultiValued/t/simple-setting.t deleted file mode 100644 index 9d9a9e2..0000000 --- a/Data-MultiValued/t/simple-setting.t +++ /dev/null @@ -1,46 +0,0 @@ -#!perl -use strict; -use warnings; -use Test::Most 'die'; -use Data::Printer; -use Data::MultiValued::Ranges; -use Data::MultiValued::Tags; -use Data::MultiValued::TagsAndRanges; - -sub test_it { - my ($obj) = @_; - - lives_ok { - $obj->set({ - value => 1234, - }); - } 'setting'; - - cmp_ok($obj->get({}),'==',1234, - 'getting'); - - lives_ok { $obj->clear } 'clearing the object'; -} - -subtest 'ranges' => sub { - my $obj = Data::MultiValued::Ranges->new(); - ok($obj,'constructor works'); - - test_it($obj); -}; - -subtest 'tags' => sub { - my $obj = Data::MultiValued::Tags->new(); - ok($obj,'constructor works'); - - test_it($obj); -}; - -subtest 'tags and ranges' => sub { - my $obj = Data::MultiValued::TagsAndRanges->new(); - ok($obj,'constructor works'); - - test_it($obj); -}; - -done_testing(); diff --git a/Data-MultiValued/t/tags-ranges-setting.t b/Data-MultiValued/t/tags-ranges-setting.t deleted file mode 100644 index e25a9f1..0000000 --- a/Data-MultiValued/t/tags-ranges-setting.t +++ /dev/null @@ -1,85 +0,0 @@ -#!perl -use strict; -use warnings; -use Test::Most 'die'; -use Data::Printer; -use Data::MultiValued::TagsAndRanges; - -my $obj = Data::MultiValued::TagsAndRanges->new(); -ok($obj,'constructor works'); - -my @tags = (undef,'tag1','tag2'); -my @ranges = ([10,20,2],[30,50,2]); - -sub _t { $_[0] ? ( tag => $_[0] ) : () } - -for my $tag (@tags) { - for my $range (@ranges) { - $obj->set({ - _t($tag), - from => $range->[0], - to => $range->[1], - value => $range->[2], - }); - } -} - -for my $tag (@tags) { - for my $range (@ranges) { - cmp_ok( - $obj->get({ - _t($tag), - at => ($range->[0]+$range->[1])/2, - }), - '==', - $range->[2], - "tag @{[ $tag // 'default' ]}, range @$range[0,1]", - ); - } -} - -for my $range (@ranges) { - dies_ok { - $obj->get({ - tag => 'not there', - from => $range->[0], - to => $range->[1], - }) - } "no such tag, range @$range[0,1]"; -} - -for my $tag (@tags) { - for my $range (@ranges) { - dies_ok { - $obj->get({ - _t($tag), - at => $range->[0]-1, - }) - } "tag @{[ $tag // 'default' ]}, out-of-range (left)"; - dies_ok { - $obj->get({ - _t($tag), - at => $range->[1], - }) - } "tag @{[ $tag // 'default' ]}, out-of-range (right)"; - } -} - -$obj->clear({tag=>$tags[1],from=>$ranges[0]->[0],to=>$ranges[0]->[1]}); -dies_ok { - $obj->get({ - tag=>$tags[1], - at => $ranges[0]->[0]+1, - }) -} 'getting deleted range from inside tag dies'; - -cmp_ok( - $obj->get({ - tag => $tags[1], - at => $ranges[1]->[0]+1, - }), - '==', - $ranges[1]->[2], - 'other ranges in same tag are still there'); - -done_testing(); diff --git a/Data-MultiValued/t/tags-setting.t b/Data-MultiValued/t/tags-setting.t deleted file mode 100644 index 929ad3d..0000000 --- a/Data-MultiValued/t/tags-setting.t +++ /dev/null @@ -1,76 +0,0 @@ -#!perl -use strict; -use warnings; -use Test::Most 'die'; -use Data::Printer; -use Data::MultiValued::Tags; -use Data::MultiValued::TagsAndRanges; - -sub test_it { - my ($obj) = @_; - - lives_ok { - $obj->set({ - tag => 'tag1', - value => 'a string', - }); - } 'setting tag1'; - lives_ok { - $obj->set({ - tag => 'tag2', - value => 'another string', - }); - } 'setting tag2'; - - cmp_ok($obj->get({tag => 'tag1'}), - 'eq', - 'a string', - 'getting tag1'); - - cmp_ok($obj->get({tag => 'tag2'}), - 'eq', - 'another string', - 'getting tag2'); - - dies_ok { - $obj->get({tag=>'no such tag'}); - } 'getting non-existent tag'; - - dies_ok { - $obj->get({}); - } 'default get dies'; - - $obj->clear({tag=>'tag1'}); - - dies_ok { - $obj->get({tag=>'tag1'}); - } 'getting cleared tag'; - - cmp_ok($obj->get({tag => 'tag2'}), - 'eq', - 'another string', - 'getting tag2 after clearing'); - - $obj->clear(); - - dies_ok { - $obj->get({tag=>'tag2'}); - } 'getting tag2 after clearing all dies'; - -} - -subtest 'tags' => sub { - my $obj = Data::MultiValued::Tags->new(); - ok($obj,'constructor works'); - - test_it($obj); -}; - -subtest 'tags and ranges' => sub { - my $obj = Data::MultiValued::TagsAndRanges->new(); - ok($obj,'constructor works'); - - test_it($obj); -}; - -done_testing(); diff --git a/attr.pl b/attr.pl deleted file mode 100644 index de90bd8..0000000 --- a/attr.pl +++ /dev/null @@ -1,363 +0,0 @@ -#!/usr/bin/perl - -=head1 SYNOPSIS - - package My::Class; - use Moose; - - has stuff => ( - is => 'rw', - isa => 'Int', - traits => ['Timed'], - predicate => 'has_stuff', - clearer => 'clear_stuff', - ); - -Later: - - my $obj = My::Class->new(); - - $obj->stuff(3); # sets value for every interval - $obj->stuff_timed({},3); # sets value the "default" interval - $obj->stuff_timed({from=>$timestamp,to=>$timestamp2},3); # sets value for the given time interval - - print $obj->stuff(); # value for time(); - print $obj->stuff_timed(); # as above - print $obj->stuff_timed({when=>$timestamp}); # as above, for given time - - print $obj->has_stuff(); # true if we have a value for time() - print $obj->has_stuff_timed(); # as above - print $obj->has_stuff_timed({when=>$timestamp}); # as above, for given time - - $obj->clear_stuff(); # deletes everything - $obj->clear_stuff_timed({}); # deletes the "default" interval - $obj->clear_stuff_timed({from=>$timestamp,to=>$timestamp2}); # deletes the given time interval - -=cut - -use strict; -use warnings all=>'FATAL'; - -package My::Attribute;{ -use Moose::Role; -use MooseX::Types::Moose qw(ArrayRef Int Any); -use MooseX::Types::Structured qw(Dict); -use Moose::Util::TypeConstraints (); -use namespace::autoclean; - -before _process_options => sub { - my ($self, $name, $options) = @_; - - my $value_type; - $value_type //= $options->{isa} ? - Moose::Util::TypeConstraints::find_or_create_isa_type_constraint($options->{isa}) - : undef; - $value_type //= $options->{does} ? - Moose::Util::TypeConstraints::find_or_create_does_type_constraint($options->{does}) - : undef; - - $value_type //= Any; - - $options->{isa} = ArrayRef[Dict[ - from => Int, - to => Int, - value => $value_type, - ]]; -}; - -sub accessor_metaclass { 'My::Accessor' } - -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 = "timed_$meth"; - my $basename = $self->$meth; - my $name = "${basename}_timed"; - - $class->add_method( - $self->_process_accessors($type => $name,0) - ); - } -}; - -use Data::Printer; - -sub _find_interval_for { - my ($self,$all_values,$when) = @_; - - my $default; - - for my $interval (@$all_values) { - if ($interval->{from}==0 and $interval->{to}==0) { - $default = $interval; - next; - } - next if $interval->{from} > $when; - next if $interval->{to} <= $when; - return $interval; - } - return $default; -} - -sub get_timed_value { - my ($self,$instance,$opts,$for_trigger) = @_; - - print join ', ',caller; - printf " get_timed_value(%s)\n",p($opts); - - my $when = $opts->{when} // $opts->{from} // time(); - - my $all_values = $self->get_value($instance,$for_trigger); - - return unless $all_values && @$all_values; - - my $interval = $self->_find_interval_for($all_values,$when); - - return unless defined $interval; - - return $interval->{value}; -} - -sub set_timed_value { - my ($self,$instance,$opts,$value) = @_; - - print join ', ',caller; - printf " set_timed_value(%s,%s)\n",p($opts),p($value); - - if ($opts->{forever}) { - $self->set_value($instance,[ - { - from => 0, - to => 0, - value => $value, - }, - ]); - } - else { - my $interval = { - from => $opts->{from}//0, - to => $opts->{to}//0, - value => $value, - }; - - # XXX this has to take into account interval intersections &c - my $all_values = $self->get_value($instance); - push @$all_values,$interval; - $self->set_value($instance,$all_values); - } -} - -sub has_timed_value { - my ($self,$instance,$opts) = @_; - - print join ', ',caller; - printf " has_timed_value(%s)\n",p($opts); - - return unless $self->has_value($instance); - - my $when = $opts->{when} // time(); - - my $all_values = $self->get_value($instance); - - return unless $all_values && @$all_values; - - return defined $self->_find_interval_for($all_values,$when); -} - -sub clear_timed_value { - my ($self,$instance,$opts) = @_; - - print join ', ',caller; - printf " clear_timed_value(%s)\n",p($opts); - - if ($opts->{forever}) { - $self->clear_value($instance); - } - # should do intersections &c - die "unimplemented"; -} -}; - -package Moose::Meta::Attribute::Custom::Trait::Timed;{ -sub register_implementation { 'My::Attribute' } -} - -package My::Accessor;{ -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_timed_value($_[0], {forever=>1}, $_[1]); - } - $attr->get_timed_value($_[0], {when=>time()}); - } -} - -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_timed_value($_[0], {when=>time()}); - }; -} - -sub _generate_writer_method { - my $self = shift; - my $attr = $self->associated_attribute; - - return sub { - $attr->set_timed_value($_[0], {forever=>1}, $_[1]); - }; -} - -sub _generate_predicate_method { - my $self = shift; - my $attr = $self->associated_attribute; - - return sub { - $attr->has_timed_value($_[0], {when=>time()}) - }; -} - -sub _generate_clearer_method { - my $self = shift; - my $attr = $self->associated_attribute; - - return sub { - $attr->clear_timed_value($_[0], {forever=>1}) - }; -} - -sub _generate_timed_accessor_method { - my $self = shift; - my $attr = $self->associated_attribute; - - return sub { - if (@_ >= 3) { - $attr->set_timed_value($_[0], $_[1], $_[2]); - } - $attr->get_timed_value($_[0],$_[1]); - } -} - -sub _generate_timed_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_timed_value($_[0],$_[1]); - }; -} - -sub _generate_timed_writer_method { - my $self = shift; - my $attr = $self->associated_attribute; - - return sub { - $attr->set_timed_value($_[0], $_[1], $_[2]); - }; -} - -sub _generate_timed_predicate_method { - my $self = shift; - my $attr = $self->associated_attribute; - - return sub { - $attr->has_timed_value($_[0],$_[1]) - }; -} - -sub _generate_timed_clearer_method { - my $self = shift; - my $attr = $self->associated_attribute; - - return sub { - $attr->clear_timed_value($_[0],$_[1]) - }; -} -}; - -package Foo;{ -use Moose; -use MooseX::Types::Moose qw(Int); - -has stuff => ( - is => 'rw', - isa => Int, - traits => ['Timed'], - predicate => 'has_stuff', - clearer => 'has_stuff', -); -} - -package main;{ -use Data::Printer; -use 5.012; - -my $obj = Foo->new(); - -p $obj; - -say $obj->stuff(2); - -eval { say $obj->stuff('wrong') } or say $@; - -say $obj->stuff_timed({from=>10,to=>20},5); -say $obj->stuff_timed({},3); - -p $obj; - -say $obj->stuff(); -say $obj->stuff_timed({}); -say $obj->stuff_timed({when=>12}); - -} - -=pod - -=head1 NOTES - -we could override C, C and -C<$meta_instance->set_slot_value> (or C) on the -L<::Meta::Attribute>. - -that would take care of type constraints, while leaving us free to use -an arbitrary internal representation. - -no inlining, it's too awkward - -=head2 internal representation - -not easy… we need something like L, but slightly less -insane, with added tagging (we can't sensibly decouple intervals from -tags/envs, the representations would clash) - -suggestion: per each tag: - -arrayref, position 0 = default (-inf,inf) - -other elements set in asc order of start - -binary search (on start, with additional check on end) to find the -right place to read from - -split / remove elements when setting / clearing - diff --git a/dist.ini b/dist.ini new file mode 100644 index 0000000..af05b71 --- /dev/null +++ b/dist.ini @@ -0,0 +1,59 @@ +name = Data-MultiValued +author = Gianni Ceccarelli +license = Perl_5 +copyright_holder = Net-a-porter.com +copyright_year = 2011 + +version = 0.001 + +abstract = Handle values with tags and validity ranges + +[GatherDir] + +[PodWeaver] + +[PruneCruft] + +[PruneFiles] +match = ~$ + +[CheckChangeLog] + +[NextRelease] + +[AutoPrereqs] + +[PkgDist] + +[PkgVersion] + +[ManifestSkip] + +[NoTabsTests] + +[PodCoverageTests] + +[PodSyntaxTests] + +[ExtraTests] + +[MetaNoIndex] + +directory = t/lib + +[MetaYAML] + +[MetaJSON] + +[ExecDir] + +[ShareDir] + +[MakeMaker] + +[Manifest] + +[TestRelease] + +;[ConfirmRelease] +;[UploadToCPAN] 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; diff --git a/t/json.t b/t/json.t new file mode 100644 index 0000000..5e00080 --- /dev/null +++ b/t/json.t @@ -0,0 +1,65 @@ +#!perl +use strict; +use warnings; +package Foo;{ +use Moose; +use Data::MultiValued::AttributeTrait::Tags; +use Data::MultiValued::AttributeTrait::Ranges; +use Data::MultiValued::AttributeTrait::TagsAndRanges; + +with 'Data::MultiValued::UglySerializationHelperRole'; + +has tt => ( + is => 'rw', + isa => 'Int', + traits => ['MultiValued::Tags'], + default => 3, + predicate => 'has_tt', + clearer => 'clear_tt', +); + +has rr => ( + is => 'rw', + isa => 'Str', + traits => ['MultiValued::Ranges'], + predicate => 'has_rr', + clearer => 'clear_rr', +); + +has ttrr => ( + is => 'rw', + isa => 'Str', + default => 'default', + traits => ['MultiValued::TagsAndRanges'], + predicate => 'has_ttrr', + clearer => 'clear_ttrr', +); + + +} +package main; +use Test::Most 'die'; +use Data::Printer; +use JSON::XS; + +my $opts={tag=>'something'}; + +my $json = JSON::XS->new->utf8; +my $obj = Foo->new(rr=>'foo'); +$obj->tt_multi($opts,1234); +my $hash = $obj->as_hash; +note p $hash; +my $str = $json->encode($hash); +note p $str; + +note "rebuilding"; +my $obj2 = Foo->new_in_place($json->decode($str)); + +note p $obj; +note p $obj2; + +is($obj2->tt,$obj->tt,'tt'); +is($obj2->tt_multi($opts),$obj->tt_multi($opts),'tt tagged'); +is($obj2->rr,$obj->rr,'rr'); + +done_testing; diff --git a/t/moose-ranges.t b/t/moose-ranges.t new file mode 100644 index 0000000..404e649 --- /dev/null +++ b/t/moose-ranges.t @@ -0,0 +1,67 @@ +#!perl +use strict; +use warnings; + +package Foo;{ +use Moose; +use Data::MultiValued::AttributeTrait::Ranges; + +has stuff => ( + is => 'rw', + isa => 'Int', + traits => ['MultiValued::Ranges'], + default => 3, + predicate => 'has_stuff', + clearer => 'clear_stuff', +); + +has other => ( + is => 'rw', + isa => 'Str', + traits => ['MultiValued::Ranges'], + 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 ranges' => sub { + my $obj = Foo->new(); + + my $opts = {from=>10,to=>20,at=>15}; + + ok($obj->has_stuff,'has stuff'); + ok($obj->has_stuff_multi($opts),'has stuff ranged (forever)'); + ok(!$obj->has_other,'not has other'); + ok(!$obj->has_other_multi($opts),'not has other ranged'); + + $obj->stuff_multi($opts,7); + $obj->other_multi($opts,'foo'); + + is($obj->stuff,3,'default'); + is($obj->stuff_multi($opts),7,'stuff ranged'); + is($obj->other_multi($opts),'foo','other ranged'); +}; + +done_testing(); diff --git a/t/moose-tagged.t b/t/moose-tagged.t new file mode 100644 index 0000000..6e1ac7a --- /dev/null +++ b/t/moose-tagged.t @@ -0,0 +1,67 @@ +#!perl +use strict; +use warnings; + +package Foo;{ +use Moose; +use Data::MultiValued::AttributeTrait::Tags; + +has stuff => ( + is => 'rw', + isa => 'Int', + traits => ['MultiValued::Tags'], + default => 3, + predicate => 'has_stuff', + clearer => 'clear_stuff', +); + +has other => ( + is => 'rw', + isa => 'Str', + traits => ['MultiValued::Tags'], + 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_multi($opts),'not has stuff tagged'); + ok(!$obj->has_other,'not has other'); + ok(!$obj->has_other_multi($opts),'not has other tagged'); + + $obj->stuff_multi($opts,7); + $obj->other_multi($opts,'foo'); + + is($obj->stuff,3,'default'); + is($obj->stuff_multi($opts),7,'stuff tagged'); + is($obj->other_multi($opts),'foo','other tagged'); +}; + +done_testing(); diff --git a/t/more-overlapping-ranges.t b/t/more-overlapping-ranges.t new file mode 100644 index 0000000..19e2fe5 --- /dev/null +++ b/t/more-overlapping-ranges.t @@ -0,0 +1,79 @@ +#!perl +use strict; +use warnings; +use Test::Most 'die'; +use Data::Printer; +use Data::MultiValued::Ranges; +use Data::MultiValued::TagsAndRanges; + +sub test_it { + my ($obj) = @_; + + $obj->set({ + from=>10, + to=>20, + value=>1, + }); + $obj->set({ + from=>30, + to => 50, + value => 2, + }); + $obj->set({ + from=>15, + to => 35, + value => 3, + }); + $obj->set({ + from => undef, + to => 12, + value => 4, + }); + $obj->set({ + from => 40, + to => undef, + value => 5, + }); + + my %points = ( + 1,4, + 9,4, + 10,4, + 11,4, + 12,1, + 13,1, + 14,1, + 15,3, + 19,3, + 20,3, + 30,3, + 34,3, + 35,2, + 39,2, + 40,5, + 50,5, + 200,5, + ); + while (my ($at,$v) = each %points) { + cmp_ok($obj->get({at=>$at}), + '==', + $v, + "value at $at"); + } +} + +subtest 'ranges' => sub { + my $obj = Data::MultiValued::Ranges->new(); + ok($obj,'constructor works'); + + test_it($obj); +}; + +subtest 'tags and ranges' => sub { + my $obj = Data::MultiValued::TagsAndRanges->new(); + ok($obj,'constructor works'); + + test_it($obj); +}; + +done_testing(); diff --git a/t/overlapping-ranges.t b/t/overlapping-ranges.t new file mode 100644 index 0000000..01bb98d --- /dev/null +++ b/t/overlapping-ranges.t @@ -0,0 +1,64 @@ +#!perl +use strict; +use warnings; +use Test::Most 'die'; +use Data::Printer; +use Data::MultiValued::Ranges; +use Data::MultiValued::TagsAndRanges; + +sub test_it { + my ($obj) = @_; + $obj->set({ + from=>10, + to=>20, + value=>1, + }); + $obj->set({ + from=>15, + to => 30, + value => 2, + }); + + my %points = ( + 10,1, + 12,1, + 13,1, + 14,1, + 15,2, + 17,2, + 19,2, + 20,2, + 25,2, + 29,2, + ); + while (my ($at,$v) = each %points) { + cmp_ok($obj->get({at=>$at}), + '==', + $v, + "value at $at"); + } + + dies_ok { + $obj->get({at=>30}) + } 'far end'; + dies_ok { + $obj->get({at=>9}) + } 'far end'; +} + + +subtest 'ranges' => sub { + my $obj = Data::MultiValued::Ranges->new(); + ok($obj,'constructor works'); + + test_it($obj); +}; + +subtest 'tags and ranges' => sub { + my $obj = Data::MultiValued::TagsAndRanges->new(); + ok($obj,'constructor works'); + + test_it($obj); +}; + +done_testing(); diff --git a/t/ranges-setting.t b/t/ranges-setting.t new file mode 100644 index 0000000..b8d2a57 --- /dev/null +++ b/t/ranges-setting.t @@ -0,0 +1,93 @@ +#!perl +use strict; +use warnings; +use Test::Most 'die'; +use Data::Printer; +use Data::MultiValued::Ranges; +use Data::MultiValued::TagsAndRanges; + +sub test_it { + my ($obj) = @_; + + lives_ok { + $obj->set({ + from => 10, + to => 20, + value => [1,2,3], + }); + } 'setting 10-20'; + lives_ok { + $obj->set({ + from => 30, + to => 50, + value => [4,5,6], + }); + } 'setting 30-50'; + + cmp_deeply($obj->get({at => 15}), + [1,2,3], + 'getting 15'); + cmp_deeply($obj->get({at => 10}), + [1,2,3], + 'getting 10'); + cmp_deeply($obj->get({at => 19.999}), + [1,2,3], + 'getting 19.999'); + dies_ok { + $obj->get({at => 20}) + } 'getting 20 dies'; + + cmp_deeply($obj->get({at => 40}), + [4,5,6], + 'getting 40'); + cmp_deeply($obj->get({at => 30}), + [4,5,6], + 'getting 30'); + cmp_deeply($obj->get({at => 49.999}), + [4,5,6], + 'getting 49.999'); + dies_ok { + $obj->get({at => 50}) + } 'getting 50 dies'; + + dies_ok { + $obj->get({at => 0}) + } 'getting 0 dies'; + + dies_ok { + $obj->get({}); + } 'default get dies'; + + $obj->clear({from=>10,to=>20}); + + dies_ok { + $obj->get({at => 15}) + } 'getting 15 after clearing dies'; + + cmp_deeply($obj->get({at => 30}), + [4,5,6], + 'getting 30 after clearing'); + + $obj->clear(); + + dies_ok { + $obj->get({at => 30}) + } 'getting 30 after clearing all dies'; + +} + +subtest 'ranges' => sub { + my $obj = Data::MultiValued::Ranges->new(); + ok($obj,'constructor works'); + + test_it($obj); +}; + +subtest 'tags and ranges' => sub { + my $obj = Data::MultiValued::TagsAndRanges->new(); + ok($obj,'constructor works'); + + test_it($obj); +}; + +done_testing(); diff --git a/t/simple-setting.t b/t/simple-setting.t new file mode 100644 index 0000000..9d9a9e2 --- /dev/null +++ b/t/simple-setting.t @@ -0,0 +1,46 @@ +#!perl +use strict; +use warnings; +use Test::Most 'die'; +use Data::Printer; +use Data::MultiValued::Ranges; +use Data::MultiValued::Tags; +use Data::MultiValued::TagsAndRanges; + +sub test_it { + my ($obj) = @_; + + lives_ok { + $obj->set({ + value => 1234, + }); + } 'setting'; + + cmp_ok($obj->get({}),'==',1234, + 'getting'); + + lives_ok { $obj->clear } 'clearing the object'; +} + +subtest 'ranges' => sub { + my $obj = Data::MultiValued::Ranges->new(); + ok($obj,'constructor works'); + + test_it($obj); +}; + +subtest 'tags' => sub { + my $obj = Data::MultiValued::Tags->new(); + ok($obj,'constructor works'); + + test_it($obj); +}; + +subtest 'tags and ranges' => sub { + my $obj = Data::MultiValued::TagsAndRanges->new(); + ok($obj,'constructor works'); + + test_it($obj); +}; + +done_testing(); diff --git a/t/tags-ranges-setting.t b/t/tags-ranges-setting.t new file mode 100644 index 0000000..e25a9f1 --- /dev/null +++ b/t/tags-ranges-setting.t @@ -0,0 +1,85 @@ +#!perl +use strict; +use warnings; +use Test::Most 'die'; +use Data::Printer; +use Data::MultiValued::TagsAndRanges; + +my $obj = Data::MultiValued::TagsAndRanges->new(); +ok($obj,'constructor works'); + +my @tags = (undef,'tag1','tag2'); +my @ranges = ([10,20,2],[30,50,2]); + +sub _t { $_[0] ? ( tag => $_[0] ) : () } + +for my $tag (@tags) { + for my $range (@ranges) { + $obj->set({ + _t($tag), + from => $range->[0], + to => $range->[1], + value => $range->[2], + }); + } +} + +for my $tag (@tags) { + for my $range (@ranges) { + cmp_ok( + $obj->get({ + _t($tag), + at => ($range->[0]+$range->[1])/2, + }), + '==', + $range->[2], + "tag @{[ $tag // 'default' ]}, range @$range[0,1]", + ); + } +} + +for my $range (@ranges) { + dies_ok { + $obj->get({ + tag => 'not there', + from => $range->[0], + to => $range->[1], + }) + } "no such tag, range @$range[0,1]"; +} + +for my $tag (@tags) { + for my $range (@ranges) { + dies_ok { + $obj->get({ + _t($tag), + at => $range->[0]-1, + }) + } "tag @{[ $tag // 'default' ]}, out-of-range (left)"; + dies_ok { + $obj->get({ + _t($tag), + at => $range->[1], + }) + } "tag @{[ $tag // 'default' ]}, out-of-range (right)"; + } +} + +$obj->clear({tag=>$tags[1],from=>$ranges[0]->[0],to=>$ranges[0]->[1]}); +dies_ok { + $obj->get({ + tag=>$tags[1], + at => $ranges[0]->[0]+1, + }) +} 'getting deleted range from inside tag dies'; + +cmp_ok( + $obj->get({ + tag => $tags[1], + at => $ranges[1]->[0]+1, + }), + '==', + $ranges[1]->[2], + 'other ranges in same tag are still there'); + +done_testing(); diff --git a/t/tags-setting.t b/t/tags-setting.t new file mode 100644 index 0000000..929ad3d --- /dev/null +++ b/t/tags-setting.t @@ -0,0 +1,76 @@ +#!perl +use strict; +use warnings; +use Test::Most 'die'; +use Data::Printer; +use Data::MultiValued::Tags; +use Data::MultiValued::TagsAndRanges; + +sub test_it { + my ($obj) = @_; + + lives_ok { + $obj->set({ + tag => 'tag1', + value => 'a string', + }); + } 'setting tag1'; + lives_ok { + $obj->set({ + tag => 'tag2', + value => 'another string', + }); + } 'setting tag2'; + + cmp_ok($obj->get({tag => 'tag1'}), + 'eq', + 'a string', + 'getting tag1'); + + cmp_ok($obj->get({tag => 'tag2'}), + 'eq', + 'another string', + 'getting tag2'); + + dies_ok { + $obj->get({tag=>'no such tag'}); + } 'getting non-existent tag'; + + dies_ok { + $obj->get({}); + } 'default get dies'; + + $obj->clear({tag=>'tag1'}); + + dies_ok { + $obj->get({tag=>'tag1'}); + } 'getting cleared tag'; + + cmp_ok($obj->get({tag => 'tag2'}), + 'eq', + 'another string', + 'getting tag2 after clearing'); + + $obj->clear(); + + dies_ok { + $obj->get({tag=>'tag2'}); + } 'getting tag2 after clearing all dies'; + +} + +subtest 'tags' => sub { + my $obj = Data::MultiValued::Tags->new(); + ok($obj,'constructor works'); + + test_it($obj); +}; + +subtest 'tags and ranges' => sub { + my $obj = Data::MultiValued::TagsAndRanges->new(); + ok($obj,'constructor works'); + + test_it($obj); +}; + +done_testing(); -- cgit v1.2.3