Checking in changes prior to tagging of version 0.81.
[gitmo/Mouse.git] / lib / Mouse / Util.pm
CommitLineData
4093c859 1package Mouse::Util;
bc69ee88 2use Mouse::Exporter; # enables strict and warnings
6d28c5cf 3
a4b15169 4# must be here because it will be refered by other modules loaded
5sub get_linear_isa($;$); ## no critic
ba153b33 6
a4b15169 7# must be here because it will called in Mouse::Exporter
8sub install_subroutines {
1194aede 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
df6dd016 20BEGIN{
8aba926d 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
823419c5 41 does meta throw_error dump
8aba926d 42 )],
43 groups => {
44 default => [], # export no functions by default
45
46 # The ':meta' group is 'use metaclass' for Mouse
823419c5 47 meta => [qw(does meta dump throw_error)],
8aba926d 48 },
49 );
50
ce1cb320 51 our $VERSION = '0.81';
df6dd016 52
bdef60b4 53 my $xs = !(defined(&is_valid_class_name) || $ENV{MOUSE_PUREPERL} || $ENV{PERL_ONLY});
df6dd016 54
4bef84ef 55 # Because Mouse::Util is loaded first in all the Mouse sub-modules,
56 # XSLoader must be placed here, not in Mouse.pm.
db5e4409 57 if($xs){
34bdc46a 58 # XXX: XSLoader tries to get the object path from caller's file name
59 # $hack_mouse_file fools its mechanism
34bdc46a 60 (my $hack_mouse_file = __FILE__) =~ s/.Util//; # .../Mouse/Util.pm -> .../Mouse.pm
db5e4409 61 $xs = eval sprintf("#line %d %s\n", __LINE__, $hack_mouse_file) . q{
4bef84ef 62 local $^W = 0; # workaround 'redefine' warning to &install_subroutines
df6dd016 63 require XSLoader;
64 XSLoader::load('Mouse', $VERSION);
923a04ba 65 Mouse::Util->import({ into => 'Mouse::Meta::Method::Constructor::XS' }, ':meta');
66 Mouse::Util->import({ into => 'Mouse::Meta::Method::Destructor::XS' }, ':meta');
3821b191 67 Mouse::Util->import({ into => 'Mouse::Meta::Method::Accessor::XS' }, ':meta');
923a04ba 68 return 1;
029463f4 69 } || 0;
823419c5 70 warn $@ if $@ && $ENV{MOUSE_XS};
df6dd016 71 }
72
db5e4409 73 if(!$xs){
df6dd016 74 require 'Mouse/PurePerl.pm'; # we don't want to create its namespace
75 }
db5e4409 76
ecd4a125 77 *MOUSE_XS = sub(){ $xs };
df6dd016 78}
79
5dd5edef 80use Carp ();
81use Scalar::Util ();
4093c859 82
739525d0 83# aliases as public APIs
deb9a0f3 84# it must be 'require', not 'use', because Mouse::Meta::Module depends on Mouse::Util
7727a2f0 85require Mouse::Meta::Module; # for the entities of metaclass cache utilities
86
01f892fa 87# aliases
88{
542f20ad 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;
f48920c1 93
01f892fa 94 *Mouse::load_class = \&load_class;
95 *Mouse::is_class_loaded = \&is_class_loaded;
96
f48920c1 97 # is-a predicates
6a4ab70d 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');
739525d0 106}
107
39a8df63 108our $in_global_destruction = 0;
109END{ $in_global_destruction = 1 }
f48920c1 110
08f7a8db 111# Moose::Util compatible utilities
112
113sub find_meta{
739525d0 114 return class_of( $_[0] );
08f7a8db 115}
116
117sub does_role{
53875581 118 my ($class_or_obj, $role_name) = @_;
8e64d0fa 119
739525d0 120 my $meta = class_of($class_or_obj);
8e64d0fa 121
53875581 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);
08f7a8db 126}
127
42d7df00 128BEGIN {
f15868c3 129 my $get_linear_isa;
bcd39bf4 130 if ($] >= 5.009_005) {
388b8ebd 131 require mro;
f15868c3 132 $get_linear_isa = \&mro::get_linear_isa;
272a1930 133 } else {
74690b26 134 # this code is based on MRO::Compat::__get_linear_isa
ce5a7699 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"}) {
74690b26 144 foreach my $p(@{ $_get_linear_isa_dfs->($parent) }) {
ce5a7699 145 next if exists $stored{$p};
146 push(@lin, $p);
147 $stored{$p} = 1;
272a1930 148 }
ce5a7699 149 }
150 return \@lin;
151 };
ce5a7699 152
74690b26 153 {
154 package # hide from PAUSE
155 Class::C3;
4bef84ef 156 our %MRO; # avoid 'once' warnings
74690b26 157 }
ce5a7699 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) = @_;
74690b26 164
ce5a7699 165 if(!defined $type){
74690b26 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);
ce5a7699 174 }
ce5a7699 175 };
eae80759 176 }
bcd39bf4 177
f15868c3 178 *get_linear_isa = $get_linear_isa;
eae80759 179}
180
3a63a2e7 181
08f7a8db 182# taken from Mouse::Util (0.90)
abfdffe0 183{
184 my %cache;
185
8e64d0fa 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{
abfdffe0 192
08f7a8db 193 my $possible_full_name = join '::',
194 'Mouse::Meta', $type, 'Custom', ($options{trait} ? 'Trait' : ()), $metaclass_name
195 ;
196
8e64d0fa 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
08f7a8db 204 : $loaded_class;
8e64d0fa 205 };
abfdffe0 206 }
207}
208
739525d0 209# Utilities from Class::MOP
210
df6dd016 211sub get_code_info;
212sub get_code_package;
739525d0 213
0ffc4183 214sub is_valid_class_name;
abfdffe0 215
216# taken from Class/MOP.pm
217sub load_first_existing_class {
218 my @classes = @_
219 or return;
220
23264b5b 221 my %exceptions;
222 for my $class (@classes) {
abfdffe0 223 my $e = _try_load_one_class($class);
224
225 if ($e) {
226 $exceptions{$class} = $e;
227 }
228 else {
53875581 229 return $class;
abfdffe0 230 }
231 }
abfdffe0 232
53875581 233 # not found
5dd5edef 234 Carp::confess join(
abfdffe0 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
244sub _try_load_one_class {
245 my $class = shift;
246
6cfa1e5e 247 unless ( is_valid_class_name($class) ) {
248 my $display = defined($class) ? $class : 'undef';
5dd5edef 249 Carp::confess "Invalid class name ($display)";
6cfa1e5e 250 }
251
be0ba859 252 return '' if is_class_loaded($class);
abfdffe0 253
637d4f17 254 $class =~ s{::}{/}g;
255 $class .= '.pm';
abfdffe0 256
257 return do {
258 local $@;
637d4f17 259 eval { require $class };
abfdffe0 260 $@;
261 };
262}
263
6cfa1e5e 264
265sub load_class {
266 my $class = shift;
267 my $e = _try_load_one_class($class);
5dd5edef 268 Carp::confess "Could not load class ($class) because : $e" if $e;
6cfa1e5e 269
637d4f17 270 return $class;
6cfa1e5e 271}
272
df6dd016 273sub is_class_loaded;
6cfa1e5e 274
2e92bb89 275sub apply_all_roles {
45f22b92 276 my $consumer = Scalar::Util::blessed($_[0])
80b463bb 277 ? $_[0] # instance
278 : Mouse::Meta::Class->initialize($_[0]); # class or role name
2e92bb89 279
21498b08 280 my @roles;
f6715552 281
282 # Basis of Data::OptList
21498b08 283 my $max = scalar(@_);
80b463bb 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);
21498b08 294 }
0126c27c 295
80b463bb 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)
45f22b92 302 || $consumer->meta->throw_error("You can only consume roles, $role_name is not a Mouse role");
21498b08 303 }
304
21498b08 305 if ( scalar @roles == 1 ) {
80b463bb 306 my ( $role, $params ) = @{ $roles[0] };
307 $role->apply( $consumer, defined $params ? $params : () );
21498b08 308 }
309 else {
45f22b92 310 Mouse::Meta::Role->combine(@roles)->apply($consumer);
21498b08 311 }
23264b5b 312 return;
2e92bb89 313}
314
2e33bb59 315# taken from Moose::Util 0.90
316sub english_list {
8e64d0fa 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";
2e33bb59 326}
327
5af36247 328sub quoted_english_list {
53f661ad 329 return english_list(map { qq{'$_'} } @_);
5af36247 330}
331
53875581 332# common utilities
333
fce211ae 334sub not_supported{
335 my($feature) = @_;
336
1d76ae62 337 $feature ||= ( caller(1) )[3] . '()'; # subroutine name
fce211ae 338
1b9e472d 339 local $Carp::CarpLevel = $Carp::CarpLevel + 1;
340 Carp::confess("Mouse does not currently support $feature");
fce211ae 341}
342
fc8628e3 343# general meta() method
344sub meta :method{
152e5759 345 return Mouse::Meta::Class->initialize(ref($_[0]) || $_[0]);
53875581 346}
347
823419c5 348# general throw_error() method
349# $o->throw_error($msg, depth => $leve, longmess => $croak_or_confess)
350sub 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
fc8628e3 364# general dump() method
365sub dump :method {
53875581 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]);
0cf6f1be 370 $dd->Maxdepth(defined($maxdepth) ? $maxdepth : 3);
53875581 371 $dd->Indent(1);
a672bf86 372 $dd->Sortkeys(1);
902174eb 373 $dd->Quotekeys(0);
53875581 374 return $dd->Dump();
375}
376
fc8628e3 377# general does() method
b64e2007 378sub does :method {
379 goto &does_role;
380}
53875581 381
4093c859 3821;
f38ce2d0 383__END__
384
385=head1 NAME
386
a672bf86 387Mouse::Util - Utilities for working with Mouse classes
f38ce2d0 388
a25ca8d6 389=head1 VERSION
390
ce1cb320 391This document describes Mouse version 0.81
a25ca8d6 392
a672bf86 393=head1 SYNOPSIS
394
395 use Mouse::Util; # turns on strict and warnings
396
397=head1 DESCRIPTION
398
399This module provides a set of utility functions. Many of these
400functions are intended for use in Mouse itself or MouseX modules, but
401some of them may be useful for use in your own code.
402
f38ce2d0 403=head1 IMPLEMENTATIONS FOR
404
a672bf86 405=head2 Moose::Util functions
406
407The following functions are exportable.
408
409=head3 C<find_meta($class_or_obj)>
410
411The same as C<Mouse::Util::class_of()>.
ea249879 412
a672bf86 413=head3 C<does_role($class_or_obj, $role_or_obj)>
ea249879 414
a672bf86 415=head3 C<resolve_metaclass_alias($category, $name, %options)>
ea249879 416
a672bf86 417=head3 C<apply_all_roles($applicant, @roles)>
ea249879 418
a672bf86 419=head3 C<english_listi(@items)>
ea249879 420
a672bf86 421=head2 Class::MOP functions
ea249879 422
2af88019 423The following functions are not exportable.
ea249879 424
a672bf86 425=head3 C<< Mouse::Util::is_class_loaded($classname) -> Bool >>
ea249879 426
a672bf86 427Returns whether I<$classname> is actually loaded or not.
428It uses a heuristic which involves checking for the existence of
429C<$VERSION>, C<@ISA>, and any locally-defined method.
1820fffe 430
a672bf86 431=head3 C<< Mouse::Util::load_class($classname) -> ClassName >>
1820fffe 432
a672bf86 433This will load a given I<$classname> (or die if it is not loadable).
1820fffe 434This function can be used in place of tricks like
a672bf86 435C<eval "use $module ()"> or using C<require>.
ea249879 436
a672bf86 437=head3 C<< Mouse::Util::class_of($classname_or_object) -> MetaClass >>
739525d0 438
a672bf86 439=head3 C<< Mouse::Util::get_metaclass_by_name($classname) -> MetaClass >>
739525d0 440
a672bf86 441=head3 C<< Mouse::Util::get_all_metaclass_instances() -> (MetaClasses) >>
739525d0 442
a672bf86 443=head3 C<< Mouse::Util::get_all_metaclass_names() -> (ClassNames) >>
739525d0 444
ea249879 445=head2 MRO::Compat
446
447=head3 C<get_linear_isa>
448
449=head2 Sub::Identify
450
451=head3 C<get_code_info>
452
5482cd4c 453=head1 Mouse specific utilities
ea249879 454
bedd575c 455=head3 C<not_supported>
f38ce2d0 456
5482cd4c 457=head3 C<get_code_package>
458
459=head3 C<get_code_ref>
460
1820fffe 461=head1 SEE ALSO
462
463L<Moose::Util>
464
5164490d 465L<Class::MOP>
1820fffe 466
467L<Sub::Identify>
468
469L<MRO::Compat>
470
f38ce2d0 471=cut
472