package Data::MultiValued::AttributeTrait;
{
$Data::MultiValued::AttributeTrait::VERSION = '0.0.1_4';
}
{
$Data::MultiValued::AttributeTrait::DIST = 'Data-MultiValued';
}
use Moose::Role;
use namespace::autoclean;
use Data::MultiValued::AttributeAccessors;
use MooseX::Types::Moose qw(Str);
use Try::Tiny;
use namespace::autoclean;
has 'full_storage_slot' => (
is => 'ro',
isa => Str,
lazy_build => 1,
);
sub _build_full_storage_slot { shift->name . '__MULTIVALUED_STORAGE__' }
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",
);
}
requires 'multivalue_storage_class';
requires 'opts_to_pass_set';
requires 'opts_to_pass_get';
around slots => sub {
my ($orig, $self) = @_;
return ($self->$orig(), $self->full_storage_slot);
};
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;
}
sub get_full_storage {
my ($self,$instance) = @_;
return $self->associated_class->get_meta_instance
->get_slot_value(
$instance,
$self->full_storage_slot,
);
}
sub full_storage {
my ($self,$instance) = @_;
return $self->get_full_storage($instance)
|| $self->set_full_storage($instance);
}
sub accessor_metaclass { 'Data::MultiValued::AttributeAccessors' }
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;
}
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);
}
}
sub raw_clear_value {
my ($self,$instance) = @_;
$self->associated_class->get_meta_instance
->deinitialize_slot(
$instance,
$self->name,
);
}
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 = {};
before get_value => sub {
my ($self,$instance) = @_;
$self->load_multi_value($instance,$dyn_opts);
};
sub get_multi_value {
my ($self,$instance,$opts) = @_;
local $dyn_opts = $opts;
return $self->get_value($instance);
}
after set_initial_value => sub {
my ($self,$instance,$value) = @_;
$self->store_multi_value($instance,$dyn_opts);
};
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);
}
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);
}
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);
}
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';
}
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;
}
sub _as_hash {
my ($self,$instance) = @_;
my $st = $self->get_full_storage($instance);
return unless $st;
return $st->_as_hash;
}
1;
__END__