lib/Mouse/Util.pm

   1 package Mouse::Util;
   2 use Mouse::Exporter; # enables strict and warnings
   3
   4 # Note that those which don't exist here are defined in XS or Mouse::PurePerl
   5
   6 # must be here because it will be refered by other modules loaded
   7 sub get_linear_isa($;$); ## no critic
   8
   9 # must be here because it will called in Mouse::Exporter
  10 sub install_subroutines {
  11     my $into = shift;
  12
  13     while(my($name, $code) = splice @_, 0, 2){
  14         no strict 'refs';
  15         no warnings 'once', 'redefine';
  16         use warnings FATAL => 'uninitialized';
  17         *{$into . '::' . $name} = \&{$code};
  18     }
  19     return;
  20 }
  21
  22 BEGIN{
  23     # This is used in Mouse::PurePerl
  24     Mouse::Exporter->setup_import_methods(
  25         as_is => [qw(
  26             find_meta
  27             does_role
  28             resolve_metaclass_alias
  29             apply_all_roles
  30             english_list
  31
  32             load_class
  33             is_class_loaded
  34
  35             get_linear_isa
  36             get_code_info
  37
  38             get_code_package
  39             get_code_ref
  40
  41             not_supported
  42
  43             does meta throw_error dump
  44         )],
  45         groups => {
  46             default => [], # export no functions by default
  47
  48             # The ':meta' group is 'use metaclass' for Mouse
  49             meta    => [qw(does meta dump throw_error)],
  50         },
  51     );
  52
  53     our $VERSION = '0.95';
  54
  55     my $xs = !(defined(&is_valid_class_name) || $ENV{MOUSE_PUREPERL} || $ENV{PERL_ONLY});
  56
  57     # Because Mouse::Util is loaded first in all the Mouse sub-modules,
  58     # XSLoader must be placed here, not in Mouse.pm.
  59     if($xs){
  60         # XXX: XSLoader tries to get the object path from caller's file name
  61         #      $hack_mouse_file fools its mechanism
  62         (my $hack_mouse_file = __FILE__) =~ s/.Util//; # .../Mouse/Util.pm -> .../Mouse.pm
  63         $xs = eval sprintf("#line %d %s\n", __LINE__, $hack_mouse_file) . q{
  64             local $^W = 0; # workaround 'redefine' warning to &install_subroutines
  65             require XSLoader;
  66             XSLoader::load('Mouse', $VERSION);
  67             Mouse::Util->import({ into => 'Mouse::Meta::Method::Constructor::XS' }, ':meta');
  68             Mouse::Util->import({ into => 'Mouse::Meta::Method::Destructor::XS'  }, ':meta');
  69             Mouse::Util->import({ into => 'Mouse::Meta::Method::Accessor::XS'    }, ':meta');
  70             return 1;
  71         } || 0;
  72         warn $@ if $@ && $ENV{MOUSE_XS};
  73     }
  74
  75     if(!$xs){
  76         require 'Mouse/PurePerl.pm'; # we don't want to create its namespace
  77     }
  78
  79     *MOUSE_XS = sub(){ $xs };
  80
  81     # definition of mro::get_linear_isa()
  82     my $get_linear_isa;
  83     if ($] >= 5.010_000) {
  84         require mro;
  85         $get_linear_isa = \&mro::get_linear_isa;
  86     }
  87     else {
  88         # this code is based on MRO::Compat::__get_linear_isa
  89         my $_get_linear_isa_dfs; # this recurses so it isn't pretty
  90         $_get_linear_isa_dfs = sub {
  91             my($classname) = @_;
  92
  93             my @lin = ($classname);
  94             my %stored;
  95
  96             no strict 'refs';
  97             foreach my $parent (@{"$classname\::ISA"}) {
  98                 foreach  my $p(@{ $_get_linear_isa_dfs->($parent) }) {
  99                     next if exists $stored{$p};
 100                     push(@lin, $p);
 101                     $stored{$p} = 1;
 102                 }
 103             }
 104             return \@lin;
 105         };
 106
 107         {
 108             package # hide from PAUSE
 109                 Class::C3;
 110             our %MRO; # avoid 'once' warnings
 111         }
 112
 113         # MRO::Compat::__get_linear_isa has no prototype, so
 114         # we define a prototyped version for compatibility with core's
 115         # See also MRO::Compat::__get_linear_isa.
 116         $get_linear_isa = sub ($;$){
 117             my($classname, $type) = @_;
 118
 119             if(!defined $type){
 120                 $type = exists $Class::C3::MRO{$classname} ? 'c3' : 'dfs';
 121             }
 122             if($type eq 'c3'){
 123                 require Class::C3;
 124                 return [Class::C3::calculateMRO($classname)];
 125             }
 126             else{
 127                 return $_get_linear_isa_dfs->($classname);
 128             }
 129         };
 130     }
 131
 132     *get_linear_isa = $get_linear_isa;
 133 }
 134
 135 use Carp         ();
 136 use Scalar::Util ();
 137
 138 # aliases as public APIs
 139 # it must be 'require', not 'use', because Mouse::Meta::Module depends on Mouse::Util
 140 require Mouse::Meta::Module; # for the entities of metaclass cache utilities
 141
 142 # aliases
 143 {
 144     *class_of                    = \&Mouse::Meta::Module::_class_of;
 145     *get_metaclass_by_name       = \&Mouse::Meta::Module::_get_metaclass_by_name;
 146     *get_all_metaclass_instances = \&Mouse::Meta::Module::_get_all_metaclass_instances;
 147     *get_all_metaclass_names     = \&Mouse::Meta::Module::_get_all_metaclass_names;
 148
 149     *Mouse::load_class           = \&load_class;
 150     *Mouse::is_class_loaded      = \&is_class_loaded;
 151
 152     # is-a predicates
 153     #generate_isa_predicate_for('Mouse::Meta::TypeConstraint' => 'is_a_type_constraint');
 154     #generate_isa_predicate_for('Mouse::Meta::Class'          => 'is_a_metaclass');
 155     #generate_isa_predicate_for('Mouse::Meta::Role'           => 'is_a_metarole');
 156
 157     # duck type predicates
 158     generate_can_predicate_for(['_compiled_type_constraint']  => 'is_a_type_constraint');
 159     generate_can_predicate_for(['create_anon_class']          => 'is_a_metaclass');
 160     generate_can_predicate_for(['create_anon_role']           => 'is_a_metarole');
 161 }
 162
 163 our $in_global_destruction = 0;
 164 END{ $in_global_destruction = 1 }
 165
 166 # Moose::Util compatible utilities
 167
 168 sub find_meta{
 169     return class_of( $_[0] );
 170 }
 171
 172 sub _does_role_impl {
 173     my ($class_or_obj, $role_name) = @_;
 174
 175     my $meta = class_of($class_or_obj);
 176
 177     (defined $role_name)
 178         || ($meta || 'Mouse::Meta::Class')->throw_error("You must supply a role name to does()");
 179
 180     return defined($meta) && $meta->does_role($role_name);
 181 }
 182
 183 sub does_role {
 184     my($thing, $role_name) = @_;
 185
 186     if( (Scalar::Util::blessed($thing) || is_class_loaded($thing))
 187             && $thing->can('does')) {
 188         return $thing->does($role_name);
 189     }
 190     goto &_does_role_impl;
 191 }
 192
 193 # taken from Mouse::Util (0.90)
 194 {
 195     my %cache;
 196
 197     sub resolve_metaclass_alias {
 198         my ( $type, $metaclass_name, %options ) = @_;
 199
 200         my $cache_key = $type . q{ } . ( $options{trait} ? '-Trait' : '' );
 201
 202         return $cache{$cache_key}{$metaclass_name} ||= do{
 203
 204             my $possible_full_name = join '::',
 205                 'Mouse::Meta', $type, 'Custom', ($options{trait} ? 'Trait' : ()), $metaclass_name
 206             ;
 207
 208             my $loaded_class = load_first_existing_class(
 209                 $possible_full_name,
 210                 $metaclass_name
 211             );
 212
 213             $loaded_class->can('register_implementation')
 214                 ? $loaded_class->register_implementation
 215                 : $loaded_class;
 216         };
 217     }
 218 }
 219
 220 # Utilities from Class::MOP
 221
 222 sub get_code_info;
 223 sub get_code_package;
 224
 225 sub is_valid_class_name;
 226 sub is_class_loaded;
 227
 228 # taken from Class/MOP.pm
 229 sub load_first_existing_class {
 230     my @classes = @_
 231       or return;
 232
 233     my %exceptions;
 234     for my $class (@classes) {
 235         my $e = _try_load_one_class($class);
 236
 237         if ($e) {
 238             $exceptions{$class} = $e;
 239         }
 240         else {
 241             return $class;
 242         }
 243     }
 244
 245     # not found
 246     Carp::confess join(
 247         "\n",
 248         map {
 249             sprintf( "Could not load class (%s) because : %s",
 250                 $_, $exceptions{$_} )
 251           } @classes
 252     );
 253 }
 254
 255 # taken from Class/MOP.pm
 256 sub _try_load_one_class {
 257     my $class = shift;
 258
 259     unless ( is_valid_class_name($class) ) {
 260         my $display = defined($class) ? $class : 'undef';
 261         Carp::confess "Invalid class name ($display)";
 262     }
 263
 264     return '' if is_class_loaded($class);
 265
 266     $class  =~ s{::}{/}g;
 267     $class .= '.pm';
 268
 269     return do {
 270         local $@;
 271         eval { require $class };
 272         $@;
 273     };
 274 }
 275
 276
 277 sub load_class {
 278     my $class = shift;
 279     my $e = _try_load_one_class($class);
 280     Carp::confess "Could not load class ($class) because : $e" if $e;
 281
 282     return $class;
 283 }
 284
 285
 286 sub apply_all_roles {
 287     my $consumer = Scalar::Util::blessed($_[0])
 288         ?                                $_[0]   # instance
 289         : Mouse::Meta::Class->initialize($_[0]); # class or role name
 290
 291     my @roles;
 292
 293     # Basis of Data::OptList
 294     my $max = scalar(@_);
 295     for (my $i = 1; $i < $max ; $i++) {
 296         my $role = $_[$i];
 297         my $role_name;
 298         if(ref $role) {
 299             $role_name = $role->name;
 300         }
 301         else {
 302             $role_name = $role;
 303             load_class($role_name);
 304             $role = get_metaclass_by_name($role_name);
 305         }
 306
 307         if ($i + 1 < $max && ref($_[$i + 1]) eq 'HASH') {
 308             push @roles, [ $role => $_[++$i] ];
 309         } else {
 310             push @roles, [ $role => undef ];
 311         }
 312         is_a_metarole($role)
 313             || $consumer->meta->throw_error("You can only consume roles, $role_name is not a Mouse role");
 314     }
 315
 316     if ( scalar @roles == 1 ) {
 317         my ( $role, $params ) = @{ $roles[0] };
 318         $role->apply( $consumer, defined $params ? $params : () );
 319     }
 320     else {
 321         Mouse::Meta::Role->combine(@roles)->apply($consumer);
 322     }
 323     return;
 324 }
 325
 326 # taken from Moose::Util 0.90
 327 sub english_list {
 328     return $_[0] if @_ == 1;
 329
 330     my @items = sort @_;
 331
 332     return "$items[0] and $items[1]" if @items == 2;
 333
 334     my $tail = pop @items;
 335
 336     return join q{, }, @items, "and $tail";
 337 }
 338
 339 sub quoted_english_list {
 340     return english_list(map { qq{'$_'} } @_);
 341 }
 342
 343 # common utilities
 344
 345 sub not_supported{
 346     my($feature) = @_;
 347
 348     $feature ||= ( caller(1) )[3] . '()'; # subroutine name
 349
 350     local $Carp::CarpLevel = $Carp::CarpLevel + 1;
 351     Carp::confess("Mouse does not currently support $feature");
 352 }
 353
 354 # general meta() method
 355 sub meta :method{
 356     return Mouse::Meta::Class->initialize(ref($_[0]) || $_[0]);
 357 }
 358
 359 # general throw_error() method
 360 # $o->throw_error($msg, depth => $leve, longmess => $croak_or_confess)
 361 sub throw_error :method {
 362     my($self, $message, %args) = @_;
 363
 364     local $Carp::CarpLevel  = $Carp::CarpLevel + 1 + ($args{depth} || 0);
 365     local $Carp::MaxArgNums = 20; # default is 8, usually we use named args which gets messier though
 366
 367     if(exists $args{longmess} && !$args{longmess}) {
 368         Carp::croak($message);
 369     }
 370     else{
 371         Carp::confess($message);
 372     }
 373 }
 374
 375 # general dump() method
 376 sub dump :method {
 377     my($self, $maxdepth) = @_;
 378
 379     require 'Data/Dumper.pm'; # we don't want to create its namespace
 380     my $dd = Data::Dumper->new([$self]);
 381     $dd->Maxdepth(defined($maxdepth) ? $maxdepth : 3);
 382     $dd->Indent(1);
 383     $dd->Sortkeys(1);
 384     $dd->Quotekeys(0);
 385     return $dd->Dump();
 386 }
 387
 388 # general does() method
 389 sub does :method {
 390     goto &_does_role_impl;
 391 }
 392
 393 1;
 394 __END__
 395
 396 =head1 NAME
 397
 398 Mouse::Util - Utilities for working with Mouse classes
 399
 400 =head1 VERSION
 401
 402 This document describes Mouse version 0.95
 403
 404 =head1 SYNOPSIS
 405
 406     use Mouse::Util; # turns on strict and warnings
 407
 408 =head1 DESCRIPTION
 409
 410 This module provides a set of utility functions. Many of these
 411 functions are intended for use in Mouse itself or MouseX modules, but
 412 some of them may be useful for use in your own code.
 413
 414 =head1 IMPLEMENTATIONS FOR
 415
 416 =head2 Moose::Util functions
 417
 418 The following functions are exportable.
 419
 420 =head3 C<find_meta($class_or_obj)>
 421
 422 The same as C<Mouse::Util::class_of()>.
 423
 424 =head3 C<does_role($class_or_obj, $role_or_obj)>
 425
 426 =head3 C<resolve_metaclass_alias($category, $name, %options)>
 427
 428 =head3 C<apply_all_roles($applicant, @roles)>
 429
 430 =head3 C<english_listi(@items)>
 431
 432 =head2 Class::MOP functions
 433
 434 The following functions are not exportable.
 435
 436 =head3 C<< Mouse::Util::is_class_loaded($classname) -> Bool >>
 437
 438 Returns whether I<$classname> is actually loaded or not.
 439 It uses a heuristic which involves checking for the existence of
 440 C<$VERSION>, C<@ISA>, and any locally-defined method.
 441
 442 =head3 C<< Mouse::Util::load_class($classname) -> ClassName >>
 443
 444 This will load a given I<$classname> (or die if it is not loadable).
 445 This function can be used in place of tricks like
 446 C<eval "use $module ()"> or using C<require>.
 447
 448 =head3 C<< Mouse::Util::class_of($classname_or_object) -> MetaClass >>
 449
 450 =head3 C<< Mouse::Util::get_metaclass_by_name($classname) -> MetaClass >>
 451
 452 =head3 C<< Mouse::Util::get_all_metaclass_instances() -> (MetaClasses) >>
 453
 454 =head3 C<< Mouse::Util::get_all_metaclass_names() -> (ClassNames) >>
 455
 456 =head2 mro (or MRO::Compat)
 457
 458 =head3 C<get_linear_isa>
 459
 460 =head2 Sub::Identify
 461
 462 =head3 C<get_code_info>
 463
 464 =head1 Mouse specific utilities
 465
 466 =head3 C<not_supported>
 467
 468 =head3 C<get_code_package>
 469
 470 =head3 C<get_code_ref>
 471
 472 =head1 SEE ALSO
 473
 474 L<Moose::Util>
 475
 476 L<Class::MOP>
 477
 478 L<Sub::Identify>
 479
 480 L<mro>
 481
 482 L<MRO::Compat>
 483
 484 =cut
 485