package MooseX::Aliases::Meta::Trait::Attribute; BEGIN { $MooseX::Aliases::Meta::Trait::Attribute::VERSION = '0.10'; } use Moose::Role; use Moose::Util::TypeConstraints; Moose::Util::meta_attribute_alias 'Aliased'; # ABSTRACT: attribute metaclass trait for L subtype 'MooseX::Aliases::ArrayRef', as 'ArrayRef[Str]'; coerce 'MooseX::Aliases::ArrayRef', from 'Str', via { [$_] }; has alias => ( is => 'ro', isa => 'MooseX::Aliases::ArrayRef', auto_deref => 1, coerce => 1, predicate => 'has_alias', ); after install_accessors => sub { my $self = shift; my $class_meta = $self->associated_class; my $orig_name = $self->get_read_method; my $orig_meth = $self->get_read_method_ref; for my $alias ($self->alias) { $class_meta->add_method( $alias => MooseX::Aliases::_get_method_metaclass($orig_meth)->wrap( sub { shift->$orig_name(@_) }, # goto $_[0]->can($orig_name) ? package_name => $class_meta->name, name => $alias, aliased_from => $orig_name, ) ); } }; around initialize_instance_slot => sub { my $orig = shift; my $self = shift; my ($meta_instance, $instance, $params) = @_; return $self->$orig(@_) # don't run if we haven't set any aliases # don't run if init_arg is explicitly undef unless $self->has_alias && $self->has_init_arg; if (my @aliases = grep { exists $params->{$_} } @{ $self->alias }) { if (exists $params->{ $self->init_arg }) { push @aliases, $self->init_arg; } $self->associated_class->throw_error( 'Conflicting init_args: (' . join(', ', @aliases) . ')' ) if @aliases > 1; $params->{ $self->init_arg } = delete $params->{ $aliases[0] }; } $self->$orig(@_); }; no Moose::Role; 1; __END__ =pod =head1 NAME MooseX::Aliases::Meta::Trait::Attribute - attribute metaclass trait for L =head1 VERSION version 0.10 =head1 SYNOPSIS package MyApp::Role; use Moose::Role; use MooseX::Aliases; has this => ( isa => 'Str', is => 'rw', alias => 'that', ); =head1 DESCRIPTION This trait adds the C option to attribute creation. It is automatically applied to all attributes when C is run. =head1 SEE ALSO =over 4 =item * L =back =head1 AUTHORS =over 4 =item * Jesse Luehrs =item * Chris Prather =item * Justin Hunter =back =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2011 by Jesse Luehrs. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut