lib/Mouse/Util.pm

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