add a function to more easily create metaclass/trait aliases

diff --git a/Changes b/Changes
index 0d8a3e7..c2983e9 100644 (file)
--- a/Changes
+++ b/Changes
@@ -18,6 +18,10 @@ next version
       - Make "use Moose -metaclass => 'Foo'" do alias resolution, like -traits
         does. (doy)
 
+    * Moose::Util
+      - Add functions meta_class_alias and meta_attribute_alias for creating
+        aliases for class and attribute metaclasses and metatraits. (doy)
+
 0.88 Fri Jul 24, 2009
     * Moose::Manual::Contributing
       - Re-write the Moose::Manual::Contributing document to reflect

diff --git a/lib/Moose/Manual/Delta.pod b/lib/Moose/Manual/Delta.pod
index cf98390..5fe7aea 100644 (file)
--- a/lib/Moose/Manual/Delta.pod
+++ b/lib/Moose/Manual/Delta.pod
@@ -21,6 +21,15 @@ send us a patch.
 C<< use Moose -metaclass => 'Foo' >> now does alias resolution, just like
 C<-traits> (and the C<metaclass> and C<traits> options to C<has>).
 
+Added two functions C<meta_class_alias> and C<meta_attribute_alias> to
+L<Moose::Util>, to simplify aliasing metaclasses and metatraits. This is
+a wrapper around the old
+
+  package Moose::Meta::Class::Custom::Trait::FooTrait;
+  sub register_implementation { 'My::Meta::Trait' }
+
+way of doing this.
+
 =head1 Version 0.84
 
 When an attribute generates I<no> accessors, we now warn. This is to help

diff --git a/lib/Moose/Util.pm b/lib/Moose/Util.pm
index 33b22b8..48dfc2b 100644 (file)
--- a/lib/Moose/Util.pm
+++ b/lib/Moose/Util.pm
@@ -24,6 +24,8 @@ my @exports = qw[
     resolve_metaclass_alias
     add_method_modifier
     english_list
+    meta_attribute_alias
+    meta_class_alias
 ];
 
 Sub::Exporter::setup_exporter({
@@ -148,6 +150,15 @@ sub resolve_metatrait_alias {
     return resolve_metaclass_alias( @_, trait => 1 );
 }
 
+sub _build_alias_package_name {
+    my ($type, $name, $trait) = @_;
+    return 'Moose::Meta::'
+         . $type
+         . '::Custom::'
+         . ( $trait ? 'Trait::' : '' )
+         . $name;
+}
+
 {
     my %cache;
 
@@ -158,12 +169,9 @@ sub resolve_metatrait_alias {
         return $cache{$cache_key}{$metaclass_name}
             if $cache{$cache_key}{$metaclass_name};
 
-        my $possible_full_name
-            = 'Moose::Meta::'
-            . $type
-            . '::Custom::'
-            . ( $options{trait} ? "Trait::" : "" )
-            . $metaclass_name;
+        my $possible_full_name = _build_alias_package_name(
+            $type, $metaclass_name, $options{trait}
+        );
 
         my $loaded_class = Class::MOP::load_first_existing_class(
             $possible_full_name,
@@ -216,6 +224,30 @@ sub _caller_info {
     return \%info;
 }
 
+sub _create_alias {
+    my ($type, $name, $trait, $for) = @_;
+    my $package = _build_alias_package_name($type, $name, $trait);
+    Class::MOP::Class->initialize($package)->add_method(
+        register_implementation => sub { $for }
+    );
+}
+
+sub meta_attribute_alias {
+    my ($to, $from) = @_;
+    $from ||= caller;
+    my $meta = Class::MOP::class_of($from);
+    my $trait = $meta->isa('Moose::Meta::Role');
+    _create_alias('Attribute', $to, $trait, $from);
+}
+
+sub meta_class_alias {
+    my ($to, $from) = @_;
+    $from ||= caller;
+    my $meta = Class::MOP::class_of($from);
+    my $trait = $meta->isa('Moose::Meta::Role');
+    _create_alias('Class', $to, $trait, $from);
+}
+
 1;
 
 __END__
@@ -318,6 +350,14 @@ Given a list of scalars, turns them into a proper list in English
 ("one and two", "one, two, three, and four"). This is used to help us
 make nicer error messages.
 
+=item B<meta_class_alias($to[, $from])>
+
+=item B<meta_attribute_alias($to[, $from])>
+
+Create an alias from the class C<$from> (or the current package, if
+C<$from> is unspecified), so that
+L<Moose/Metaclass and Trait Name Resolution> works properly.
+
 =back
 
 =head1 TODO

diff --git a/t/400_moose_util/006_create_alias.t b/t/400_moose_util/006_create_alias.t
new file mode 100644 (file)
index 0000000..bed8292
--- /dev/null
+++ b/t/400_moose_util/006_create_alias.t
@@ -0,0 +1,102 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 8;
+use Test::Moose qw(does_ok);
+
+BEGIN {
+    package Foo::Meta::Role;
+    use Moose::Role;
+    Moose::Util::meta_class_alias
+        FooRole => 'Foo::Meta::Role';
+
+    package Foo::Meta::Class;
+    use Moose;
+    extends 'Moose::Meta::Class';
+    with 'Foo::Meta::Role';
+    Moose::Util::meta_class_alias
+        FooClass => 'Foo::Meta::Class';
+
+    package Foo::Meta::Role::Attribute;
+    use Moose::Role;
+    Moose::Util::meta_attribute_alias
+        FooAttrRole => 'Foo::Meta::Role::Attribute';
+
+    package Foo::Meta::Attribute;
+    use Moose;
+    extends 'Moose::Meta::Attribute';
+    with 'Foo::Meta::Role::Attribute';
+    Moose::Util::meta_attribute_alias
+        FooAttrClass => 'Foo::Meta::Attribute';
+
+    package Bar::Meta::Role;
+    use Moose::Role;
+    Moose::Util::meta_class_alias 'BarRole';
+
+    package Bar::Meta::Class;
+    use Moose;
+    extends 'Moose::Meta::Class';
+    with 'Bar::Meta::Role';
+    Moose::Util::meta_class_alias 'BarClass';
+
+    package Bar::Meta::Role::Attribute;
+    use Moose::Role;
+    Moose::Util::meta_attribute_alias 'BarAttrRole';
+
+    package Bar::Meta::Attribute;
+    use Moose;
+    extends 'Moose::Meta::Attribute';
+    with 'Bar::Meta::Role::Attribute';
+    Moose::Util::meta_attribute_alias 'BarAttrClass';
+}
+
+package FooWithMetaClass;
+use Moose -metaclass => 'FooClass';
+
+has bar => (
+    metaclass => 'FooAttrClass',
+    is        => 'ro',
+);
+
+
+package FooWithMetaTrait;
+use Moose -traits => 'FooRole';
+
+has bar => (
+    traits => [qw(FooAttrRole)],
+    is     => 'ro',
+);
+
+package BarWithMetaClass;
+use Moose -metaclass => 'BarClass';
+
+has bar => (
+    metaclass => 'BarAttrClass',
+    is        => 'ro',
+);
+
+
+package BarWithMetaTrait;
+use Moose -traits => 'BarRole';
+
+has bar => (
+    traits => [qw(BarAttrRole)],
+    is     => 'ro',
+);
+
+package main;
+my $fwmc_meta = FooWithMetaClass->meta;
+my $fwmt_meta = FooWithMetaTrait->meta;
+isa_ok($fwmc_meta, 'Foo::Meta::Class');
+isa_ok($fwmc_meta->get_attribute('bar'), 'Foo::Meta::Attribute');
+does_ok($fwmt_meta, 'Foo::Meta::Role');
+does_ok($fwmt_meta->get_attribute('bar'), 'Foo::Meta::Role::Attribute');
+
+my $bwmc_meta = BarWithMetaClass->meta;
+my $bwmt_meta = BarWithMetaTrait->meta;
+isa_ok($bwmc_meta, 'Bar::Meta::Class');
+isa_ok($bwmc_meta->get_attribute('bar'), 'Bar::Meta::Attribute');
+does_ok($bwmt_meta, 'Bar::Meta::Role');
+does_ok($bwmt_meta->get_attribute('bar'), 'Bar::Meta::Role::Attribute');