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

# --8<--8<--8<--8<--
#
# Copyright (C) 2012 Smithsonian Astrophysical Observatory
#
# This file is part of MooX-Attributes-Shadow
#
# MooX-Attributes-Shadow is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 3 of the License, or (at
# your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program.  If not, see .
#
# -->8-->8-->8-->8--

package MooX::Attributes::Shadow;

use strict;
use warnings;

our $VERSION = '0.03';

use Carp;
use Params::Check qw[ check last_error ];
use Scalar::Util qw[ blessed ];

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 = 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 croak( "error parsing arguments: ", last_error, "\n" );


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

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

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

    }

    my $has = $container->can( 'has' )
      or 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 = blessed $contained || $contained;

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

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

    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 = blessed $container or
      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;
__END__