lib/Mouse/Util.pm

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