lib/Mouse/Util.pm

   1 package Mouse::Util;
   2 use strict;
   3 use warnings;
   4 use base qw/Exporter/;
   5 use Carp qw(confess);
   6 use B ();
   7
   8 our @EXPORT_OK = qw(
   9     find_meta
  10     does_role
  11     resolve_metaclass_alias
  12     english_list
  13
  14     load_class
  15     is_class_loaded
  16
  17     apply_all_roles
  18     not_supported
  19
  20     get_linear_isa
  21     get_code_info
  22 );
  23 our %EXPORT_TAGS = (
  24     all  => \@EXPORT_OK,
  25 );
  26
  27 # Moose::Util compatible utilities
  28
  29 sub find_meta{
  30     return Mouse::Meta::Module::class_of( $_[0] );
  31 }
  32
  33 sub does_role{
  34     my ($class_or_obj, $role) = @_;\r
  35 \r
  36     my $meta = Mouse::Meta::Module::class_of($class_or_obj);\r
  37 \r
  38     return 0 unless defined $meta;\r
  39     return 1 if $meta->does_role($role);\r
  40     return 0;
  41 }
  42
  43
  44
  45 BEGIN {
  46     my $impl;
  47     if ($] >= 5.009_005) {
  48         require mro;
  49         $impl = \&mro::get_linear_isa;
  50     } else {
  51         my $e = do {
  52             local $@;
  53             eval { require MRO::Compat };
  54             $@;
  55         };
  56         if (!$e) {
  57             $impl = \&mro::get_linear_isa;
  58         } else {
  59 #       VVVVV   CODE TAKEN FROM MRO::COMPAT   VVVVV
  60             my $_get_linear_isa_dfs; # this recurses so it isn't pretty
  61             $_get_linear_isa_dfs = sub {
  62                 no strict 'refs';
  63
  64                 my $classname = shift;
  65
  66                 my @lin = ($classname);
  67                 my %stored;
  68                 foreach my $parent (@{"$classname\::ISA"}) {
  69                     my $plin = $_get_linear_isa_dfs->($parent);
  70                     foreach  my $p(@$plin) {
  71                         next if exists $stored{$p};
  72                         push(@lin, $p);
  73                         $stored{$p} = 1;
  74                     }
  75                 }
  76                 return \@lin;
  77             };
  78 #       ^^^^^   CODE TAKEN FROM MRO::COMPAT   ^^^^^
  79             $impl = $_get_linear_isa_dfs;
  80         }
  81     }
  82
  83
  84     no warnings 'once';
  85     *get_linear_isa = $impl;
  86 }
  87
  88 { # taken from Sub::Identify
  89     sub get_code_info($) {\r
  90         my ($coderef) = @_;\r
  91         ref($coderef) or return;\r
  92
  93         my $cv = B::svref_2object($coderef);\r
  94         $cv->isa('B::CV') or return;
  95
  96         my $gv = $cv->GV;\r
  97         $gv->isa('B::GV') or return;\r
  98 \r
  99         return ($gv->STASH->NAME, $gv->NAME);\r
 100     }\r
 101 }
 102
 103 # taken from Mouse::Util (0.90)
 104 {
 105     my %cache;
 106
 107     sub resolve_metaclass_alias {\r
 108         my ( $type, $metaclass_name, %options ) = @_;\r
 109 \r
 110         my $cache_key = $type . q{ } . ( $options{trait} ? '-Trait' : '' );\r
 111
 112         return $cache{$cache_key}{$metaclass_name} ||= do{\r
 113 \r
 114             my $possible_full_name = join '::',
 115                 'Mouse::Meta', $type, 'Custom', ($options{trait} ? 'Trait' : ()), $metaclass_name
 116             ;
 117
 118             my $loaded_class = load_first_existing_class(\r
 119                 $possible_full_name,\r
 120                 $metaclass_name\r
 121             );\r
 122 \r
 123             $loaded_class->can('register_implementation')\r
 124                 ? $loaded_class->register_implementation\r
 125                 : $loaded_class;
 126         };\r
 127     }
 128 }
 129
 130 # taken from Class/MOP.pm
 131 sub is_valid_class_name {
 132     my $class = shift;
 133
 134     return 0 if ref($class);
 135     return 0 unless defined($class);
 136
 137     return 1 if $class =~ /^\w+(?:::\w+)*$/;
 138
 139     return 0;
 140 }
 141
 142 # taken from Class/MOP.pm
 143 sub load_first_existing_class {
 144     my @classes = @_
 145       or return;
 146
 147     my $found;
 148     my %exceptions;
 149     for my $class (@classes) {
 150         my $e = _try_load_one_class($class);
 151
 152         if ($e) {
 153             $exceptions{$class} = $e;
 154         }
 155         else {
 156             $found = $class;
 157             last;
 158         }
 159     }
 160     return $found if $found;
 161
 162     confess join(
 163         "\n",
 164         map {
 165             sprintf( "Could not load class (%s) because : %s",
 166                 $_, $exceptions{$_} )
 167           } @classes
 168     );
 169 }
 170
 171 # taken from Class/MOP.pm
 172 sub _try_load_one_class {
 173     my $class = shift;
 174
 175     unless ( is_valid_class_name($class) ) {
 176         my $display = defined($class) ? $class : 'undef';
 177         confess "Invalid class name ($display)";
 178     }
 179
 180     return if is_class_loaded($class);
 181
 182     my $file = $class . '.pm';
 183     $file =~ s{::}{/}g;
 184
 185     return do {
 186         local $@;
 187         eval { require($file) };
 188         $@;
 189     };
 190 }
 191
 192
 193 sub load_class {
 194     my $class = shift;
 195     my $e = _try_load_one_class($class);
 196     confess "Could not load class ($class) because : $e" if $e;
 197
 198     return 1;
 199 }
 200
 201 my %is_class_loaded_cache;
 202 sub is_class_loaded {
 203     my $class = shift;
 204
 205     return 0 if ref($class) || !defined($class) || !length($class);
 206
 207     return 1 if $is_class_loaded_cache{$class};
 208
 209     # walk the symbol table tree to avoid autovififying
 210     # \*{${main::}{"Foo::"}} == \*main::Foo::
 211
 212     my $pack = \%::;
 213     foreach my $part (split('::', $class)) {
 214         my $entry = \$pack->{$part . '::'};
 215         return 0 if ref($entry) ne 'GLOB';
 216         $pack = *{$entry}{HASH} or return 0;
 217     }
 218
 219     # check for $VERSION or @ISA
 220     return ++$is_class_loaded_cache{$class} if exists $pack->{VERSION}
 221              && defined *{$pack->{VERSION}}{SCALAR} && defined ${ $pack->{VERSION} };
 222     return ++$is_class_loaded_cache{$class} if exists $pack->{ISA}
 223              && defined *{$pack->{ISA}}{ARRAY} && @{ $pack->{ISA} } != 0;
 224
 225     # check for any method
 226     foreach my $name( keys %{$pack} ) {
 227         my $entry = \$pack->{$name};
 228         return ++$is_class_loaded_cache{$class} if ref($entry) ne 'GLOB' || defined *{$entry}{CODE};
 229     }
 230
 231     # fail
 232     return 0;
 233 }
 234
 235
 236 sub apply_all_roles {
 237     my $meta = Mouse::Meta::Class->initialize(shift);
 238
 239     my @roles;
 240
 241     # Basis of Data::OptList
 242     my $max = scalar(@_);
 243     for (my $i = 0; $i < $max ; $i++) {
 244         if ($i + 1 < $max && ref($_[$i + 1])) {
 245             push @roles, [ $_[$i++] => $_[$i] ];
 246         } else {
 247             push @roles, [ $_[$i] => {} ];
 248         }
 249         my $role_name = $roles[-1][0];
 250         load_class($role_name);
 251         ( $role_name->can('meta') && $role_name->meta->isa('Mouse::Meta::Role') )
 252             || $meta->throw_error("You can only consume roles, $role_name(".$role_name->meta.") is not a Mouse role");
 253     }
 254
 255     if ( scalar @roles == 1 ) {
 256         my ( $role, $params ) = @{ $roles[0] };
 257         $role->meta->apply( $meta, ( defined $params ? %$params : () ) );
 258     }
 259     else {
 260         Mouse::Meta::Role->combine_apply($meta, @roles);
 261     }
 262     return;
 263 }
 264
 265 # taken from Moose::Util 0.90
 266 sub english_list {
 267     return $_[0] if @_ == 1;\r
 268
 269     my @items = sort @_;\r
 270 \r
 271     return "$items[0] and $items[1]" if @items == 2;\r
 272 \r
 273     my $tail = pop @items;\r
 274 \r
 275     return join q{, }, @items, "and $tail";\r
 276 }
 277
 278 sub not_supported{
 279     my($feature) = @_;
 280
 281     $feature ||= ( caller(1) )[3]; # subroutine name
 282
 283     local $Carp::CarpLevel = $Carp::CarpLevel + 2;
 284     Carp::croak("Mouse does not currently support $feature");
 285 }
 286
 287 1;
 288
 289 __END__
 290
 291 =head1 NAME
 292
 293 Mouse::Util - features, with or without their dependencies
 294
 295 =head1 IMPLEMENTATIONS FOR
 296
 297 =head2 L<MRO::Compat>
 298
 299 =head3 get_linear_isa
 300
 301 =cut
 302