storage class for tags/ranges

8 files changed, 459 insertions, 0 deletions

diff --git a/.gitignore b/.gitignore
new file mode 100644
index 0000000..68f70d8
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1,3 @@
+*.sw?
+*.tar.gz
+*~
diff --git a/Data-TagsAndRanges/.gitignore b/Data-TagsAndRanges/.gitignore
new file mode 100644
index 0000000..a916a46
--- /dev/null
+++ b/Data-TagsAndRanges/.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-TagsAndRanges/dist.ini b/Data-TagsAndRanges/dist.ini
new file mode 100644
index 0000000..b69e340
--- /dev/null
+++ b/Data-TagsAndRanges/dist.ini
@@ -0,0 +1,69 @@
+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
new file mode 100644
index 0000000..7c8ed7b
--- /dev/null
+++ b/Data-TagsAndRanges/lib/Data/TagsAndRanges.pm
@@ -0,0 +1,54 @@
+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::TagContainer;
+
+# ABSTRACT: Handle values with tags and validity ranges
+
+has _storage => (
+    is => 'rw',
+    isa => class_type('Data::TagsAndRanges::TagContainer'),
+    init_arg => undef,
+    lazy_build => 1,
+);
+
+sub _build__storage {
+    Data::TagsAndRanges::TagContainer->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
new file mode 100644
index 0000000..c28824b
--- /dev/null
+++ b/Data-TagsAndRanges/lib/Data/TagsAndRanges/Exceptions.pm
@@ -0,0 +1,38 @@
+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 ',
+);
+}
+
+1;
diff --git a/Data-TagsAndRanges/lib/Data/TagsAndRanges/RangeContainer.pm b/Data-TagsAndRanges/lib/Data/TagsAndRanges/RangeContainer.pm
new file mode 100644
index 0000000..5f3653a
--- /dev/null
+++ b/Data-TagsAndRanges/lib/Data/TagsAndRanges/RangeContainer.pm
@@ -0,0 +1,91 @@
+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|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::TagsAndRanges::Exceptions::RangeNotFound->throw({
+            value => $at,
+        });
+    }
+
+    return $range;
+}
+
+sub _cmp_less { 
+    return if !defined $_[0];
+    return 1 if !defined $_[1];
+    return $_[0] <= $_[1];
+}
+sub _cmp_more {
+    return if !defined $_[0];
+    return 1 if !defined $_[1];
+    return $_[0] > $_[1];
+}
+sub _cmp_eq {
+    return 1 if !defined($_[0]) && !defined($_[1]);
+    return if defined($_[0]) xor defined($_[1]);
+    return $_[0] == $_[1];
+}
+
+sub _get_slot_at {
+    my ($self,$at) = @_;
+
+    for my $slot (@{$self->_storage}) {
+        next if _cmp_less($slot->{to},$at);
+        last if _cmp_more($slot->{from},$at);
+        return $slot;
+    }
+    return;
+}
+
+sub set_or_create {
+    my ($self,$args) = @_;
+
+    my $from = $args->{from};
+    my $to = $args->{to};
+
+    my ($range) = $self->_get_slot_at($from);
+
+    if ($range && _cmp_eq($range->{from},$from) && _cmp_eq($range->{to},$to)) {
+        return $range;
+    }
+
+    $range = $self->_create_slot($from,$to);
+    return $range;
+}
+
+sub _create_slot {
+    my ($self,$from,$to) = @_;
+
+    push @{$self->_storage},{
+        from => $from,
+        to => $to,
+        value => undef,
+    };
+    return $self->_storage->[-1];
+}
+
+1;
diff --git a/Data-TagsAndRanges/lib/Data/TagsAndRanges/TagContainer.pm b/Data-TagsAndRanges/lib/Data/TagsAndRanges/TagContainer.pm
new file mode 100644
index 0000000..c820f9a
--- /dev/null
+++ b/Data-TagsAndRanges/lib/Data/TagsAndRanges/TagContainer.pm
@@ -0,0 +1,73 @@
+package Data::TagsAndRanges::TagContainer;
+use Moose;
+use Moose::Util::TypeConstraints;
+use MooseX::Types::Moose qw(HashRef);
+use Data::TagsAndRanges::Exceptions;
+use Data::TagsAndRanges::RangeContainer;
+
+has _storage => (
+    is => 'rw',
+    isa => HashRef[class_type('Data::TagsAndRanges::RangeContainer')],
+    init_arg => undef,
+    default => sub { { } },
+    traits => ['Hash'],
+    handles => {
+        _has_tag => 'exists',
+        _get_tag => 'get',
+        _create_tag => 'set',
+    },
+);
+
+has _default_range => (
+    is => 'rw',
+    isa => class_type('Data::TagsAndRanges::RangeContainer'),
+    init_arg => undef,
+    predicate => '_has_default_range',
+);
+
+sub get {
+    my ($self,$args) = @_;
+
+    my $tag = $args->{tag};
+
+    if (!defined($tag)) {
+        if ($self->_has_default_range) {
+            return $self->_default_range;
+        }
+
+        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_range) {
+            return $self->_default_range;
+        }
+        else {
+            return $self->_default_range(
+                Data::TagsAndRanges::RangeContainer->new()
+              );
+        }
+    }
+
+    if (!$self->_has_tag($tag)) {
+        $self->_create_tag($tag,Data::TagsAndRanges::RangeContainer->new());
+    }
+    return $self->_get_tag($tag);
+}
+
+1;
diff --git a/Data-TagsAndRanges/t/setting.t b/Data-TagsAndRanges/t/setting.t
new file mode 100644
index 0000000..0eba1ef
--- /dev/null
+++ b/Data-TagsAndRanges/t/setting.t
@@ -0,0 +1,118 @@
+#!perl
+use strict;
+use warnings;
+use Test::Most 'die';
+use Data::Printer;
+use Data::TagsAndRanges;
+
+my $obj = Data::TagsAndRanges->new();
+ok($obj,'constructor works');
+
+sub clear_it {
+    lives_ok { $obj->clear } 'clearing the object';
+}
+
+subtest 'no ranges or tags' => sub {
+    clear_it;
+
+    lives_ok {
+        $obj->set({
+            value => 1234,
+        });
+    } 'setting';
+
+    cmp_ok($obj->get({}),'==',1234,
+           'getting');
+};
+
+subtest 'tags' => sub {
+    clear_it;
+
+    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';
+};
+
+subtest 'ranges' => sub {
+    clear_it;
+
+    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';
+
+    note p $obj;
+
+    dies_ok {
+        $obj->get({});
+    } 'default get dies';
+};
+
+done_testing();