diff options
26 files changed, 2803 insertions, 1 deletions
@@ -10,3 +10,4 @@ META.yml .prove *~ /.build/ +/Data-*/ @@ -0,0 +1,9 @@ +Revision history for Data::MultiValued + +{{$NEXT}} + +0.0.1_2 2011-11-30 11:01:47 Europe/London + - remove the need for perl 5.12 + +0.0.1_1 2011-11-24 17:59:57 Europe/London + - first working version @@ -1,8 +1,13 @@ +name = Data-MultiValued author = Gianni Ceccarelli <dakkar@thenautilus.net> license = Perl_5 -copyright_holder = Gianni Ceccarelli <dakkar@thenautilus.net> +copyright_holder = Net-a-Porter.com copyright_year = 2011 +abstract = Handle values with tags and validity ranges + +main_module = lib/Data/MultiValued.pm + [GatherDir] [PodWeaver] @@ -34,6 +39,7 @@ tag_format = v%v [NextRelease] [AutoPrereqs] +skips = Data::MultiValued::Exceptions::NotFound [PkgDist] diff --git a/lib/Data/MultiValued.pm b/lib/Data/MultiValued.pm new file mode 100644 index 0000000..aff7a17 --- /dev/null +++ b/lib/Data/MultiValued.pm @@ -0,0 +1,76 @@ +package Data::MultiValued; +use strict; +use warnings; +# ABSTRACT: store tag- and range-dependant data in a scalar or Moose attribute + +warn "Don't use this module directly, use Data::MultiValued::Tags or Data::MultiValued::Ranges or the like"; + +1; + +=head1 SYNOPSIS + + use Data::MultiValued::Tags; + + my $obj = Data::MultiValued::Tags->new(); + $obj->set({ + tag => 'tag1', + value => 'a string', + }); + say $obj->get({tag=>'tag1'}); # prints 'a string' + say $obj->get({tag=>'tag2'}); # dies + +Also: + + package My::Class; + use Moose; + use Data::MultiValued::AttributeTrait::Tags; + + has stuff => ( + is => 'rw', + isa => 'Int', + traits => ['MultiValued::Tags'], + ); + + # later + + my $obj = My::Class->new(); + $obj->stuff_multi({tag=>'tag1'},123); + say $obj->stuff_multi({tag=>'tag1'}); # prints 123 + +=head1 DESCRIPTION + +This set of classes allows you to store different values inside a +single object, and access them by tag and / or by a numeric value. + +Yes, you could do the same with hashes and some clever use of +arrays. Or you could use L<Array::IntSpan>. Or some other CPAN +module. Why use these? + +=over 4 + +=item * + +they are optimised for serialisation, see +L<Data::MultiValued::UglySerializationHelperRole> and F<t/json.t>. + +=item * + +you get accessors generated for your Moose attributes just by setting +a trait + +=item * + +tags and ranges interact in sensible ways, including clearing ranges + +=back + +=head1 Where to go from here + +Look at the tests for detailed examples of usage. Look at +L<Data::MultiValued::Tags>, L<Data::MultiValued::Ranges> and +L<Data::MultiValued::TagsAndRanges> for the containers +themselves. Look at L<Data::MultiValued::AttributeTrait::Tags>, +L<Data::MultiValued::AttributeTrait::Ranges> and +L<Data::MultiValued::AttributeTrait::TagsAndRanges> for the Moose +attribute traits. + diff --git a/lib/Data/MultiValued/AttributeAccessors.pm b/lib/Data/MultiValued/AttributeAccessors.pm new file mode 100644 index 0000000..8480f98 --- /dev/null +++ b/lib/Data/MultiValued/AttributeAccessors.pm @@ -0,0 +1,154 @@ +package Data::MultiValued::AttributeAccessors; +use strict; +use warnings; +use base 'Moose::Meta::Method::Accessor'; +use Carp 'confess'; + +# ABSTRACT: method meta-class for multi-valued attribute accessors + +=head1 DESCRIPTION + +Subclass of L<Moose::Meta::Method::Accessor>, generates non-inlined +(patches welcome) accessors for multi-valued attributes. + +=method C<_instance_is_inlinable> + +Returns C<0> to prevent attempts to inline the accessor methods. + +=cut + +sub _instance_is_inlinable { 0 } + +=method C<_generate_accessor_method> + +=method C<_generate_reader_method> + +=method C<_generate_writer_method> + +=method C<_generate_predicate_method> + +=method C<_generate_clearer_method> + +Delegate to C<set_multi_value>, C<get_multi_value>, +C<has_multi_value>, C<clear_multi_value>, passing empty options +(i.e. no tags, no ranges). + +=cut + +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], {}) + }; +} + +=method C<_generate_multi_accessor_method> + +=method C<_generate_multi_reader_method> + +=method C<_generate_multi_writer_method> + +=method C<_generate_multi_predicate_method> + +=method C<_generate_multi_clearer_method> + +Delegate to C<set_multi_value>, C<get_multi_value>, +C<has_multi_value>, C<clear_multi_value>, passing C<$_[1]> as options +and C<$_[2]> as values. + +=cut + +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..78ae31e --- /dev/null +++ b/lib/Data/MultiValued/AttributeTrait.pm @@ -0,0 +1,492 @@ +package Data::MultiValued::AttributeTrait; +use Moose::Role; +use Data::MultiValued::AttributeAccessors; +use MooseX::Types::Moose qw(Str); +use Try::Tiny; +use namespace::autoclean; + +# ABSTRACT: "base role" for traits of multi-valued Moose attributes + +=head1 DESCRIPTION + +Don't use this role directly, use +L<Data::MultiValued::AttributeTrait::Tags>, +L<Data::MultiValued::AttributeTrait::Ranges> or +L<Data::MultiValued::AttributeTrait::TagsAndRanges>. + +This role (together with L<Data::MultiValued::AttributeAccessors>) +defines all the basic plumbing to glue C<Data::MultiValued::Tags> etc +into Moose attributes. + +=head2 Implementation details + +The multi-value object is stored in the instance slot named by the +L</full_storage_slot> attribute attribute. C<before> modifiers on +getters load the appropriate value from the multi-value object into +the regular instance slot, C<after> modifiers on setters store the +value from the regular instance slot into the multi-value object. + +=head2 Attributes + +This trait adds some attributes to the attribute declarations in your +class. Example: + + has stuff => ( + is => 'rw', + isa => 'Int', + traits => ['MultiValued::Tags'], + predicate => 'has_stuff', + multi_accessor => 'stuff_tagged', + multi_predicate => 'has_stuff_tagged', + ); + +=attr C<full_storage_slot> + +The instance slot to use to store the C<Data::MultiValued::Tags> or +similar object. Defaults to C<"${name}__MULTIVALUED_STORAGE__">, where +C<$name> is the attribute name. + +=cut + +has 'full_storage_slot' => ( + is => 'ro', + isa => Str, + lazy_build => 1, +); +sub _build_full_storage_slot { shift->name . '__MULTIVALUED_STORAGE__' } + +=attr C<multi_accessor> + +=attr C<multi_reader> + +=attr C<multi_writer> + +=attr C<multi_predicate> + +=attr C<multi_clearer> + +The names to use for the various additional accessors. See +L<Class::MOP::Attribute> for details. These default to +C<"${name}_multi"> where C<$name> is the name of the corresponding +non-multi accessor. So, for example, + + has stuff => ( + is => 'rw', + traits => ['MultiValued::Tags'], + ); + +will create a C<stuff> read / write accessor and a C<stuff_multi> read +/ write tagged accessor. + +=cut + +my @accs_to_multiply=qw(accessor reader writer predicate clearer); + +for my $acc (@accs_to_multiply) { + has "multi_$acc" => ( + is => 'ro', + isa => Str, + predicate => "has_multi_$acc", + ); +} + +=head1 REQUIREMENTS + +These methods must be provided by any class consuming this role. See +L<Data::MultiValued::AttributeTrait::Tags> etc. for examples. + +=head2 C<multivalue_storage_class> + +The class to use to create the multi-value objects. + +=cut + +requires 'multivalue_storage_class'; + +=head2 C<opts_to_pass_set> + +Which options to pass from the multi-value accessors to the C<set> +method of the multi-value object. + +=cut + +requires 'opts_to_pass_set'; + +=head2 C<opts_to_pass_get> + +Which options to pass from the multi-value accessors to the C<get> +method of the multi-value object. + +=cut + +requires 'opts_to_pass_get'; + +=method C<slots> + +Adds the L</full_storage_slot> to the list of used slots. + +=cut + +around slots => sub { + my ($orig, $self) = @_; + return ($self->$orig(), $self->full_storage_slot); +}; + +=method C<set_full_storage> + +Stores a new instance of L</multivalue_storage_class> into the +L</full_storage_slot> of the instance. + +=cut + +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; +} + +=method C<get_full_storage> + +Retrieves the value of the L</full_storage_slot> of the instance. + +=cut + +sub get_full_storage { + my ($self,$instance) = @_; + + return $self->associated_class->get_meta_instance + ->get_slot_value( + $instance, + $self->full_storage_slot, + ); +} + +=method C<full_storage> + +Returns an instance of L</multivalue_storage_class>, either by +retrieving it from the instance, or by creating one (and setting it in +the instance). Calls L</get_full_storage> and L</set_full_storage>. + +=cut + +sub full_storage { + my ($self,$instance) = @_; + + return $self->get_full_storage($instance) + || $self->set_full_storage($instance); +} + +=method C<accessor_metaclass> + +Makes sure that all accessors for this attribute are created via the +L<Data::MultiValued::AttributeAccessors> method meta class. + +=cut + +sub accessor_metaclass { 'Data::MultiValued::AttributeAccessors' } + +=method C<install_accessors> + +After the regular L<Moose::Meta::Attribute> method, installs the +multi-value accessors. + +Each installed normal accessor gets a multi-value version + +You can add or rename the multi-value version by using the attributes +described above + +If you are passing explicit subrefs for your accessors, things won't work. + +=cut + +after install_accessors => sub { + my ($self) = @_; + + my $class = $self->associated_class; + + for my $meth (@accs_to_multiply) { + my $type = "multi_$meth"; + my $check = "has_$meth"; + my $multi_check = "has_$type"; + next unless $self->$check || $self->$multi_check; + + my $name = $self->$type; + if (!$name) { + my $basename = $self->$meth; + + die 'MultiValued attribute trait is not compatible with subref accessors' + if ref($basename); + + $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; +} + +=method C<load_multi_value> + +Retrieves a value from the multi-value object, and stores it in the +regular slot in the instance. If the value is not found, clears the +slot. + +This traps the +L<Data::MultiValued::Exceptions::NotFound|Data::MultiValued::Exceptions/Data::MultiValued::Exceptions::NotFound> +exception that may be thrown by the multi-value object, but re-throws +any other exception. + +=cut + +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); + } +} + +=method C<raw_clear_value> + +Clears the instance slot. Does the same as +L<Moose::Meta::Attribute/clear_value>, but we need this method because +the other one gets changed by this trait. + +=cut + +sub raw_clear_value { + my ($self,$instance) = @_; + + $self->associated_class->get_meta_instance + ->deinitialize_slot( + $instance, + $self->name, + ); +} + +=method C<store_multi_value> + +Gets the value from the regular slot in the instance, and stores it +into the multi-value object. + +=cut + +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 = {}; + +=method C<get_value> + +Before the normal method, calls L</load_multi_value>. Normally, no +options will be passed to the multi-value object C<get> method. + +=cut + +before get_value => sub { + my ($self,$instance) = @_; + + $self->load_multi_value($instance,$dyn_opts); +}; + +=method C<get_multi_value> + +Sets the options that L</load_multi_value> will use, then calls L</get_value>. + +The options are passed via an ugly C<local>ised package +variable. There might be a better way. + +=cut + +sub get_multi_value { + my ($self,$instance,$opts) = @_; + + local $dyn_opts = $opts; + + return $self->get_value($instance); +} + +=method C<set_initial_value> + +After the normal method, calls L</store_multi_value>. + +=cut + +after set_initial_value => sub { + my ($self,$instance,$value) = @_; + + $self->store_multi_value($instance,$dyn_opts); +}; + +=method C<set_value> + +=method C<set_multi_value> + +Just like L</get_value> and L</get_multi_value>, but calling +L</store_multi_value> after the regular C<set_value> + +=cut + +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); +} + +=method C<has_value> + +=method C<has_multi_value> + +Just like L</get_value> and L</get_multi_value>. + +=cut + +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); +} + +=method C<clear_value> + +=method C<clear_multi_value> + +Call the C<clear> method on the multi-value object. + +=cut + +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); +} + +=method C<get_multi_read_method> + +=method C<get_multi_write_method> + +Return the name of the reader or writer method, honoring +L</multi_reader>, L</multi_writer> and L</multi_accessor>. + +=cut + +sub get_multi_read_method { + my $self = shift; + return $self->multi_reader || $self->multi_accessor + || $self->get_read_method . '_multi'; +} + +sub get_multi_write_method { + my $self = shift; + return $self->multi_writer || $self->multi_accessor + || $self->get_write_method . '_multi'; +} + +=head1 Serialisation helpers + +These are used through +L<Data::MultiValued::UglySerializationHelperRole>. + +=head2 C<_rebless_slot> + +Blesses the value inside the L</full_storage_slot> of the instance +into L</multivalue_storage_class>, then calls C<_rebless_storage> on +it. + +=cut + +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; +} + +=head2 C<_as_hash> + +Returns the result of calling C<_as_hash> on the value inside the +L</full_storage_slot> of the instance. Returns nothing if the slot +does not have a value. + +=cut + +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..3d3b3f8 --- /dev/null +++ b/lib/Data/MultiValued/AttributeTrait/Ranges.pm @@ -0,0 +1,51 @@ +package Data::MultiValued::AttributeTrait::Ranges; +use Moose::Role; +use Data::MultiValued::Ranges; +with 'Data::MultiValued::AttributeTrait'; + +# ABSTRACT: attribute traits for attributes holding ranged values + +=head1 SYNOPSIS + + package My::Class; + use Moose; + use Data::MultiValued::AttributeTrait::Ranges; + + has stuff => ( + is => 'rw', + isa => 'Int', + traits => ['MultiValued::Ranges'], + predicate => 'has_stuff', + multi_accessor => 'stuff_tagged', + multi_predicate => 'has_stuff_tagged', + ); + +=head1 DESCRIPTION + +This role consumes L<Data::MultiValued::AttributeTrait> and +specialises it to use L<Data::MultiValued::Ranges> as multi-value +storage: + +=head2 C<multivalue_storage_class> + +Returns C<'Data::MultiValued::Ranges'>. + +=head2 C<opts_to_pass_set> + +Returns C<('from', 'to')>. + +=head2 C<opts_to_pass_get> + +Returns C<('at')>. + +=cut + +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..d671ed4 --- /dev/null +++ b/lib/Data/MultiValued/AttributeTrait/Tags.pm @@ -0,0 +1,51 @@ +package Data::MultiValued::AttributeTrait::Tags; +use Moose::Role; +use Data::MultiValued::Tags; +with 'Data::MultiValued::AttributeTrait'; + +# ABSTRACT: attribute traits for attributes holding tagged values + +=head1 SYNOPSIS + + package My::Class; + use Moose; + use Data::MultiValued::AttributeTrait::Tags; + + has stuff => ( + is => 'rw', + isa => 'Int', + traits => ['MultiValued::Tags'], + predicate => 'has_stuff', + multi_accessor => 'stuff_tagged', + multi_predicate => 'has_stuff_tagged', + ); + +=head1 DESCRIPTION + +This role consumes L<Data::MultiValued::AttributeTrait> and +specialises it to use L<Data::MultiValued::Tags> as multi-value +storage: + +=head2 C<multivalue_storage_class> + +Returns C<'Data::MultiValued::Tags'>. + +=head2 C<opts_to_pass_set> + +Returns C<('tag')>. + +=head2 C<opts_to_pass_get> + +Returns C<('tag')>. + +=cut + +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..0bb87ef --- /dev/null +++ b/lib/Data/MultiValued/AttributeTrait/TagsAndRanges.pm @@ -0,0 +1,51 @@ +package Data::MultiValued::AttributeTrait::TagsAndRanges; +use Moose::Role; +use Data::MultiValued::TagsAndRanges; +with 'Data::MultiValued::AttributeTrait'; + +# ABSTRACT: attribute traits for attributes holding tagged and ranged values + +=head1 SYNOPSIS + + package My::Class; + use Moose; + use Data::MultiValued::AttributeTrait::TagsAndRanges; + + has stuff => ( + is => 'rw', + isa => 'Int', + traits => ['MultiValued::TagsAndRanges'], + predicate => 'has_stuff', + multi_accessor => 'stuff_tagged', + multi_predicate => 'has_stuff_tagged', + ); + +=head1 DESCRIPTION + +This role consumes L<Data::MultiValued::AttributeTrait> and +specialises it to use L<Data::MultiValued::TagsAndRanges> as multi-value +storage: + +=head2 C<multivalue_storage_class> + +Returns C<'Data::MultiValued::TagsAndRanges'>. + +=head2 C<opts_to_pass_set> + +Returns C<('tag', 'from', 'to')>. + +=head2 C<opts_to_pass_get> + +Returns C<('tag', 'at')>. + +=cut + +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..6495780 --- /dev/null +++ b/lib/Data/MultiValued/Exceptions.pm @@ -0,0 +1,111 @@ +package Data::MultiValued::Exceptions; + +# ABSTRACT: exception classes + +=head1 DESCRIPTION + +This module defines a few exception classes, using L<Throwable::Error> +as a base class. + +=head1 CLASSES + +=head2 C<Data::MultiValued::Exceptions::NotFound> + +Base class for "not found" errors. Has a C<value> attribute, +containing the value that was not found. + +=cut + +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 // '<undef>'); + $str .= "\n\n" . $self->stack_trace->as_string; + + return $str; +} +} + +=head2 C<Data::MultiValued::Exceptions::TagNotFound> + +Subclass of L</Data::MultiValued::Exceptions::NotFound>, for +tags. Stringifies to: + + tag not found: $value + + $stack_trace + +=cut + +package Data::MultiValued::Exceptions::TagNotFound;{ +use Moose; +extends 'Data::MultiValued::Exceptions::NotFound'; + +has '+message' => ( + default => 'tag not found: ', +); +} + +=head2 C<Data::MultiValued::Exceptions::RangeNotFound> + +Subclass of L</Data::MultiValued::Exceptions::NotFound>, for +ranges. Stringifies to: + + no range found for value: $value + + $stack_trace + +=cut + +package Data::MultiValued::Exceptions::RangeNotFound;{ +use Moose; +extends 'Data::MultiValued::Exceptions::NotFound'; + +has '+message' => ( + default => 'no range found for value: ', +); +} + +=head2 C<Data::MultiValued::Exceptions::BadRange> + +Thrown when an invalid range is supplied to a method. An invalid range +is a range with C<from> greater than C<to>. + +Stringifies to: + + invalid range: $from, $to + + $stack_trace + +=cut + +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..8dd9933 --- /dev/null +++ b/lib/Data/MultiValued/RangeContainer.pm @@ -0,0 +1,287 @@ +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; + +# ABSTRACT: container for ranged values + +=head1 DESCRIPTION + +Please don't use this module directly, use L<Data::MultiValued::Ranges>. + +This module implements the storage for ranged data. It's similar to +L<Array::IntSpan>, but simpler (and slower). + +A range is defined by a pair of numbers, C<from> and C<to>, and it +contains C<< Num $x : $min <= $x < $max >>. C<undef> is treated as +"inf" (negative infinity if used as C<from> or C<at>, positive +infinity if used as C<to>). + +The internal representation of a range is a hash with three keys, +C<from> C<to> C<value>. + +=cut + +has _storage => ( + is => 'rw', + isa => ArrayRef[ + Dict[ + from => Num|Undef, + to => Num|Undef, + value => Any, + ], + ], + init_arg => undef, + default => sub { [ ] }, +); + +=method C<get> + + my $value = $obj->get({ at => $point }); + +Retrieves the range that includes the given point. Throws a +L<Data::MultiValued::Exceptions::RangeNotFound|Data::MultiValued::Exceptions/Data::MultiValued::Exceptions::RangeNotFound> +exception if no range includes the point. + +=cut + +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; +} + +# a binary search would be a good idea. + +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; +} + +# this is quite probably uselessly slow: we don't really need all of +# @before and @after, we just need to know if they're not empty; also, +# a binary search would be a good idea. + +sub _partition_slots { + my ($self,$from,$to) = @_; + + my (@before,@overlap,@after); + my $st=$self->_storage; + + for my $idx (0..$#$st) { + my $slot = $st->[$idx]; + + 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; +} + +=method C<get_or_create> + + $obj->get_or_create({ from => $min, to => $max }); + +Retrieves the range that has the given extremes. If no such range +exists, creates a new range, splicing any existing overlapping range, +and returns it. Throws +L<Data::MultiValued::Exceptions::BadRange|Data::MultiValued::Exceptions/Data::MultiValued::Exceptions::BadRange> +if C<< $min > $max >>. + +=cut + +sub get_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; +} + +=method C<clear> + + $obj->clear({ from => $min, to => $max }); + +Removes the range that has the given extremes. If no such range +exists, splices any existing overlapping range so that C<< +$obj->get({at => $point }) >> for any C<< $min <= $point < $max >> +will die. + +Throws +L<Data::MultiValued::Exceptions::BadRange|Data::MultiValued::Exceptions/Data::MultiValued::Exceptions::BadRange> +if C<< $min > $max >>. + +=cut + +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); +} + +# Most of the splicing mechanics is here. Given a range and something +# to put in it, do "the right thing" + +sub _splice_slot { + my ($self,$from,$to,$new) = @_; + + # if !$new, it's like C<splice> without a replacement list: we + # just delete the range + + if (!@{$self->_storage}) { # empty, just store + push @{$self->_storage},$new if $new; + return $new; + } + + my ($before,$overlap,$after) = $self->_partition_slots($from,$to); + + if (!@$before && !@$overlap) { + # nothing before, nothing overlapping: put $new at the beginning + unshift @{$self->_storage},$new if $new; + return $new; + } + if (!@$after && !@$overlap) { + # nothing after, nothing overlapping: put $new at the end + push @{$self->_storage},$new if $new; + return $new; + } + + # ok, we have to insert in the middle of things, and maybe we have + # to trim existing ranges + + my $first_to_replace; + my $how_many = @$overlap; + + my @replacement = $new ? ($new) : (); + + if ($how_many > 0) { # we have to splice + # by costruction, the first and the last may have to be split, all + # others must be removed + $first_to_replace = $overlap->[0]; + my $last_to_replace = $overlap->[-1]; + my $first = $self->_storage->[$first_to_replace]; + my $last = $self->_storage->[$last_to_replace]; + + # does the first overlapping range need trimming? + 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}, + } + } + # does the last overlapping range need trimming? + 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}, + } + } + } + else { + # no overlaps, just insert between @before and @after + $first_to_replace = $before->[-1]+1; + } + + splice @{$self->_storage}, + $first_to_replace,$how_many, + @replacement; + + return $new; +} + +=method C<all_ranges> + + my @ranges = $obj->all_ranges; + +Returns all the ranges defined in this object, as a list of 2-elements +arrayrefs. + +=cut + +sub all_ranges { + my ($self) = @_; + + return map { [ $_->{from}, $_->{to} ] } @{$self->_storage}; +} + +1; diff --git a/lib/Data/MultiValued/Ranges.pm b/lib/Data/MultiValued/Ranges.pm new file mode 100644 index 0000000..aed29f4 --- /dev/null +++ b/lib/Data/MultiValued/Ranges.pm @@ -0,0 +1,188 @@ +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 validity ranges + +=head1 SYNOPSIS + + use Data::MultiValued::Ranges; + + my $obj = Data::MultiValued::Ranges->new(); + $obj->set({ + from => 10, + to => 20, + value => 'foo', + }); + say $obj->get({at => 15}); # prints 'foo' + say $obj->get({at => 35}); # dies + +=cut + +has _storage => ( + is => 'rw', + isa => class_type('Data::MultiValued::RangeContainer'), + init_arg => undef, + lazy_build => 1, +); + +sub _build__storage { + Data::MultiValued::RangeContainer->new(); +} + +=method C<set> + + $obj->set({ from => $min, to => $max, value => $the_value }); + +Stores the given value for the given range. Throws +L<Data::MultiValued::Exceptions::BadRange|Data::MultiValued::Exceptions/Data::MultiValued::Exceptions::BadRange> +if C<< $min > $max >>. + +The range is defined as C<< Num $x : $min <= $x < $max >>. A C<< from +=> undef >> means "from -Inf", and a C<< to => undef >> means "to ++Inf". Not passing in C<from> or C<to> is equivalent to passing +C<undef>. + +If the given range intersects existing ranges, these are spliced to +avoid overlaps. In other words: + + $obj->set({ + from => 10, + to => 20, + value => 'foo', + }); + $obj->set({ + from => 15, + to => 25, + value => 'bar', + }); + say $obj->get({at => 12}); # prints 'foo' + say $obj->get({at => 15}); # prints 'bar' + say $obj->get({at => 25}); # dies + +No cloning is done: if you pass in a reference, the reference is +just stored. + +=cut + +sub set { + my ($self,%args) = validated_hash( + \@_, + from => { isa => Num|Undef, optional => 1, }, + to => { isa => Num|Undef, optional => 1, }, + value => { isa => Any, }, + ); + + $self->_storage->get_or_create(\%args) + ->{value} = $args{value}; +} + +=method C<get> + + my $value = $obj->get({ at => $point }); + +Retrieves the value for the given point. Throws a +L<Data::MultiValued::Exceptions::RangeNotFound|Data::MultiValued::Exceptions/Data::MultiValued::Exceptions::RangeNotFound> +exception if no ranges exist in this object that include the point +(remember that a range does not include its C<to> point). + +A C<< at => undef >> means "at -Inf". Not passing in C<at> is +equivalent to passing C<undef>. + +No cloning is done: if a reference was stored, you get it back +untouched. + +=cut + +sub get { + my ($self,%args) = validated_hash( + \@_, + at => { isa => Num|Undef, optional => 1, }, + ); + + $self->_storage->get(\%args) + ->{value}; +} + +=method C<clear> + + $obj->clear({ from => $min, to => $max }); + +Deletes all values for the given range. Throws +L<Data::MultiValued::Exceptions::BadRange|Data::MultiValued::Exceptions/Data::MultiValued::Exceptions::BadRange> +if C<< $min > $max >>. + +A C<< from => undef >> means "from -Inf", and a C<< to => undef >> +means "to +Inf". Not passing in C<from> or C<to> is equivalent to +passing C<undef>. Thus, C<< $obj->clear() >> clears everything. + +If the given range intersects existing ranges, these are spliced. In +other words: + + $obj->set({ + from => 10, + to => 20, + value => 'foo', + }); + $obj->clear({ + from => 15, + to => 25, + }); + say $obj->get({at => 12}); # prints 'foo' + say $obj->get({at => 15}); # dies + +=cut + +sub clear { + my ($self,%args) = validated_hash( + \@_, + from => { isa => Num|Undef, optional => 1, }, + to => { isa => Num|Undef, optional => 1, }, + ); + + $self->_storage->clear(\%args); +} + +=head1 Serialisation helpers + +These are used through +L<Data::MultiValued::UglySerializationHelperRole>. + +=head2 C<_rebless_storage> + +Blesses the storage into L<Data::MultiValued::RangeContainer>. + +=cut + +sub _rebless_storage { + my ($self) = @_; + + bless $self->{_storage},'Data::MultiValued::RangeContainer'; +} + + +=head2 C<_as_hash> + +Returns the internal representation with no blessed hashes, with as +few copies as possible. + +=cut + +sub _as_hash { + my ($self) = @_; + + my %ret = %{$self->_storage}; + return {_storage=>\%ret}; +} + +=head1 SEE ALSO + +L<Data::MultiValued::RangeContainer>, L<Data::MultiValued::Exceptions> + +=cut + +1; diff --git a/lib/Data/MultiValued/TagContainer.pm b/lib/Data/MultiValued/TagContainer.pm new file mode 100644 index 0000000..fe1a794 --- /dev/null +++ b/lib/Data/MultiValued/TagContainer.pm @@ -0,0 +1,171 @@ +package Data::MultiValued::TagContainer; +use Moose; +use Moose::Util::TypeConstraints; +use MooseX::Types::Moose qw(HashRef); +use Data::MultiValued::Exceptions; + +# ABSTRACT: container for tagged values + +=head1 DESCRIPTION + +Please don't use this module directly, use L<Data::MultiValued::Tags>. + +This module implements the storage for tagged data. It's almost +exactly a hash, the main difference being that C<undef> is a valid key +and it's distinct from the empty string. + +Another difference is that you get an exception if you try to access a +tag that's not there. + +Data is kept in "storage cells", as created by +L</_create_new_inferior> (by default, a hashref). + +=cut + +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', + all_tags => 'keys', + }, +); + +has _default_tag => ( + is => 'rw', + init_arg => undef, + predicate => '_has_default_tag', + clearer => '_clear_default_tag', +); + +=method C<get> + + my $value = $obj->get({ tag => $the_tag }); + +Retrieves the "storage cell" for the given tag. Throws a +L<Data::MultiValued::Exceptions::TagNotFound|Data::MultiValued::Exceptions/Data::MultiValued::Exceptions::TagNotFound> +exception if the tag does not exists in this object. + +Not passing in a C<tag> is equivalent to passing in C<< tag => undef +>>. + +=cut + +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); +} + +=method C<get_or_create> + + $obj->get_or_create({ tag => $the_tag }); + +Retrieves the "storage cell" for the given tag. If the tag does not +exist, creates a new cell (see L</_create_new_inferior>), sets it for +the tag, and returns it. + +Not passing in a C<tag> is equivalent to passing in C<< tag => undef +>>. + +=cut + +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({}); +} + +=method C<clear> + + $obj->clear({ tag => $the_tag }); + +Deletes the given tag and all data associated with it. Does not throw +exceptions: if the tag does not exist, nothing happens. + +Not passing in a C<tag>, or passing C<< tag => undef >>, clears +everything. If you want to only clear the C<undef> tag, you may call +C<_clear_default_tag> (which is considered a "protected" method). + +=cut + +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; +} + +=method C<all_tags> + + my @tags = $obj->all_tags; + +Returns all the tags defined in this object. Does not return the +C<undef> tag. + +=method C<_create_new_inferior> + +Returns a new "storage cell", by default an empty hashref. See +L<Data::MultiValued::TagContainerForRanges> for an example of use. + +=cut + +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..8e3c2b9 --- /dev/null +++ b/lib/Data/MultiValued/TagContainerForRanges.pm @@ -0,0 +1,80 @@ +package Data::MultiValued::TagContainerForRanges; +use Moose; +use MooseX::Types::Moose qw(HashRef); +use Moose::Util::TypeConstraints; +use Data::MultiValued::RangeContainer; + +# ABSTRACT: container for tagged values that are ranged containers + +=head1 DESCRIPTION + +Please don't use this module directly, use +L<Data::MultiValued::TagsAndRanges>. + +This module is a subclass of L<Data::MultiValued::TagContainer>, which +only allows instances of L<Data::MultiValued::RangeContainer> as +"storage cells". + +=cut + +extends 'Data::MultiValued::TagContainer'; + +has '+_storage' => ( + isa => HashRef[class_type('Data::MultiValued::RangeContainer')], +); + +has '+_default_tag' => ( + isa => class_type('Data::MultiValued::RangeContainer'), +); + +=method C<_create_new_inferior> + +Returns a new L<Data::MultiValued::RangeContainer> instance. + +=cut + +sub _create_new_inferior { + Data::MultiValued::RangeContainer->new(); +} + +=head1 Serialisation helpers + +These are used through +L<Data::MultiValued::UglySerializationHelperRole>. + +=head2 C<_rebless_storage> + +Blesses the "storage cells" into L<Data::MultiValued::RangeContainer>. + +=cut + +sub _rebless_storage { + my ($self) = @_; + bless $_,'Data::MultiValued::RangeContainer' + for values %{$self->{_storage}}; + bless $self->{_default_tag},'Data::MultiValued::RangeContainer'; + return; +} + +=head2 C<_as_hash> + +Returns the internal representation with no blessed hashes, with as +few copies as possible. + +=cut + +sub _as_hash { + my ($self) = @_; + my %st; + for my $k (keys %{$self->_storage}) { + my %v = %{$self->_storage->{$k}}; + $st{$k}=\%v; + } + 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..640db40 --- /dev/null +++ b/lib/Data/MultiValued/Tags.pm @@ -0,0 +1,146 @@ +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 + +=head1 SYNOPSIS + + use Data::MultiValued::Tags; + + my $obj = Data::MultiValued::Tags->new(); + $obj->set({ + tag => 'tag1', + value => 'a string', + }); + say $obj->get({tag=>'tag1'}); # prints 'a string' + say $obj->get({tag=>'tag2'}); # dies + +=cut + +has _storage => ( + is => 'rw', + isa => class_type('Data::MultiValued::TagContainer'), + init_arg => undef, + lazy_build => 1, +); + +sub _build__storage { + Data::MultiValued::TagContainer->new(); +} + +=method C<set> + + $obj->set({ tag => $the_tag, value => $the_value }); + +Stores the given value for the given tag. Replaces existing +values. Does not throw exceptions. + +Not passing in a C<tag> is equivalent to passing in C<< tag => undef +>>. + +No cloning is done: if you pass in a reference, the reference is +just stored. + +=cut + +sub set { + my ($self,%args) = validated_hash( + \@_, + tag => { isa => Str, optional => 1, }, + value => { isa => Any, }, + ); + + $self->_storage->get_or_create(\%args) + ->{value} = $args{value}; +} + +=method C<get> + + my $value = $obj->get({ tag => $the_tag }); + +Retrieves the value for the given tag. Throws a +L<Data::MultiValued::Exceptions::TagNotFound|Data::MultiValued::Exceptions/Data::MultiValued::Exceptions::TagNotFound> +exception if the tag does not exists in this object. + +Not passing in a C<tag> is equivalent to passing in C<< tag => undef +>>. + +No cloning is done: if a reference was stored, you get it back +untouched. + +=cut + +sub get { + my ($self,%args) = validated_hash( + \@_, + tag => { isa => Str, optional => 1, }, + ); + + $self->_storage->get(\%args) + ->{value}; +} + +=method C<clear> + + $obj->clear({ tag => $the_tag }); + +Deletes the given tag and all data associated with it. Does not throw +exceptions: if the tag does not exist, nothing happens. + +Not passing in a C<tag> clears everything. Yes, this means that there +is no way to just clear the value for the C<undef> tag. + +=cut + +sub clear { + my ($self,%args) = validated_hash( + \@_, + tag => { isa => Str, optional => 1, }, + ); + + $self->_storage->clear(\%args); +} + +=head1 Serialisation helpers + +These are used through +L<Data::MultiValued::UglySerializationHelperRole>. + +=head2 C<_rebless_storage> + +Blesses the storage into L<Data::MultiValued::TagContainer>. + +=cut + +sub _rebless_storage { + my ($self) = @_; + + bless $self->{_storage},'Data::MultiValued::TagContainer'; +} + +=head2 C<_as_hash> + +Returns the internal representation with no blessed hashes, with as +few copies as possible. + +=cut + +sub _as_hash { + my ($self) = @_; + + my %ret = %{$self->_storage}; + return {_storage=>\%ret}; +} + +=head1 SEE ALSO + +L<Data::MultiValued::TagContainer>, L<Data::MultiValued::Exceptions> + +=cut + +1; diff --git a/lib/Data/MultiValued/TagsAndRanges.pm b/lib/Data/MultiValued/TagsAndRanges.pm new file mode 100644 index 0000000..085b8c1 --- /dev/null +++ b/lib/Data/MultiValued/TagsAndRanges.pm @@ -0,0 +1,158 @@ +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 + +=head1 SYNOPSIS + + use Data::MultiValued::TagsAndRanges; + + my $obj = Data::MultiValued::TagsAndRanges->new(); + $obj->set({ + tag => 'tag1', + from => 10, + to => 20, + value => 'foo', + }); + say $obj->get({tag => 'tag1', at => 15}); # prints 'foo' + say $obj->get({tag => 'tag1', at => 35}); # dies + say $obj->get({tag => 'tag2', at => 15}); # dies + +=cut + +has _storage => ( + is => 'rw', + isa => class_type('Data::MultiValued::TagContainerForRanges'), + init_arg => undef, + lazy_build => 1, +); + +sub _build__storage { + Data::MultiValued::TagContainerForRanges->new(); +} + +=method C<set> + + $obj->set({ tag => $the_tag, from => $min, to => $max, value => $the_value }); + +Stores the given value for the given tag and range. Does not throw +exceptions. + +See L<Data::MultiValued::Tags/set> and +L<Data::MultiValued::Ranges/set> for more details. + +=cut + +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) + ->get_or_create(\%args) + ->{value} = $args{value}; +} + +=method C<get> + + my $value = $obj->get({ tag => $the_tag, at => $point }); + +Retrieves the value for the given tag and point. Throws a +L<Data::MultiValued::Exceptions::RangeNotFound|Data::MultiValued::Exceptions/Data::MultiValued::Exceptions::RangeNotFound> +exception if no ranges exist in this object that include the point, +and +L<Data::MultiValued::Exceptions::TagNotFound|Data::MultiValued::Exceptions/Data::MultiValued::Exceptions::TagNotFound> +exception if the tag does not exists in this object. + +See L<Data::MultiValued::Tags/get> and +L<Data::MultiValued::Ranges/get> for more details. + +=cut + +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}; +} + +=method C<clear> + + $obj->clear({ tag => $the_tag, from => $min, to => $max }); + +If a range is specified, deletes all values for the given range and +tag. If no range is specified, delete all values for the given tag. + +Does not throw exceptions. + +See L<Data::MultiValued::Tags/clear> and +L<Data::MultiValued::Ranges/clear> for more details. + +=cut + +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); + } +} + +=head1 Serialisation helpers + +These are used through +L<Data::MultiValued::UglySerializationHelperRole>. + +=head2 C<_rebless_storage> + +Blesses the storage into L<Data::MultiValued::TagContainerForRanges>, +then calls C<_rebless_storage> on it. + +=cut + +sub _rebless_storage { + my ($self) = @_; + + bless $self->{_storage},'Data::MultiValued::TagContainerForRanges'; + $self->_storage->_rebless_storage; +} + +=head2 C<_as_hash> + +Returns the internal representation with no blessed hashes, with as +few copies as possible. Depends on +L<Data::MultiValued::TagContainerForRanges/_as_hash>. + +=cut + +sub _as_hash { + my ($self) = @_; + + my $ret = $self->_storage->_as_hash; + return {_storage=>$ret}; +} + +1; diff --git a/lib/Data/MultiValued/UglySerializationHelperRole.pm b/lib/Data/MultiValued/UglySerializationHelperRole.pm new file mode 100644 index 0000000..19f1268 --- /dev/null +++ b/lib/Data/MultiValued/UglySerializationHelperRole.pm @@ -0,0 +1,111 @@ +package Data::MultiValued::UglySerializationHelperRole; +use Moose::Role; + +# ABSTRACT: only use this if you know what you're doing + +=head1 SYNOPSIS + + package My::Class; + use Moose; + use Data::MultiValued::AttributeTrait::Tags; + + with 'Data::MultiValued::UglySerializationHelperRole'; + + has tt => ( + is => 'rw', + isa => 'Int', + traits => ['MultiValued::Tags'], + default => 3, + predicate => 'has_tt', + clearer => 'clear_tt', + ); + +Later: + + my $json = JSON::XS->new->utf8; + my $obj = My::Class->new(rr=>'foo'); + + my $str = $json->encode($obj->as_hash); + + my $obj2 = My::Class->new_in_place($json->decode($str)); + + # $obj and $obj2 have the same contents + +=head1 DESCRIPTION + +This is an ugly hack. It pokes inside the internals of your objects, +and will break if you're not careful. It assumes that your instances +are hashref-based. It mostly assumes that you're not storing blessed +refs inside the multi-value attributes. It goes to these lengths to +give a decent serialisation performance, without lots of unnecessary +copies. Oh, and on de-serialise it will skip all type constraint +checking and bypass the accessors, so it may well give you an unusable +object. + +=method C<new_in_place> + + my $obj = My::Class->new_in_place($hashref); + +Directly C<bless>es the hashref into the class, then calls +C<_rebless_slot> on any multi-value attribute. + +This is very dangerous, don't try this at home without the supervision +of an adult. + +=cut + +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; +} + +=method C<as_hash> + + my $hashref = $obj->as_hash; + +Performs a shallow copy of the object's hash, then replaces the values +of all the multi-value slots with the results of calling C<_as_hash> +on the corresponding multi-value attribute. + +This is very dangerous, don't try this at home without the supervision +of an adult. + +=cut + +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; +} + +=head1 FINAL WARNING + + my $obj_clone = My::Class->new_in_place($obj->as_hash); + +This will create a shallow clone. Most internals will be +shared. Things may break. Just don't do it, C<dclone> the hashref, or +do something equivalent (as in the synopsis), instead. + +=cut + +1; diff --git a/t/json.t b/t/json.t new file mode 100644 index 0000000..d1162b3 --- /dev/null +++ b/t/json.t @@ -0,0 +1,68 @@ +#!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 $ropts={tag=>'something',from=>10,to=>20}; + +my $json = JSON::XS->new->utf8; +my $obj = Foo->new(rr=>'foo'); +$obj->tt_multi($opts,1234); +$obj->ttrr_multi($ropts,777); +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->ttrr_multi({at => 15}),$obj->ttrr_multi({at => 15}),'ttrr'); +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..2493aff --- /dev/null +++ b/t/moose-tagged.t @@ -0,0 +1,69 @@ +#!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', + multi_accessor => 'stuff_tagged', + multi_predicate => 'has_stuff_tagged', +); + +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_tagged($opts),'not has stuff tagged'); + ok(!$obj->has_other,'not has other'); + ok(!$obj->has_other_multi($opts),'not has other tagged'); + + $obj->stuff_tagged($opts,7); + $obj->other_multi($opts,'foo'); + + is($obj->stuff,3,'default'); + is($obj->stuff_tagged($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..e8f4c77 --- /dev/null +++ b/t/ranges-setting.t @@ -0,0 +1,105 @@ +#!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'; + + lives_ok { + $obj->set({ + from => 25, + to => 27, + value => [7,8,9], + }); + } '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'; + + cmp_deeply($obj->get({at => 25}), + [7,8,9], + 'getting 25'); + + 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(); |