8d7e0787397da3f74abce4b3bbfda8a2c56e9b80
[gitmo/Mouse.git] / 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.80';
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.80
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