File Coverage

blib/lib/MooX/PDL/Role/Proxy.pm

Criterion	Covered	Total	%
statement	72	73	98.6
branch	3	4	75.0
condition	1	3	33.3
subroutine	21	22	95.4
pod	7	7	100.0
total	104	109	95.4

package MooX::PDL::Role::Proxy;

# ABSTRACT: treat a container of piddles as if it were a piddle

use 5.010;
use strict;
use warnings;

our $VERSION = '0.05';

use Types::Standard -types;

use PDL::Primitive ();
use Hash::Wrap;
use Scalar::Util ();

use Moo::Role;

use namespace::clean;

use MooX::TaggedAttributes -tags => [qw( piddle )];

# requires 'clone_with_piddles';










has _piddles => (
    is       => 'lazy',
    isa      => ArrayRef [Str],
    init_arg => undef,
    builder  => sub {
        my $self = shift;
        [ keys %{ $self->_tags->{piddle} } ];
    },
);

has _set_attr_subs => (
    is       => 'ro',
    isa      => HashRef,
    init_arg => undef,
    default  => sub { {} },
);


has _piddle_op_inplace => (
    is       => 'rwp',
    init_arg => undef,
    clearer  => 1,
    default  => 0
);

















sub _apply_to_tagged_attrs {
    my ( $self, $action ) = @_;

    my $inplace = $self->_piddle_op_inplace;

    my %attr = map {
        my $field = $_;
        $field => $action->( $self->$field, $inplace );
    } @{ $self->_piddles };

    if ( $self->_piddle_op_inplace ) {
        $self->_clear_piddle_op_inplace;
        $self->_set_attr( %attr );
        return $self;
    }

    return $self->clone_with_piddles( %attr );
}










sub inplace {
    my $self = shift;
    $self->_set__piddle_op_inplace( 1 );
    return $self;
}









sub is_inplace { !! $_[0]->__piddle_op_inplace }












sub copy {
    my $self = shift;
    return $self->clone_with_piddles( map { $_ => $self->$_->copy }
          @{ $self->_piddles } );
}









sub sever {
    my $self = shift;
    $self->$_->sever for @{ $self->_piddles };
}









sub index {
    my ( $self, $index ) = @_;
    return $self->_apply_to_tagged_attrs( sub { $_[0]->index( $index ) } );
}

# is there a use for this?
# sub which {
#     my ( $self, $which ) = @_;
#     return PDL::Primitive::which(
#         'CODE' eq ref $which
#         ? do { local $_ = $self; $which->() }
#         : $which
#     );
# }











sub at {
    my ( $self, @idx ) = @_;
    wrap_hash( { map { $_ => $self->$_->at( @idx ) } @{ $self->_piddles } } );
}









sub where {
    my ( $self, $where ) = @_;

    return $self->_apply_to_tagged_attrs( sub { $_[0]->where( $where ) } );
}












sub _set_attr {
    my ( $self, %attr ) = @_;
    my $subs = $self->_set_attr_subs;

    for my $key ( keys %attr ) {
        my $sub = $subs->{$key};

        if ( !defined $sub ) {
            Scalar::Util::weaken( $subs->{$key} = $self->can( "_set_${key}" )
                  // $self->can( $key ) );
            $sub = $subs->{$key};
        }

        $sub->( $self, $attr{$key} );
    }

    return $self;
}


1;

#
# This file is part of MooX-PDL-Role-Proxy
#
# This software is Copyright (c) 2018 by Smithsonian Astrophysical Observatory.
#
# This is free software, licensed under:
#
#   The GNU General Public License, Version 3, June 2007
#

__END__