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