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

package MooX::Aliases;
use strictures 1;

our $VERSION = '0.001006';
$VERSION = eval $VERSION;

use Carp;
use Class::Method::Modifiers qw(install_modifier);

sub import {
  my ($class) = @_;
  my $target = caller;

  my $around = do { no strict 'refs'; \&{"${target}::around"} }
    or croak "$target is not a Moo class or role";

  my $make_alias = sub {
    my ($from, $to) = @_;
    if (!$target->can($to)) {
      croak "Cannot find method $to to alias";
    }

    eval qq{
      sub ${target}::${from} {
        goto &{\$_[0]->can("$to")};
      };
      1;
    } or die "$@";
  };

  {
    no strict 'refs';
    *{"${target}::alias"} = $make_alias;
  }

  my $installed_buildargs;
  my %init_args;
  install_modifier $target, 'around', 'has', sub {
    my $orig = shift;
    my ($attr, %opts) = @_;

    my $aliases = delete $opts{alias};
    $aliases = [ $aliases ]
      if $aliases && !ref $aliases;

    return $orig->($attr, %opts)
      unless $aliases && @$aliases;

    my $attr_name
      = !ref $attr     ? $attr
      : @{$attr} == 1  ? $attr->[0]
      : croak "Cannot make alias to list of attributes";

    $attr_name =~ s/^\+//;

    my $name = defined $opts{init_arg} ? $opts{init_arg} : $attr_name;
    my @names = @$aliases;
    if (!exists $opts{init_arg} || defined $opts{init_arg}) {
      unshift @names, $name;
    }
    $init_args{$name} = \@names;

    my $out = $orig->($attr, %opts);

    for my $alias (@$aliases) {
      $make_alias->($alias => $attr_name);
    }

    if (!$installed_buildargs) {
      $installed_buildargs = 1;
      $around->('BUILDARGS', sub {
        my $orig = shift;
        my $self = shift;
        my $args = $self->$orig(@_);
        for my $attr (keys %init_args) {
          my @init = grep { exists $args->{$_} } (@{$init_args{$attr}});
          if (@init > 1) {
            croak "Conflicting init_args: (" . join(', ', @init) . ")";
          }
          elsif (@init == 1) {
            $args->{$attr} = delete $args->{$init[0]};
          }
        }
        return $args;
      });
    }

    return $out;
  };
}

1;

__END__