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{
 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 # taken from Mouse::Util (0.90)
 184 {
 185     my %cache;
 186
 187     sub resolve_metaclass_alias {
 188         my ( $type, $metaclass_name, %options ) = @_;
 189
 190         my $cache_key = $type . q{ } . ( $options{trait} ? '-Trait' : '' );
 191
 192         return $cache{$cache_key}{$metaclass_name} ||= do{
 193
 194             my $possible_full_name = join '::',
 195                 'Mouse::Meta', $type, 'Custom', ($options{trait} ? 'Trait' : ()), $metaclass_name
 196             ;
 197
 198             my $loaded_class = load_first_existing_class(
 199                 $possible_full_name,
 200                 $metaclass_name
 201             );
 202
 203             $loaded_class->can('register_implementation')
 204                 ? $loaded_class->register_implementation
 205                 : $loaded_class;
 206         };
 207     }
 208 }
 209
 210 # Utilities from Class::MOP
 211
 212 sub get_code_info;
 213 sub get_code_package;
 214
 215 sub is_valid_class_name;
 216 sub is_class_loaded;
 217
 218 # taken from Class/MOP.pm
 219 sub load_first_existing_class {
 220     my @classes = @_
 221       or return;
 222
 223     my %exceptions;
 224     for my $class (@classes) {
 225         my $e = _try_load_one_class($class);
 226
 227         if ($e) {
 228             $exceptions{$class} = $e;
 229         }
 230         else {
 231             return $class;
 232         }
 233     }
 234
 235     # not found
 236     Carp::confess join(
 237         "\n",
 238         map {
 239             sprintf( "Could not load class (%s) because : %s",
 240                 $_, $exceptions{$_} )
 241           } @classes
 242     );
 243 }
 244
 245 # taken from Class/MOP.pm
 246 sub _try_load_one_class {
 247     my $class = shift;
 248
 249     unless ( is_valid_class_name($class) ) {
 250         my $display = defined($class) ? $class : 'undef';
 251         Carp::confess "Invalid class name ($display)";
 252     }
 253
 254     return '' if is_class_loaded($class);
 255
 256     $class  =~ s{::}{/}g;
 257     $class .= '.pm';
 258
 259     return do {
 260         local $@;
 261         eval { require $class };
 262         $@;
 263     };
 264 }
 265
 266
 267 sub load_class {
 268     my $class = shift;
 269     my $e = _try_load_one_class($class);
 270     Carp::confess "Could not load class ($class) because : $e" if $e;
 271
 272     return $class;
 273 }
 274
 275
 276 sub apply_all_roles {
 277     my $consumer = Scalar::Util::blessed($_[0])
 278         ?                                $_[0]   # instance
 279         : Mouse::Meta::Class->initialize($_[0]); # class or role name
 280
 281     my @roles;
 282
 283     # Basis of Data::OptList
 284     my $max = scalar(@_);
 285     for (my $i = 1; $i < $max ; $i++) {
 286         my $role = $_[$i];
 287         my $role_name;
 288         if(ref $role) {
 289             $role_name = $role->name;
 290         }
 291         else {
 292             $role_name = $role;
 293             load_class($role_name);
 294             $role = get_metaclass_by_name($role_name);
 295         }
 296
 297         if ($i + 1 < $max && ref($_[$i + 1]) eq 'HASH') {
 298             push @roles, [ $role => $_[++$i] ];
 299         } else {
 300             push @roles, [ $role => undef ];
 301         }
 302         is_a_metarole($role)
 303             || $consumer->meta->throw_error("You can only consume roles, $role_name is not a Mouse role");
 304     }
 305
 306     if ( scalar @roles == 1 ) {
 307         my ( $role, $params ) = @{ $roles[0] };
 308         $role->apply( $consumer, defined $params ? $params : () );
 309     }
 310     else {
 311         Mouse::Meta::Role->combine(@roles)->apply($consumer);
 312     }
 313     return;
 314 }
 315
 316 # taken from Moose::Util 0.90
 317 sub english_list {
 318     return $_[0] if @_ == 1;
 319
 320     my @items = sort @_;
 321
 322     return "$items[0] and $items[1]" if @items == 2;
 323
 324     my $tail = pop @items;
 325
 326     return join q{, }, @items, "and $tail";
 327 }
 328
 329 sub quoted_english_list {
 330     return english_list(map { qq{'$_'} } @_);
 331 }
 332
 333 # common utilities
 334
 335 sub not_supported{
 336     my($feature) = @_;
 337
 338     $feature ||= ( caller(1) )[3] . '()'; # subroutine name
 339
 340     local $Carp::CarpLevel = $Carp::CarpLevel + 1;
 341     Carp::confess("Mouse does not currently support $feature");
 342 }
 343
 344 # general meta() method
 345 sub meta :method{
 346     return Mouse::Meta::Class->initialize(ref($_[0]) || $_[0]);
 347 }
 348
 349 # general throw_error() method
 350 # $o->throw_error($msg, depth => $leve, longmess => $croak_or_confess)
 351 sub throw_error :method {
 352     my($self, $message, %args) = @_;
 353
 354     local $Carp::CarpLevel  = $Carp::CarpLevel + 1 + ($args{depth} || 0);
 355     local $Carp::MaxArgNums = 20; # default is 8, usually we use named args which gets messier though
 356
 357     if(exists $args{longmess} && !$args{longmess}) {
 358         Carp::croak($message);
 359     }
 360     else{
 361         Carp::confess($message);
 362     }
 363 }
 364
 365 # general dump() method
 366 sub dump :method {
 367     my($self, $maxdepth) = @_;
 368
 369     require 'Data/Dumper.pm'; # we don't want to create its namespace
 370     my $dd = Data::Dumper->new([$self]);
 371     $dd->Maxdepth(defined($maxdepth) ? $maxdepth : 3);
 372     $dd->Indent(1);
 373     $dd->Sortkeys(1);
 374     $dd->Quotekeys(0);
 375     return $dd->Dump();
 376 }
 377
 378 # general does() method
 379 sub does :method {
 380     goto &does_role;
 381 }
 382
 383 1;
 384 __END__
 385
 386 =head1 NAME
 387
 388 Mouse::Util - Utilities for working with Mouse classes
 389
 390 =head1 VERSION
 391
 392 This document describes Mouse version 0.95
 393
 394 =head1 SYNOPSIS
 395
 396     use Mouse::Util; # turns on strict and warnings
 397
 398 =head1 DESCRIPTION
 399
 400 This module provides a set of utility functions. Many of these
 401 functions are intended for use in Mouse itself or MouseX modules, but
 402 some of them may be useful for use in your own code.
 403
 404 =head1 IMPLEMENTATIONS FOR
 405
 406 =head2 Moose::Util functions
 407
 408 The following functions are exportable.
 409
 410 =head3 C<find_meta($class_or_obj)>
 411
 412 The same as C<Mouse::Util::class_of()>.
 413
 414 =head3 C<does_role($class_or_obj, $role_or_obj)>
 415
 416 =head3 C<resolve_metaclass_alias($category, $name, %options)>
 417
 418 =head3 C<apply_all_roles($applicant, @roles)>
 419
 420 =head3 C<english_listi(@items)>
 421
 422 =head2 Class::MOP functions
 423
 424 The following functions are not exportable.
 425
 426 =head3 C<< Mouse::Util::is_class_loaded($classname) -> Bool >>
 427
 428 Returns whether I<$classname> is actually loaded or not.
 429 It uses a heuristic which involves checking for the existence of
 430 C<$VERSION>, C<@ISA>, and any locally-defined method.
 431
 432 =head3 C<< Mouse::Util::load_class($classname) -> ClassName >>
 433
 434 This will load a given I<$classname> (or die if it is not loadable).
 435 This function can be used in place of tricks like
 436 C<eval "use $module ()"> or using C<require>.
 437
 438 =head3 C<< Mouse::Util::class_of($classname_or_object) -> MetaClass >>
 439
 440 =head3 C<< Mouse::Util::get_metaclass_by_name($classname) -> MetaClass >>
 441
 442 =head3 C<< Mouse::Util::get_all_metaclass_instances() -> (MetaClasses) >>
 443
 444 =head3 C<< Mouse::Util::get_all_metaclass_names() -> (ClassNames) >>
 445
 446 =head2 mro (or MRO::Compat)
 447
 448 =head3 C<get_linear_isa>
 449
 450 =head2 Sub::Identify
 451
 452 =head3 C<get_code_info>
 453
 454 =head1 Mouse specific utilities
 455
 456 =head3 C<not_supported>
 457
 458 =head3 C<get_code_package>
 459
 460 =head3 C<get_code_ref>
 461
 462 =head1 SEE ALSO
 463
 464 L<Moose::Util>
 465
 466 L<Class::MOP>
 467
 468 L<Sub::Identify>
 469
 470 L<mro>
 471
 472 L<MRO::Compat>
 473
 474 =cut
 475