File Coverage

blib/lib/MooX/Attributes/Shadow.pm

Criterion	Covered	Total	%
statement	70	70	100.0
branch	34	34	100.0
condition	6	9	66.6
subroutine	13	13	100.0
pod	3	3	100.0
total	126	129	97.6

package MooX::Attributes::Shadow;

# ABSTRACT: shadow attributes of contained objects

use strict;
use warnings;

our $VERSION = '0.04'; # TRIAL

use Carp ();
use Params::Check;
use Scalar::Util;

use Exporter 'import';

our %EXPORT_TAGS = ( all => [ qw( shadow_attrs shadowed_attrs xtract_attrs ) ],
                   );
Exporter::export_ok_tags('all');

my %MAP;

## no critic (ProhibitAccessOfPrivateData)

sub shadow_attrs {

    my $contained = shift;

    my $container = caller;

    my $args = Params::Check::check( {
            fmt => {
                allow => sub { ref $_[0] eq 'CODE' }
            },

            attrs => { allow => sub { 'ARRAY' eq ref $_[0] && @{ $_[0] }
                                        or 'HASH' eq ref $_[0] },
                     },
            private  => { default => 1 },
            instance => {},
        },
        {@_} ) or Carp::croak( "error parsing arguments: ", Params::Check::last_error, "\n" );


    unless ( exists $args->{attrs} ) {

        $args->{attrs} = [ eval { $contained->shadowable_attrs } ];

        Carp::croak( "must specify attrs or call shadowable_attrs in shadowed class" )
          if $@;

    }

    my $has = $container->can( 'has' )
      or Carp::croak( "container class $container does not have a 'has' function.",
                " Is it really a Moo class?" );

    my %attr =
      'ARRAY' eq ref $args->{attrs} ? ( map { $_ => undef } @{$args->{attrs}} )
                                   : %{$args->{attrs}};

    my %map;
    while( my ( $attr, $alias ) = each %attr ) {

        $alias = $args->{fmt} ? $args->{fmt}->( $attr ) : $attr
          unless defined $alias;

        my $priv  = $args->{private} ? "_shadow_${contained}_${alias}" : $alias;
        $priv =~ s/::/_/g;
        $map{$attr} = { priv => $priv, alias => $alias };

        ## no critic (ProhibitNoStrict)
        no strict 'refs';
        $has->(
            $priv => (
                is        => 'ro',
                init_arg  => $alias,
                predicate => "_has_${priv}",
            ) );

    }

    if ( defined $args->{instance} ) {

        $MAP{$contained}{$container}{instance}{ $args->{instance} } = \%map;

    }

    else {

        $MAP{$contained}{$container}{default} = \%map;

    }

    return;
}

sub _resolve_attr_env {

    my ( $contained, $container, $options ) = @_;

    # contained should be resolved into a class name
    my $containedClass = Scalar::Util::blessed $contained || $contained;

    # allow $container to be either a class or an object
    my $containerClass = Scalar::Util::blessed $container || $container;

    my $map = defined $options->{instance}
            ? $MAP{$containedClass}{$containerClass}{instance}{$options->{instance}}
            : $MAP{$containedClass}{$containerClass}{default};

    Carp::croak( "attributes must first be shadowed using ${containedClass}::shadow_attrs\n" )
      unless defined $map;

    return $map;
}

# call as
# shadowed_attrs( $ContainedClass, [ $container ], \%options)

sub shadowed_attrs {

    my $containedClass = shift;
    my $options = 'HASH' eq ref $_[-1] ? pop() : {};

    my $containerClass = @_ ? shift : caller();

    my $map = _resolve_attr_env( $containedClass, $containerClass, $options );

    return { map { $map->{$_}{alias}, $_ } keys %$map }
}

# call as
# xtract_attrs( $ContainedClass, $container_obj, \%options)
sub xtract_attrs {

    my $containedClass = shift;
    my $options = 'HASH' eq ref $_[-1] ? pop() : {};
    my $container = shift;
    my $containerClass = Scalar::Util::blessed $container or
      Carp::croak( "container_obj parameter is not a container object\n" );

    my $map = _resolve_attr_env( $containedClass, $containerClass, $options );

    my %attr;
    while( my ($attr, $names) = each %$map ) {

        my $priv = $names->{priv};
        my $has = "_has_${priv}";

        $attr{$attr} = $container->$priv
          if $container->$has;
    }

    return %attr;
}

1;

#
# This file is part of MooX-Attributes-Shadow
#
# 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__