lib/Mouse/Util.pm

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