From: Tokuhiro Matsuno <tokuhirom@gp.ath.cx>
Date: Sun, 1 Mar 2009 14:41:54 +0000 (+0000)
Subject: added attribute metaclass support.
X-Git-Tag: 0.19~23
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=abfdffe0146e788b3b808398fb075231163c3948;p=gitmo%2FMouse.git

added attribute metaclass support.
This feature is required by MouseX::*
---

diff --git a/lib/Mouse.pm b/lib/Mouse.pm
index 737dfc9..4731125 100644
--- a/lib/Mouse.pm
+++ b/lib/Mouse.pm
@@ -32,13 +32,25 @@ sub has {
 
     my $names = shift;
     $names = [$names] if !ref($names);
+    my $metaclass = 'Mouse::Meta::Attribute';
+    my %options = @_;
+
+    if ( my $metaclass_name = delete $options{metaclass} ) {
+        my $new_class = Mouse::Util::resolve_metaclass_alias(
+            'Attribute',
+            $metaclass_name
+        );
+        if ( $metaclass ne $new_class ) {
+            $metaclass = $new_class;
+        }
+    }
 
     for my $name (@$names) {
         if ($name =~ s/^\+//) {
-            Mouse::Meta::Attribute->clone_parent($meta, $name, @_);
+            $metaclass->clone_parent($meta, $name, @_);
         }
         else {
-            Mouse::Meta::Attribute->create($meta, $name, @_);
+            $metaclass->create($meta, $name, @_);
         }
     }
 }
diff --git a/lib/Mouse/Util.pm b/lib/Mouse/Util.pm
index 33c51f1..1bb4d41 100644
--- a/lib/Mouse/Util.pm
+++ b/lib/Mouse/Util.pm
@@ -53,6 +53,99 @@ BEGIN {
     *{ __PACKAGE__ . '::get_linear_isa'} = $impl;
 }
 
+# taken from Class/MOP.pm
+{
+    my %cache;
+
+    sub resolve_metaclass_alias {
+        my ( $type, $metaclass_name, %options ) = @_;
+
+        my $cache_key = $type;
+        return $cache{$cache_key}{$metaclass_name}
+          if $cache{$cache_key}{$metaclass_name};
+
+        my $possible_full_name =
+            'Mouse::Meta::' 
+          . $type
+          . '::Custom::'
+          . $metaclass_name;
+
+        my $loaded_class =
+          load_first_existing_class( $possible_full_name,
+            $metaclass_name );
+
+        return $cache{$cache_key}{$metaclass_name} =
+            $loaded_class->can('register_implementation')
+          ? $loaded_class->register_implementation
+          : $loaded_class;
+    }
+}
+
+# taken from Class/MOP.pm
+sub _is_valid_class_name {
+    my $class = shift;
+
+    return 0 if ref($class);
+    return 0 unless defined($class);
+    return 0 unless length($class);
+
+    return 1 if $class =~ /^\w+(?:::\w+)*$/;
+
+    return 0;
+}
+
+# taken from Class/MOP.pm
+sub load_first_existing_class {
+    my @classes = @_
+      or return;
+
+    foreach my $class (@classes) {
+        unless ( _is_valid_class_name($class) ) {
+            my $display = defined($class) ? $class : 'undef';
+            confess "Invalid class name ($display)";
+        }
+    }
+
+    my $found;
+    my %exceptions;
+    for my $class (@classes) {
+        my $e = _try_load_one_class($class);
+
+        if ($e) {
+            $exceptions{$class} = $e;
+        }
+        else {
+            $found = $class;
+            last;
+        }
+    }
+    return $found if $found;
+
+    confess join(
+        "\n",
+        map {
+            sprintf( "Could not load class (%s) because : %s",
+                $_, $exceptions{$_} )
+          } @classes
+    );
+}
+
+# taken from Class/MOP.pm
+sub _try_load_one_class {
+    my $class = shift;
+
+    return if Mouse::is_class_loaded($class);
+
+    my $file = $class . '.pm';
+    $file =~ s{::}{/}g;
+
+    return do {
+        local $@;
+        eval { require($file) };
+        $@;
+    };
+}
+
 sub apply_all_roles {
     my $meta = Mouse::Meta::Class->initialize(shift);
 
diff --git a/t/044-attribute-metaclass.t b/t/044-attribute-metaclass.t
new file mode 100644
index 0000000..bd9ca8f
--- /dev/null
+++ b/t/044-attribute-metaclass.t
@@ -0,0 +1,55 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More tests => 2;
+use lib 't/lib';
+
+do {
+    package MouseX::AttributeHelpers::Number;
+    use Mouse;
+    extends 'Mouse::Meta::Attribute';
+
+    around 'create' => sub {
+        my ($next, @args) = @_;
+        my $attr = $next->(@args);
+        my %provides = %{$attr->{provides}};
+        my $method_constructors = {
+            add => sub {
+                my ($attr, $name) = @_;
+                return sub {
+                    $_[0]->$name( $_[0]->$name() + $_[1])
+                };
+            },
+        };
+        while (my ($name, $aliased) = each %provides) {
+            $attr->associated_class->add_method(
+                $aliased => $method_constructors->{$name}->($attr, $attr->name)
+            );
+        }
+        return $attr;
+    };
+
+    package # hide me from search.cpan.org
+        Mouse::Meta::Attribute::Custom::Number;
+    sub register_implementation { 'MouseX::AttributeHelpers::Number' }
+
+    1;
+
+    package Klass;
+    use Mouse;
+
+    has 'i' => (
+        metaclass => 'Number',
+        is => 'rw',
+        isa => 'Int',
+        provides => {
+            'add' => 'add_number'
+        },
+    );
+};
+
+can_ok 'Klass', 'add_number';
+my $k = Klass->new(i=>3);
+$k->add_number(4);
+is $k->i, 7;
+