File Coverage

blib/lib/MooX/Aliases.pm
Criterion Covered Total %
statement 71 73 97.2
branch 21 24 87.5
condition 8 9 88.8
subroutine 13 14 92.8
pod 0 6 0.0
total 113 126 89.6


line stmt bran cond sub pod time code
1             package MooX::Aliases;
2 8     8   283348 use strictures 1;
  8         45  
  8         167  
3              
4             our $VERSION = '0.001006';
5             $VERSION = eval $VERSION;
6              
7 8     8   702 use Carp;
  8         10  
  8         622  
8 8     8   4236 use Class::Method::Modifiers qw(install_modifier);
  8         10930  
  8         691  
9              
10             sub import {
11 10     10   1375 my ($class) = @_;
12 10         23 my $target = caller;
13              
14 8 50   8   45 my $around = do { no strict 'refs'; \&{"${target}::around"} }
  8         10  
  8         1078  
  10         15  
  10         11  
  10         64  
15             or croak "$target is not a Moo class or role";
16              
17             my $make_alias = sub {
18 26     26   128 my ($from, $to) = @_;
19 26 100       172 if (!$target->can($to)) {
20 1         188 croak "Cannot find method $to to alias";
21             }
22              
23 25 50   0 0 2342 eval qq{
  0     5 0 0  
  0     2 0 0  
  5     3 0 2033  
  5     21 0 56  
  2     2 0 58  
  2         14  
  3         196  
  3         60  
  21         13195  
  21         273  
  2         785  
  2         12  
24             sub ${target}::${from} {
25             goto &{\$_[0]->can("$to")};
26             };
27             1;
28             } or die "$@";
29 10         38 };
30              
31             {
32 8     8   40 no strict 'refs';
  8         11  
  8         3355  
  10         15  
33 10         12 *{"${target}::alias"} = $make_alias;
  10         92  
34             }
35              
36 10         13 my $installed_buildargs;
37             my %init_args;
38             install_modifier $target, 'around', 'has', sub {
39 20     20   4326 my $orig = shift;
40 20         79 my ($attr, %opts) = @_;
41              
42 20         51 my $aliases = delete $opts{alias};
43 20 100 100     153 $aliases = [ $aliases ]
44             if $aliases && !ref $aliases;
45              
46 20 100 100     103 return $orig->($attr, %opts)
47             unless $aliases && @$aliases;
48              
49 2         169 my $attr_name
50             = !ref $attr ? $attr
51 17 100       54 : @{$attr} == 1 ? $attr->[0]
    100          
52             : croak "Cannot make alias to list of attributes";
53              
54 16         39 $attr_name =~ s/^\+//;
55              
56 16 50       46 my $name = defined $opts{init_arg} ? $opts{init_arg} : $attr_name;
57 16         44 my @names = @$aliases;
58 16 100 66     73 if (!exists $opts{init_arg} || defined $opts{init_arg}) {
59 13         32 unshift @names, $name;
60             }
61 16         38 $init_args{$name} = \@names;
62              
63 16         117 my $out = $orig->($attr, %opts);
64              
65 16         109198 for my $alias (@$aliases) {
66 22         59 $make_alias->($alias => $attr_name);
67             }
68              
69 16 100       53 if (!$installed_buildargs) {
70 9         14 $installed_buildargs = 1;
71             $around->('BUILDARGS', sub {
72 14         19549 my $orig = shift;
73 14         27 my $self = shift;
74 14         94 my $args = $self->$orig(@_);
75 14         195 for my $attr (keys %init_args) {
76 27         65 my @init = grep { exists $args->{$_} } (@{$init_args{$attr}});
  55         104  
  27         50  
77 27 100       111 if (@init > 1) {
    100          
78 1         163 croak "Conflicting init_args: (" . join(', ', @init) . ")";
79             }
80             elsif (@init == 1) {
81 7         27 $args->{$attr} = delete $args->{$init[0]};
82             }
83             }
84 13         217 return $args;
85 9         80 });
86             }
87              
88 16         2027 return $out;
89 10         65 };
90             }
91              
92             1;
93              
94             __END__