lib/Mouse/Util.pm

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