File Coverage

blib/lib/MooX/Aliases.pm
Criterion Covered Total %
statement 65 65 100.0
branch 16 18 88.8
condition 2 3 66.6
subroutine 10 10 100.0
pod n/a
total 93 96 96.8


line stmt bran cond sub pod time code
1             package MooX::Aliases;
2 8     8   407670 use strictures 1;
  8         62  
  8         235  
3              
4             our $VERSION = '0.001004';
5             $VERSION = eval $VERSION;
6              
7 8     8   844 use Carp;
  8         16  
  8         1268  
8 8     8   5829 use Class::Method::Modifiers qw(install_modifier);
  8         15972  
  8         1319  
9              
10             sub import {
11 10     10   2402 my ($class) = @_;
12 10         30 my $target = caller;
13              
14 8 50   8   80 my $around = do { no strict 'refs'; \&{"${target}::around"} }
  8         16  
  8         1323  
  10         16  
  10         14  
  10         86  
15             or croak "$target is not a Moo class or role";
16              
17             my $make_alias = sub {
18 25     25   154 my ($from, $to) = @_;
19 25 100       175 if (!$target->can($to)) {
20 1         496 croak "Cannot find method $to to alias";
21             }
22              
23 8     8   82 no strict 'refs';
  8         15  
  8         1019  
24 24         166 *{"${target}::${from}"} = sub {
25 33     33   15924 goto &{$_[0]->can($to)};
  33         536  
26 24         108 };
27 10         131 };
28              
29             {
30 8     8   53 no strict 'refs';
  8         14  
  8         3938  
  10         19  
31 10         13 *{"${target}::alias"} = $make_alias;
  10         64  
32             }
33              
34 10         13 my $installed_buildargs;
35             my %init_args;
36             install_modifier $target, 'around', 'has', sub {
37 16     16   2594 my $orig = shift;
38 16         79 my ($attr, %opts) = @_;
39 16         39 $attr =~ s/^\+//;
40              
41 16         50 my $aliases = delete $opts{alias};
42 16 100       55 return $orig->($attr, %opts)
43             unless $aliases;
44              
45 15 100       72 $aliases = [ $aliases ]
46             if !ref $aliases;
47              
48 15 50       63 my $name = defined $opts{init_arg} ? $opts{init_arg} : $attr;
49 15         42 my @names = @$aliases;
50 15 100 66     76 if (!exists $opts{init_arg} || defined $opts{init_arg}) {
51 12         28 unshift @names, $name;
52             }
53 15         41 $init_args{$name} = \@names;
54              
55 15         85 my $out = $orig->($attr, %opts);
56              
57 15         132505 for my $alias (@$aliases) {
58 21         61 $make_alias->($alias => $attr);
59             }
60              
61 15 100       42 if (!$installed_buildargs) {
62 9         14 $installed_buildargs = 1;
63             $around->('BUILDARGS', sub {
64 14         24018 my $orig = shift;
65 14         34 my $self = shift;
66 14         118 my $args = $self->$orig(@_);
67 14         301 for my $attr (keys %init_args) {
68 25         32 my @init = grep { exists $args->{$_} } (@{$init_args{$attr}});
  51         133  
  25         66  
69 25 100       116 if (@init > 1) {
    100          
70 1         253 croak "Conflicting init_args: (" . join(', ', @init) . ")";
71             }
72             elsif (@init == 1) {
73 7         32 $args->{$attr} = delete $args->{$init[0]};
74             }
75             }
76 13         306 return $args;
77 9         64 });
78             }
79              
80 15         2325 return $out;
81 10         204 };
82             }
83              
84             1;
85              
86             __END__