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.93';
  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 (eval { require mro }) {
  84         $get_linear_isa = \&mro::get_linear_isa;
  85     }
  86     else {
  87         # this code is based on MRO::Compat::__get_linear_isa
  88         my $_get_linear_isa_dfs; # this recurses so it isn't pretty
  89         $_get_linear_isa_dfs = sub {
  90             my($classname) = @_;
  91
  92             my @lin = ($classname);
  93             my %stored;
  94
  95             no strict 'refs';
  96             foreach my $parent (@{"$classname\::ISA"}) {
  97                 foreach  my $p(@{ $_get_linear_isa_dfs->($parent) }) {
  98                     next if exists $stored{$p};
  99                     push(@lin, $p);
 100                     $stored{$p} = 1;
 101                 }
 102             }
 103             return \@lin;
 104         };
 105
 106         {
 107             package # hide from PAUSE
 108                 Class::C3;
 109             our %MRO; # avoid 'once' warnings
 110         }
 111
 112         # MRO::Compat::__get_linear_isa has no prototype, so
 113         # we define a prototyped version for compatibility with core's
 114         # See also MRO::Compat::__get_linear_isa.
 115         $get_linear_isa = sub ($;$){
 116             my($classname, $type) = @_;
 117
 118             if(!defined $type){
 119                 $type = exists $Class::C3::MRO{$classname} ? 'c3' : 'dfs';
 120             }
 121             if($type eq 'c3'){
 122                 require Class::C3;
 123                 return [Class::C3::calculateMRO($classname)];
 124             }
 125             else{
 126                 return $_get_linear_isa_dfs->($classname);
 127             }
 128         };
 129     }
 130
 131     *get_linear_isa = $get_linear_isa;
 132 }
 133
 134 use Carp         ();
 135 use Scalar::Util ();
 136
 137 # aliases as public APIs
 138 # it must be 'require', not 'use', because Mouse::Meta::Module depends on Mouse::Util
 139 require Mouse::Meta::Module; # for the entities of metaclass cache utilities
 140
 141 # aliases
 142 {
 143     *class_of                    = \&Mouse::Meta::Module::_class_of;
 144     *get_metaclass_by_name       = \&Mouse::Meta::Module::_get_metaclass_by_name;
 145     *get_all_metaclass_instances = \&Mouse::Meta::Module::_get_all_metaclass_instances;
 146     *get_all_metaclass_names     = \&Mouse::Meta::Module::_get_all_metaclass_names;
 147
 148     *Mouse::load_class           = \&load_class;
 149     *Mouse::is_class_loaded      = \&is_class_loaded;
 150
 151     # is-a predicates
 152     #generate_isa_predicate_for('Mouse::Meta::TypeConstraint' => 'is_a_type_constraint');
 153     #generate_isa_predicate_for('Mouse::Meta::Class'          => 'is_a_metaclass');
 154     #generate_isa_predicate_for('Mouse::Meta::Role'           => 'is_a_metarole');
 155
 156     # duck type predicates
 157     generate_can_predicate_for(['_compiled_type_constraint']  => 'is_a_type_constraint');
 158     generate_can_predicate_for(['create_anon_class']          => 'is_a_metaclass');
 159     generate_can_predicate_for(['create_anon_role']           => 'is_a_metarole');
 160 }
 161
 162 our $in_global_destruction = 0;
 163 END{ $in_global_destruction = 1 }
 164
 165 # Moose::Util compatible utilities
 166
 167 sub find_meta{
 168     return class_of( $_[0] );
 169 }
 170
 171 sub does_role{
 172     my ($class_or_obj, $role_name) = @_;
 173
 174     my $meta = class_of($class_or_obj);
 175
 176     (defined $role_name)
 177         || ($meta || 'Mouse::Meta::Class')->throw_error("You must supply a role name to does()");
 178
 179     return defined($meta) && $meta->does_role($role_name);
 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 sub is_class_loaded;
 216
 217 # taken from Class/MOP.pm
 218 sub load_first_existing_class {
 219     my @classes = @_
 220       or return;
 221
 222     my %exceptions;
 223     for my $class (@classes) {
 224         my $e = _try_load_one_class($class);
 225
 226         if ($e) {
 227             $exceptions{$class} = $e;
 228         }
 229         else {
 230             return $class;
 231         }
 232     }
 233
 234     # not found
 235     Carp::confess join(
 236         "\n",
 237         map {
 238             sprintf( "Could not load class (%s) because : %s",
 239                 $_, $exceptions{$_} )
 240           } @classes
 241     );
 242 }
 243
 244 # taken from Class/MOP.pm
 245 sub _try_load_one_class {
 246     my $class = shift;
 247
 248     unless ( is_valid_class_name($class) ) {
 249         my $display = defined($class) ? $class : 'undef';
 250         Carp::confess "Invalid class name ($display)";
 251     }
 252
 253     return '' if is_class_loaded($class);
 254
 255     $class  =~ s{::}{/}g;
 256     $class .= '.pm';
 257
 258     return do {
 259         local $@;
 260         eval { require $class };
 261         $@;
 262     };
 263 }
 264
 265
 266 sub load_class {
 267     my $class = shift;
 268     my $e = _try_load_one_class($class);
 269     Carp::confess "Could not load class ($class) because : $e" if $e;
 270
 271     return $class;
 272 }
 273
 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.93
 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 (or 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>
 470
 471 L<MRO::Compat>
 472
 473 =cut
 474