added attribute metaclass support.

[gitmo/Mouse.git] / lib / Mouse / Util.pm

diff --git a/lib/Mouse/Util.pm b/lib/Mouse/Util.pm
index cf807da..1bb4d41 100644 (file)
--- a/lib/Mouse/Util.pm
+++ b/lib/Mouse/Util.pm
@@ -1,14 +1,12 @@
-#!/usr/bin/env perl
 package Mouse::Util;
 use strict;
 use warnings;
 use base qw/Exporter/;
 use Carp;
-use Scalar::Util qw(blessed looks_like_number openhandle reftype weaken);
 
 our @EXPORT_OK = qw(
-    blessed looks_like_number openhandle reftype weaken
     get_linear_isa
+    apply_all_roles
 );
 our %EXPORT_TAGS = (
     all  => \@EXPORT_OK,
@@ -16,12 +14,13 @@ our %EXPORT_TAGS = (
 
 BEGIN {
     my $impl;
-    if (\&mro::get_linear_isa) {
+    if ($] >= 5.009_005) {
+        require mro;
         $impl = \&mro::get_linear_isa;
     } else {
         my $loaded = do {
             local $SIG{__DIE__} = 'DEFAULT';
-            eval "use MRO::Compat (); 1";
+            eval "require MRO::Compat; 1";
         };
         if ($loaded) {
             $impl = \&mro::get_linear_isa;
@@ -49,14 +48,110 @@ BEGIN {
             $impl = $code;
         }
     }
+
     no strict 'refs';
     *{ __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);
 
     my @roles;
+
+    # Basis of Data::OptList
     my $max = scalar(@_);
     for (my $i = 0; $i < $max ; $i++) {
         if ($i + 1 < $max && ref($_[$i + 1])) {
@@ -100,26 +195,5 @@ Mouse::Util - features, with or without their dependencies
 
 =head3 get_linear_isa
 
-=head2 L<Scalar::Util>
-
-=head3 blessed
-
-=head3 looks_like_number
-
-=head3 reftype
-
-=head3 openhandle
-
-=head3 weaken
-
-C<weaken> I<must> be implemented in XS. If the user tries to use C<weaken>
-without L<Scalar::Util>, an error is thrown.
-
-=head2 Test::Exception
-
-=head3 throws_ok
-
-=head3 lives_ok
-
 =cut