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