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


line stmt bran cond sub pod time code
1             package MooX::Attributes::Shadow;
2              
3             # ABSTRACT: shadow attributes of contained objects
4              
5 10     10   2023196 use strict;
  10         79  
  10         285  
6 10     10   57 use warnings;
  10         22  
  10         398  
7              
8             our $VERSION = '0.05';
9              
10 10     10   66 use Carp ();
  10         20  
  10         148  
11 10     10   4897 use Params::Check;
  10         40384  
  10         486  
12 10     10   85 use Scalar::Util;
  10         21  
  10         385  
13              
14 10     10   61 use Exporter 'import';
  10         36  
  10         3777  
15              
16             our %EXPORT_TAGS = ( all => [ qw( shadow_attrs shadowed_attrs xtract_attrs ) ],
17             );
18             Exporter::export_ok_tags('all');
19              
20             my %MAP;
21              
22             ## no critic (ProhibitAccessOfPrivateData)
23              
24             sub shadow_attrs {
25              
26 16     16 1 1158 my $contained = shift;
27              
28 16         49 my $container = caller;
29              
30             my $args = Params::Check::check( {
31             fmt => {
32 11     11   1070 allow => sub { ref $_[0] eq 'CODE' }
33             },
34              
35 7 100 66 7   706 attrs => { allow => sub { 'ARRAY' eq ref $_[0] && @{ $_[0] }
  5         30  
36             or 'HASH' eq ref $_[0] },
37             },
38 16 100       596 private => { default => 1 },
39             instance => {},
40             },
41             {@_} ) or Carp::croak( "error parsing arguments: ", Params::Check::last_error, "\n" );
42              
43              
44 15 100       529 unless ( exists $args->{attrs} ) {
45              
46 9         20 $args->{attrs} = [ eval { $contained->shadowable_attrs } ];
  9         51  
47              
48 9 100       140 Carp::croak( "must specify attrs or call shadowable_attrs in shadowed class" )
49             if $@;
50              
51             }
52              
53 14 100       359 my $has = $container->can( 'has' )
54             or Carp::croak( "container class $container does not have a 'has' function.",
55             " Is it really a Moo class?" );
56              
57             my %attr =
58 20         64 'ARRAY' eq ref $args->{attrs} ? ( map { $_ => undef } @{$args->{attrs}} )
  12         37  
59 13 100       88 : %{$args->{attrs}};
  1         5  
60              
61 13         44 my %map;
62 13         77 while( my ( $attr, $alias ) = each %attr ) {
63              
64 22 100       5289 $alias = $args->{fmt} ? $args->{fmt}->( $attr ) : $attr
    100          
65             unless defined $alias;
66              
67 22 100       163 my $priv = $args->{private} ? "_shadow_${contained}_${alias}" : $alias;
68 22         59 $priv =~ s/::/_/g;
69 22         77 $map{$attr} = { priv => $priv, alias => $alias };
70              
71             ## no critic (ProhibitNoStrict)
72 10     10   98 no strict 'refs';
  10         25  
  10         5376  
73 22         102 $has->(
74             $priv => (
75             is => 'ro',
76             init_arg => $alias,
77             predicate => "_has_${priv}",
78             ) );
79              
80             }
81              
82 13 100       5696 if ( defined $args->{instance} ) {
83              
84 6         23 $MAP{$contained}{$container}{instance}{ $args->{instance} } = \%map;
85              
86             }
87              
88             else {
89              
90 7         28 $MAP{$contained}{$container}{default} = \%map;
91              
92             }
93              
94 13         59 return;
95             }
96              
97             sub _resolve_attr_env {
98              
99 28     28   72 my ( $contained, $container, $options ) = @_;
100              
101             # contained should be resolved into a class name
102 28   66     132 my $containedClass = Scalar::Util::blessed $contained || $contained;
103              
104             # allow $container to be either a class or an object
105 28   66     116 my $containerClass = Scalar::Util::blessed $container || $container;
106              
107             my $map = defined $options->{instance}
108             ? $MAP{$containedClass}{$containerClass}{instance}{$options->{instance}}
109 28 100       121 : $MAP{$containedClass}{$containerClass}{default};
110              
111 28 100       251 Carp::croak( "attributes must first be shadowed using ${containedClass}::shadow_attrs\n" )
112             unless defined $map;
113              
114 27         63 return $map;
115             }
116              
117             # call as
118             # shadowed_attrs( $ContainedClass, [ $container ], \%options)
119              
120             sub shadowed_attrs {
121              
122 8     8 1 2531 my $containedClass = shift;
123 8 100       26 my $options = 'HASH' eq ref $_[-1] ? pop() : {};
124              
125 8 100       23 my $containerClass = @_ ? shift : caller();
126              
127 8         18 my $map = _resolve_attr_env( $containedClass, $containerClass, $options );
128              
129 8         24 return { map { $map->{$_}{alias}, $_ } keys %$map }
  16         86  
130             }
131              
132             # call as
133             # xtract_attrs( $ContainedClass, $container_obj, \%options)
134             sub xtract_attrs {
135              
136 21     21 1 45839 my $containedClass = shift;
137 21 100       86 my $options = 'HASH' eq ref $_[-1] ? pop() : {};
138 21         43 my $container = shift;
139 21 100       307 my $containerClass = Scalar::Util::blessed $container or
140             Carp::croak( "container_obj parameter is not a container object\n" );
141              
142 20         65 my $map = _resolve_attr_env( $containedClass, $containerClass, $options );
143              
144 19         38 my %attr;
145 19         81 while( my ($attr, $names) = each %$map ) {
146              
147 34         82 my $priv = $names->{priv};
148 34         79 my $has = "_has_${priv}";
149              
150 34 100       253 $attr{$attr} = $container->$priv
151             if $container->$has;
152             }
153              
154 19         266 return %attr;
155             }
156              
157             1;
158              
159             #
160             # This file is part of MooX-Attributes-Shadow
161             #
162             # This software is Copyright (c) 2018 by Smithsonian Astrophysical Observatory.
163             #
164             # This is free software, licensed under:
165             #
166             # The GNU General Public License, Version 3, June 2007
167             #
168              
169             __END__