From: Jesse Luehrs <doy@tozt.net>
Date: Wed, 22 Sep 2010 07:00:09 +0000 (-0500)
Subject: add trait_aliases option to Moose::Exporter
X-Git-Tag: 1.15~55
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=f88cfe7c09baf4da7359f8f0fe93851aa4fae9d0;p=gitmo%2FMoose.git

add trait_aliases option to Moose::Exporter
---

diff --git a/lib/Moose/Exporter.pm b/lib/Moose/Exporter.pm
index d1d4cab..4e87db8 100644
--- a/lib/Moose/Exporter.pm
+++ b/lib/Moose/Exporter.pm
@@ -12,6 +12,7 @@ use Class::MOP;
 use List::MoreUtils qw( first_index uniq );
 use Moose::Deprecated;
 use Moose::Util::MetaRole;
+use Scalar::Util qw(reftype);
 use Sub::Exporter 0.980;
 use Sub::Name qw(subname);
 
@@ -130,6 +131,30 @@ sub build_import_methods {
     }
 }
 
+sub _parse_trait_aliases {
+    my $class   = shift;
+    my ($package, $aliases) = @_;
+
+    my @ret;
+    for my $alias (@$aliases) {
+        my $name;
+        if (ref($alias)) {
+            reftype($alias) eq 'ARRAY'
+                or Moose->throw_error(reftype($alias) . " references are not "
+                                    . "valid arguments to the 'trait_aliases' "
+                                    . "option");
+
+            ($alias, $name) = @$alias;
+        }
+        else {
+            ($name = $alias) =~ s/.*:://;
+        }
+        push @ret, subname "${package}::${name}" => sub () { $alias };
+    }
+
+    return @ret;
+}
+
 sub _make_sub_exporter_params {
     my $class           = shift;
     my $packages        = shift;
@@ -168,7 +193,10 @@ sub _make_sub_exporter_params {
             );
         }
 
-        for my $name ( @{ $args->{as_is} } ) {
+        my @extra_exports = $class->_parse_trait_aliases(
+            $package, $args->{trait_aliases},
+        );
+        for my $name ( @{ $args->{as_is} }, @extra_exports ) {
             my ( $sub, $coderef_name );
 
             if ( ref $name ) {
@@ -678,6 +706,14 @@ removed by the C<unimport> method. The reason for this is we cannot know if
 the caller I<also> explicitly imported the sub themselves, and therefore wants
 to keep it.
 
+=item * trait_aliases => [ ... ]
+
+This is a list of package names which should have shortened alias exported,
+similar to the functionality of L<aliased>. Each element in the list can be
+either a package name, in which case the export will be named as the last
+namespace component of the package, or an arrayref, whose first element is the
+package to alias to, and second element is the alias to export.
+
 =item * also => $name or \@names
 
 This is a list of modules which contain functions that the caller
diff --git a/t/050_metaclasses/061_moose_exporter_trait_aliases.t b/t/050_metaclasses/061_moose_exporter_trait_aliases.t
new file mode 100644
index 0000000..e64c882
--- /dev/null
+++ b/t/050_metaclasses/061_moose_exporter_trait_aliases.t
@@ -0,0 +1,90 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More;
+use Test::Moose;
+use Test::Exception;
+
+{
+    package Attribute::Trait::Awesome;
+    use Moose::Role;
+}
+
+BEGIN {
+    package Awesome::Exporter;
+    use Moose::Exporter;
+
+    Moose::Exporter->setup_import_methods(
+        trait_aliases => ['Attribute::Trait::Awesome'],
+    );
+}
+
+{
+    package Awesome;
+    use Moose;
+    BEGIN { Awesome::Exporter->import }
+
+    has foo => (
+        traits => [Awesome],
+        is     => 'ro',
+    );
+    ::does_ok(__PACKAGE__->meta->get_attribute('foo'), 'Attribute::Trait::Awesome');
+
+    no Moose;
+    BEGIN { Awesome::Exporter->unimport }
+
+    my $val = eval "Awesome";
+    ::like($@, qr/Bareword "Awesome" not allowed/, "unimported properly");
+    ::is($val, undef, "unimported properly");
+}
+
+BEGIN {
+    package Awesome2::Exporter;
+    use Moose::Exporter;
+
+    Moose::Exporter->setup_import_methods(
+        trait_aliases => [
+            [ 'Attribute::Trait::Awesome' => 'Awesome2' ],
+        ],
+    );
+}
+
+{
+    package Awesome2;
+    use Moose;
+    BEGIN { Awesome2::Exporter->import }
+
+    has foo => (
+        traits => [Awesome2],
+        is     => 'ro',
+    );
+    ::does_ok(__PACKAGE__->meta->get_attribute('foo'), 'Attribute::Trait::Awesome');
+
+    BEGIN { Awesome2::Exporter->unimport }
+
+    my $val = eval "Awesome2";
+    ::like($@, qr/Bareword "Awesome2" not allowed/, "unimported properly");
+    ::is($val, undef, "unimported properly");
+}
+
+{
+    package Awesome2::Rename;
+    use Moose;
+    BEGIN { Awesome2::Exporter->import(Awesome2 => { -as => 'emosewA' }) }
+
+    has foo => (
+        traits => [emosewA],
+        is     => 'ro',
+    );
+    ::does_ok(__PACKAGE__->meta->get_attribute('foo'), 'Attribute::Trait::Awesome');
+
+    BEGIN { Awesome2::Exporter->unimport }
+
+    { our $TODO; local $TODO = "unimporting renamed subs currently doesn't work";
+    my $val = eval "emosewA";
+    ::like($@, qr/Bareword "emosewA" not allowed/, "unimported properly");
+    ::is($val, undef, "unimported properly");
+    }
+}
+
+done_testing;