summaryrefslogtreecommitdiff
path: root/Data-TagsAndRanges
diff options
context:
space:
mode:
Diffstat (limited to 'Data-TagsAndRanges')
-rw-r--r--Data-TagsAndRanges/.gitignore13
-rw-r--r--Data-TagsAndRanges/dist.ini69
-rw-r--r--Data-TagsAndRanges/lib/Data/TagsAndRanges.pm54
-rw-r--r--Data-TagsAndRanges/lib/Data/TagsAndRanges/Exceptions.pm57
-rw-r--r--Data-TagsAndRanges/lib/Data/TagsAndRanges/RangeContainer.pm153
-rw-r--r--Data-TagsAndRanges/lib/Data/TagsAndRanges/TagContainer.pm76
-rw-r--r--Data-TagsAndRanges/lib/Data/TagsAndRanges/TagContainerForRanges.pm21
-rw-r--r--Data-TagsAndRanges/t/more-overlapping-ranges.t63
-rw-r--r--Data-TagsAndRanges/t/overlapping-ranges.t48
-rw-r--r--Data-TagsAndRanges/t/ranges-setting.t60
-rw-r--r--Data-TagsAndRanges/t/simple-setting.t22
-rw-r--r--Data-TagsAndRanges/t/tags-ranges-setting.t68
-rw-r--r--Data-TagsAndRanges/t/tags-setting.t42
13 files changed, 0 insertions, 746 deletions
diff --git a/Data-TagsAndRanges/.gitignore b/Data-TagsAndRanges/.gitignore
deleted file mode 100644
index a916a46..0000000
--- a/Data-TagsAndRanges/.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-TagsAndRanges/dist.ini b/Data-TagsAndRanges/dist.ini
deleted file mode 100644
index b69e340..0000000
--- a/Data-TagsAndRanges/dist.ini
+++ /dev/null
@@ -1,69 +0,0 @@
-name = Data-TagsAndRanges
-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] \ No newline at end of file
diff --git a/Data-TagsAndRanges/lib/Data/TagsAndRanges.pm b/Data-TagsAndRanges/lib/Data/TagsAndRanges.pm
deleted file mode 100644
index 8a94b8f..0000000
--- a/Data-TagsAndRanges/lib/Data/TagsAndRanges.pm
+++ /dev/null
@@ -1,54 +0,0 @@
-package Data::TagsAndRanges;
-use Moose;
-use MooseX::Params::Validate;
-use Moose::Util::TypeConstraints;
-use MooseX::Types::Moose qw(Num Str Undef Any);
-use Data::TagsAndRanges::Exceptions;
-use Data::TagsAndRanges::TagContainerForRanges;
-
-# ABSTRACT: Handle values with tags and validity ranges
-
-has _storage => (
- is => 'rw',
- isa => class_type('Data::TagsAndRanges::TagContainerForRanges'),
- init_arg => undef,
- lazy_build => 1,
-);
-
-sub _build__storage {
- Data::TagsAndRanges::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-TagsAndRanges/lib/Data/TagsAndRanges/Exceptions.pm b/Data-TagsAndRanges/lib/Data/TagsAndRanges/Exceptions.pm
deleted file mode 100644
index def6108..0000000
--- a/Data-TagsAndRanges/lib/Data/TagsAndRanges/Exceptions.pm
+++ /dev/null
@@ -1,57 +0,0 @@
-package Data::TagsAndRanges::Exceptions;
-package Data::TagsAndRanges::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::TagsAndRanges::Exceptions::TagNotFound;{
-use Moose;
-extends 'Data::TagsAndRanges::Exceptions::NotFound';
-
-has '+message' => (
- default => 'tag not found: ',
-);
-}
-package Data::TagsAndRanges::Exceptions::RangeNotFound;{
-use Moose;
-extends 'Data::TagsAndRanges::Exceptions::NotFound';
-
-has '+message' => (
- default => 'no range found for value ',
-);
-}
-package Data::TagsAndRanges::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-TagsAndRanges/lib/Data/TagsAndRanges/RangeContainer.pm b/Data-TagsAndRanges/lib/Data/TagsAndRanges/RangeContainer.pm
deleted file mode 100644
index e93805e..0000000
--- a/Data-TagsAndRanges/lib/Data/TagsAndRanges/RangeContainer.pm
+++ /dev/null
@@ -1,153 +0,0 @@
-package Data::TagsAndRanges::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::TagsAndRanges::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::TagsAndRanges::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::TagsAndRanges::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-TagsAndRanges/lib/Data/TagsAndRanges/TagContainer.pm b/Data-TagsAndRanges/lib/Data/TagsAndRanges/TagContainer.pm
deleted file mode 100644
index 8ede59f..0000000
--- a/Data-TagsAndRanges/lib/Data/TagsAndRanges/TagContainer.pm
+++ /dev/null
@@ -1,76 +0,0 @@
-package Data::TagsAndRanges::TagContainer;
-use Moose;
-use Moose::Util::TypeConstraints;
-use MooseX::Types::Moose qw(HashRef);
-use Data::TagsAndRanges::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::TagsAndRanges::Exceptions::TagNotFound->throw({
- value => $tag,
- });
- }
-
- if (!$self->_has_tag($tag)) {
- Data::TagsAndRanges::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-TagsAndRanges/lib/Data/TagsAndRanges/TagContainerForRanges.pm b/Data-TagsAndRanges/lib/Data/TagsAndRanges/TagContainerForRanges.pm
deleted file mode 100644
index 3c1b44a..0000000
--- a/Data-TagsAndRanges/lib/Data/TagsAndRanges/TagContainerForRanges.pm
+++ /dev/null
@@ -1,21 +0,0 @@
-package Data::TagsAndRanges::TagContainerForRanges;
-use Moose;
-use MooseX::Types::Moose qw(HashRef);
-use Moose::Util::TypeConstraints;
-use Data::TagsAndRanges::RangeContainer;
-
-extends 'Data::TagsAndRanges::TagContainer';
-
-has '+_storage' => (
- isa => HashRef[class_type('Data::TagsAndRanges::RangeContainer')],
-);
-
-has '+_default_tag' => (
- isa => class_type('Data::TagsAndRanges::RangeContainer'),
-);
-
-sub _create_new_inferior {
- Data::TagsAndRanges::RangeContainer->new();
-}
-
-1;
diff --git a/Data-TagsAndRanges/t/more-overlapping-ranges.t b/Data-TagsAndRanges/t/more-overlapping-ranges.t
deleted file mode 100644
index 899127f..0000000
--- a/Data-TagsAndRanges/t/more-overlapping-ranges.t
+++ /dev/null
@@ -1,63 +0,0 @@
-#!perl
-use strict;
-use warnings;
-use Test::Most 'die';
-use Data::Printer;
-use Data::TagsAndRanges;
-
-my $obj = Data::TagsAndRanges->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-TagsAndRanges/t/overlapping-ranges.t b/Data-TagsAndRanges/t/overlapping-ranges.t
deleted file mode 100644
index 55355ef..0000000
--- a/Data-TagsAndRanges/t/overlapping-ranges.t
+++ /dev/null
@@ -1,48 +0,0 @@
-#!perl
-use strict;
-use warnings;
-use Test::Most 'die';
-use Data::Printer;
-use Data::TagsAndRanges;
-
-my $obj = Data::TagsAndRanges->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-TagsAndRanges/t/ranges-setting.t b/Data-TagsAndRanges/t/ranges-setting.t
deleted file mode 100644
index 1b92000..0000000
--- a/Data-TagsAndRanges/t/ranges-setting.t
+++ /dev/null
@@ -1,60 +0,0 @@
-#!perl
-use strict;
-use warnings;
-use Test::Most 'die';
-use Data::Printer;
-use Data::TagsAndRanges;
-
-my $obj = Data::TagsAndRanges->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-TagsAndRanges/t/simple-setting.t b/Data-TagsAndRanges/t/simple-setting.t
deleted file mode 100644
index 594e7d7..0000000
--- a/Data-TagsAndRanges/t/simple-setting.t
+++ /dev/null
@@ -1,22 +0,0 @@
-#!perl
-use strict;
-use warnings;
-use Test::Most 'die';
-use Data::Printer;
-use Data::TagsAndRanges;
-
-my $obj = Data::TagsAndRanges->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-TagsAndRanges/t/tags-ranges-setting.t b/Data-TagsAndRanges/t/tags-ranges-setting.t
deleted file mode 100644
index ec9f837..0000000
--- a/Data-TagsAndRanges/t/tags-ranges-setting.t
+++ /dev/null
@@ -1,68 +0,0 @@
-#!perl
-use strict;
-use warnings;
-use Test::Most 'die';
-use Data::Printer;
-use Data::TagsAndRanges;
-
-my $obj = Data::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)";
- }
-}
-
-done_testing();
diff --git a/Data-TagsAndRanges/t/tags-setting.t b/Data-TagsAndRanges/t/tags-setting.t
deleted file mode 100644
index 9b4a697..0000000
--- a/Data-TagsAndRanges/t/tags-setting.t
+++ /dev/null
@@ -1,42 +0,0 @@
-#!perl
-use strict;
-use warnings;
-use Test::Most 'die';
-use Data::Printer;
-use Data::TagsAndRanges;
-
-my $obj = Data::TagsAndRanges->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-04 08:47:33 +0000