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.70';
  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         ?                                shift   # instance
 278         : Mouse::Meta::Class->initialize(shift); # class or role name
 279
 280     my @roles;
 281
 282     # Basis of Data::OptList
 283     my $max = scalar(@_);
 284     for (my $i = 0; $i < $max ; $i++) {
 285         if ($i + 1 < $max && ref($_[$i + 1])) {
 286             push @roles, [ $_[$i] => $_[++$i] ];
 287         } else {
 288             push @roles, [ $_[$i] => undef ];
 289         }
 290         my $role_name = $roles[-1][0];
 291         load_class($role_name);
 292
 293         is_a_metarole( get_metaclass_by_name($role_name) )
 294             || $consumer->meta->throw_error("You can only consume roles, $role_name is not a Mouse role");
 295     }
 296
 297     if ( scalar @roles == 1 ) {
 298         my ( $role_name, $params ) = @{ $roles[0] };
 299         get_metaclass_by_name($role_name)->apply( $consumer, defined $params ? $params : () );
 300     }
 301     else {
 302         Mouse::Meta::Role->combine(@roles)->apply($consumer);
 303     }
 304     return;
 305 }
 306
 307 # taken from Moose::Util 0.90
 308 sub english_list {
 309     return $_[0] if @_ == 1;
 310
 311     my @items = sort @_;
 312
 313     return "$items[0] and $items[1]" if @items == 2;
 314
 315     my $tail = pop @items;
 316
 317     return join q{, }, @items, "and $tail";
 318 }
 319
 320 sub quoted_english_list {
 321     return english_list(map { qq{'$_'} } @_);
 322 }
 323
 324 # common utilities
 325
 326 sub not_supported{
 327     my($feature) = @_;
 328
 329     $feature ||= ( caller(1) )[3]; # subroutine name
 330
 331     local $Carp::CarpLevel = $Carp::CarpLevel + 1;
 332     Carp::confess("Mouse does not currently support $feature");
 333 }
 334
 335 # general meta() method
 336 sub meta :method{
 337     return Mouse::Meta::Class->initialize(ref($_[0]) || $_[0]);
 338 }
 339
 340 # general throw_error() method
 341 # $o->throw_error($msg, depth => $leve, longmess => $croak_or_confess)
 342 sub throw_error :method {
 343     my($self, $message, %args) = @_;
 344
 345     local $Carp::CarpLevel  = $Carp::CarpLevel + 1 + ($args{depth} || 0);
 346     local $Carp::MaxArgNums = 20; # default is 8, usually we use named args which gets messier though
 347
 348     if(exists $args{longmess} && !$args{longmess}) {
 349         Carp::croak($message);
 350     }
 351     else{
 352         Carp::confess($message);
 353     }
 354 }
 355
 356 # general dump() method
 357 sub dump :method {
 358     my($self, $maxdepth) = @_;
 359
 360     require 'Data/Dumper.pm'; # we don't want to create its namespace
 361     my $dd = Data::Dumper->new([$self]);
 362     $dd->Maxdepth(defined($maxdepth) ? $maxdepth : 3);
 363     $dd->Indent(1);
 364     $dd->Sortkeys(1);
 365     $dd->Quotekeys(0);
 366     return $dd->Dump();
 367 }
 368
 369 # general does() method
 370 sub does :method {
 371     goto &does_role;
 372 }
 373
 374 1;
 375 __END__
 376
 377 =head1 NAME
 378
 379 Mouse::Util - Utilities for working with Mouse classes
 380
 381 =head1 VERSION
 382
 383 This document describes Mouse version 0.70
 384
 385 =head1 SYNOPSIS
 386
 387     use Mouse::Util; # turns on strict and warnings
 388
 389 =head1 DESCRIPTION
 390
 391 This module provides a set of utility functions. Many of these
 392 functions are intended for use in Mouse itself or MouseX modules, but
 393 some of them may be useful for use in your own code.
 394
 395 =head1 IMPLEMENTATIONS FOR
 396
 397 =head2 Moose::Util functions
 398
 399 The following functions are exportable.
 400
 401 =head3 C<find_meta($class_or_obj)>
 402
 403 The same as C<Mouse::Util::class_of()>.
 404
 405 =head3 C<does_role($class_or_obj, $role_or_obj)>
 406
 407 =head3 C<resolve_metaclass_alias($category, $name, %options)>
 408
 409 =head3 C<apply_all_roles($applicant, @roles)>
 410
 411 =head3 C<english_listi(@items)>
 412
 413 =head2 Class::MOP functions
 414
 415 The following functions are not exportable.
 416
 417 =head3 C<< Mouse::Util::is_class_loaded($classname) -> Bool >>
 418
 419 Returns whether I<$classname> is actually loaded or not.
 420 It uses a heuristic which involves checking for the existence of
 421 C<$VERSION>, C<@ISA>, and any locally-defined method.
 422
 423 =head3 C<< Mouse::Util::load_class($classname) -> ClassName >>
 424
 425 This will load a given I<$classname> (or die if it is not loadable).
 426 This function can be used in place of tricks like
 427 C<eval "use $module ()"> or using C<require>.
 428
 429 =head3 C<< Mouse::Util::class_of($classname_or_object) -> MetaClass >>
 430
 431 =head3 C<< Mouse::Util::get_metaclass_by_name($classname) -> MetaClass >>
 432
 433 =head3 C<< Mouse::Util::get_all_metaclass_instances() -> (MetaClasses) >>
 434
 435 =head3 C<< Mouse::Util::get_all_metaclass_names() -> (ClassNames) >>
 436
 437 =head2 MRO::Compat
 438
 439 =head3 C<get_linear_isa>
 440
 441 =head2 Sub::Identify
 442
 443 =head3 C<get_code_info>
 444
 445 =head1 Mouse specific utilities
 446
 447 =head3 C<not_supported>
 448
 449 =head3 C<get_code_package>
 450
 451 =head3 C<get_code_ref>
 452
 453 =head1 SEE ALSO
 454
 455 L<Moose::Util>
 456
 457 L<Class::MOP>
 458
 459 L<Sub::Identify>
 460
 461 L<MRO::Compat>
 462
 463 =cut
 464