summaryrefslogtreecommitdiff
path: root/Data-MultiValued
diff options
context:
space:
mode:
Diffstat (limited to 'Data-MultiValued')
-rw-r--r--Data-MultiValued/.gitignore13
-rw-r--r--Data-MultiValued/dist.ini69
-rw-r--r--Data-MultiValued/lib/Data/MultiValued.pm54
-rw-r--r--Data-MultiValued/lib/Data/MultiValued/Exceptions.pm57
-rw-r--r--Data-MultiValued/lib/Data/MultiValued/RangeContainer.pm153
-rw-r--r--Data-MultiValued/lib/Data/MultiValued/TagContainer.pm76
-rw-r--r--Data-MultiValued/lib/Data/MultiValued/TagContainerForRanges.pm21
-rw-r--r--Data-MultiValued/t/more-overlapping-ranges.t63
-rw-r--r--Data-MultiValued/t/overlapping-ranges.t48
-rw-r--r--Data-MultiValued/t/ranges-setting.t60
-rw-r--r--Data-MultiValued/t/simple-setting.t22
-rw-r--r--Data-MultiValued/t/tags-ranges-setting.t68
-rw-r--r--Data-MultiValued/t/tags-setting.t42
13 files changed, 746 insertions, 0 deletions
diff --git a/Data-MultiValued/.gitignore b/Data-MultiValued/.gitignore
new file mode 100644
index 0000000..a916a46
--- /dev/null
+++ b/Data-MultiValued/.gitignore
@@ -0,0 +1,13 @@
+blib
+pm_to_blib
+*.sw?
+Makefile
+Makefile.old
+MANIFEST.bak
+*.tar.gz
+/inc/
+META.yml
+.prove
+*~
+/.build/
+/Data-/
diff --git a/Data-MultiValued/dist.ini b/Data-MultiValued/dist.ini
new file mode 100644
index 0000000..d9411c9
--- /dev/null
+++ b/Data-MultiValued/dist.ini
@@ -0,0 +1,69 @@
+name = Data-MultiValued
+author = Gianni Ceccarelli <dakkar@thenautilus.net>
+license = Perl_5
+copyright_holder = Net-a-porter.com
+copyright_year = 2011
+
+abstract = Handle values with tags and validity ranges
+
+[GatherDir]
+
+[PodWeaver]
+
+[PruneCruft]
+
+[PruneFiles]
+match = ~$
+
+[Git::Check]
+allow_dirty = dist.ini
+
+[Git::NextVersion]
+first_version = 0.0.1
+
+[Git::Commit]
+
+[Git::CommitBuild]
+
+[Git::Tag]
+
+[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.pm b/Data-MultiValued/lib/Data/MultiValued.pm
new file mode 100644
index 0000000..65b041d
--- /dev/null
+++ b/Data-MultiValued/lib/Data/MultiValued.pm
@@ -0,0 +1,54 @@
+package Data::MultiValued;
+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 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) = @_;
+
+ $self->_clear_storage;
+}
+
+1;
diff --git a/Data-MultiValued/lib/Data/MultiValued/Exceptions.pm b/Data-MultiValued/lib/Data/MultiValued/Exceptions.pm
new file mode 100644
index 0000000..571db0a
--- /dev/null
+++ b/Data-MultiValued/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/Data-MultiValued/lib/Data/MultiValued/RangeContainer.pm b/Data-MultiValued/lib/Data/MultiValued/RangeContainer.pm
new file mode 100644
index 0000000..5c4fb3a
--- /dev/null
+++ b/Data-MultiValued/lib/Data/MultiValued/RangeContainer.pm
@@ -0,0 +1,153 @@
+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,
+ to => Num,
+ value => Any,
+ ],
+ ],
+ init_arg => undef,
+ default => sub { [ ] },
+);
+
+sub get {
+ my ($self,$args) = @_;
+
+ my $at = $args->{at} // 0-'inf';
+
+ my ($range) = $self->_get_slot_at($at);
+
+ if (!$range) {
+ Data::MultiValued::Exceptions::RangeNotFound->throw({
+ value => $at,
+ });
+ }
+
+ return $range;
+}
+
+sub _get_slot_at {
+ my ($self,$at) = @_;
+
+ for my $slot (@{$self->_storage}) {
+ next if $slot->{to} <= $at;
+ last if $slot->{from} > $at;
+ 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 ($st<$from) {
+ push @before,$idx;
+ }
+ elsif ($sf>=$to) {
+ push @after,$idx;
+ }
+ else {
+ push @overlap,$idx;
+ }
+ }
+ return \@before,\@overlap,\@after;
+}
+
+sub set_or_create {
+ my ($self,$args) = @_;
+
+ my $from = $args->{from} // 0-'inf';
+ my $to = $args->{to} // 0+'inf';
+
+ Data::MultiValued::Exceptions::BadRange->({
+ from => $from,
+ to => $to,
+ }) if $from > $to;
+
+ my ($range) = $self->_get_slot_at($from);
+
+ if ($range && $range->{from}==$from && $range->{to}==$to) {
+ return $range;
+ }
+
+ $range = $self->_create_slot($from,$to);
+ return $range;
+}
+
+sub _create_slot {
+ my ($self,$from,$to) = @_;
+
+ my $new = {
+ from => $from,
+ to => $to,
+ value => undef,
+ };
+
+ if (!@{$self->_storage}) { # empty
+ push @{$self->_storage},$new;
+ return $new;
+ }
+
+ my ($before,$overlap,$after) = $self->_partition_slots($from,$to);
+
+ if (!@$before && !@$overlap) {
+ unshift @{$self->_storage},$new;
+ return $new;
+ }
+ if (!@$after && !@$overlap) {
+ push @{$self->_storage},$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);
+
+ if ($how_many > 0) { # we have to splice
+ my $first = $self->_storage->[$first_to_replace];
+ my $last = $self->_storage->[$last_to_replace];
+
+ if ($first->{from} < $from && $first->{to} >= $from) {
+ unshift @replacement, {
+ from => $first->{from},
+ to => $from,
+ value => $first->{value},
+ }
+ }
+ if ($last->{from} < $to && $last->{to} >= $to) {
+ 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/TagContainer.pm b/Data-MultiValued/lib/Data/MultiValued/TagContainer.pm
new file mode 100644
index 0000000..e0c7f4f
--- /dev/null
+++ b/Data-MultiValued/lib/Data/MultiValued/TagContainer.pm
@@ -0,0 +1,76 @@
+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',
+ },
+);
+
+has _default_tag => (
+ is => 'rw',
+ init_arg => undef,
+ predicate => '_has_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 _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
new file mode 100644
index 0000000..71fd7f9
--- /dev/null
+++ b/Data-MultiValued/lib/Data/MultiValued/TagContainerForRanges.pm
@@ -0,0 +1,21 @@
+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();
+}
+
+1;
diff --git a/Data-MultiValued/t/more-overlapping-ranges.t b/Data-MultiValued/t/more-overlapping-ranges.t
new file mode 100644
index 0000000..9ff1dc2
--- /dev/null
+++ b/Data-MultiValued/t/more-overlapping-ranges.t
@@ -0,0 +1,63 @@
+#!perl
+use strict;
+use warnings;
+use Test::Most 'die';
+use Data::Printer;
+use Data::MultiValued;
+
+my $obj = Data::MultiValued->new();
+ok($obj,'constructor works');
+
+$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");
+}
+
+done_testing();
diff --git a/Data-MultiValued/t/overlapping-ranges.t b/Data-MultiValued/t/overlapping-ranges.t
new file mode 100644
index 0000000..e359894
--- /dev/null
+++ b/Data-MultiValued/t/overlapping-ranges.t
@@ -0,0 +1,48 @@
+#!perl
+use strict;
+use warnings;
+use Test::Most 'die';
+use Data::Printer;
+use Data::MultiValued;
+
+my $obj = Data::MultiValued->new();
+ok($obj,'constructor works');
+
+$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';
+
+done_testing();
diff --git a/Data-MultiValued/t/ranges-setting.t b/Data-MultiValued/t/ranges-setting.t
new file mode 100644
index 0000000..148a4c6
--- /dev/null
+++ b/Data-MultiValued/t/ranges-setting.t
@@ -0,0 +1,60 @@
+#!perl
+use strict;
+use warnings;
+use Test::Most 'die';
+use Data::Printer;
+use Data::MultiValued;
+
+my $obj = Data::MultiValued->new();
+ok($obj,'constructor works');
+
+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';
+
+done_testing();
diff --git a/Data-MultiValued/t/simple-setting.t b/Data-MultiValued/t/simple-setting.t
new file mode 100644
index 0000000..b478e7a
--- /dev/null
+++ b/Data-MultiValued/t/simple-setting.t
@@ -0,0 +1,22 @@
+#!perl
+use strict;
+use warnings;
+use Test::Most 'die';
+use Data::Printer;
+use Data::MultiValued;
+
+my $obj = Data::MultiValued->new();
+ok($obj,'constructor works');
+
+lives_ok {
+ $obj->set({
+ value => 1234,
+ });
+} 'setting';
+
+cmp_ok($obj->get({}),'==',1234,
+ 'getting');
+
+lives_ok { $obj->clear } 'clearing the object';
+
+done_testing();
diff --git a/Data-MultiValued/t/tags-ranges-setting.t b/Data-MultiValued/t/tags-ranges-setting.t
new file mode 100644
index 0000000..7214ebe
--- /dev/null
+++ b/Data-MultiValued/t/tags-ranges-setting.t
@@ -0,0 +1,68 @@
+#!perl
+use strict;
+use warnings;
+use Test::Most 'die';
+use Data::Printer;
+use Data::MultiValued;
+
+my $obj = Data::MultiValued->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)";
+ }
+}
+
+done_testing();
diff --git a/Data-MultiValued/t/tags-setting.t b/Data-MultiValued/t/tags-setting.t
new file mode 100644
index 0000000..d9f6fd8
--- /dev/null
+++ b/Data-MultiValued/t/tags-setting.t
@@ -0,0 +1,42 @@
+#!perl
+use strict;
+use warnings;
+use Test::Most 'die';
+use Data::Printer;
+use Data::MultiValued;
+
+my $obj = Data::MultiValued->new();
+ok($obj,'constructor works');
+
+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';
+
+done_testing();
generated by cgit v1.2.3 (git 2.46.0) at 2025-05-01 11:24:40 +0000