summaryrefslogtreecommitdiff
path: root/lib/Data/MultiValued/AttributeTrait.pm
diff options
context:
space:
mode:
Diffstat (limited to 'lib/Data/MultiValued/AttributeTrait.pm')
-rw-r--r--lib/Data/MultiValued/AttributeTrait.pm492
1 files changed, 492 insertions, 0 deletions
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;
generated by cgit v1.2.3 (git 2.46.0) at 2025-05-01 10:27:02 +0000