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