X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=gitmo%2FMouse.git;a=blobdiff_plain;f=lib%2FMouse%2FUtil.pm;h=eb72c43fda3e347039196c083170da1834b37cd5;hp=2f1018137e2bfcd58db838efb2469fd489f86337;hb=8f98ed261eac95dc093a9b6d22c462c790e63736;hpb=e0396a57ff4663622ba6862a3039d05c2514fe4b diff --git a/lib/Mouse/Util.pm b/lib/Mouse/Util.pm index 2f10181..eb72c43 100644 --- a/lib/Mouse/Util.pm +++ b/lib/Mouse/Util.pm @@ -2,19 +2,45 @@ package Mouse::Util; use strict; use warnings; use base qw/Exporter/; -use Carp; +use Carp qw(confess); +use B (); our @EXPORT_OK = qw( - get_linear_isa + find_meta + does_role + resolve_metaclass_alias + + load_class + is_class_loaded + apply_all_roles - version - authority - identifier + not_supported + + get_linear_isa + get_code_info ); our %EXPORT_TAGS = ( all => \@EXPORT_OK, ); +# Moose::Util compatible utilities + +sub find_meta{ + return Mouse::Module::class_of( $_[0] ); +} + +sub does_role{ + my ($class_or_obj, $role) = @_; + + my $meta = Mouse::Module::class_of($class_or_obj); + + return 0 unless defined $meta; + return 1 if $meta->does_role($role); + return 0; +} + + + BEGIN { my $impl; if ($] >= 5.009_005) { @@ -53,59 +79,59 @@ BEGIN { } } - no strict 'refs'; - *{ __PACKAGE__ . '::get_linear_isa'} = $impl; -} -{ # adapted from Class::MOP::Module - - sub version { no strict 'refs'; ${shift->name.'::VERSION'} } - sub authority { no strict 'refs'; ${shift->name.'::AUTHORITY'} } - sub identifier { - my $self = shift; - join '-' => ( - $self->name, - ($self->version || ()), - ($self->authority || ()), - ); - } + no warnings 'once'; + *get_linear_isa = $impl; } -# taken from Class/MOP.pm -{ - my %cache; - - sub resolve_metaclass_alias { - my ( $type, $metaclass_name, %options ) = @_; +{ # taken from Sub::Identify + sub get_code_info($) { + my ($coderef) = @_; + ref($coderef) or return; - my $cache_key = $type; - return $cache{$cache_key}{$metaclass_name} - if $cache{$cache_key}{$metaclass_name}; + my $cv = B::svref_2object($coderef); + $cv->isa('B::CV') or return; - my $possible_full_name = - 'Mouse::Meta::' - . $type - . '::Custom::' - . $metaclass_name; + my $gv = $cv->GV; + $gv->isa('B::GV') or return; + + return ($gv->STASH->NAME, $gv->NAME); + } +} - my $loaded_class = - load_first_existing_class( $possible_full_name, - $metaclass_name ); +# taken from Mouse::Util (0.90) +{ + my %cache; - return $cache{$cache_key}{$metaclass_name} = - $loaded_class->can('register_implementation') - ? $loaded_class->register_implementation - : $loaded_class; + sub resolve_metaclass_alias { + my ( $type, $metaclass_name, %options ) = @_; + + my $cache_key = $type . q{ } . ( $options{trait} ? '-Trait' : '' ); + + return $cache{$cache_key}{$metaclass_name} ||= do{ + + 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 + ); + + $loaded_class->can('register_implementation') + ? $loaded_class->register_implementation + : $loaded_class; + }; } } # taken from Class/MOP.pm -sub _is_valid_class_name { +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+)*$/; @@ -117,13 +143,6 @@ 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) { @@ -152,7 +171,12 @@ sub load_first_existing_class { sub _try_load_one_class { my $class = shift; - return if Mouse::is_class_loaded($class); + unless ( is_valid_class_name($class) ) { + my $display = defined($class) ? $class : 'undef'; + confess "Invalid class name ($display)"; + } + + return if is_class_loaded($class); my $file = $class . '.pm'; $file =~ s{::}{/}g; @@ -164,6 +188,50 @@ sub _try_load_one_class { }; } + +sub load_class { + my $class = shift; + my $e = _try_load_one_class($class); + confess "Could not load class ($class) because : $e" if $e; + + 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 $is_class_loaded_cache{$class}; + + # walk the symbol table tree to avoid autovififying + # \*{${main::}{"Foo::"}} == \*main::Foo:: + + my $pack = \%::; + foreach my $part (split('::', $class)) { + my $entry = \$pack->{$part . '::'}; + return 0 if ref($entry) ne 'GLOB'; + $pack = *{$entry}{HASH} or return 0; + } + + # check for $VERSION or @ISA + return ++$is_class_loaded_cache{$class} if exists $pack->{VERSION} + && defined *{$pack->{VERSION}}{SCALAR} && defined ${ $pack->{VERSION} }; + return ++$is_class_loaded_cache{$class} if exists $pack->{ISA} + && defined *{$pack->{ISA}}{ARRAY} && @{ $pack->{ISA} } != 0; + + # check for any method + foreach my $name( keys %{$pack} ) { + my $entry = \$pack->{$name}; + return ++$is_class_loaded_cache{$class} if ref($entry) ne 'GLOB' || defined *{$entry}{CODE}; + } + + # fail + return 0; +} + + sub apply_all_roles { my $meta = Mouse::Meta::Class->initialize(shift); @@ -177,18 +245,12 @@ sub apply_all_roles { } else { push @roles, [ $_[$i] => {} ]; } + my $role_name = $roles[-1][0]; + load_class($role_name); + ( $role_name->can('meta') && $role_name->meta->isa('Mouse::Meta::Role') ) + || $meta->throw_error("You can only consume roles, $role_name(".$role_name->meta.") is not a Mouse role"); } - foreach my $role_spec (@roles) { - Mouse::load_class( $role_spec->[0] ); - } - - ( $_->[0]->can('meta') && $_->[0]->meta->isa('Mouse::Meta::Role') ) - || croak("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 : () ) ); @@ -196,7 +258,16 @@ sub apply_all_roles { else { Mouse::Meta::Role->combine_apply($meta, @roles); } + return; +} + +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"); } 1;