X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=gitmo%2FMouse.git;a=blobdiff_plain;f=lib%2FMouse%2FUtil.pm;h=f24da52f53263a3a64f8fe3d00d7cb5d7c1b322a;hp=9f3ecf9eef6a3204718df0d9590b5727e3697d2c;hb=df6dd016657118a06b408d21767dbc9b4ca476b9;hpb=6cfa1e5e70616fb102915489c02d8347ffa912fb

diff --git a/lib/Mouse/Util.pm b/lib/Mouse/Util.pm
index 9f3ecf9..f24da52 100644
--- a/lib/Mouse/Util.pm
+++ b/lib/Mouse/Util.pm
@@ -1,22 +1,91 @@
 package Mouse::Util;
-use strict;
-use warnings;
-use base qw/Exporter/;
+use Mouse::Exporter; # enables strict and warnings
+
+BEGIN{
+    # Because Mouse::Util is loaded first in all the Mouse sub-modules,
+    # XS loader is placed here, not in Mouse.pm.
+
+    our $VERSION = '0.40';
+
+    my $need_pp = !!$ENV{MOUSE_PUREPERL};
+
+    if(!$need_pp && !exists $INC{'Mouse/PurePerl.pm'}){
+        local $@;
+        $need_pp = !eval{
+            require XSLoader;
+            XSLoader::load('Mouse', $VERSION);
+        };
+        warn $@ if $@; # for DEBUGGING
+    }
+
+    if($need_pp){
+        require 'Mouse/PurePerl.pm'; # we don't want to create its namespace
+    }
+}
+
+
 use Carp qw(confess);
-use B ();
-
-our @EXPORT_OK = qw(
-    load_class
-    is_class_loaded
-    get_linear_isa
-    apply_all_roles
-    get_code_info
-    not_supported
-);
-our %EXPORT_TAGS = (
-    all  => \@EXPORT_OK,
+use Scalar::Util qw(blessed);
+
+use constant _MOUSE_VERBOSE => !!$ENV{MOUSE_VERBOSE};
+
+Mouse::Exporter->setup_import_methods(
+    as_is => [qw(
+        find_meta
+        does_role
+        resolve_metaclass_alias
+        apply_all_roles
+        english_list
+
+        load_class
+        is_class_loaded
+
+        get_linear_isa
+        get_code_info
+
+        get_code_package
+
+        not_supported
+
+        does meta dump
+        _MOUSE_VERBOSE
+    )],
+    groups => {
+        default => [], # export no functions by default
+
+        # The ':meta' group is 'use metaclass' for Mouse
+        meta    => [qw(does meta dump _MOUSE_VERBOSE)],
+    },
 );
 
+# aliases as public APIs
+# it must be 'require', not 'use', because Mouse::Meta::Module depends on Mouse::Util
+require Mouse::Meta::Module; # for the entities of metaclass cache utilities
+
+BEGIN {
+    *class_of                    = \&Mouse::Meta::Module::class_of;
+    *get_metaclass_by_name       = \&Mouse::Meta::Module::get_metaclass_by_name;
+    *get_all_metaclass_instances = \&Mouse::Meta::Module::get_all_metaclass_instances;
+    *get_all_metaclass_names     = \&Mouse::Meta::Module::get_all_metaclass_names;
+}
+
+# Moose::Util compatible utilities
+
+sub find_meta{
+    return class_of( $_[0] );
+}
+
+sub does_role{
+    my ($class_or_obj, $role_name) = @_;
+
+    my $meta = class_of($class_or_obj);
+
+    (defined $role_name)
+        || ($meta || 'Mouse::Meta::Class')->throw_error("You must supply a role name to does()");
+
+    return defined($meta) && $meta->does_role($role_name);
+}
+
 BEGIN {
     my $impl;
     if ($] >= 5.009_005) {
@@ -60,49 +129,39 @@ BEGIN {
     *get_linear_isa = $impl;
 }
 
-{ # taken from Sub::Identify
-    sub get_code_info($) {
-        my ($coderef) = @_;
-        ref($coderef) or return;
-
-        my $cv = B::svref_2object($coderef);
-        $cv->isa('B::CV') or return;
 
-        my $gv = $cv->GV;
-        $gv->isa('B::GV') or return;
-
-        return ($gv->STASH->NAME, $gv->NAME);
-    }
-}
-
-# taken from Class/MOP.pm
+# taken from Mouse::Util (0.90)
 {
     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 $cache_key = $type . q{ } . ( $options{trait} ? '-Trait' : '' );
 
-        my $possible_full_name =
-            'Mouse::Meta::' 
-          . $type
-          . '::Custom::'
-          . $metaclass_name;
+        return $cache{$cache_key}{$metaclass_name} ||= do{
 
-        my $loaded_class =
-          load_first_existing_class( $possible_full_name,
-            $metaclass_name );
+            my $possible_full_name = join '::',
+                'Mouse::Meta', $type, 'Custom', ($options{trait} ? 'Trait' : ()), $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;
+                ? $loaded_class->register_implementation
+                : $loaded_class;
+        };
     }
 }
 
+# Utilities from Class::MOP
+
+sub get_code_info;
+sub get_code_package;
+
 # taken from Class/MOP.pm
 sub is_valid_class_name {
     my $class = shift;
@@ -120,7 +179,6 @@ sub load_first_existing_class {
     my @classes = @_
       or return;
 
-    my $found;
     my %exceptions;
     for my $class (@classes) {
         my $e = _try_load_one_class($class);
@@ -129,12 +187,11 @@ sub load_first_existing_class {
             $exceptions{$class} = $e;
         }
         else {
-            $found = $class;
-            last;
+            return $class;
         }
     }
-    return $found if $found;
 
+    # not found
     confess join(
         "\n",
         map {
@@ -145,6 +202,7 @@ sub load_first_existing_class {
 }
 
 # taken from Class/MOP.pm
+my %is_class_loaded_cache;
 sub _try_load_one_class {
     my $class = shift;
 
@@ -153,7 +211,7 @@ sub _try_load_one_class {
         confess "Invalid class name ($display)";
     }
 
-    return if is_class_loaded($class);
+    return undef if $is_class_loaded_cache{$class} ||= is_class_loaded($class);
 
     my $file = $class . '.pm';
     $file =~ s{::}{/}g;
@@ -174,42 +232,11 @@ sub load_class {
     return 1;
 }
 
-my %is_class_loaded_cache;
-sub is_class_loaded {
-    my $class = shift;
-
-    return 0 if ref($class) || !defined($class) || !length($class);
-
-    return 1 if exists $is_class_loaded_cache{$class};
-
-    # walk the symbol table tree to avoid autovififying
-    # \*{${main::}{"Foo::"}} == \*main::Foo::
-
-    my $pack = \*::;
-    foreach my $part (split('::', $class)) {
-        return 0 unless exists ${$$pack}{"${part}::"};
-        $pack = \*{${$$pack}{"${part}::"}};
-    }
-
-    # check for $VERSION or @ISA
-    return ++$is_class_loaded_cache{$class} if exists ${$$pack}{VERSION}
-             && defined *{${$$pack}{VERSION}}{SCALAR};
-    return ++$is_class_loaded_cache{$class} if exists ${$$pack}{ISA}
-             && defined *{${$$pack}{ISA}}{ARRAY};
-
-    # check for any method
-    foreach ( keys %{$$pack} ) {
-        next if substr($_, -2, 2) eq '::';
-        return ++$is_class_loaded_cache{$class} if defined *{${$$pack}{$_}}{CODE};
-    }
-
-    # fail
-    return 0;
-}
+sub is_class_loaded;
 
 
 sub apply_all_roles {
-    my $meta = Mouse::Meta::Class->initialize(shift);
+    my $applicant = blessed($_[0]) ? shift : Mouse::Meta::Class->initialize(shift);
 
     my @roles;
 
@@ -217,54 +244,142 @@ sub apply_all_roles {
     my $max = scalar(@_);
     for (my $i = 0; $i < $max ; $i++) {
         if ($i + 1 < $max && ref($_[$i + 1])) {
-            push @roles, [ $_[$i++] => $_[$i] ];
+            push @roles, [ $_[$i] => $_[++$i] ];
         } else {
-            push @roles, [ $_[$i] => {} ];
+            push @roles, [ $_[$i] => undef ];
         }
-    }
+        my $role_name = $roles[-1][0];
+        load_class($role_name);
 
-    foreach my $role_spec (@roles) {
-        Mouse::load_class( $role_spec->[0] );
+        my $metarole = get_metaclass_by_name($role_name);
+        ( $metarole && $metarole->isa('Mouse::Meta::Role') )
+            || $applicant->meta->throw_error("You can only consume roles, $role_name(".$role_name->meta.") is not a Mouse role");
     }
 
-    ( $_->[0]->can('meta') && $_->[0]->meta->isa('Mouse::Meta::Role') )
-        || confess("You can only consume roles, "
-        . $_->[0]
-        . " is not a Moose role")
-        foreach @roles;
-
     if ( scalar @roles == 1 ) {
-        my ( $role, $params ) = @{ $roles[0] };
-        $role->meta->apply( $meta, ( defined $params ? %$params : () ) );
+        my ( $role_name, $params ) = @{ $roles[0] };
+        get_metaclass_by_name($role_name)->apply( $applicant, defined $params ? $params : () );
     }
     else {
-        Mouse::Meta::Role->combine_apply($meta, @roles);
+        Mouse::Meta::Role->combine(@roles)->apply($applicant);
     }
     return;
 }
 
+# taken from Moose::Util 0.90
+sub english_list {
+    return $_[0] if @_ == 1;
+
+    my @items = sort @_;
+
+    return "$items[0] and $items[1]" if @items == 2;
+
+    my $tail = pop @items;
+
+    return join q{, }, @items, "and $tail";
+}
+
+
+# common utilities
+
 sub not_supported{
     my($feature) = @_;
 
     $feature ||= ( caller(1) )[3]; # subroutine name
 
-    local $Carp::CarpLevel = $Carp::CarpLevel + 2;
-    Carp::croak("Mouse does not currently support $feature");
+    local $Carp::CarpLevel = $Carp::CarpLevel + 1;
+    Carp::confess("Mouse does not currently support $feature");
+}
+
+# general meta() method
+sub meta :method{
+    return Mouse::Meta::Class->initialize(ref($_[0]) || $_[0]);
 }
 
+# general dump() method
+sub dump :method {
+    my($self, $maxdepth) = @_;
+
+    require 'Data/Dumper.pm'; # we don't want to create its namespace
+    my $dd = Data::Dumper->new([$self]);
+    $dd->Maxdepth(defined($maxdepth) ? $maxdepth : 2);
+    $dd->Indent(1);
+    return $dd->Dump();
+}
+
+# general does() method
+sub does :method;
+*does = \&does_role; # alias
+
 1;
 
 __END__
 
 =head1 NAME
 
-Mouse::Util - features, with or without their dependencies
+Mouse::Util - Features, with or without their dependencies
+
+=head1 VERSION
+
+This document describes Mouse version 0.40
 
 =head1 IMPLEMENTATIONS FOR
 
-=head2 L<MRO::Compat>
+=head2 Moose::Util
+
+=head3 C<find_meta>
+
+=head3 C<does_role>
+
+=head3 C<resolve_metaclass_alias>
+
+=head3 C<apply_all_roles>
+
+=head3 C<english_list>
+
+=head2 Class::MOP
+
+=head3 C<< is_class_loaded(ClassName) -> Bool >>
+
+Returns whether C<ClassName> is actually loaded or not. It uses a heuristic which
+involves checking for the existence of C<$VERSION>, C<@ISA>, and any
+locally-defined method.
+
+=head3 C<< load_class(ClassName) >>
+
+This will load a given C<ClassName> (or die if it is not loadable).
+This function can be used in place of tricks like
+C<eval "use $module"> or using C<require>.
+
+=head3 C<< Mouse::Util::class_of(ClassName or Object) >>
+
+=head3 C<< Mouse::Util::get_metaclass_by_name(ClassName) >>
+
+=head3 C<< Mouse::Util::get_all_metaclass_instances() >>
+
+=head3 C<< Mouse::Util::get_all_metaclass_names() >>
+
+=head2 MRO::Compat
+
+=head3 C<get_linear_isa>
+
+=head2 Sub::Identify
+
+=head3 C<get_code_info>
+
+=head1 UTILITIES FOR MOUSE
+
+=head3 C<not_supported>
+
+=head1 SEE ALSO
+
+L<Moose::Util>
+
+L<Class::MOP>
+
+L<Sub::Identify>
 
-=head3 get_linear_isa
+L<MRO::Compat>
 
 =cut