File Coverage

blib/lib/Mouse/Tiny.pm
Criterion Covered Total %
statement 819 2347 34.9
branch 176 950 18.5
condition 44 402 10.9
subroutine 169 457 36.9
pod 63 252 25.0
total 1271 4408 28.8


line stmt bran cond sub pod time code
1             # This file was generated by tool/generate-mouse-tiny.pl from Mouse v2.4.10.
2             #
3             # ANY CHANGES MADE HERE WILL BE LOST!
4 4     4   35187 use strict;
  4         12  
  4         108  
5 4     4   19 use warnings;
  4         7  
  4         4861  
6             # if regular Mouse is loaded, bail out
7             unless ($INC{'Mouse.pm'}) {
8             # tell Perl we already have all of the Mouse files loaded:
9             $INC{'Mouse.pm'} = __FILE__;
10             $INC{'Mouse/Exporter.pm'} = __FILE__;
11             $INC{'Mouse/Object.pm'} = __FILE__;
12             $INC{'Mouse/Util.pm'} = __FILE__;
13             $INC{'Mouse/Role.pm'} = __FILE__;
14             $INC{'Mouse/PurePerl.pm'} = __FILE__;
15             $INC{'Mouse/Meta/Module.pm'} = __FILE__;
16             $INC{'Mouse/Meta/Attribute.pm'} = __FILE__;
17             $INC{'Mouse/Meta/Method.pm'} = __FILE__;
18             $INC{'Mouse/Meta/TypeConstraint.pm'} = __FILE__;
19             $INC{'Mouse/Meta/Role.pm'} = __FILE__;
20             $INC{'Mouse/Meta/Class.pm'} = __FILE__;
21             $INC{'Mouse/Meta/Method/Constructor.pm'} = __FILE__;
22             $INC{'Mouse/Meta/Method/Delegation.pm'} = __FILE__;
23             $INC{'Mouse/Meta/Method/Accessor.pm'} = __FILE__;
24             $INC{'Mouse/Meta/Method/Destructor.pm'} = __FILE__;
25             $INC{'Mouse/Meta/Role/Application.pm'} = __FILE__;
26             $INC{'Mouse/Meta/Role/Method.pm'} = __FILE__;
27             $INC{'Mouse/Meta/Role/Composite.pm'} = __FILE__;
28             $INC{'Mouse/Util/MetaRole.pm'} = __FILE__;
29             $INC{'Mouse/Util/TypeConstraints.pm'} = __FILE__;
30             eval sprintf("#line %d %s\n", __LINE__, __FILE__) . <<'END_OF_TINY';
31              
32             # and now their contents
33              
34             BEGIN{ # lib/Mouse/PurePerl.pm
35             package Mouse::PurePerl;
36             # The pure Perl backend for Mouse
37 2     2   17 package Mouse::Util;
  2         5  
  2         47  
38 2     2   12 use strict;
  2         4  
  2         95  
39 2     2   14 use warnings;
  2         4  
  2         81  
40             use warnings FATAL => 'redefine'; # to avoid to load Mouse::PurePerl twice
41 2     2   11  
  2         4  
  2         34  
42 2     2   10 use Scalar::Util ();
  2         5  
  2         1019  
43             use B ();
44 2     2   19  
45             require Mouse::Util;
46              
47             # taken from Class/MOP.pm
48 8     8 0 17 sub is_valid_class_name {
49             my $class = shift;
50 8 50       22  
51 8 50       23 return 0 if ref($class);
52             return 0 unless defined($class);
53 8 50       85  
54             return 1 if $class =~ /\A \w+ (?: :: \w+ )* \z/xms;
55 0         0  
56             return 0;
57             }
58              
59 8     8 1 17 sub is_class_loaded {
60             my $class = shift;
61 8 50 33     73  
      33        
62             return 0 if ref($class) || !defined($class) || !length($class);
63              
64             # walk the symbol table tree to avoid autovififying
65             # \*{${main::}{"Foo::"}{"Bar::"}} == \*main::Foo::Bar::
66 8         20  
67 8         40 my $pack = \%::;
68 24         50 foreach my $part (split('::', $class)) {
69 24 50       65 $part .= '::';
70             return 0 if !exists $pack->{$part};
71 24         47  
72 24 50       66 my $entry = \$pack->{$part};
73 24         52 return 0 if ref($entry) ne 'GLOB';
  24         63  
74             $pack = *{$entry}{HASH};
75             }
76 8 50       19  
  8         47  
77             return 0 if !%{$pack};
78              
79             # check for $VERSION or @ISA
80 8 0 33     34 return 1 if exists $pack->{VERSION}
  0   33     0  
  0         0  
81             && defined *{$pack->{VERSION}}{SCALAR} && defined ${ $pack->{VERSION} };
82 8 0 33     27 return 1 if exists $pack->{ISA}
  0   33     0  
  0         0  
83             && defined *{$pack->{ISA}}{ARRAY} && @{ $pack->{ISA} } != 0;
84              
85 8         17 # check for any method
  8         37  
86 12         22 foreach my $name( keys %{$pack} ) {
87 12 100 66     43 my $entry = \$pack->{$name};
  12         77  
88             return 1 if ref($entry) ne 'GLOB' || defined *{$entry}{CODE};
89             }
90              
91 0         0 # fail
92             return 0;
93             }
94              
95              
96             # taken from Sub::Identify
97 12     12 1 27 sub get_code_info {
98 12 50       40 my ($coderef) = @_;
99             ref($coderef) or return;
100 12         62  
101 12 50       110 my $cv = B::svref_2object($coderef);
102             $cv->isa('B::CV') or return;
103 12         59  
104 12 50       56 my $gv = $cv->GV;
105             $gv->isa('B::GV') or return;
106 12         111  
107             return ($gv->STASH->NAME, $gv->NAME);
108             }
109              
110 0     0 1 0 sub get_code_package{
111             my($coderef) = @_;
112 0         0  
113 0 0       0 my $cv = B::svref_2object($coderef);
114             $cv->isa('B::CV') or return '';
115 0         0  
116 0 0       0 my $gv = $cv->GV;
117             $gv->isa('B::GV') or return '';
118 0         0  
119             return $gv->STASH->NAME;
120             }
121              
122 0     0 1 0 sub get_code_ref{
123 2     2   14 my($package, $name) = @_;
  2         4  
  2         56  
124 2     2   8 no strict 'refs';
  2         4  
  2         64  
125 2     2   9 no warnings 'once';
  2         4  
  2         2179  
126 0         0 use warnings FATAL => 'uninitialized';
  0         0  
127             return *{$package . '::' . $name}{CODE};
128             }
129              
130 4     4 0 10 sub generate_isa_predicate_for {
131             my($for_class, $name) = @_;
132 4 0   0   20  
  0         0  
133             my $predicate = sub{ Scalar::Util::blessed($_[0]) && $_[0]->isa($for_class) };
134 4 50       14  
135 0         0 if(defined $name){
136 0         0 Mouse::Util::install_subroutines(scalar caller, $name => $predicate);
137             return;
138             }
139 4         16  
140             return $predicate;
141             }
142              
143 6     6 0 15 sub generate_can_predicate_for {
144             my($methods_ref, $name) = @_;
145 6         11  
  6         17  
146             my @methods = @{$methods_ref};
147              
148 8     8   17 my $predicate = sub{
149 8 50       45 my($instance) = @_;
150 0         0 if(Scalar::Util::blessed($instance)){
151 0 0       0 foreach my $method(@methods){
152 0         0 if(!$instance->can($method)){
153             return 0;
154             }
155 0         0 }
156             return 1;
157 8         45 }
158 6         26 return 0;
159             };
160 6 50       19  
161 6         19 if(defined $name){
162 6         13 Mouse::Util::install_subroutines(scalar caller, $name => $predicate);
163             return;
164             }
165 0         0  
166             return $predicate;
167             }
168              
169             package Mouse::Util::TypeConstraints;
170              
171 0     0 0 0  
172 0     0 0 0 sub Any { 1 }
173             sub Item { 1 }
174 0 0   0 0 0  
175 0     0 0 0 sub Bool { !$_[0] || $_[0] eq '1' }
176 0     0 0 0 sub Undef { !defined($_[0]) }
177 0 0   0 0 0 sub Defined { defined($_[0]) }
178 0     0 0 0 sub Value { defined($_[0]) && !ref($_[0]) }
179             sub Num { Scalar::Util::looks_like_number($_[0]) }
180             sub Str {
181             # We need to use a copy here to flatten MAGICs, for instance as in
182 0     0 0 0 # Str( substr($_, 0, 42) ).
183 0   0     0 my($value) = @_;
184             return defined($value) && ref(\$value) eq 'SCALAR';
185             }
186             sub Int {
187 0     0 0 0 # We need to use a copy here to save the original internal SV flags.
188 0   0     0 my($value) = @_;
189             return defined($value) && $value =~ /\A -? [0-9]+ \z/xms;
190             }
191 0     0 0 0  
192             sub Ref { ref($_[0]) }
193 0     0 0 0 sub ScalarRef {
194 0   0     0 my($value) = @_;
195             return ref($value) eq 'SCALAR' || ref($value) eq 'REF';
196 0     0 0 0 }
197 0     0 0 0 sub ArrayRef { ref($_[0]) eq 'ARRAY' }
198 0     0 0 0 sub HashRef { ref($_[0]) eq 'HASH' }
199 0     0 0 0 sub CodeRef { ref($_[0]) eq 'CODE' }
200 0     0 0 0 sub RegexpRef { ref($_[0]) eq 'Regexp' }
201             sub GlobRef { ref($_[0]) eq 'GLOB' }
202              
203 0     0 0 0 sub FileHandle {
204 0   0     0 my($value) = @_;
205             return Scalar::Util::openhandle($value)
206             || (Scalar::Util::blessed($value) && $value->isa("IO::Handle"))
207             }
208 0 0   0 0 0  
209             sub Object { Scalar::Util::blessed($_[0]) && ref($_[0]) ne 'Regexp' }
210 0     0 0 0  
211 0   0 0 0 0 sub ClassName { Mouse::Util::is_class_loaded($_[0]) }
212             sub RoleName { (Mouse::Util::class_of($_[0]) || return 0)->isa('Mouse::Meta::Role') }
213              
214 0     0   0 sub _parameterize_ArrayRef_for {
215 0         0 my($type_parameter) = @_;
216             my $check = $type_parameter->_compiled_type_constraint;
217              
218 0     0   0 return sub {
  0         0  
219 0 0       0 foreach my $value (@{$_}) {
220             return undef unless $check->($value);
221 0         0 }
222             return 1;
223 0         0 }
224             }
225              
226 0     0   0 sub _parameterize_HashRef_for {
227 0         0 my($type_parameter) = @_;
228             my $check = $type_parameter->_compiled_type_constraint;
229              
230 0     0   0 return sub {
  0         0  
231 0 0       0 foreach my $value(values %{$_}){
232             return undef unless $check->($value);
233 0         0 }
234 0         0 return 1;
235             };
236             }
237              
238             # 'Maybe' type accepts 'Any', so it requires parameters
239 0     0   0 sub _parameterize_Maybe_for {
240 0         0 my($type_parameter) = @_;
241             my $check = $type_parameter->_compiled_type_constraint;
242              
243 0   0 0   0 return sub{
244 0         0 return !defined($_) || $check->($_);
245             };
246             }
247              
248             package Mouse::Meta::Module;
249 24     24 0 106  
250             sub name { $_[0]->{package} }
251 0     0   0  
252 0     0   0 sub _method_map { $_[0]->{methods} }
253             sub _attribute_map{ $_[0]->{attributes} }
254              
255 0     0 0 0 sub namespace{
256 2     2   15 my $name = $_[0]->{package};
  2         5  
  2         632  
257 0         0 no strict 'refs';
  0         0  
258             return \%{ $name . '::' };
259             }
260              
261 8     8 0 24 sub add_method {
262             my($self, $name, $code) = @_;
263 8 50       26  
264 0         0 if(!defined $name){
265             $self->throw_error('You must pass a defined name');
266 8 50       26 }
267 0         0 if(!defined $code){
268             $self->throw_error('You must pass a defined code');
269             }
270 8 50       29  
271 0         0 if(ref($code) ne 'CODE'){
  0         0  
272             $code = \&{$code}; # coerce
273             }
274 8         22  
275             $self->{methods}->{$name} = $code; # Moose stores meta object here.
276 8         24  
277             Mouse::Util::install_subroutines($self->name,
278             $name => $code,
279 8         18 );
280             return;
281             }
282              
283 2         8 my $generate_class_accessor = sub {
284             my($name) = @_;
285 4     4   10 return sub {
286 4 50       14 my $self = shift;
287 0         0 if(@_) {
288             return $self->{$name} = shift;
289             }
290 4         14  
291 8 100       20 foreach my $class($self->linearized_isa) {
292             my $meta = Mouse::Util::get_metaclass_by_name($class)
293             or next;
294 4 50       18  
295 0         0 if(exists $meta->{$name}) {
296             return $meta->{$name};
297             }
298 4         13 }
299 2         14 return undef;
300 2         14 };
301             };
302              
303              
304             package Mouse::Meta::Class;
305 2     2   762  
  2         821  
  2         77  
306 2     2   11 use Mouse::Meta::Method::Constructor;
  2         3  
  2         4175  
307             use Mouse::Meta::Method::Destructor;
308 0 0   0 0 0  
309 4 50   4 0 44 sub method_metaclass { $_[0]->{method_metaclass} || 'Mouse::Meta::Method' }
310             sub attribute_metaclass { $_[0]->{attribute_metaclass} || 'Mouse::Meta::Attribute' }
311 4 50   4 0 31  
312 0 0   0 0 0 sub constructor_class { $_[0]->{constructor_class} || 'Mouse::Meta::Method::Constructor' }
313             sub destructor_class { $_[0]->{destructor_class} || 'Mouse::Meta::Method::Destructor' }
314              
315 4     4 0 16 sub is_anon_class{
316             return exists $_[0]->{anon_serial_id};
317             }
318 0     0 0 0  
319             sub roles { $_[0]->{roles} }
320 8     8 1 15  
  8         52  
321             sub linearized_isa { @{ Mouse::Util::get_linear_isa($_[0]->{package}) } }
322              
323 4     4 1 11 sub new_object {
324 4 50       14 my $meta = shift;
  4         20  
325             my %args = (@_ == 1 ? %{$_[0]} : @_);
326 4         14  
327             my $object = bless {}, $meta->name;
328 4         20  
329             $meta->_initialize_object($object, \%args, 0);
330 4 50       39 # BUILDALL
331 0         0 if( $object->can('BUILD') ) {
332 0   0     0 for my $class (reverse $meta->linearized_isa) {
333             my $build = Mouse::Util::get_code_ref($class, 'BUILD')
334             || next;
335 0         0  
336             $object->$build(\%args);
337             }
338 4         31 }
339             return $object;
340             }
341              
342 0     0 1 0 sub clone_object {
343 0         0 my $class = shift;
344 0         0 my $object = shift;
345             my $args = $object->Mouse::Object::BUILDARGS(@_);
346 0 0 0     0  
347             (Scalar::Util::blessed($object) && $object->isa($class->name))
348             || $class->throw_error("You must pass an instance of the metaclass (" . $class->name . "), not ($object)");
349 0         0  
350 0         0 my $cloned = bless { %$object }, ref $object;
351 0         0 $class->_initialize_object($cloned, $args, 1);
352             return $cloned;
353             }
354              
355 4     4   12 sub _initialize_object{
356             my($self, $object, $args, $is_cloning) = @_;
357             # The initializer, which is used everywhere, must be clear
358             # when an attribute is added. See Mouse::Meta::Class::add_attribute.
359 4   33     27 my $initializer = $self->{_mouse_cache}{_initialize_object} ||=
360             Mouse::Util::load_class($self->constructor_class)
361 4         10 ->_generate_initialize_object($self);
  4         15  
362             goto &{$initializer};
363             }
364              
365 4     4 1 11 sub get_all_attributes {
366 4         8 my($self) = @_;
367 4   33     27 return @{ $self->{_mouse_cache}{all_attributes}
368             ||= $self->_calculate_all_attributes };
369             }
370 0     0 0 0  
371             sub is_immutable { $_[0]->{is_immutable} }
372              
373 2         9 sub strict_constructor;
374             *strict_constructor = $generate_class_accessor->('strict_constructor');
375              
376 4     4   12 sub _invalidate_metaclass_cache {
377 4         9 my($self) = @_;
378 4         8 delete $self->{_mouse_cache};
379             return;
380             }
381              
382 0     0   0 sub _report_unknown_args {
383             my($metaclass, $attrs, $args) = @_;
384 0         0  
385             my @unknowns;
386 0         0 my %init_args;
  0         0  
387 0         0 foreach my $attr(@{$attrs}){
388 0 0       0 my $init_arg = $attr->init_arg;
389 0         0 if(defined $init_arg){
390             $init_args{$init_arg}++;
391             }
392             }
393 0         0  
  0         0  
394 0 0       0 while(my $key = each %{$args}){
395 0         0 if(!exists $init_args{$key}){
396             push @unknowns, $key;
397             }
398             }
399 0         0  
400             $metaclass->throw_error( sprintf
401             "Unknown attribute passed to the constructor of %s: %s",
402             $metaclass->name, Mouse::Util::english_list(@unknowns),
403             );
404             }
405              
406             package Mouse::Meta::Role;
407 0 0   0 0 0  
408             sub method_metaclass{ $_[0]->{method_metaclass} || 'Mouse::Meta::Role::Method' }
409              
410 0     0 0 0 sub is_anon_role{
411             return exists $_[0]->{anon_serial_id};
412             }
413 0     0 0 0  
414             sub get_roles { $_[0]->{roles} }
415              
416 0     0 0 0 sub add_before_method_modifier {
417             my ($self, $method_name, $method) = @_;
418 0   0     0  
  0         0  
419 0         0 push @{ $self->{before_method_modifiers}{$method_name} ||= [] }, $method;
420             return;
421             }
422 0     0 0 0 sub add_around_method_modifier {
423             my ($self, $method_name, $method) = @_;
424 0   0     0  
  0         0  
425 0         0 push @{ $self->{around_method_modifiers}{$method_name} ||= [] }, $method;
426             return;
427             }
428 0     0 0 0 sub add_after_method_modifier {
429             my ($self, $method_name, $method) = @_;
430 0   0     0  
  0         0  
431 0         0 push @{ $self->{after_method_modifiers}{$method_name} ||= [] }, $method;
432             return;
433             }
434              
435 0     0 0 0 sub get_before_method_modifiers {
436 0   0     0 my ($self, $method_name) = @_;
  0         0  
437             return @{ $self->{before_method_modifiers}{$method_name} ||= [] }
438             }
439 0     0 0 0 sub get_around_method_modifiers {
440 0   0     0 my ($self, $method_name) = @_;
  0         0  
441             return @{ $self->{around_method_modifiers}{$method_name} ||= [] }
442             }
443 0     0 0 0 sub get_after_method_modifiers {
444 0   0     0 my ($self, $method_name) = @_;
  0         0  
445             return @{ $self->{after_method_modifiers}{$method_name} ||= [] }
446             }
447              
448 0     0 0 0 sub add_metaclass_accessor { # for meta roles (a.k.a. traits)
449 0         0 my($meta, $name) = @_;
450 0         0 $meta->add_method($name => $generate_class_accessor->($name));
451             return;
452             }
453              
454             package Mouse::Meta::Attribute;
455 2         11  
456             require Mouse::Meta::Method::Accessor;
457 4 50   4 0 25  
458             sub accessor_metaclass{ $_[0]->{accessor_metaclass} || 'Mouse::Meta::Method::Accessor' }
459              
460             # readers
461 12     12 0 41  
462 4     4 0 12 sub name { $_[0]->{name} }
463             sub associated_class { $_[0]->{associated_class} }
464 0     0 0 0  
465 0     0 0 0 sub accessor { $_[0]->{accessor} }
466 0     0 0 0 sub reader { $_[0]->{reader} }
467 0     0 0 0 sub writer { $_[0]->{writer} }
468 0     0 0 0 sub predicate { $_[0]->{predicate} }
469 0     0 0 0 sub clearer { $_[0]->{clearer} }
470             sub handles { $_[0]->{handles} }
471 0     0   0  
472 4     4 0 13 sub _is_metadata { $_[0]->{is} }
473             sub is_required { $_[0]->{required} }
474 4     4 0 10 sub default {
475 4         10 my($self, $instance) = @_;
476 4 50 33     18 my $value = $self->{default};
477 4         12 $value = $value->($instance) if defined($instance) and ref($value) eq "CODE";
478             return $value;
479 4     4 0 16 }
480 0     0 0 0 sub is_lazy { $_[0]->{lazy} }
481 8     8 0 19 sub is_lazy_build { $_[0]->{lazy_build} }
482 4     4 0 13 sub is_weak_ref { $_[0]->{weak_ref} }
483 12     12 0 34 sub init_arg { $_[0]->{init_arg} }
484             sub type_constraint { $_[0]->{type_constraint} }
485 4     4 1 10  
486 4     4 0 9 sub trigger { $_[0]->{trigger} }
487 4     4 0 9 sub builder { $_[0]->{builder} }
488 0     0 0 0 sub should_auto_deref { $_[0]->{auto_deref} }
489             sub should_coerce { $_[0]->{coerce} }
490 0     0 0 0  
491 0     0 0 0 sub documentation { $_[0]->{documentation} }
492             sub insertion_order { $_[0]->{insertion_order} }
493              
494             # predicates
495 0     0 0 0  
496 0     0 0 0 sub has_accessor { exists $_[0]->{accessor} }
497 0     0 0 0 sub has_reader { exists $_[0]->{reader} }
498 0     0 0 0 sub has_writer { exists $_[0]->{writer} }
499 0     0 0 0 sub has_predicate { exists $_[0]->{predicate} }
500 0     0 0 0 sub has_clearer { exists $_[0]->{clearer} }
501             sub has_handles { exists $_[0]->{handles} }
502 4     4 0 23  
503 0     0 0 0 sub has_default { exists $_[0]->{default} }
504 4     4 0 18 sub has_type_constraint { exists $_[0]->{type_constraint} }
505 4     4 0 26 sub has_trigger { exists $_[0]->{trigger} }
506             sub has_builder { exists $_[0]->{builder} }
507 0     0 0 0  
508             sub has_documentation { exists $_[0]->{documentation} }
509              
510 4     4   12 sub _process_options{
511             my($class, $name, $args) = @_;
512              
513             # taken from Class::MOP::Attribute::new
514 4 50       14  
515             defined($name)
516             or $class->throw_error('You must provide a name for the attribute');
517 4 50       17  
518 4         10 if(!exists $args->{init_arg}){
519             $args->{init_arg} = $name;
520             }
521              
522 4         11 # 'required' requires either 'init_arg', 'builder', or 'default'
523             my $can_be_required = defined( $args->{init_arg} );
524 4 50       28  
    50          
525             if(exists $args->{builder}){
526             # XXX:
527             # Moose refuses a CODE ref builder, but Mouse doesn't for backward compatibility
528             # This feature will be changed in a future. (gfx)
529             $class->throw_error('builder must be a defined scalar value which is a method name')
530 0 0       0 #if ref $args->{builder} || !defined $args->{builder};
531             if !defined $args->{builder};
532 0         0  
533             $can_be_required++;
534             }
535 0 0 0     0 elsif(exists $args->{default}){
536 0         0 if(ref $args->{default} && ref($args->{default}) ne 'CODE'){
537             $class->throw_error("References are not allowed as default values, you must "
538             . "wrap the default of '$name' in a CODE reference (ex: sub { [] } and not [])");
539 0         0 }
540             $can_be_required++;
541             }
542 4 50 33     18  
543 0         0 if( $args->{required} && !$can_be_required ) {
544             $class->throw_error("You cannot have a required attribute ($name) without a default, builder, or an init_arg");
545             }
546              
547             # taken from Mouse::Meta::Attribute->new and ->_process_args
548 4 50       16  
549 4         10 if(exists $args->{is}){
550             my $is = $args->{is};
551 4 50       18  
    50          
    0          
552 0   0     0 if($is eq 'ro'){
553             $args->{reader} ||= $name;
554             }
555 4 50       13 elsif($is eq 'rw'){
556 0   0     0 if(exists $args->{writer}){
557             $args->{reader} ||= $name;
558             }
559 4   33     24 else{
560             $args->{accessor} ||= $name;
561             }
562             }
563             elsif($is eq 'bare'){
564             # do nothing, but don't complain (later) about missing methods
565             }
566 0 0       0 else{
567 0         0 $is = 'undef' if !defined $is;
568             $class->throw_error("I do not understand this option (is => $is) on attribute ($name)");
569             }
570             }
571 4         10  
572 4 50       14 my $tc;
573 0         0 if(exists $args->{isa}){
574             $tc = $args->{type_constraint} = Mouse::Util::TypeConstraints::find_or_create_isa_type_constraint($args->{isa});
575             }
576 4 50       16  
577 0 0       0 if(exists $args->{does}){
578 0         0 if(defined $tc){ # both isa and does supplied
579 0         0 my $does_ok = do{
580 0         0 local $@;
  0         0  
581             eval{ "$tc"->does($args->{does}) };
582 0 0       0 };
583 0         0 if(!$does_ok){
584             $class->throw_error("Cannot have both an isa option and a does option because '$tc' does not do '$args->{does}' on attribute ($name)");
585             }
586             }
587 0         0 else {
588             $tc = $args->{type_constraint} = Mouse::Util::TypeConstraints::find_or_create_does_type_constraint($args->{does});
589             }
590             }
591 4 50       77  
592 0 0       0 if($args->{coerce}){
593             defined($tc)
594             || $class->throw_error("You cannot have coercion without specifying a type constraint on attribute ($name)");
595              
596 0 0       0 $args->{weak_ref}
597             && $class->throw_error("You cannot have a weak reference to a coerced value on attribute ($name)");
598             }
599 4 50       17  
600             if ($args->{lazy_build}) {
601 0 0       0 exists($args->{default})
602             && $class->throw_error("You can not use lazy_build and default for the same attribute ($name)");
603 0         0  
604 0   0     0 $args->{lazy} = 1;
605 0 0       0 $args->{builder} ||= "_build_${name}";
606 0   0     0 if ($name =~ /^_/) {
607 0   0     0 $args->{clearer} ||= "_clear${name}";
608             $args->{predicate} ||= "_has${name}";
609             }
610 0   0     0 else {
611 0   0     0 $args->{clearer} ||= "clear_${name}";
612             $args->{predicate} ||= "has_${name}";
613             }
614             }
615 4 50       15  
616 0 0       0 if ($args->{auto_deref}) {
617             defined($tc)
618             || $class->throw_error("You cannot auto-dereference without specifying a type constraint on attribute ($name)");
619 0 0 0     0  
620             ( $tc->is_a_type_of('ArrayRef') || $tc->is_a_type_of('HashRef') )
621             || $class->throw_error("You cannot auto-dereference anything other than a ArrayRef or HashRef on attribute ($name)");
622             }
623 4 50       15  
624             if (exists $args->{trigger}) {
625 0 0       0 ('CODE' eq ref $args->{trigger})
626             || $class->throw_error("Trigger must be a CODE ref on attribute ($name)");
627             }
628 4 50       15  
629             if ($args->{lazy}) {
630 0 0 0     0 (exists $args->{default} || defined $args->{builder})
631             || $class->throw_error("You cannot have a lazy attribute ($name) without specifying a default value for it");
632             }
633 4         10  
634             return;
635             }
636              
637              
638             package Mouse::Meta::TypeConstraint;
639              
640 2         14 use overload
641             '""' => '_as_string',
642             '0+' => '_identity',
643             '|' => '_unite',
644 2     2   2337  
  2         1722  
645             fallback => 1;
646 0     0 1 0  
647 0     0 1 0 sub name { $_[0]->{name} }
648 0     0 1 0 sub parent { $_[0]->{parent} }
649             sub message { $_[0]->{message} }
650 0     0   0  
651             sub _identity { Scalar::Util::refaddr($_[0]) } # overload 0+
652 0     0 0 0  
653 0     0   0 sub type_parameter { $_[0]->{type_parameter} }
654             sub _compiled_type_constraint{ $_[0]->{compiled_type_constraint} }
655 0     0   0  
656 0     0 1 0 sub __is_parameterized { exists $_[0]->{type_parameter} }
657             sub has_coercion { exists $_[0]->{_compiled_type_coercion} }
658              
659              
660 6     6 0 8 sub compile_type_constraint{
661             my($self) = @_;
662              
663 6         12 # add parents first
664 6         76 my @checks;
665 6 50       27 for(my $parent = $self->{parent}; defined $parent; $parent = $parent->{parent}){
    50          
666 0         0 if($parent->{hand_optimized_type_constraint}){
667 0         0 unshift @checks, $parent->{hand_optimized_type_constraint};
668             last; # a hand optimized constraint must include all the parents
669             }
670 0         0 elsif($parent->{constraint}){
671             unshift @checks, $parent->{constraint};
672             }
673             }
674              
675 6 50       19 # then add child
676 0         0 if($self->{constraint}){
677             push @checks, $self->{constraint};
678             }
679 6 50       15  
680 0         0 if($self->{type_constraints}){ # Union
  0         0  
  0         0  
681             my @types = map{ $_->{compiled_type_constraint} } @{ $self->{type_constraints} };
682 0     0   0 push @checks, sub{
683 0 0       0 foreach my $c(@types){
684             return 1 if $c->($_[0]);
685 0         0 }
686 0         0 return 0;
687             };
688             }
689 6 50       16  
690 6         12 if(@checks == 0){
691             $self->{compiled_type_constraint} = \&Mouse::Util::TypeConstraints::Any;
692             }
693             else{
694 0     0   0 $self->{compiled_type_constraint} = sub{
695 0         0 my(@args) = @_;
696 0         0 for ($args[0]) { # local $_ will cancel tie-ness due to perl's bug
697 0 0       0 foreach my $c(@checks){
698             return undef if !$c->(@args);
699             }
700 0         0 }
701 0         0 return 1;
702             };
703 6         12 }
704             return;
705             }
706              
707 0     0 1 0 sub check {
708 0         0 my $self = shift;
709             return $self->_compiled_type_constraint->(@_);
710             }
711              
712              
713             package Mouse::Object;
714              
715 8     8 1 17 sub BUILDARGS {
716             my $class = shift;
717 8 50       27  
718 0 0       0 if (scalar @_ == 1) {
719             (ref($_[0]) eq 'HASH')
720             || $class->meta->throw_error("Single parameters to new() must be a HASH ref");
721 0         0  
  0         0  
722             return {%{$_[0]}};
723             }
724 8         31 else {
725             return {@_};
726             }
727             }
728              
729 4     4 1 31 sub new {
730 4         22 my $class = shift;
731 4         17 my $args = $class->BUILDARGS(@_);
732             return $class->meta->new_object($args);
733             }
734              
735 4     4   2547 sub DESTROY {
736             my $self = shift;
737 4 50       91  
738             return unless $self->can('DEMOLISH'); # short circuit
739 0         0  
740 0         0 my $e = do{
741 0         0 local $?;
742 0         0 local $@;
743             eval{
744             # DEMOLISHALL
745              
746             # We cannot count on being able to retrieve a previously made
747             # metaclass, _or_ being able to make a new one during global
748             # destruction. However, we should still be able to use mro at
749             # that time (at least tests suggest so ;)
750 0         0  
  0         0  
751 0   0     0 foreach my $class (@{ Mouse::Util::get_linear_isa(ref $self) }) {
752             my $demolish = Mouse::Util::get_code_ref($class, 'DEMOLISH')
753             || next;
754 0         0  
755             $self->$demolish(Mouse::Util::in_global_destruction());
756             }
757 0         0 };
758             $@;
759             };
760 2     2   1623  
  2         5  
  2         510  
761 0 0       0 no warnings 'misc';
762             die $e if $e; # rethrow
763             }
764              
765 0     0 1 0 sub BUILDALL {
766             my $self = shift;
767              
768 0 0       0 # short circuit
769             return unless $self->can('BUILD');
770 0         0  
771 0   0     0 for my $class (reverse $self->meta->linearized_isa) {
772             my $build = Mouse::Util::get_code_ref($class, 'BUILD')
773             || next;
774 0         0  
775             $self->$build(@_);
776 0         0 }
777             return;
778             }
779              
780 2         97 sub DEMOLISHALL;
781             *DEMOLISHALL = \&DESTROY;
782              
783 0         0 }
784             BEGIN{ # lib/Mouse/Exporter.pm
785 2     2   14 package Mouse::Exporter;
  2         4  
  2         60  
786 2     2   11 use strict;
  2         8  
  2         69  
787 2     2   13 use warnings;
  2         5  
  2         928  
788             use Carp ();
789 2     2   7  
790             my %SPEC;
791              
792             # it must be "require", because Mouse::Util depends on Mouse::Exporter,
793 2         195 # which depends on Mouse::Util::import()
794             require Mouse::Util;
795              
796 8     8   41 sub import{
797 8         176 strict->import;
798 8         365 warnings->import('all', FATAL => 'recursion');
799             return;
800             }
801              
802              
803 10     10 1 43 sub setup_import_methods{
804             my($class, %args) = @_;
805 10   33     79  
806             my $exporting_package = $args{exporting_package} ||= caller();
807 10         41  
808             my($import, $unimport) = $class->build_import_methods(%args);
809              
810             Mouse::Util::install_subroutines($exporting_package,
811             import => $import,
812             unimport => $unimport,
813              
814 0     0   0 export_to_level => sub {
815 0         0 my($package, $level, undef, @args) = @_; # the third argument is redundant
816             $package->import({ into_level => $level + 1 }, @args);
817             },
818 0     0   0 export => sub {
819 0         0 my($package, $into, @args) = @_;
820             $package->import({ into => $into }, @args);
821 10         95 },
822 10         86 );
823             return;
824             }
825              
826 10     10 1 30 sub build_import_methods{
827             my($self, %args) = @_;
828 10   33     34  
829             my $exporting_package = $args{exporting_package} ||= caller();
830 10         54  
831             $SPEC{$exporting_package} = \%args;
832              
833 10         22 # canonicalize args
834 10 100       26 my @export_from;
835 2         73 if($args{also}){
836 2         6 my %seen;
837             my @stack = ($exporting_package);
838 2         37  
839 4         8 while(my $current = shift @stack){
840             push @export_from, $current;
841 4 100       19  
842 2 50       8 my $also = $SPEC{$current}{also} or next;
  2         14  
  0         0  
843             push @stack, grep{ !$seen{$_}++ } ref($also) ? @{ $also } : $also;
844             }
845             }
846 8         23 else{
847             @export_from = ($exporting_package);
848             }
849 10         39  
850             my %exports;
851 10         0 my @removables;
852             my @all;
853 10         0  
854             my @init_meta_methods;
855 10         26  
856 12 50       39 foreach my $package(@export_from){
857             my $spec = $SPEC{$package} or next;
858 12 100       32  
859 10         31 if(my $as_is = $spec->{as_is}){
  10         23  
860 140         240 foreach my $thingy (@{$as_is}){
861             my($code_package, $code_name, $code);
862 140 100       255  
863 12         23 if(ref($thingy)){
864 12         46 $code = $thingy;
865             ($code_package, $code_name) = Mouse::Util::get_code_info($code);
866             }
867 128         171 else{
868 128         167 $code_package = $package;
869 2     2   13 $code_name = $thingy;
  2         4  
  2         1869  
870 128         156 no strict 'refs';
  128         332  
871             $code = \&{ $code_package . '::' . $code_name };
872             }
873 140         245  
874 140         250 push @all, $code_name;
875 140 100       293 $exports{$code_name} = $code;
876 128         248 if($code_package eq $package){
877             push @removables, $code_name;
878             }
879             }
880             }
881 12 100       127  
882 6 50       19 if(my $init_meta = $package->can('init_meta')){
  0         0  
883 6         18 if(!grep{ $_ == $init_meta } @init_meta_methods){
884             push @init_meta_methods, $init_meta;
885             }
886             }
887 10         23 }
888 10         20 $args{EXPORTS} = \%exports;
889             $args{REMOVABLES} = \@removables;
890 10   50     59  
891             $args{groups}{all} ||= \@all;
892 10 100       25  
893 2         4 if(my $default_list = $args{groups}{default}){
894 2         4 my %default;
  2         5  
895 0   0     0 foreach my $keyword(@{$default_list}){
896             $default{$keyword} = $exports{$keyword}
897             || Carp::confess(qq{The $exporting_package package does not export "$keyword"});
898 2         5 }
899             $args{DEFAULT} = \%default;
900             }
901 8   50     43 else{
902 8         18 $args{groups}{default} ||= \@all;
903             $args{DEFAULT} = $args{EXPORTS};
904             }
905 10 100       31  
906 6         11 if(@init_meta_methods){
907             $args{INIT_META} = \@init_meta_methods;
908             }
909 10         51  
910             return (\&do_import, \&do_unimport);
911             }
912              
913             # the entity of general import()
914 36     36 0 131 sub do_import {
915             my($package, @args) = @_;
916 36   33     130  
917             my $spec = $SPEC{$package}
918             || Carp::confess("The package $package package does not use Mouse::Exporter");
919 36 50       124  
920             my $into = _get_caller_package(ref($args[0]) ? shift @args : undef);
921 36         96  
922             my @exports;
923             my @traits;
924 36         99  
925 28         52 while(@args){
926 28 50       163 my $arg = shift @args;
    100          
927 0 0       0 if($arg =~ s/^-//){
928 0 0       0 if($arg eq 'traits'){
  0         0  
929             push @traits, ref($args[0]) ? @{shift(@args)} : shift(@args);
930             }
931 0         0 else {
932             Mouse::Util::not_supported("-$arg");
933             }
934             }
935 22   33     68 elsif($arg =~ s/^://){
936             my $group = $spec->{groups}{$arg}
937 22         35 || Carp::confess(qq{The $package package does not export the group "$arg"});
  22         84  
938             push @exports, @{$group};
939             }
940 6         23 else{
941             push @exports, $arg;
942             }
943             }
944 36         192  
945 36         525 strict->import;
946             warnings->import('all', FATAL => 'recursion');
947 36 100       138  
    50          
948 4         10 if($spec->{INIT_META}){
949 4         7 my $meta;
  4         12  
950 4         15 foreach my $init_meta(@{$spec->{INIT_META}}){
951             $meta = $package->$init_meta(for_class => $into);
952             }
953 4 50       14  
954 0         0 if(@traits){
955             my $type = (split /::/, ref $meta)[-1]; # e.g. "Class" for "My::Meta::Class"
956 0 0       0 @traits = map{
  0         0  
957             ref($_)
958             ? $_
959             : Mouse::Util::resolve_metaclass_alias($type => $_, trait => 1)
960             } @traits;
961 0         0  
962 0 0       0 require Mouse::Util::MetaRole;
963             Mouse::Util::MetaRole::apply_metaroles(
964             for => $into,
965             Mouse::Util::is_a_metarole($into->meta)
966             ? (role_metaroles => { role => \@traits })
967             : (class_metaroles => { class => \@traits }),
968             );
969             }
970             }
971 0         0 elsif(@traits){
972             Carp::confess("Cannot provide traits when $package does not have an init_meta() method");
973             }
974 36 100       78  
975 24         42 if(@exports){
976 24         71 my @export_table;
977             foreach my $keyword(@exports){
978 94   33     253 push @export_table,
979             $keyword => ($spec->{EXPORTS}{$keyword}
980             || Carp::confess(qq{The $package package does not export "$keyword"})
981             );
982 24         73 }
983             Mouse::Util::install_subroutines($into, @export_table);
984             }
985 12         23 else{
  12         78  
986             Mouse::Util::install_subroutines($into, %{$spec->{DEFAULT}});
987 36         8493 }
988             return;
989             }
990              
991             # the entity of general unimport()
992 0     0 0 0 sub do_unimport {
993             my($package, $arg) = @_;
994 0   0     0  
995             my $spec = $SPEC{$package}
996             || Carp::confess("The package $package does not use Mouse::Exporter");
997 0         0  
998             my $from = _get_caller_package($arg);
999 0         0  
1000 2     2   15 my $stash = do{
  2         4  
  2         434  
1001 0         0 no strict 'refs';
  0         0  
1002             \%{$from . '::'}
1003             };
1004 0         0  
  0         0  
1005 0 0       0 for my $keyword (@{ $spec->{REMOVABLES} }) {
1006 0         0 next if !exists $stash->{$keyword};
1007             my $gv = \$stash->{$keyword};
1008              
1009 0 0 0     0 # remove what is from us
  0         0  
1010 0         0 if(ref($gv) eq 'GLOB' && *{$gv}{CODE} == $spec->{EXPORTS}{$keyword}){
1011             delete $stash->{$keyword};
1012             }
1013 0         0 }
1014             return;
1015             }
1016              
1017 36     36   67 sub _get_caller_package {
1018             my($arg) = @_;
1019              
1020             # We need one extra level because it's called by import so there's a layer
1021 36 50       74 # of indirection
1022             if(ref $arg){
1023             return defined($arg->{into}) ? $arg->{into}
1024 0 0       0 : defined($arg->{into_level}) ? scalar caller(1 + $arg->{into_level})
    0          
1025             : scalar caller(1);
1026             }
1027 36         114 else{
1028             return scalar caller(1);
1029             }
1030             }
1031              
1032 0         0 }
1033             BEGIN{ # lib/Mouse/Util.pm
1034 2     2   13 package Mouse::Util;
  2         5  
  2         8  
1035             use Mouse::Exporter; # enables strict and warnings
1036              
1037             # Note that those which don't exist here are defined in XS or Mouse::PurePerl
1038              
1039             # must be here because it will be referred by other modules loaded
1040             sub get_linear_isa($;$); ## no critic
1041              
1042             # must be here because it will called in Mouse::Exporter
1043 60     60 0 111 sub install_subroutines {
1044             my $into = shift;
1045 60         209  
1046 2     2   12 while(my($name, $code) = splice @_, 0, 2){
  2         4  
  2         83  
1047 2     2   15 no strict 'refs';
  2         4  
  2         77  
1048 2     2   10 no warnings 'once', 'redefine';
  2         4  
  2         701  
1049 196         297 use warnings FATAL => 'uninitialized';
  196         1064  
  196         324  
1050             *{$into . '::' . $name} = \&{$code};
1051 60         191 }
1052             return;
1053             }
1054              
1055             BEGIN{
1056 2     2   27 # This is used in Mouse::PurePerl
1057             Mouse::Exporter->setup_import_methods(
1058             as_is => [qw(
1059             find_meta
1060             does_role
1061             resolve_metaclass_alias
1062             apply_all_roles
1063             english_list
1064              
1065             load_class
1066             is_class_loaded
1067              
1068             get_linear_isa
1069             get_code_info
1070              
1071             get_code_package
1072             get_code_ref
1073              
1074             not_supported
1075              
1076             does meta throw_error dump
1077             )],
1078             groups => {
1079             default => [], # export no functions by default
1080              
1081             # The ':meta' group is 'use metaclass' for Mouse
1082             meta => [qw(does meta dump throw_error)],
1083             },
1084             );
1085 2         5  
1086             our $VERSION = 'v2.4.10';
1087 2   0     10  
1088             my $xs = !(defined(&is_valid_class_name) || $ENV{MOUSE_PUREPERL} || $ENV{PERL_ONLY});
1089              
1090             # Because Mouse::Util is loaded first in all the Mouse sub-modules,
1091 2 50       7 # XSLoader must be placed here, not in Mouse.pm.
1092             if($xs){
1093             # XXX: XSLoader tries to get the object path from caller's file name
1094 0         0 # $hack_mouse_file fools its mechanism
1095 0   0     0 (my $hack_mouse_file = __FILE__) =~ s/.Util//; # .../Mouse/Util.pm -> .../Mouse.pm
1096             $xs = eval sprintf("#line %d %s\n", __LINE__, $hack_mouse_file) . q{
1097             local $^W = 0; # workaround 'redefine' warning to &install_subroutines
1098             no warnings 'redefine';
1099             require XSLoader;
1100             XSLoader::load('Mouse', $VERSION);
1101             Mouse::Util->import({ into => 'Mouse::Meta::Method::Constructor::XS' }, ':meta');
1102             Mouse::Util->import({ into => 'Mouse::Meta::Method::Destructor::XS' }, ':meta');
1103             Mouse::Util->import({ into => 'Mouse::Meta::Method::Accessor::XS' }, ':meta');
1104             return 1;
1105 0 0 0     0 } || 0;
1106             warn $@ if $@ && $ENV{MOUSE_XS};
1107             }
1108 2 50       5  
1109 2         11 if(!$xs){
1110             require 'Mouse/PurePerl.pm'; # we don't want to create its namespace
1111             }
1112              
1113 2         3 {
  2         4  
1114 2         15 my $value = $xs; # avoid "Constants from lexical variables potentially modified elsewhere are deprecated"
  0         0  
1115             *MOUSE_XS = sub(){ $value };
1116             }
1117              
1118 2         4 # definition of mro::get_linear_isa()
1119 2 50       9 my $get_linear_isa;
1120 2         1150 if ($] >= 5.010_000) {
1121 2         1431 require 'mro.pm';
1122             $get_linear_isa = \&mro::get_linear_isa;
1123             }
1124             else {
1125 0         0 # this code is based on MRO::Compat::__get_linear_isa
1126             my $_get_linear_isa_dfs; # this recurses so it isn't pretty
1127 0         0 $_get_linear_isa_dfs = sub {
1128             my($classname) = @_;
1129 0         0  
1130 0         0 my @lin = ($classname);
1131             my %stored;
1132 2     2   48  
  2         5  
  2         638  
1133 0         0 no strict 'refs';
  0         0  
1134 0         0 foreach my $parent (@{"$classname\::ISA"}) {
  0         0  
1135 0 0       0 foreach my $p(@{ $_get_linear_isa_dfs->($parent) }) {
1136 0         0 next if exists $stored{$p};
1137 0         0 push(@lin, $p);
1138             $stored{$p} = 1;
1139             }
1140 0         0 }
1141 0         0 return \@lin;
1142             };
1143              
1144 0         0 {
1145             package # hide from PAUSE
1146 0         0 Class::C3;
1147             our %MRO; # avoid 'once' warnings
1148             }
1149              
1150             # MRO::Compat::__get_linear_isa has no prototype, so
1151             # we define a prototyped version for compatibility with core's
1152             # See also MRO::Compat::__get_linear_isa.
1153 0         0 $get_linear_isa = sub ($;$){
1154             my($classname, $type) = @_;
1155 0 0       0  
1156 0 0       0 if(!defined $type){
1157             $type = exists $Class::C3::MRO{$classname} ? 'c3' : 'dfs';
1158 0 0       0 }
1159 0         0 if($type eq 'c3'){
1160 0         0 require Class::C3;
1161             return [Class::C3::calculateMRO($classname)];
1162             }
1163 0         0 else{
1164             return $_get_linear_isa_dfs->($classname);
1165 0         0 }
1166             };
1167             }
1168 2         50  
1169             *get_linear_isa = $get_linear_isa;
1170             }
1171 2     2   10  
  2         4  
  2         25  
1172 2     2   9 use Carp ();
  2         2  
  2         2495  
1173             use Scalar::Util ();
1174              
1175             # aliases as public APIs
1176 2     2   18 # it must be 'require', not 'use', because Mouse::Meta::Module depends on Mouse::Util
1177             require Mouse::Meta::Module; # for the entities of metaclass cache utilities
1178              
1179             # aliases
1180 2         6 {
  2         12  
1181 2         9 *class_of = \&Mouse::Meta::Module::_class_of;
1182 2         9 *get_metaclass_by_name = \&Mouse::Meta::Module::_get_metaclass_by_name;
1183 2         8 *get_all_metaclass_instances = \&Mouse::Meta::Module::_get_all_metaclass_instances;
1184             *get_all_metaclass_names = \&Mouse::Meta::Module::_get_all_metaclass_names;
1185 2         7  
1186 2         6 *Mouse::load_class = \&load_class;
1187             *Mouse::is_class_loaded = \&is_class_loaded;
1188              
1189             # is-a predicates
1190             #generate_isa_predicate_for('Mouse::Meta::TypeConstraint' => 'is_a_type_constraint');
1191             #generate_isa_predicate_for('Mouse::Meta::Class' => 'is_a_metaclass');
1192             #generate_isa_predicate_for('Mouse::Meta::Role' => 'is_a_metarole');
1193              
1194 2         16 # duck type predicates
1195 2         7 generate_can_predicate_for(['_compiled_type_constraint'] => 'is_a_type_constraint');
1196 2         5 generate_can_predicate_for(['create_anon_class'] => 'is_a_metaclass');
1197             generate_can_predicate_for(['create_anon_role'] => 'is_a_metarole');
1198             }
1199              
1200             sub in_global_destruction;
1201 2 50       13  
1202             if (defined ${^GLOBAL_PHASE}) {
1203 0     0   0 *in_global_destruction = sub {
1204 2         14 return ${^GLOBAL_PHASE} eq 'DESTRUCT';
1205             };
1206             }
1207 0         0 else {
1208 2     2   13 my $in_global_destruction = 0;
1209             END { $in_global_destruction = 1 }
1210 0         0 *in_global_destruction = sub {
1211 0         0 return $in_global_destruction;
1212             };
1213             }
1214              
1215             # Moose::Util compatible utilities
1216              
1217 0     0 1 0 sub find_meta{
1218             return class_of( $_[0] );
1219             }
1220              
1221 0     0   0 sub _does_role_impl {
1222             my ($class_or_obj, $role_name) = @_;
1223 0         0  
1224             my $meta = class_of($class_or_obj);
1225 0 0 0     0  
1226             (defined $role_name)
1227             || ($meta || 'Mouse::Meta::Class')->throw_error("You must supply a role name to does()");
1228 0   0     0  
1229             return defined($meta) && $meta->does_role($role_name);
1230             }
1231              
1232 0     0 1 0 sub does_role {
1233             my($thing, $role_name) = @_;
1234 0 0 0     0  
      0        
1235             if( (Scalar::Util::blessed($thing) || is_class_loaded($thing))
1236 0         0 && $thing->can('does')) {
1237             return $thing->does($role_name);
1238 0         0 }
1239             goto &_does_role_impl;
1240             }
1241              
1242             # taken from Mouse::Util (0.90)
1243 2         74 {
  0         0  
1244             my %cache;
1245              
1246 0     0 1 0 sub resolve_metaclass_alias {
1247             my ( $type, $metaclass_name, %options ) = @_;
1248 0 0       0  
1249             my $cache_key = $type . q{ } . ( $options{trait} ? '-Trait' : '' );
1250 0   0     0  
1251             return $cache{$cache_key}{$metaclass_name} ||= do{
1252              
1253 0 0       0 my $possible_full_name = join '::',
1254             'Mouse::Meta', $type, 'Custom', ($options{trait} ? 'Trait' : ()), $metaclass_name
1255             ;
1256 0         0  
1257             my $loaded_class = load_first_existing_class(
1258             $possible_full_name,
1259             $metaclass_name
1260             );
1261 0 0       0  
1262             $loaded_class->can('register_implementation')
1263             ? $loaded_class->register_implementation
1264             : $loaded_class;
1265             };
1266             }
1267             }
1268              
1269 2         7 # Taken from Module::Runtime
1270 4     4 0 10 sub module_notional_filename {
1271             my $class = shift;
1272 4         12  
1273             $class =~ s{::}{/}g;
1274 4         13  
1275             return $class.'.pm';
1276             }
1277              
1278             # Utilities from Class::MOP
1279              
1280             sub get_code_info;
1281             sub get_code_package;
1282              
1283             sub is_valid_class_name;
1284             sub is_class_loaded;
1285              
1286             # taken from Class/MOP.pm
1287 0 0   0 0 0 sub load_first_existing_class {
1288             my @classes = @_
1289             or return;
1290 0         0  
1291 0         0 my %exceptions;
1292 0         0 for my $class (@classes) {
1293             my $e = _try_load_one_class($class);
1294 0 0       0  
1295 0         0 if ($e) {
1296             $exceptions{$class} = $e;
1297             }
1298 0         0 else {
1299             return $class;
1300             }
1301             }
1302              
1303             # not found
1304             Carp::confess join(
1305             "\n",
1306 0         0 map {
1307 0         0 sprintf( "Could not load class (%s) because : %s",
1308             $_, $exceptions{$_} )
1309             } @classes
1310             );
1311             }
1312              
1313             # taken from Class/MOP.pm
1314 8     8   16 sub _try_load_one_class {
1315             my $class = shift;
1316 8 50       26  
1317 0 0       0 unless ( is_valid_class_name($class) ) {
1318 0         0 my $display = defined($class) ? $class : 'undef';
1319             Carp::confess "Invalid class name ($display)";
1320             }
1321 8 50       27  
1322             return '' if is_class_loaded($class);
1323 0         0  
1324             my $filename = module_notional_filename($class);
1325 0         0  
1326 0         0 return do {
1327 0         0 local $@;
  0         0  
1328 0         0 eval { require $filename };
1329             $@;
1330             };
1331             }
1332              
1333              
1334 8     8 1 17 sub load_class {
1335 8         25 my $class = shift;
1336 8 50       28 my $e = _try_load_one_class($class);
1337             Carp::confess "Could not load class ($class) because : $e" if $e;
1338 8         30  
1339             return $class;
1340             }
1341              
1342              
1343 0 0   0 1 0 sub apply_all_roles {
1344             my $consumer = Scalar::Util::blessed($_[0])
1345             ? $_[0] # instance
1346             : Mouse::Meta::Class->initialize($_[0]); # class or role name
1347 0         0  
1348             my @roles;
1349              
1350 0         0 # Basis of Data::OptList
1351 0         0 my $max = scalar(@_);
1352 0         0 for (my $i = 1; $i < $max ; $i++) {
1353 0         0 my $role = $_[$i];
1354 0 0       0 my $role_name;
1355 0         0 if(ref $role) {
1356             $role_name = $role->name;
1357             }
1358 0         0 else {
1359 0         0 $role_name = $role;
1360 0         0 load_class($role_name);
1361             $role = get_metaclass_by_name($role_name);
1362             }
1363 0 0 0     0  
1364 0         0 if ($i + 1 < $max && ref($_[$i + 1]) eq 'HASH') {
1365             push @roles, [ $role => $_[++$i] ];
1366 0         0 } else {
1367             push @roles, [ $role => undef ];
1368 0 0       0 }
1369             is_a_metarole($role)
1370             || $consumer->meta->throw_error("You can only consume roles, $role_name is not a Mouse role");
1371             }
1372 0 0       0  
1373 0         0 if ( scalar @roles == 1 ) {
  0         0  
1374 0 0       0 my ( $role, $params ) = @{ $roles[0] };
1375             $role->apply( $consumer, defined $params ? $params : () );
1376             }
1377 0         0 else {
1378             Mouse::Meta::Role->combine(@roles)->apply($consumer);
1379 0         0 }
1380             return;
1381             }
1382              
1383             # taken from Moose::Util 0.90
1384 0 0   0 0 0 sub english_list {
1385             return $_[0] if @_ == 1;
1386 0         0  
1387             my @items = sort @_;
1388 0 0       0  
1389             return "$items[0] and $items[1]" if @items == 2;
1390 0         0  
1391             my $tail = pop @items;
1392 0         0  
1393             return join q{, }, @items, "and $tail";
1394             }
1395              
1396 0     0 0 0 sub quoted_english_list {
  0         0  
1397             return english_list(map { qq{'$_'} } @_);
1398             }
1399              
1400             # common utilities
1401              
1402 0     0 1 0 sub not_supported{
1403             my($feature) = @_;
1404 0   0     0  
1405             $feature ||= ( caller(1) )[3] . '()'; # subroutine name
1406 0         0  
1407 0         0 local $Carp::CarpLevel = $Carp::CarpLevel + 1;
1408             Carp::confess("Mouse does not currently support $feature");
1409             }
1410              
1411             # general meta() method
1412 0   0 0 0 0 sub meta :method{
1413             return Mouse::Meta::Class->initialize(ref($_[0]) || $_[0]);
1414             }
1415              
1416             # general throw_error() method
1417             # $o->throw_error($msg, depth => $leve, longmess => $croak_or_confess)
1418 0     0 0 0 sub throw_error :method {
1419             my($self, $message, %args) = @_;
1420 0   0     0  
1421 0         0 local $Carp::CarpLevel = $Carp::CarpLevel + 1 + ($args{depth} || 0);
1422             local $Carp::MaxArgNums = 20; # default is 8, usually we use named args which gets messier though
1423 0 0 0     0  
1424 0         0 if(exists $args{longmess} && !$args{longmess}) {
1425             Carp::croak($message);
1426             }
1427 0         0 else{
1428             Carp::confess($message);
1429             }
1430             }
1431              
1432             # general dump() method
1433 0     0 0 0 sub dump :method {
1434             my($self, $maxdepth) = @_;
1435 0         0  
1436 0         0 require 'Data/Dumper.pm'; # we don't want to create its namespace
1437 0 0       0 my $dd = Data::Dumper->new([$self]);
1438 0         0 $dd->Maxdepth(defined($maxdepth) ? $maxdepth : 3);
1439 0         0 $dd->Indent(1);
1440 0         0 $dd->Sortkeys(1);
1441 0         0 $dd->Quotekeys(0);
1442             return $dd->Dump();
1443             }
1444              
1445             # general does() method
1446 0     0 0 0 sub does :method {
1447             goto &_does_role_impl;
1448             }
1449              
1450 0         0 }
1451             BEGIN{ # lib/Mouse/Meta/TypeConstraint.pm
1452 2     2   12 package Mouse::Meta::TypeConstraint;
  2     0   3  
  2         9  
1453             use Mouse::Util qw(:meta); # enables strict and warnings
1454              
1455 46     46 1 73 sub new {
1456 46 50       147 my $class = shift;
  0         0  
1457             my %args = @_ == 1 ? %{$_[0]} : @_;
1458 46 50       103  
1459             $args{name} = '__ANON__' if !defined $args{name};
1460 46         66  
1461 46 100       95 my $type_parameter;
1462 44         59 if(defined $args{parent}) { # subtyping
  44         216  
1463             %args = (%{$args{parent}}, %args);
1464              
1465             # a child type must not inherit 'compiled_type_constraint'
1466 44         100 # and 'hand_optimized_type_constraint' from the parent
1467 44         76 delete $args{compiled_type_constraint}; # don't inherit it
1468             delete $args{hand_optimized_type_constraint}; # don't inherit it
1469 44         63  
1470 44 50       109 $type_parameter = $args{type_parameter};
1471 0 0       0 if(defined(my $parent_tp = $args{parent}{type_parameter})) {
1472 0 0       0 if($parent_tp != $type_parameter) {
1473             $type_parameter->is_a_type_of($parent_tp)
1474             or $class->throw_error(
1475             "$type_parameter is not a subtype of $parent_tp",
1476             );
1477             }
1478 0         0 else {
1479             $type_parameter = undef;
1480             }
1481             }
1482             }
1483 46         68  
1484             my $check;
1485 46 100       93  
    50          
1486 40         63 if($check = delete $args{optimized}) { # likely to be builtins
1487 40         58 $args{hand_optimized_type_constraint} = $check;
1488             $args{compiled_type_constraint} = $check;
1489             }
1490             elsif(defined $type_parameter) { # parameterizing
1491 0   0     0 my $generator = $args{constraint_generator}
1492             || $class->throw_error(
1493             "The $args{name} constraint cannot be used,"
1494             . " because $type_parameter doesn't subtype"
1495             . " from a parameterizable type");
1496 0         0  
1497 0 0       0 my $parameterized_check = $generator->($type_parameter);
1498             if(defined(my $my_check = $args{constraint})) {
1499 0   0 0   0 $check = sub {
1500 0         0 return $parameterized_check->($_) && $my_check->($_);
1501             };
1502             }
1503 0         0 else {
1504             $check = $parameterized_check;
1505 0         0 }
1506             $args{constraint} = $check;
1507             }
1508 6         9 else { # common cases
1509             $check = $args{constraint};
1510             }
1511 46 50 66     210  
1512 0         0 if(defined($check) && ref($check) ne 'CODE'){
1513             $class->throw_error(
1514             "Constraint for $args{name} is not a CODE reference");
1515             }
1516 46         84  
1517             my $self = bless \%args, $class;
1518 46 100       107 $self->compile_type_constraint()
1519             if !$args{hand_optimized_type_constraint};
1520 46 50       96  
1521 0         0 if($args{type_constraints}) { # union types
  0         0  
1522 0 0       0 foreach my $type(@{$self->{type_constraints}}){
1523             if($type->has_coercion){
1524 0         0 # set undef for has_coercion()
1525 0         0 $self->{_compiled_type_coercion} = undef;
1526             last;
1527             }
1528             }
1529             }
1530 46         162  
1531             return $self;
1532             }
1533              
1534 0     0 1 0 sub create_child_type {
1535 0         0 my $self = shift;
1536             return ref($self)->new(@_, parent => $self);
1537             }
1538              
1539             sub name;
1540             sub parent;
1541             sub message;
1542             sub has_coercion;
1543              
1544             sub check;
1545              
1546             sub type_parameter;
1547             sub __is_parameterized;
1548              
1549             sub _compiled_type_constraint;
1550             sub _compiled_type_coercion;
1551              
1552             sub compile_type_constraint;
1553              
1554              
1555 0     0   0 sub _add_type_coercions { # ($self, @pairs)
1556             my $self = shift;
1557 0 0       0  
1558 0         0 if(exists $self->{type_constraints}){ # union type
1559             $self->throw_error(
1560             "Cannot add additional type coercions to Union types '$self'");
1561             }
1562 0   0     0  
1563 0         0 my $coercion_map = ($self->{coercion_map} ||= []);
  0         0  
  0         0  
1564             my %has = map{ $_->[0]->name => undef } @{$coercion_map};
1565 0         0  
1566 0         0 for(my $i = 0; $i < @_; $i++){
1567 0         0 my $from = $_[ $i];
1568             my $action = $_[++$i];
1569 0 0       0  
1570 0         0 if(exists $has{$from}){
1571             $self->throw_error("A coercion action already exists for '$from'");
1572             }
1573 0 0       0  
1574             my $type = Mouse::Util::TypeConstraints::find_or_parse_type_constraint($from)
1575             or $self->throw_error(
1576             "Could not find the type constraint ($from) to coerce from");
1577 0         0  
  0         0  
1578             push @{$coercion_map}, [ $type => $action ];
1579             }
1580 0         0  
1581 0         0 $self->{_compiled_type_coercion} = undef;
1582             return;
1583             }
1584              
1585 0     0   0 sub _compiled_type_coercion {
1586             my($self) = @_;
1587 0         0  
1588 0 0       0 my $coercion = $self->{_compiled_type_coercion};
1589             return $coercion if defined $coercion;
1590 0 0       0  
1591 0         0 if(!$self->{type_constraints}) {
1592 0         0 my @coercions;
  0         0  
1593 0         0 foreach my $pair(@{$self->{coercion_map}}) {
1594             push @coercions,
1595             [ $pair->[0]->_compiled_type_constraint, $pair->[1] ];
1596             }
1597              
1598 0     0   0 $coercion = sub {
1599 0         0 my($thing) = @_;
1600             foreach my $pair (@coercions) {
1601 0 0       0 #my ($constraint, $converter) = @$pair;
1602 0         0 if ($pair->[0]->($thing)) {
1603             return $pair->[1]->($thing) for $thing; # local $_ will cancel tie-ness due to perl's bug
1604             }
1605 0         0 }
1606 0         0 return $thing;
1607             };
1608             }
1609 0         0 else { # for union type
1610 0         0 my @coercions;
  0         0  
1611 0 0       0 foreach my $type(@{$self->{type_constraints}}){
1612 0         0 if($type->has_coercion){
1613             push @coercions, $type;
1614             }
1615 0 0       0 }
1616             if(@coercions){
1617 0     0   0 $coercion = sub {
1618 0         0 my($thing) = @_;
1619 0         0 foreach my $type(@coercions){
1620 0 0       0 my $value = $type->coerce($thing);
1621             return $value if $self->check($value);
1622 0         0 }
1623 0         0 return $thing;
1624             };
1625             }
1626             }
1627 0         0  
1628             return( $self->{_compiled_type_coercion} = $coercion );
1629             }
1630              
1631 0     0 1 0 sub coerce {
1632 0 0       0 my $self = shift;
1633             return $_[0] if $self->check(@_);
1634 0 0       0  
1635             my $coercion = $self->_compiled_type_coercion
1636 0         0 or $self->throw_error("Cannot coerce without a type coercion");
1637             return $coercion->(@_);
1638             }
1639              
1640 0     0 1 0 sub get_message {
1641 0 0       0 my ($self, $value) = @_;
1642 0         0 if ( my $msg = $self->message ) {
1643             return $msg->($value) for $value; # local $_ will cancel tie-ness due to perl's bug
1644             }
1645 0 0 0     0 else {
    0          
1646 0         0 if(not defined $value) {
1647             $value = 'undef';
1648             }
1649 0         0 elsif( ref($value) && defined(&overload::StrVal) ) {
1650             $value = overload::StrVal($value);
1651 0         0 }
1652             return "Validation failed for '$self' with value $value";
1653             }
1654             }
1655              
1656 0     0 1 0 sub is_a_type_of {
1657             my($self, $other) = @_;
1658              
1659 0 0 0     0 # ->is_a_type_of('__ANON__') is always false
1660             return 0 if !ref($other) && $other eq '__ANON__';
1661 0         0  
1662             (my $other_name = $other) =~ s/\s+//g;
1663 0 0       0  
1664             return 1 if $self->name eq $other_name;
1665 0 0       0  
1666 0         0 if(exists $self->{type_constraints}){ # union
  0         0  
1667 0 0       0 foreach my $type(@{$self->{type_constraints}}) {
1668             return 1 if $type->name eq $other_name;
1669             }
1670             }
1671 0         0  
1672 0 0       0 for(my $p = $self->parent; defined $p; $p = $p->parent) {
1673             return 1 if $p->name eq $other_name;
1674             }
1675 0         0  
1676             return 0;
1677             }
1678              
1679             # See also Moose::Meta::TypeConstraint::Parameterizable
1680 0     0 0 0 sub parameterize {
1681             my($self, $param, $name) = @_;
1682 0 0       0  
1683 0         0 if(!ref $param){
1684 0         0 require Mouse::Util::TypeConstraints;
1685             $param = Mouse::Util::TypeConstraints::find_or_create_isa_type_constraint($param);
1686             }
1687 0   0     0  
1688 0         0 $name ||= sprintf '%s[%s]', $self->name, $param->name;
1689             return Mouse::Meta::TypeConstraint->new(
1690             name => $name,
1691             parent => $self,
1692             type_parameter => $param,
1693             );
1694             }
1695              
1696 0     0 1 0 sub assert_valid {
1697             my ($self, $value) = @_;
1698 0 0       0  
1699 0         0 if(!$self->check($value)){
1700             $self->throw_error($self->get_message($value));
1701 0         0 }
1702             return 1;
1703             }
1704              
1705             # overloading stuff
1706 0     0   0  
1707             sub _as_string { $_[0]->name } # overload ""
1708             sub _identity; # overload 0+
1709              
1710 0     0   0 sub _unite { # overload infix:<|>
1711 0         0 my($lhs, $rhs) = @_;
1712 0         0 require Mouse::Util::TypeConstraints;
1713             return Mouse::Util::TypeConstraints::_find_or_create_union_type(
1714             $lhs,
1715             Mouse::Util::TypeConstraints::find_or_create_isa_type_constraint($rhs),
1716             );
1717             }
1718              
1719 0         0 }
1720             BEGIN{ # lib/Mouse/Util/TypeConstraints.pm
1721 2     2   17 package Mouse::Util::TypeConstraints;
  2         5  
  2         8  
1722             use Mouse::Util; # enables strict and warnings
1723 2     2   17  
  2         4  
  2         68  
1724 2     2   13 use Mouse::Meta::TypeConstraint;
  2         4  
  2         12  
1725             use Mouse::Exporter;
1726 2     2   12  
  2         4  
  2         32  
1727 2     2   10 use Carp ();
  2         4  
  2         4766  
1728             use Scalar::Util ();
1729 2     2   18  
1730             Mouse::Exporter->setup_import_methods(
1731             as_is => [qw(
1732             as where message optimize_as
1733             from via
1734              
1735             type subtype class_type role_type maybe_type duck_type
1736             enum
1737             coerce
1738              
1739             find_type_constraint
1740             register_type_constraint
1741             )],
1742             );
1743 2         6  
1744             our @CARP_NOT = qw(Mouse::Meta::Attribute);
1745 2         3  
1746             my %TYPE;
1747              
1748 2         7 # The root type
1749             $TYPE{Any} = Mouse::Meta::TypeConstraint->new(
1750             name => 'Any',
1751             );
1752 2         20  
1753             my @builtins = (
1754             # $name => $parent, $code,
1755              
1756             # the base type
1757             Item => 'Any', undef,
1758              
1759             # the maybe[] type
1760             Maybe => 'Item', undef,
1761              
1762             # value types
1763             Undef => 'Item', \&Undef,
1764             Defined => 'Item', \&Defined,
1765             Bool => 'Item', \&Bool,
1766             Value => 'Defined', \&Value,
1767             Str => 'Value', \&Str,
1768             Num => 'Str', \&Num,
1769             Int => 'Num', \&Int,
1770              
1771             # ref types
1772             Ref => 'Defined', \&Ref,
1773             ScalarRef => 'Ref', \&ScalarRef,
1774             ArrayRef => 'Ref', \&ArrayRef,
1775             HashRef => 'Ref', \&HashRef,
1776             CodeRef => 'Ref', \&CodeRef,
1777             RegexpRef => 'Ref', \&RegexpRef,
1778             GlobRef => 'Ref', \&GlobRef,
1779              
1780             # object types
1781             FileHandle => 'GlobRef', \&FileHandle,
1782             Object => 'Ref', \&Object,
1783              
1784             # special string types
1785             ClassName => 'Str', \&ClassName,
1786             RoleName => 'ClassName', \&RoleName,
1787             );
1788 2         8  
1789             while (my ($name, $parent, $code) = splice @builtins, 0, 3) {
1790             $TYPE{$name} = Mouse::Meta::TypeConstraint->new(
1791 40         92 name => $name,
1792             parent => $TYPE{$parent},
1793             optimized => $code,
1794             );
1795             }
1796              
1797 2         6 # parametarizable types
1798 2         5 $TYPE{Maybe} {constraint_generator} = \&_parameterize_Maybe_for;
1799 2         4 $TYPE{ArrayRef}{constraint_generator} = \&_parameterize_ArrayRef_for;
1800             $TYPE{HashRef} {constraint_generator} = \&_parameterize_HashRef_for;
1801              
1802 0     0 1 0 # sugars
1803 0     0 1 0 sub as ($) { (as => $_[0]) } ## no critic
1804 0     0 0 0 sub where (&) { (where => $_[0]) } ## no critic
1805 0     0 0 0 sub message (&) { (message => $_[0]) } ## no critic
1806             sub optimize_as (&) { (optimize_as => $_[0]) } ## no critic
1807 0     0 1 0  
1808 0     0 1 0 sub from { @_ }
1809             sub via (&) { $_[0] } ## no critic
1810              
1811             # type utilities
1812              
1813 0     0 0 0 sub optimized_constraints { # DEPRECATED
1814 0         0 Carp::cluck('optimized_constraints() has been deprecated');
1815             return \%TYPE;
1816             }
1817 2         5  
1818 2         78 undef @builtins; # free the allocated memory
1819 0     0 1 0 @builtins = keys %TYPE; # reuse it
1820 0     0 1 0 sub list_all_builtin_type_constraints { @builtins }
1821             sub list_all_type_constraints { keys %TYPE }
1822              
1823 4     4   9 sub _define_type {
1824 4         9 my $is_subtype = shift;
1825             my $name;
1826             my %args;
1827 4 50 33     34  
    50 33        
    50          
1828 0         0 if(@_ == 1 && ref $_[0] ){ # @_ : { name => $name, where => ... }
  0         0  
1829             %args = %{$_[0]};
1830             }
1831 0         0 elsif(@_ == 2 && ref $_[1]) { # @_ : $name => { where => ... }
1832 0         0 $name = $_[0];
  0         0  
1833             %args = %{$_[1]};
1834             }
1835 4         17 elsif(@_ % 2) { # @_ : $name => ( where => ... )
1836             ($name, %args) = @_;
1837             }
1838 0         0 else{ # @_ : (name => $name, where => ...)
1839             %args = @_;
1840             }
1841 4 50       14  
1842 0         0 if(!defined $name){
1843             $name = $args{name};
1844             }
1845 4         14  
1846             $args{name} = $name;
1847 4         10  
1848 4 50 33     22 my $parent = delete $args{as};
1849 0         0 if($is_subtype && !$parent){
1850 0         0 $parent = delete $args{name};
1851             $name = undef;
1852             }
1853 4 50       15  
1854 4         14 if(defined $parent) {
1855             $args{parent} = find_or_create_isa_type_constraint($parent);
1856             }
1857 4 50       12  
1858             if(defined $name){
1859 4         10 # set 'package_defined_in' only if it is not a core package
1860 4 50       12 my $this = $args{package_defined_in};
1861 4         10 if(!$this){
1862 4 50       21 $this = caller(1);
1863 0         0 if($this !~ /\A Mouse \b/xms){
1864             $args{package_defined_in} = $this;
1865             }
1866             }
1867 4 50       15  
1868 0   0     0 if(defined $TYPE{$name}){
1869 0 0       0 my $that = $TYPE{$name}->{package_defined_in} || __PACKAGE__;
1870 0         0 if($this ne $that) {
1871 0 0       0 my $note = '';
1872             if($that eq __PACKAGE__) {
1873             $note = sprintf " ('%s' is %s type constraint)",
1874 0 0       0 $name,
  0         0  
1875             scalar(grep { $name eq $_ } list_all_builtin_type_constraints())
1876             ? 'a builtin'
1877             : 'an implicitly created';
1878 0         0 }
1879             Carp::croak("The type constraint '$name' has already been created in $that"
1880             . " and cannot be created again in $this" . $note);
1881             }
1882             }
1883             }
1884 4 50       13  
1885 4 50       15 $args{constraint} = delete $args{where} if exists $args{where};
1886             $args{optimized} = delete $args{optimized_as} if exists $args{optimized_as};
1887 4         38  
1888             my $constraint = Mouse::Meta::TypeConstraint->new(%args);
1889 4 50       13  
1890 4         15 if(defined $name){
1891             return $TYPE{$name} = $constraint;
1892             }
1893 0         0 else{
1894             return $constraint;
1895             }
1896             }
1897              
1898 0     0 1 0 sub type {
1899             return _define_type 0, @_;
1900             }
1901              
1902 4     4 1 15 sub subtype {
1903             return _define_type 1, @_;
1904             }
1905              
1906 0     0 1 0 sub coerce { # coerce $type, from $from, via { ... }, ...
1907 0 0       0 my $type_name = shift;
1908             my $type = find_type_constraint($type_name)
1909             or Carp::croak("Cannot find type '$type_name', perhaps you forgot to load it");
1910 0         0  
1911 0         0 $type->_add_type_coercions(@_);
1912             return;
1913             }
1914              
1915 4     4 1 10 sub class_type {
1916 4   33     23 my($name, $options) = @_;
1917             my $class = $options->{class} || $name;
1918              
1919 4         14 # ClassType
1920             return subtype $name => (
1921             as => 'Object',
1922             optimized_as => Mouse::Util::generate_isa_predicate_for($class),
1923             class => $class,
1924             );
1925             }
1926              
1927 0     0 1 0 sub role_type {
1928 0   0     0 my($name, $options) = @_;
1929             my $role = $options->{role} || $name;
1930              
1931             # RoleType
1932             return subtype $name => (
1933             as => 'Object',
1934 0   0 0   0 optimized_as => sub {
1935             return Scalar::Util::blessed($_[0])
1936             && Mouse::Util::does_role($_[0], $role);
1937 0         0 },
1938             role => $role,
1939             );
1940             }
1941              
1942 0     0 0 0 sub maybe_type {
1943 0         0 my $param = shift;
1944             return _find_or_create_parameterized_type($TYPE{Maybe}, $param);
1945             }
1946              
1947 0     0 1 0 sub duck_type {
1948             my($name, @methods);
1949 0 0       0  
1950 0         0 if(ref($_[0]) ne 'ARRAY'){
1951             $name = shift;
1952             }
1953 0 0 0     0  
  0         0  
1954             @methods = (@_ == 1 && ref($_[0]) eq 'ARRAY') ? @{$_[0]} : @_;
1955              
1956             # DuckType
1957             return _define_type 1, $name => (
1958             as => 'Object',
1959             optimized_as => Mouse::Util::generate_can_predicate_for(\@methods),
1960 0     0   0 message => sub {
1961 0         0 my($object) = @_;
  0         0  
1962 0         0 my @missing = grep { !$object->can($_) } @methods;
1963             return ref($object)
1964             . ' is missing methods '
1965             . Mouse::Util::quoted_english_list(@missing);
1966 0         0 },
1967             methods => \@methods,
1968             );
1969             }
1970              
1971 0     0 1 0 sub enum {
1972             my($name, %valid);
1973 0 0 0     0  
1974 0         0 if(!(@_ == 1 && ref($_[0]) eq 'ARRAY')){
1975             $name = shift;
1976             }
1977 0         0  
1978 0 0 0     0 %valid = map{ $_ => undef }
  0         0  
1979             (@_ == 1 && ref($_[0]) eq 'ARRAY' ? @{$_[0]} : @_);
1980              
1981             # EnumType
1982             return _define_type 1, $name => (
1983             as => 'Str',
1984 0   0 0   0 optimized_as => sub{
1985             return defined($_[0]) && !ref($_[0]) && exists $valid{$_[0]};
1986 0         0 },
1987             );
1988             }
1989              
1990 0     0   0 sub _find_or_create_regular_type{
1991             my($spec, $create) = @_;
1992 0 0       0  
1993             return $TYPE{$spec} if exists $TYPE{$spec};
1994 0         0  
1995             my $meta = Mouse::Util::get_metaclass_by_name($spec);
1996 0 0       0  
1997 0 0       0 if(!defined $meta){
1998             return $create ? class_type($spec) : undef;
1999             }
2000 0 0       0  
2001 0         0 if(Mouse::Util::is_a_metarole($meta)){
2002             return role_type($spec);
2003             }
2004 0         0 else{
2005             return class_type($spec);
2006             }
2007             }
2008              
2009 0     0   0 sub _find_or_create_parameterized_type{
2010             my($base, $param) = @_;
2011 0         0  
2012             my $name = sprintf '%s[%s]', $base->name, $param->name;
2013 0   0     0  
2014             $TYPE{$name} ||= $base->parameterize($param, $name);
2015             }
2016              
2017 0 0   0   0 sub _find_or_create_union_type{
  0         0  
2018             return if grep{ not defined } @_; # all things must be defined
2019 0 0       0 my @types = sort
  0         0  
  0         0  
2020             map{ $_->{type_constraints} ? @{$_->{type_constraints}} : $_ } @_;
2021 0         0  
2022             my $name = join '|', @types;
2023              
2024 0   0     0 # UnionType
2025             $TYPE{$name} ||= Mouse::Meta::TypeConstraint->new(
2026             name => $name,
2027             type_constraints => \@types,
2028             );
2029             }
2030              
2031             # The type parser
2032              
2033             # param : '[' type ']' | NOTHING
2034 0     0   0 sub _parse_param {
2035             my($c) = @_;
2036 0 0       0  
2037 0         0 if($c->{spec} =~ s/^\[//){
2038             my $type = _parse_type($c, 1);
2039 0 0       0  
2040 0         0 if($c->{spec} =~ s/^\]//){
2041             return $type;
2042 0         0 }
2043             Carp::croak("Syntax error in type: missing right square bracket in '$c->{orig}'");
2044             }
2045 0         0  
2046             return undef;
2047             }
2048              
2049             # name : [\w.:]+
2050 0     0   0 sub _parse_name {
2051             my($c, $create) = @_;
2052 0 0       0  
2053 0         0 if($c->{spec} =~ s/\A ([\w.:]+) //xms){
2054             return _find_or_create_regular_type($1, $create);
2055 0         0 }
2056             Carp::croak("Syntax error in type: expect type name near '$c->{spec}' in '$c->{orig}'");
2057             }
2058              
2059             # single_type : name param
2060 0     0   0 sub _parse_single_type {
2061             my($c, $create) = @_;
2062 0         0  
2063 0         0 my $type = _parse_name($c, $create);
2064             my $param = _parse_param($c);
2065 0 0       0  
    0          
2066 0 0       0 if(defined $type){
2067 0         0 if(defined $param){
2068             return _find_or_create_parameterized_type($type, $param);
2069             }
2070 0         0 else {
2071             return $type;
2072             }
2073             }
2074 0         0 elsif(defined $param){
2075             Carp::croak("Undefined type with parameter [$param] in '$c->{orig}'");
2076             }
2077 0         0 else{
2078             return undef;
2079             }
2080             }
2081              
2082             # type : single_type ('|' single_type)*
2083 0     0   0 sub _parse_type {
2084             my($c, $create) = @_;
2085 0         0  
2086 0 0       0 my $type = _parse_single_type($c, $create);
2087 0         0 if($c->{spec}){ # can be an union type
2088 0         0 my @types;
2089 0         0 while($c->{spec} =~ s/^\|//){
2090             push @types, _parse_single_type($c, $create);
2091 0 0       0 }
2092 0         0 if(@types){
2093             return _find_or_create_union_type($type, @types);
2094             }
2095 0         0 }
2096             return $type;
2097             }
2098              
2099              
2100 4     4 1 10 sub find_type_constraint {
2101 4 50 33     13 my($spec) = @_;
2102             return $spec if Mouse::Util::is_a_type_constraint($spec) or not defined $spec;
2103 4         18  
2104 4         24 $spec =~ s/\s+//g;
2105             return $TYPE{$spec};
2106             }
2107              
2108 0     0 0 0 sub register_type_constraint {
2109 0 0       0 my($constraint) = @_;
2110             Carp::croak("No type supplied / type is not a valid type constraint")
2111 0         0 unless Mouse::Util::is_a_type_constraint($constraint);
2112             return $TYPE{$constraint->name} = $constraint;
2113             }
2114              
2115 4     4 0 10 sub find_or_parse_type_constraint {
2116 4 50 33     11 my($spec) = @_;
2117             return $spec if Mouse::Util::is_a_type_constraint($spec) or not defined $spec;
2118 4         13  
2119             $spec =~ tr/ \t\r\n//d;
2120 4         10  
2121 4 50       11 my $tc = $TYPE{$spec};
2122 4         11 if(defined $tc) {
2123             return $tc;
2124             }
2125 0         0  
2126             my %context = (
2127             spec => $spec,
2128             orig => $spec,
2129 0         0 );
2130             $tc = _parse_type(\%context);
2131 0 0       0  
2132 0         0 if($context{spec}){
2133             Carp::croak("Syntax error: extra elements '$context{spec}' in '$context{orig}'");
2134             }
2135 0         0  
2136             return $TYPE{$spec} = $tc;
2137             }
2138              
2139             sub find_or_create_does_type_constraint{
2140 0     0 0 0 # XXX: Moose does not register a new role_type, but Mouse does.
2141 0 0       0 my $tc = find_or_parse_type_constraint(@_);
2142             return defined($tc) ? $tc : role_type(@_);
2143             }
2144              
2145             sub find_or_create_isa_type_constraint {
2146 4     4 0 13 # XXX: Moose does not register a new class_type, but Mouse does.
2147 4 50       16 my $tc = find_or_parse_type_constraint(@_);
2148             return defined($tc) ? $tc : class_type(@_);
2149             }
2150              
2151 0         0 }
2152             BEGIN{ # lib/Mouse.pm
2153 2     2   47 package Mouse;
  2         7  
2154             use 5.008_005;
2155 2     2   9  
  2         4  
  2         7  
2156             use Mouse::Exporter; # enables strict and warnings
2157 2     2   8  
2158             our $VERSION = 'v2.4.10';
2159 2     2   10  
  2         5  
  2         24  
2160 2     2   8 use Carp ();
  2         3  
  2         19  
2161             use Scalar::Util ();
2162 2     2   7  
  2         3  
  2         26  
2163             use Mouse::Util ();
2164 2     2   8  
  2         3  
  2         44  
2165 2     2   10 use Mouse::Meta::Module;
  2         4  
  2         32  
2166 2     2   8 use Mouse::Meta::Class;
  2         4  
  2         39  
2167 2     2   8 use Mouse::Meta::Role;
  2         3  
  2         41  
2168 2     2   9 use Mouse::Meta::Attribute;
  2         3  
  2         34  
2169 2     2   12 use Mouse::Object;
  2         3  
  2         1181  
2170             use Mouse::Util::TypeConstraints ();
2171 2         15  
2172             Mouse::Exporter->setup_import_methods(
2173             as_is => [qw(
2174             extends with
2175             has
2176             before after around
2177             override super
2178             augment inner
2179             ),
2180             \&Scalar::Util::blessed,
2181             \&Carp::confess,
2182             ],
2183             );
2184              
2185              
2186 0     0 1 0 sub extends {
2187 0         0 Mouse::Meta::Class->initialize(scalar caller)->superclasses(@_);
2188             return;
2189             }
2190              
2191 0     0 0 0 sub with {
2192 0         0 Mouse::Util::apply_all_roles(scalar(caller), @_);
2193             return;
2194             }
2195              
2196 4     4 1 67 sub has {
2197 4         14 my $meta = Mouse::Meta::Class->initialize(scalar caller);
2198             my $name = shift;
2199 4 50       16  
2200             $meta->throw_error(q{Usage: has 'name' => ( key => value, ... )})
2201             if @_ % 2; # odd number of arguments
2202 4 50       20  
  0         0  
2203 4         18 for my $n(ref($name) ? @{$name} : $name){
2204             $meta->add_attribute($n => @_);
2205 4         13 }
2206             return;
2207             }
2208              
2209 0     0 1 0 sub before {
2210 0         0 my $meta = Mouse::Meta::Class->initialize(scalar caller);
2211 0         0 my $code = pop;
2212 0         0 for my $name($meta->_collect_methods(@_)) {
2213             $meta->add_before_method_modifier($name => $code);
2214 0         0 }
2215             return;
2216             }
2217              
2218 0     0 1 0 sub after {
2219 0         0 my $meta = Mouse::Meta::Class->initialize(scalar caller);
2220 0         0 my $code = pop;
2221 0         0 for my $name($meta->_collect_methods(@_)) {
2222             $meta->add_after_method_modifier($name => $code);
2223 0         0 }
2224             return;
2225             }
2226              
2227 0     0 1 0 sub around {
2228 0         0 my $meta = Mouse::Meta::Class->initialize(scalar caller);
2229 0         0 my $code = pop;
2230 0         0 for my $name($meta->_collect_methods(@_)) {
2231             $meta->add_around_method_modifier($name => $code);
2232 0         0 }
2233             return;
2234             }
2235 2         4  
2236 2         3 our $SUPER_PACKAGE;
2237 2         9 our $SUPER_BODY;
2238             our @SUPER_ARGS;
2239              
2240             sub super {
2241             # This check avoids a recursion loop - see
2242 0 0 0 0 0 0 # t/100_bugs/020_super_recursion.t
2243 0 0       0 return if defined $SUPER_PACKAGE && $SUPER_PACKAGE ne caller();
2244 0         0 return if !defined $SUPER_BODY;
2245             $SUPER_BODY->(@SUPER_ARGS);
2246             }
2247              
2248             sub override {
2249 0     0 0 0 # my($name, $method) = @_;
2250             Mouse::Meta::Class->initialize(scalar caller)->add_override_method_modifier(@_);
2251             }
2252 2         4  
2253 2         69 our %INNER_BODY;
2254             our %INNER_ARGS;
2255              
2256 0     0 0 0 sub inner {
2257 0 0       0 my $pkg = caller();
2258 0         0 if ( my $body = $INNER_BODY{$pkg} ) {
2259 0         0 my $args = $INNER_ARGS{$pkg};
2260 0         0 local $INNER_ARGS{$pkg};
2261 0         0 local $INNER_BODY{$pkg};
  0         0  
2262             return $body->(@{$args});
2263             }
2264 0         0 else {
2265             return;
2266             }
2267             }
2268              
2269             sub augment {
2270 0     0 0 0 #my($name, $method) = @_;
2271 0         0 Mouse::Meta::Class->initialize(scalar caller)->add_augment_method_modifier(@_);
2272             return;
2273             }
2274              
2275 4     4 0 8 sub init_meta {
2276 4         15 shift;
2277             my %args = @_;
2278              
2279 4 50       15 my $class = $args{for_class}
2280             or confess("Cannot call init_meta without specifying a for_class");
2281 4   50     23  
2282 4   50     18 my $base_class = $args{base_class} || 'Mouse::Object';
2283             my $metaclass = $args{metaclass} || 'Mouse::Meta::Class';
2284 4         22  
2285 4         22 my $meta = $metaclass->initialize($class);
2286             my $filename = Mouse::Util::module_notional_filename($meta->name);
2287 4 50       19 $INC{$filename} = '(set by Mouse)'
2288             unless exists $INC{$filename};
2289              
2290 4   33 4   34 $meta->add_method(meta => sub{
2291 4         30 return $metaclass->initialize(ref($_[0]) || $_[0]);
2292             });
2293 4 50       15  
2294             $meta->superclasses($base_class)
2295             unless $meta->superclasses;
2296              
2297 4 50       16 # make a class type for each Mouse class
2298             Mouse::Util::TypeConstraints::class_type($class)
2299             unless Mouse::Util::TypeConstraints::find_type_constraint($class);
2300 4         15  
2301             return $meta;
2302             }
2303              
2304 0         0 }
2305             BEGIN{ # lib/Mouse/Meta/Attribute.pm
2306 2     2   12 package Mouse::Meta::Attribute;
  2         4  
  2         6  
2307             use Mouse::Util qw(:meta); # enables strict and warnings
2308 2     2   10  
  2         2  
  2         25  
2309             use Carp ();
2310 2     2   12  
  2         4  
  2         2730  
2311             use Mouse::Meta::TypeConstraint;
2312 2     2   10  
  58         111  
2313             my %valid_options = map { $_ => undef } (
2314             'accessor',
2315             'auto_deref',
2316             'builder',
2317             'clearer',
2318             'coerce',
2319             'default',
2320             'documentation',
2321             'does',
2322             'handles',
2323             'init_arg',
2324             'insertion_order',
2325             'is',
2326             'isa',
2327             'lazy',
2328             'lazy_build',
2329             'name',
2330             'predicate',
2331             'reader',
2332             'required',
2333             'traits',
2334             'trigger',
2335             'type_constraint',
2336             'weak_ref',
2337             'writer',
2338              
2339             # internally used
2340             'associated_class',
2341             'associated_methods',
2342             '__METACLASS__',
2343              
2344             # Moose defines, but Mouse doesn't
2345             #'definition_context',
2346             #'initializer',
2347              
2348             # special case for AttributeHelpers
2349             'provides',
2350             'curries',
2351             );
2352 2         65  
2353             our @CARP_NOT = qw(Mouse::Meta::Class);
2354              
2355 4     4 1 10 sub new {
2356 4         9 my $class = shift;
2357             my $name = shift;
2358 4         26  
2359             my $args = $class->Mouse::Object::BUILDARGS(@_);
2360 4         21  
2361             $class->_process_options($name, $args);
2362 4         11  
2363             $args->{name} = $name;
2364              
2365             # check options
2366 4         10 # (1) known by core
  16         49  
  4         17  
2367             my @bad = grep{ !exists $valid_options{$_} } keys %{$args};
2368              
2369 4 50 33     56 # (2) known by subclasses
2370             if(@bad && $class ne __PACKAGE__){
2371 0         0 my %valid_attrs = (
2372 0         0 map { $_ => undef }
2373 0         0 grep { defined }
  0         0  
2374             map { $_->init_arg() }
2375             $class->meta->get_all_attributes()
2376 0         0 );
  0         0  
2377             @bad = grep{ !exists $valid_attrs{$_} } @bad;
2378             }
2379              
2380 4 50       16 # (3) bad options found
2381 0         0 if(@bad){
2382             Carp::carp(
2383             "Found unknown argument(s) passed to '$name' attribute constructor in '$class': "
2384             . Mouse::Util::english_list(@bad));
2385             }
2386 4         12  
2387 4 50       14 my $self = bless $args, $class;
2388 0         0 if($class ne __PACKAGE__){
2389             $class->meta->_initialize_object($self, $args);
2390 4         18 }
2391             return $self;
2392             }
2393 0 0   0 0 0  
2394 0 0   0 0 0 sub has_read_method { $_[0]->has_reader || $_[0]->has_accessor }
2395             sub has_write_method { $_[0]->has_writer || $_[0]->has_accessor }
2396 0 0   0 0 0  
2397 0 0   0 0 0 sub get_read_method { $_[0]->reader || $_[0]->accessor }
2398             sub get_write_method { $_[0]->writer || $_[0]->accessor }
2399              
2400 0     0 1 0 sub get_read_method_ref{
2401             my($self) = @_;
2402 0   0     0 return $self->{_mouse_cache_read_method_ref}
2403             ||= $self->_get_accessor_method_ref('get_read_method', '_generate_reader');
2404             }
2405              
2406 0     0 1 0 sub get_write_method_ref{
2407             my($self) = @_;
2408 0   0     0 return $self->{_mouse_cache_write_method_ref}
2409             ||= $self->_get_accessor_method_ref('get_write_method', '_generate_writer');
2410             }
2411              
2412 4     4 0 12 sub interpolate_class{
2413             my($class, $args) = @_;
2414 4 50       18  
2415 0         0 if(my $metaclass = delete $args->{metaclass}){
2416             $class = Mouse::Util::resolve_metaclass_alias( Attribute => $metaclass );
2417             }
2418 4         10  
2419 4 50       14 my @traits;
2420             if(my $traits_ref = delete $args->{traits}){
2421 0         0  
  0         0  
2422 0         0 for (my $i = 0; $i < @{$traits_ref}; $i++) {
2423             my $trait = Mouse::Util::resolve_metaclass_alias(Attribute => $traits_ref->[$i], trait => 1);
2424 0 0       0  
2425             next if $class->does($trait);
2426 0         0  
2427             push @traits, $trait;
2428              
2429 0 0       0 # are there options?
2430             push @traits, $traits_ref->[++$i]
2431             if ref($traits_ref->[$i+1]);
2432             }
2433 0 0       0  
2434 0         0 if (@traits) {
2435             $class = Mouse::Meta::Class->create_anon_class(
2436             superclasses => [ $class ],
2437             roles => \@traits,
2438             cache => 1,
2439             )->name;
2440             }
2441             }
2442 4         16  
2443             return( $class, @traits );
2444             }
2445              
2446 0     0 1 0 sub verify_against_type_constraint {
2447             my ($self, $value) = @_;
2448 0         0  
2449 0 0       0 my $type_constraint = $self->{type_constraint};
2450 0 0       0 return 1 if !$type_constraint;
2451             return 1 if $type_constraint->check($value);
2452 0         0  
2453             $self->_throw_type_constraint_error($value, $type_constraint);
2454             }
2455              
2456 0     0   0 sub _throw_type_constraint_error {
2457             my($self, $value, $type) = @_;
2458 0         0  
2459             $self->throw_error(
2460             sprintf q{Attribute (%s) does not pass the type constraint because: %s},
2461             $self->name,
2462             $type->get_message($value),
2463             );
2464             }
2465              
2466 0     0 0 0 sub illegal_options_for_inheritance {
2467             return qw(reader writer accessor clearer predicate);
2468             }
2469              
2470 0     0 1 0 sub clone_and_inherit_options{
2471 0         0 my $self = shift;
2472             my $args = $self->Mouse::Object::BUILDARGS(@_);
2473 0         0  
2474 0 0 0     0 foreach my $illegal($self->illegal_options_for_inheritance) {
2475 0         0 if(exists $args->{$illegal} and exists $self->{$illegal}) {
2476             $self->throw_error("Illegal inherited option: $illegal");
2477             }
2478             }
2479 0         0  
  0         0  
2480 0 0       0 foreach my $name(keys %{$self}){
2481 0         0 if(!exists $args->{$name}){
2482             $args->{$name} = $self->{$name}; # inherit from self
2483             }
2484             }
2485 0         0  
2486 0 0       0 my($attribute_class, @traits) = ref($self)->interpolate_class($args);
2487             $args->{traits} = \@traits if @traits;
2488              
2489 0         0 # remove temporary caches
  0         0  
2490 0 0       0 foreach my $attr(keys %{$args}){
2491 0         0 if($attr =~ /\A _mouse_cache_/xms){
2492             delete $args->{$attr};
2493             }
2494             }
2495              
2496 0 0       0 # remove default if lazy_build => 1
2497 0         0 if($args->{lazy_build}) {
2498             delete $args->{default};
2499             }
2500 0         0  
2501             return $attribute_class->new($self->name, $args);
2502             }
2503              
2504              
2505 0     0   0 sub _get_accessor_method_ref {
2506             my($self, $type, $generator) = @_;
2507 0   0     0  
2508             my $metaclass = $self->associated_class
2509             || $self->throw_error('No asocciated class for ' . $self->name);
2510 0         0  
2511 0 0       0 my $accessor = $self->$type();
2512 0         0 if($accessor){
2513             return $metaclass->get_method_body($accessor);
2514             }
2515 0         0 else{
2516             return $self->accessor_metaclass->$generator($self, $metaclass);
2517             }
2518             }
2519              
2520 0     0 0 0 sub set_value {
2521 0         0 my($self, $object, $value) = @_;
2522             return $self->get_write_method_ref()->($object, $value);
2523             }
2524              
2525 0     0 0 0 sub get_value {
2526 0         0 my($self, $object) = @_;
2527             return $self->get_read_method_ref()->($object);
2528             }
2529              
2530 0     0 0 0 sub has_value {
2531             my($self, $object) = @_;
2532 0   0     0 my $accessor_ref = $self->{_mouse_cache_predicate_ref}
2533             ||= $self->_get_accessor_method_ref('predicate', '_generate_predicate');
2534 0         0  
2535             return $accessor_ref->($object);
2536             }
2537              
2538 0     0 0 0 sub clear_value {
2539             my($self, $object) = @_;
2540 0   0     0 my $accessor_ref = $self->{_mouse_cache_crealer_ref}
2541             ||= $self->_get_accessor_method_ref('clearer', '_generate_clearer');
2542 0         0  
2543             return $accessor_ref->($object);
2544             }
2545              
2546             sub associate_method{
2547 4     4 1 9 #my($attribute, $method_name) = @_;
2548 4         14 my($attribute) = @_;
2549 4         11 $attribute->{associated_methods}++;
2550             return;
2551             }
2552              
2553 4     4 0 12 sub install_accessors{
2554             my($attribute) = @_;
2555 4         17  
2556 4         12 my $metaclass = $attribute->associated_class;
2557             my $accessor_class = $attribute->accessor_metaclass;
2558 4         13  
2559 20 100       74 foreach my $type(qw(accessor reader writer predicate clearer)){
2560 4         13 if(exists $attribute->{$type}){
2561 4         32 my $generator = '_generate_' . $type;
2562 4         14 my $code = $accessor_class->$generator($attribute, $metaclass);
2563             my $name = $attribute->{$type};
2564             # TODO: do something for compatibility
2565             # if( $metaclass->name->can($name) ) {
2566             # my $t = $metaclass->has_method($name) ? 'method' : 'function';
2567             # Carp::cluck("You are overwriting a locally defined $t"
2568             # . " ($name) with an accessor");
2569 4         24 # }
2570 4         16 $metaclass->add_method($name => $code);
2571             $attribute->associate_method($name);
2572             }
2573             }
2574              
2575 4 50       16 # install delegation
2576 0         0 if(exists $attribute->{handles}){
2577 0         0 my %handles = $attribute->_canonicalize_handles();
2578 0 0       0 while(my($handle, $method_to_call) = each %handles){
2579             next if Mouse::Object->can($handle);
2580 0 0       0  
2581 0         0 if($metaclass->has_method($handle)) {
2582             $attribute->throw_error("You cannot overwrite a locally defined method ($handle) with a delegation");
2583             }
2584 0         0  
2585             $metaclass->add_method($handle =>
2586             $attribute->_make_delegation_method(
2587             $handle, $method_to_call));
2588 0         0  
2589             $attribute->associate_method($handle);
2590             }
2591             }
2592 4         9  
2593             return;
2594             }
2595              
2596             sub delegation_metaclass() { ## no critic
2597             'Mouse::Meta::Method::Delegation'
2598             }
2599              
2600 0     0   0 sub _canonicalize_handles {
2601 0         0 my($self) = @_;
2602             my $handles = $self->{handles};
2603 0         0  
2604 0 0       0 my $handle_type = ref $handles;
    0          
    0          
    0          
2605 0         0 if ($handle_type eq 'HASH') {
2606             return %$handles;
2607             }
2608 0         0 elsif ($handle_type eq 'ARRAY') {
  0         0  
2609             return map { $_ => $_ } @$handles;
2610             }
2611 0         0 elsif ($handle_type eq 'Regexp') {
2612 0         0 my $meta = $self->_find_delegate_metaclass();
2613 0 0       0 return map { $_ => $_ }
  0         0  
2614             grep { /$handles/ }
2615             Mouse::Util::is_a_metarole($meta)
2616             ? $meta->get_method_list
2617             : $meta->get_all_method_names;
2618             }
2619 0         0 elsif ($handle_type eq 'CODE') {
2620             return $handles->( $self, $self->_find_delegate_metaclass() );
2621             }
2622 0         0 else {
2623             $self->throw_error("Unable to canonicalize the 'handles' option with $handles");
2624             }
2625             }
2626              
2627 0     0   0 sub _find_delegate_metaclass {
2628 0         0 my($self) = @_;
2629 0 0       0 my $meta;
    0          
2630 0         0 if($self->{isa}) {
2631             $meta = Mouse::Meta::Class->initialize("$self->{isa}");
2632             }
2633 0         0 elsif($self->{does}) {
2634             $meta = Mouse::Util::get_metaclass_by_name("$self->{does}");
2635 0 0       0 }
2636             defined($meta) or $self->throw_error(
2637 0         0 "Cannot find delegate metaclass for attribute " . $self->name);
2638             return $meta;
2639             }
2640              
2641              
2642 0     0   0 sub _make_delegation_method {
2643 0         0 my($self, $handle, $method_to_call) = @_;
2644             return Mouse::Util::load_class($self->delegation_metaclass)
2645             ->_generate_delegation($self, $handle, $method_to_call);
2646             }
2647              
2648 0         0 }
2649             BEGIN{ # lib/Mouse/Meta/Class.pm
2650 2     2   13 package Mouse::Meta::Class;
  2         4  
  2         7  
2651             use Mouse::Util qw/:meta/; # enables strict and warnings
2652 2     2   10  
  2         4  
  2         36  
2653             use Scalar::Util ();
2654 2     2   12  
  2         4  
  2         184  
2655 2     2   33 use Mouse::Meta::Module;
2656             our @ISA = qw(Mouse::Meta::Module);
2657 2         12  
2658             our @CARP_NOT = qw(Mouse); # trust Mouse
2659              
2660             sub attribute_metaclass;
2661             sub method_metaclass;
2662              
2663             sub constructor_class;
2664             sub destructor_class;
2665              
2666              
2667 4     4   28 sub _construct_meta {
2668             my($class, %args) = @_;
2669 4         12  
2670 4         11 $args{attributes} = {};
2671 4         9 $args{methods} = {};
2672             $args{roles} = [];
2673 4         9  
2674 2     2   11 $args{superclasses} = do {
  2         3  
  2         3958  
2675 4         6 no strict 'refs';
  4         28  
2676             \@{ $args{package} . '::ISA' };
2677             };
2678 4   33     26  
2679 4 50       15 my $self = bless \%args, ref($class) || $class;
2680 0         0 if(ref($self) ne __PACKAGE__){
2681             $self->meta->_initialize_object($self, \%args);
2682 4         26 }
2683             return $self;
2684             }
2685              
2686 0     0 0 0 sub create_anon_class{
2687 0         0 my $self = shift;
2688             return $self->create(undef, @_);
2689             }
2690              
2691             sub is_anon_class;
2692              
2693             sub roles;
2694              
2695 0     0 0 0 sub calculate_all_roles {
2696 0         0 my $self = shift;
2697 0         0 my %seen;
2698 0         0 return grep { !$seen{ $_->name }++ }
  0         0  
  0         0  
2699             map { $_->calculate_all_roles } @{ $self->roles };
2700             }
2701              
2702 8     8 1 14 sub superclasses {
2703             my $self = shift;
2704 8 100       26  
2705 4         10 if (@_) {
2706 4         18 foreach my $super(@_){
2707 4         12 Mouse::Util::load_class($super);
2708 4 50       13 my $meta = Mouse::Util::get_metaclass_by_name($super);
2709 0         0 next if $self->verify_superclass($super, $meta);
2710             $self->_reconcile_with_superclass_meta($meta);
2711 4         10 }
  4         35  
2712             return @{ $self->{superclasses} } = @_;
2713             }
2714 4         6  
  4         23  
2715             return @{ $self->{superclasses} };
2716             }
2717              
2718 4     4 0 11 sub verify_superclass {
2719             my($self, $super, $super_meta) = @_;
2720 4 50       13  
2721 0 0       0 if(defined $super_meta) {
2722 0         0 if(Mouse::Util::is_a_metarole($super_meta)){
2723             $self->throw_error("You cannot inherit from a Mouse Role ($super)");
2724             }
2725             }
2726             else {
2727             # The metaclass of $super is not initialized.
2728             # i.e. it might be Mouse::Object, a mixin package (e.g. Exporter),
2729             # or a foreign class including Moose classes.
2730 4         27 # See also Mouse::Foreign::Meta::Role::Class.
2731 4 50 33     28 my $mm = $super->can('meta');
2732 0 0 0     0 if(!($mm && $mm == \&Mouse::Util::meta)) {
2733 0         0 if($super->can('new') or $super->can('DESTROY')) {
2734             $self->inherit_from_foreign_class($super);
2735             }
2736 4         18 }
2737             return 1; # always ok
2738             }
2739 0         0  
2740             return $self->isa(ref $super_meta); # checks metaclass compatibility
2741             }
2742              
2743 0     0 0 0 sub inherit_from_foreign_class {
2744 0 0       0 my($class, $super) = @_;
2745 0         0 if($ENV{PERL_MOUSE_STRICT}) {
2746             Carp::carp("You inherit from non-Mouse class ($super),"
2747             . " but it is unlikely to work correctly."
2748             . " Please consider using MouseX::Foreign");
2749 0         0 }
2750             return;
2751             }
2752 2         62  
2753             my @MetaClassTypes = (
2754             'attribute', # Mouse::Meta::Attribute
2755             'method', # Mouse::Meta::Method
2756             'constructor', # Mouse::Meta::Method::Constructor
2757             'destructor', # Mouse::Meta::Method::Destructor
2758             );
2759              
2760 0     0   0 sub _reconcile_with_superclass_meta {
2761             my($self, $other) = @_;
2762              
2763 0         0 # find incompatible traits
2764 0         0 my %metaroles;
2765 0   0     0 foreach my $metaclass_type(@MetaClassTypes){
2766             my $accessor = $self->can($metaclass_type . '_metaclass')
2767             || $self->can($metaclass_type . '_class');
2768 0         0  
2769 0         0 my $other_c = $other->$accessor();
2770             my $self_c = $self->$accessor();
2771 0 0       0  
2772 0         0 if(!$self_c->isa($other_c)){
2773             $metaroles{$metaclass_type}
2774             = [ $self_c->meta->_collect_roles($other_c->meta) ];
2775             }
2776             }
2777 0         0  
2778             $metaroles{class} = [$self->meta->_collect_roles($other->meta)];
2779              
2780             #use Data::Dumper; print Data::Dumper->new([\%metaroles], ['*metaroles'])->Indent(1)->Dump;
2781 0         0  
2782 0         0 require Mouse::Util::MetaRole;
2783             $_[0] = Mouse::Util::MetaRole::apply_metaroles(
2784             for => $self,
2785             class_metaroles => \%metaroles,
2786 0         0 );
2787             return;
2788             }
2789              
2790 0     0   0 sub _collect_roles {
2791             my ($self, $other) = @_;
2792              
2793 0         0 # find common ancestor
2794 0         0 my @self_lin_isa = $self->linearized_isa;
2795             my @other_lin_isa = $other->linearized_isa;
2796 0         0  
2797 0         0 my(@self_anon_supers, @other_anon_supers);
2798 0         0 push @self_anon_supers, shift @self_lin_isa while $self_lin_isa[0]->meta->is_anon_class;
2799             push @other_anon_supers, shift @other_lin_isa while $other_lin_isa[0]->meta->is_anon_class;
2800 0   0     0  
2801             my $common_ancestor = $self_lin_isa[0] eq $other_lin_isa[0] && $self_lin_isa[0];
2802 0 0       0  
2803 0         0 if(!$common_ancestor){
2804             $self->throw_error(sprintf '%s cannot have %s as a super class because of their metaclass incompatibility',
2805             $self->name, $other->name);
2806             }
2807 0         0  
2808 0         0 my %seen;
2809 0         0 return sort grep { !$seen{$_}++ } ## no critic
  0         0  
2810 0         0 (map{ $_->name } map{ $_->meta->calculate_all_roles } @self_anon_supers),
  0         0  
  0         0  
2811             (map{ $_->name } map{ $_->meta->calculate_all_roles } @other_anon_supers),
2812             ;
2813             }
2814              
2815              
2816 0     0 0 0 sub find_method_by_name {
2817 0 0       0 my($self, $method_name) = @_;
2818             defined($method_name)
2819             or $self->throw_error('You must define a method name to find');
2820 0         0  
2821 0         0 foreach my $class( $self->linearized_isa ){
2822 0 0       0 my $method = $self->initialize($class)->get_method($method_name);
2823             return $method if defined $method;
2824 0         0 }
2825             return undef;
2826             }
2827              
2828 0     0 1 0 sub get_all_methods {
2829 0         0 my($self) = @_;
  0         0  
2830             return map{ $self->find_method_by_name($_) } $self->get_all_method_names;
2831             }
2832              
2833 0     0 0 0 sub get_all_method_names {
2834 0         0 my $self = shift;
2835 0         0 my %uniq;
2836 0         0 return grep { $uniq{$_}++ == 0 }
  0         0  
2837             map { Mouse::Meta::Class->initialize($_)->get_method_list() }
2838             $self->linearized_isa;
2839             }
2840              
2841 0     0 0 0 sub find_attribute_by_name {
2842 0 0       0 my($self, $name) = @_;
2843             defined($name)
2844 0         0 or $self->throw_error('You must define an attribute name to find');
2845 0 0       0 foreach my $attr($self->get_all_attributes) {
2846             return $attr if $attr->name eq $name;
2847 0         0 }
2848             return undef;
2849             }
2850              
2851 4     4 1 9 sub add_attribute {
2852             my $self = shift;
2853 4         11  
2854             my($attr, $name);
2855 4 50       19  
2856 0         0 if(Scalar::Util::blessed($_[0])){
2857             $attr = $_[0];
2858 0 0       0  
2859             $attr->isa('Mouse::Meta::Attribute')
2860             || $self->throw_error("Your attribute must be an instance of Mouse::Meta::Attribute (or a subclass)");
2861 0         0  
2862             $name = $attr->name;
2863             }
2864             else{
2865 4         9 # _process_attribute
2866             $name = shift;
2867 4 50       20  
  0         0  
2868             my %args = (@_ == 1) ? %{$_[0]} : @_;
2869 4 50       15  
2870             defined($name)
2871             or $self->throw_error('You must provide a name for the attribute');
2872 4 50       16  
2873             if ($name =~ s/^\+//) { # inherited attributes
2874             # Workaround for https://github.com/gfx/p5-Mouse/issues/64
2875             # Do not use find_attribute_by_name to avoid problems with cached attributes list
2876 0         0 # because we're about to change it anyway
2877 0         0 my $inherited_attr;
  0         0  
2878 0 0       0 foreach my $i ( @{ $self->_calculate_all_attributes } ) {
2879 0         0 if ( $i->name eq $name ) {
2880 0         0 $inherited_attr = $i;
2881             last;
2882             }
2883 0 0       0 }
2884             $self->throw_error("Could not find an attribute by the name of '$name' to inherit from in ".$self->name)
2885             unless $inherited_attr;
2886 0         0  
2887             $attr = $inherited_attr->clone_and_inherit_options(%args);
2888             }
2889 4         17 else{
2890 4 50       14 my($attribute_class, @traits) = $self->attribute_metaclass->interpolate_class(\%args);
2891             $args{traits} = \@traits if @traits;
2892 4         21  
2893             $attr = $attribute_class->new($name, %args);
2894             }
2895             }
2896 4         30  
2897             Scalar::Util::weaken( $attr->{associated_class} = $self );
2898              
2899 4         19 # install accessors first
2900             $attr->install_accessors();
2901              
2902 4         8 # then register the attribute to the metaclass
  4         17  
2903 4         12 $attr->{insertion_order} = keys %{ $self->{attributes} };
2904 4         18 $self->{attributes}{$name} = $attr;
2905             $self->_invalidate_metaclass_cache();
2906 4 50 0     17  
      33        
2907 0         0 if(!$attr->{associated_methods} && ($attr->{is} || '') ne 'bare'){
2908             Carp::carp(qq{Attribute ($name) of class }.$self->name
2909             .qq{ has no associated methods (did you mean to provide an "is" argument?)});
2910 4         11 }
2911             return $attr;
2912             }
2913              
2914 4     4   10 sub _calculate_all_attributes {
2915 4         10 my($self) = @_;
2916             my %seen;
2917 4         15 my @all_attrs;
2918 8 100       27 foreach my $class($self->linearized_isa) {
2919 4         9 my $meta = Mouse::Util::get_metaclass_by_name($class) or next;
  4         16  
  4         15  
2920             my @attrs = grep { !$seen{$_->name}++ } values %{$meta->{attributes}};
2921 4         15 @attrs = sort {
2922 0         0 $b->{insertion_order} <=> $a->{insertion_order}
2923 4         11 } @attrs;
2924             push @all_attrs, @attrs;
2925 4         28 }
2926             return [reverse @all_attrs];
2927             }
2928              
2929             sub linearized_isa;
2930              
2931             sub new_object;
2932             sub clone_object;
2933              
2934 0     0 0 0 sub immutable_options {
2935             my ( $self, @args ) = @_;
2936              
2937 0         0 return (
2938             inline_constructor => 1,
2939             inline_destructor => 1,
2940             constructor_name => 'new',
2941             @args,
2942             );
2943             }
2944              
2945 0     0 0 0 sub make_immutable {
2946 0         0 my $self = shift;
2947             my %args = $self->immutable_options(@_);
2948 0         0  
2949             $self->{is_immutable}++;
2950 0 0       0  
2951             if ($args{inline_constructor}) {
2952 0         0 $self->add_method($args{constructor_name} =>
2953             Mouse::Util::load_class($self->constructor_class)
2954             ->_generate_constructor($self, \%args));
2955             }
2956 0 0       0  
2957 0         0 if ($args{inline_destructor}) {
2958             $self->add_method(DESTROY =>
2959             Mouse::Util::load_class($self->destructor_class)
2960             ->_generate_destructor($self, \%args));
2961             }
2962              
2963             # Moose's make_immutable returns true allowing calling code to skip
2964 0         0 # setting an explicit true value at the end of a source file.
2965             return 1;
2966             }
2967              
2968 0     0 0 0 sub make_mutable {
2969 0         0 my($self) = @_;
2970 0         0 $self->{is_immutable} = 0;
2971             return;
2972             }
2973              
2974 0     0 0 0 sub is_immutable;
2975             sub is_mutable { !$_[0]->is_immutable }
2976              
2977 0     0   0 sub _install_modifier {
2978 0         0 my( $self, $type, $name, $code ) = @_;
2979             my $into = $self->name;
2980 0 0       0  
2981             my $original = $into->can($name)
2982             or $self->throw_error("The method '$name' was not found in the inheritance hierarchy for $into");
2983 0         0  
2984             my $modifier_table = $self->{modifiers}{$name};
2985 0 0       0  
2986 0         0 if(!$modifier_table){
2987 0         0 my(@before, @after, @around);
2988             my $cache = $original;
2989 0 0   0   0 my $modified = sub {
2990 0         0 if(@before) {
  0         0  
2991             for my $c (@before) { $c->(@_) }
2992 0 0       0 }
2993 0         0 unless(@after) {
2994             return $cache->(@_);
2995             }
2996 0 0       0  
    0          
2997 0         0 if(wantarray){ # list context
2998             my @rval = $cache->(@_);
2999 0         0  
  0         0  
3000 0         0 for my $c(@after){ $c->(@_) }
3001             return @rval;
3002             }
3003 0         0 elsif(defined wantarray){ # scalar context
3004             my $rval = $cache->(@_);
3005 0         0  
  0         0  
3006 0         0 for my $c(@after){ $c->(@_) }
3007             return $rval;
3008             }
3009 0         0 else{ # void context
3010             $cache->(@_);
3011 0         0  
  0         0  
3012 0         0 for my $c(@after){ $c->(@_) }
3013             return;
3014 0         0 }
3015             };
3016 0         0  
3017             $self->{modifiers}{$name} = $modifier_table = {
3018             original => $original,
3019              
3020             before => \@before,
3021             after => \@after,
3022             around => \@around,
3023              
3024             cache => \$cache, # cache for around modifiers
3025             };
3026 0         0  
3027             $self->add_method($name => $modified);
3028             }
3029 0 0       0  
    0          
3030 0         0 if($type eq 'before'){
  0         0  
3031             unshift @{$modifier_table->{before}}, $code;
3032             }
3033 0         0 elsif($type eq 'after'){
  0         0  
3034             push @{$modifier_table->{after}}, $code;
3035             }
3036 0         0 else{ # around
  0         0  
3037             push @{$modifier_table->{around}}, $code;
3038 0         0  
  0         0  
3039 0     0   0 my $next = ${ $modifier_table->{cache} };
  0         0  
  0         0  
3040             ${ $modifier_table->{cache} } = sub{ $code->($next, @_) };
3041             }
3042 0         0  
3043             return;
3044             }
3045              
3046 0     0 0 0 sub add_before_method_modifier {
3047 0         0 my ( $self, $name, $code ) = @_;
3048             $self->_install_modifier( 'before', $name, $code );
3049             }
3050              
3051 0     0 0 0 sub add_around_method_modifier {
3052 0         0 my ( $self, $name, $code ) = @_;
3053             $self->_install_modifier( 'around', $name, $code );
3054             }
3055              
3056 0     0 0 0 sub add_after_method_modifier {
3057 0         0 my ( $self, $name, $code ) = @_;
3058             $self->_install_modifier( 'after', $name, $code );
3059             }
3060              
3061 0     0 0 0 sub add_override_method_modifier {
3062             my ($self, $name, $code) = @_;
3063 0 0       0  
3064 0         0 if($self->has_method($name)){
3065             $self->throw_error("Cannot add an override method if a local method is already present");
3066             }
3067 0         0  
3068             my $package = $self->name;
3069 0 0       0  
3070             my $super_body = $package->can($name)
3071             or $self->throw_error("You cannot override '$name' because it has no super method");
3072              
3073 0     0   0 $self->add_method($name => sub {
3074 0         0 local $Mouse::SUPER_PACKAGE = $package;
3075 0         0 local $Mouse::SUPER_BODY = $super_body;
3076 0         0 local @Mouse::SUPER_ARGS = @_;
  0         0  
3077 0         0 &{$code};
3078 0         0 });
3079             return;
3080             }
3081              
3082 0     0 0 0 sub add_augment_method_modifier {
3083 0 0       0 my ($self, $name, $code) = @_;
3084 0         0 if($self->has_method($name)){
3085             $self->throw_error("Cannot add an augment method if a local method is already present");
3086             }
3087 0 0       0  
3088             my $super = $self->find_method_by_name($name)
3089             or $self->throw_error("You cannot augment '$name' because it has no super method");
3090 0         0  
3091 0         0 my $super_package = $super->package_name;
3092             my $super_body = $super->body;
3093              
3094 0     0   0 $self->add_method($name => sub {
3095 0         0 local $Mouse::INNER_BODY{$super_package} = $code;
3096 0         0 local $Mouse::INNER_ARGS{$super_package} = [@_];
  0         0  
3097 0         0 &{$super_body};
3098 0         0 });
3099             return;
3100             }
3101              
3102 0     0 0 0 sub does_role {
3103             my ($self, $role_name) = @_;
3104 0 0       0  
3105             (defined $role_name)
3106             || $self->throw_error("You must supply a role name to look for");
3107 0 0       0  
3108             $role_name = $role_name->name if ref $role_name;
3109 0         0  
3110 0 0       0 for my $class ($self->linearized_isa) {
3111             my $meta = Mouse::Util::get_metaclass_by_name($class)
3112             or next;
3113 0         0  
  0         0  
3114             for my $role (@{ $meta->roles }) {
3115 0 0       0  
3116             return 1 if $role->does_role($role_name);
3117             }
3118             }
3119 0         0  
3120             return 0;
3121             }
3122              
3123 0         0 }
3124             BEGIN{ # lib/Mouse/Meta/Method.pm
3125 2     2   12 package Mouse::Meta::Method;
  2         4  
  2         7  
3126 2     2   10 use Mouse::Util qw(:meta); # enables strict and warnings
  2         5  
  2         95  
3127             use Scalar::Util ();
3128              
3129             use overload
3130             '==' => '_equal',
3131 0     0   0 'eq' => '_equal',
3132 2         18 '&{}' => sub{ $_[0]->body },
3133 2     2   10 fallback => 1,
  2     0   4  
3134             ;
3135              
3136 0     0 0 0 sub wrap {
3137 0 0       0 my $class = shift;
3138 0         0 unshift @_, 'body' if @_ % 2 != 0;
3139             return $class->_new(@_);
3140             }
3141              
3142 0     0   0 sub _new{
3143 0         0 my($class, %args) = @_;
3144             my $self = bless \%args, $class;
3145 0 0       0  
3146 0         0 if($class ne __PACKAGE__){
3147             $self->meta->_initialize_object($self, \%args);
3148 0         0 }
3149             return $self;
3150             }
3151 0     0 0 0  
3152 0     0 0 0 sub body { $_[0]->{body} }
3153 0     0 0 0 sub name { $_[0]->{name} }
3154 0     0 0 0 sub package_name { $_[0]->{package} }
3155             sub associated_metaclass { $_[0]->{associated_metaclass} }
3156              
3157 0     0 0 0 sub fully_qualified_name {
3158 0         0 my($self) = @_;
3159             return $self->package_name . '::' . $self->name;
3160             }
3161              
3162             # for Moose compat
3163 0     0   0 sub _equal {
3164             my($l, $r) = @_;
3165 0   0     0  
3166             return Scalar::Util::blessed($r)
3167             && $l->body == $r->body
3168             && $l->name eq $r->name
3169             && $l->package_name eq $r->package_name;
3170             }
3171              
3172 0         0 }
3173             BEGIN{ # lib/Mouse/Meta/Method/Accessor.pm
3174 2     2   627 package Mouse::Meta::Method::Accessor;
  2         6  
  2         5  
3175             use Mouse::Util qw(:meta); # enables strict and warnings
3176 2 50   2   15  
  2     0   5  
  2         1552  
3177             use constant _MOUSE_DEBUG => $ENV{MOUSE_DEBUG} ? 1 : 0;
3178              
3179 4     4   11 sub _inline_slot{
3180 4         25 my(undef, $self_var, $attr_name) = @_;
3181             return sprintf '%s->{q{%s}}', $self_var, $attr_name;
3182             }
3183              
3184 4     4   13 sub _generate_accessor_any{
3185             my($method_class, $type, $attribute, $class) = @_;
3186 4         16  
3187 4         16 my $name = $attribute->name;
3188 4         14 my $default = $attribute->default;
3189 4         16 my $constraint = $attribute->type_constraint;
3190 4         14 my $builder = $attribute->builder;
3191 4         12 my $trigger = $attribute->trigger;
3192 4         12 my $is_weak = $attribute->is_weak_ref;
3193 4   33     17 my $should_deref = $attribute->should_auto_deref;
3194             my $should_coerce = (defined($constraint)
3195             && $constraint->has_coercion
3196             && $attribute->should_coerce);
3197 4 50       14  
3198             my $compiled_type_constraint = defined($constraint)
3199             ? $constraint->_compiled_type_constraint
3200             : undef;
3201 4         10  
3202 4         15 my $self = '$_[0]';
3203             my $slot = $method_class->_inline_slot($self, $name);;
3204 4         20  
3205             my $accessor = sprintf(qq{package %s;\n#line 1 "%s-accessor for %s (%s)"\n}, $class->name, $type, $name, __FILE__)
3206             . "sub {\n";
3207 4 50 33     18  
    0          
3208 4 50       12 if ($type eq 'rw' || $type eq 'wo') {
3209 4         11 if($type eq 'rw'){
3210             $accessor .=
3211             'if (scalar(@_) >= 2) {' . "\n";
3212             }
3213 0         0 else{ # writer
3214             $accessor .=
3215             'if(@_ < 2){ Carp::confess("Not enough arguments for the writer of $name") }'.
3216             '{' . "\n";
3217             }
3218 4         9  
3219             my $value = '$_[1]';
3220 4 50       15  
3221 0 0       0 if (defined $constraint) {
3222 0         0 if ($should_coerce) {
3223             $accessor .=
3224             "\n".
3225 0         0 'my $val = $constraint->coerce('.$value.');';
3226             $value = '$val';
3227             }
3228 0         0 $accessor .=
3229             "\n".
3230             '$compiled_type_constraint->('.$value.') or
3231             $attribute->_throw_type_constraint_error('.$value.', $constraint);' . "\n";
3232             }
3233              
3234             # if there's nothing left to do for the attribute we can return during
3235 4 50 33     47 # this setter
      33        
3236             $accessor .= 'return ' if !$is_weak && !$trigger && !$should_deref;
3237 4 50       15  
3238 4         14 $accessor .= "my \@old_value = exists $slot ? $slot : ();\n" if $trigger;
3239             $accessor .= "$slot = $value;\n";
3240 4 50       13  
3241 0         0 if ($is_weak) {
3242             $accessor .= "Scalar::Util::weaken($slot) if ref $slot;\n";
3243             }
3244 4 50       12  
3245 0         0 if ($trigger) {
3246             $accessor .= '$trigger->('.$self.', '.$value.', @old_value);' . "\n";
3247             }
3248 4         11  
3249             $accessor .= "}\n";
3250             }
3251 0         0 elsif($type eq 'ro') {
3252             $accessor .= 'Carp::confess("Cannot assign a value to a read-only accessor of $name") if scalar(@_) >= 2;' . "\n";
3253             }
3254 0         0 else{
3255             $class->throw_error("Unknown accessor type '$type'");
3256             }
3257 4 50 33     15  
3258 0         0 if ($attribute->is_lazy and $type ne 'wo') {
3259             my $value;
3260 0 0       0  
    0          
3261 0         0 if (defined $builder){
3262             $value = "$self->\$builder()";
3263             }
3264 0         0 elsif (ref($default) eq 'CODE'){
3265             $value = "$self->\$default()";
3266             }
3267 0         0 else{
3268             $value = '$default';
3269             }
3270 0 0       0  
3271 0         0 $accessor .= "els" if $type eq 'rw';
3272 0 0       0 $accessor .= "if(!exists $slot){\n";
    0          
3273 0         0 if($should_coerce){
3274             $accessor .= "$slot = \$constraint->coerce($value)";
3275             }
3276 0         0 elsif(defined $constraint){
3277 0         0 $accessor .= "my \$tmp = $value;\n";
3278 0         0 $accessor .= "\$compiled_type_constraint->(\$tmp)";
3279 0         0 $accessor .= " || \$attribute->_throw_type_constraint_error(\$tmp, \$constraint);\n";
3280             $accessor .= "$slot = \$tmp;\n";
3281             }
3282 0         0 else{
3283             $accessor .= "$slot = $value;\n";
3284 0 0       0 }
3285 0         0 if ($is_weak) {
3286             $accessor .= "Scalar::Util::weaken($slot) if ref $slot;\n";
3287 0         0 }
3288             $accessor .= "}\n";
3289             }
3290 4 50       13  
3291 0 0       0 if ($should_deref) {
    0          
3292 0         0 if ($constraint->is_a_type_of('ArrayRef')) {
3293             $accessor .= "return \@{ $slot || [] } if wantarray;\n";
3294             }
3295 0         0 elsif($constraint->is_a_type_of('HashRef')){
3296             $accessor .= "return \%{ $slot || {} } if wantarray;\n";
3297             }
3298 0         0 else{
3299             $class->throw_error("Can not auto de-reference the type constraint " . $constraint->name);
3300             }
3301             }
3302 4         12  
3303             $accessor .= "return $slot;\n}\n";
3304 4         8  
3305 4         8 warn $accessor if _MOUSE_DEBUG;
3306 4         7 my $code;
3307 4         10 my $e = do{
3308 4         711 local $@;
3309 4         65 $code = eval $accessor;
3310             $@;
3311 4 50       17 };
3312             die $e if $e;
3313 4         13  
3314             return $code;
3315             }
3316              
3317             sub _generate_accessor{
3318 4     4   9 #my($self, $attribute, $metaclass) = @_;
3319 4         16 my $self = shift;
3320             return $self->_generate_accessor_any(rw => @_);
3321             }
3322              
3323             sub _generate_reader {
3324 0     0   0 #my($self, $attribute, $metaclass) = @_;
3325 0         0 my $self = shift;
3326             return $self->_generate_accessor_any(ro => @_);
3327             }
3328              
3329             sub _generate_writer {
3330 0     0   0 #my($self, $attribute, $metaclass) = @_;
3331 0         0 my $self = shift;
3332             return $self->_generate_accessor_any(wo => @_);
3333             }
3334              
3335             sub _generate_predicate {
3336 0     0   0 #my($self, $attribute, $metaclass) = @_;
3337             my(undef, $attribute) = @_;
3338 0         0  
3339             my $slot = $attribute->name;
3340 0     0   0 return sub{
3341 0         0 return exists $_[0]->{$slot};
3342             };
3343             }
3344              
3345             sub _generate_clearer {
3346 0     0   0 #my($self, $attribute, $metaclass) = @_;
3347             my(undef, $attribute) = @_;
3348 0         0  
3349             my $slot = $attribute->name;
3350 0     0   0 return sub{
3351 0         0 delete $_[0]->{$slot};
3352             };
3353             }
3354              
3355 0         0 }
3356             BEGIN{ # lib/Mouse/Meta/Method/Constructor.pm
3357 2     2   14 package Mouse::Meta::Method::Constructor;
  2         4  
  2         6  
3358             use Mouse::Util qw(:meta); # enables strict and warnings
3359 2 50   2   11  
  2     0   4  
  2         2011  
3360             use constant _MOUSE_DEBUG => $ENV{MOUSE_DEBUG} ? 1 : 0;
3361              
3362 4     4   11 sub _inline_slot{
3363 4         21 my(undef, $self_var, $attr_name) = @_;
3364             return sprintf '%s->{q{%s}}', $self_var, $attr_name;
3365             }
3366              
3367 0     0   0 sub _generate_constructor {
3368             my ($class, $metaclass, $args) = @_;
3369 0         0  
3370             my $associated_metaclass_name = $metaclass->name;
3371 0         0  
3372 0         0 my $buildall = $class->_generate_BUILDALL($metaclass);
3373             my $buildargs = $class->_generate_BUILDARGS($metaclass);
3374 0   0     0 my $initializer = $metaclass->{_mouse_cache}{_initialize_object} ||=
3375 0         0 $class->_generate_initialize_object($metaclass);
3376             my $source = sprintf(<<'EOT', __FILE__, $metaclass->name, $buildargs, $buildall);
3377             #line 1 "%s"
3378             package %s;
3379             sub {
3380             my $class = shift;
3381             return $class->Mouse::Object::new(@_)
3382             if $class ne __PACKAGE__;
3383             # BUILDARGS
3384             %s;
3385             my $instance = bless {}, $class;
3386             $metaclass->$initializer($instance, $args, 0);
3387             # BUILDALL
3388             %s;
3389             return $instance;
3390             }
3391 0         0 EOT
3392 0         0 warn $source if _MOUSE_DEBUG;
3393 0         0 my $body;
3394 0         0 my $e = do{
3395 0         0 local $@;
3396 0         0 $body = eval $source;
3397             $@;
3398 0 0       0 };
3399 0         0 die $e if $e;
3400             return $body;
3401             }
3402              
3403 4     4   13 sub _generate_initialize_object {
3404 4         16 my ($method_class, $metaclass) = @_;
3405             my @attrs = $metaclass->get_all_attributes;
3406 4 50       17  
3407 4         13 my @checks = map { $_ && $_->_compiled_type_constraint }
  4         13  
3408             map { $_->type_constraint } @attrs;
3409 4         10  
3410             my @res;
3411              
3412 4         14 my $has_triggers;
3413             my $strict = $metaclass->strict_constructor;
3414 4 50       18  
3415 0         0 if($strict){
3416             push @res, 'my $used = 0;';
3417             }
3418 4         18  
3419 4         14 for my $index (0 .. @attrs - 1) {
3420             my $code = '';
3421 4         12  
3422 4         11 my $attr = $attrs[$index];
3423             my $key = $attr->name;
3424 4         25  
3425 4         10 my $init_arg = $attr->init_arg;
3426 4         11 my $type_constraint = $attr->type_constraint;
3427 4         6 my $is_weak_ref = $attr->is_weak_ref;
3428             my $need_coercion;
3429 4         19  
3430 4         15 my $instance_slot = $method_class->_inline_slot('$instance', $key);
3431 4         8 my $attr_var = "\$attrs[$index]";
3432             my $constraint_var;
3433 4 50       14  
3434 0         0 if(defined $type_constraint){
3435 0   0     0 $constraint_var = "$attr_var\->{type_constraint}";
3436             $need_coercion = ($attr->should_coerce && $type_constraint->has_coercion);
3437             }
3438 4         14  
3439             $code .= "# initialize $key\n";
3440 4         10  
3441 4 50       14 my $post_process = '';
3442 0         0 if(defined $type_constraint){
3443 0         0 $post_process .= "\$checks[$index]->($instance_slot)\n";
3444             $post_process .= " or $attr_var->_throw_type_constraint_error($instance_slot, $constraint_var);\n";
3445             }
3446              
3447 4 50       14 # build cde for an attribute
3448 4         12 if (defined $init_arg) {
3449             my $value = "\$args->{q{$init_arg}}";
3450 4         13  
3451             $code .= "if (exists $value) {\n";
3452 4 50       11  
3453 0         0 if($need_coercion){
3454             $value = "$constraint_var->coerce($value)";
3455             }
3456 4         16  
3457 4         7 $code .= "$instance_slot = $value;\n";
3458             $code .= $post_process;
3459 4 50       14  
3460 0         0 if ($attr->has_trigger) {
3461 0         0 $has_triggers++;
3462             $code .= "push \@triggers, [$attr_var\->{trigger}, $instance_slot];\n";
3463             }
3464 4 50       17  
3465 0         0 if ($strict){
3466             $code .= '++$used;' . "\n";
3467             }
3468 4         11  
3469             $code .= "\n} else {\n"; # $value exists
3470             }
3471 4 50 33     14  
    50          
3472 0 0       0 if ($attr->has_default || $attr->has_builder) {
3473 0         0 unless ($attr->is_lazy) {
3474 0         0 my $default = $attr->default;
3475             my $builder = $attr->builder;
3476 0         0  
3477 0 0       0 my $value;
    0          
    0          
3478 0         0 if (defined($builder)) {
3479             $value = "\$instance->$builder()";
3480             }
3481 0         0 elsif (ref($default) eq 'CODE') {
3482             $value = "$attr_var\->{default}->(\$instance)";
3483             }
3484 0         0 elsif (defined($default)) {
3485             $value = "$attr_var\->{default}";
3486             }
3487 0         0 else {
3488             $value = 'undef';
3489             }
3490 0 0       0  
3491 0         0 if($need_coercion){
3492             $value = "$constraint_var->coerce($value)";
3493             }
3494 0         0  
3495 0         0 $code .= "$instance_slot = $value;\n";
3496             $code .= $post_process;
3497             }
3498             }
3499 0         0 elsif ($attr->is_required) {
3500 0         0 $code .= "\$meta->throw_error('Attribute ($key) is required')";
3501             $code .= " unless \$is_cloning;\n";
3502             }
3503 4 50       16  
3504             $code .= "}\n" if defined $init_arg;
3505 4 50       13  
3506 0         0 if($is_weak_ref){
3507             $code .= "Scalar::Util::weaken($instance_slot) "
3508             . "if ref $instance_slot and not Scalar::Util::isweak($instance_slot);\n";
3509             }
3510 4         15  
3511             push @res, $code;
3512             }
3513 4 50       14  
3514 0         0 if($strict){
3515             push @res, q{if($used < keys %{$args})}
3516             . q{{ $meta->_report_unknown_args(\@attrs, $args) }};
3517             }
3518 4 50       13  
3519 0         0 if($metaclass->is_anon_class){
3520             push @res, q{$instance->{__METACLASS__} = $meta;};
3521             }
3522 4 50       14  
3523 0         0 if($has_triggers){
3524 0         0 unshift @res, q{my @triggers;};
3525             push @res, q{$_->[0]->($instance, $_->[1]) for @triggers;};
3526             }
3527 4         12  
3528             my $source = sprintf <<'EOT', __FILE__, $metaclass->name, join "\n", @res;
3529             #line 1 "%s"
3530             package %s;
3531             sub {
3532             my($meta, $instance, $args, $is_cloning) = @_;
3533             %s;
3534             return $instance;
3535             }
3536 4         10 EOT
3537 4         7 warn $source if _MOUSE_DEBUG;
3538 4         9 my $body;
3539 4         8 my $e = do {
3540 4         427 local $@;
3541 4         17 $body = eval $source;
3542             $@;
3543 4 50       14 };
3544 4         24 die $e if $e;
3545             return $body;
3546             }
3547              
3548 0     0   0 sub _generate_BUILDARGS {
3549             my(undef, $metaclass) = @_;
3550 0         0  
3551 0 0 0     0 my $class = $metaclass->name;
3552 0         0 if ( $class->can('BUILDARGS') && $class->can('BUILDARGS') != \&Mouse::Object::BUILDARGS ) {
3553             return 'my $args = $class->BUILDARGS(@_)';
3554             }
3555 0         0  
3556             return <<'...';
3557             my $args;
3558             if ( scalar @_ == 1 ) {
3559             ( ref( $_[0] ) eq 'HASH' )
3560             || Carp::confess "Single parameters to new() must be a HASH ref";
3561             $args = +{ %{ $_[0] } };
3562             }
3563             else {
3564             $args = +{@_};
3565             }
3566             ...
3567             }
3568              
3569 0     0   0 sub _generate_BUILDALL {
3570             my (undef, $metaclass) = @_;
3571 0 0       0  
3572             return '' unless $metaclass->name->can('BUILD');
3573 0         0  
3574 0         0 my @code;
3575 0 0       0 for my $class ($metaclass->linearized_isa) {
3576 0         0 if (Mouse::Util::get_code_ref($class, 'BUILD')) {
3577             unshift @code, qq{${class}::BUILD(\$instance, \$args);};
3578             }
3579 0         0 }
3580             return join "\n", @code;
3581             }
3582              
3583 0         0 }
3584             BEGIN{ # lib/Mouse/Meta/Method/Delegation.pm
3585 2     2   14 package Mouse::Meta::Method::Delegation;
  2         4  
  2         8  
3586 2     2   10 use Mouse::Util qw(:meta); # enables strict and warnings
  2     0   4  
  2         577  
3587             use Scalar::Util;
3588              
3589 0     0   0 sub _generate_delegation{
3590             my (undef, $attr, $handle_name, $method_to_call) = @_;
3591 0         0  
3592 0 0       0 my @curried_args;
3593 0         0 if(ref($method_to_call) eq 'ARRAY'){
  0         0  
3594             ($method_to_call, @curried_args) = @{$method_to_call};
3595             }
3596              
3597 0   0     0 # If it has a reader, we must use it to make method modifiers work
3598             my $reader = $attr->get_read_method() || $attr->get_read_method_ref();
3599 0         0  
3600             my $can_be_optimized = $attr->{_mouse_cache_method_delegation_can_be_optimized};
3601 0 0       0  
3602 0         0 if(!defined $can_be_optimized){
3603             my $tc = $attr->type_constraint;
3604 0   0     0 $attr->{_mouse_cache_method_delegation_can_be_optimized} =
3605             (defined($tc) && $tc->is_a_type_of('Object'))
3606             && ($attr->is_required || $attr->has_default || $attr->has_builder)
3607             && ($attr->is_lazy || !$attr->has_clearer);
3608             }
3609 0 0       0  
3610             if($can_be_optimized){
3611             # need not check the attribute value
3612 0     0   0 return sub {
3613 0         0 return shift()->$reader()->$method_to_call(@curried_args, @_);
3614             };
3615             }
3616             else {
3617             # need to check the attribute value
3618 0     0   0 return sub {
3619 0         0 my $instance = shift;
3620             my $proxy = $instance->$reader();
3621 0 0 0     0  
    0          
3622             my $error = !defined($proxy) ? ' is not defined'
3623             : ref($proxy) && !Scalar::Util::blessed($proxy) ? qq{ is not an object (got '$proxy')}
3624 0 0       0 : undef;
3625 0         0 if ($error) {
3626             $instance->meta->throw_error(
3627             "Cannot delegate $handle_name to $method_to_call because "
3628             . "the value of "
3629             . $attr->name
3630             . $error
3631             );
3632 0         0 }
3633 0         0 $proxy->$method_to_call(@curried_args, @_);
3634             };
3635             }
3636             }
3637              
3638              
3639 0         0 }
3640             BEGIN{ # lib/Mouse/Meta/Method/Destructor.pm
3641 2     2   12 package Mouse::Meta::Method::Destructor;
  2         3  
  2         8  
3642             use Mouse::Util qw(:meta); # enables strict and warnings
3643 2 50   2   11  
  2     0   5  
  2         400  
3644             use constant _MOUSE_DEBUG => $ENV{MOUSE_DEBUG} ? 1 : 0;
3645              
3646 0     0   0 sub _generate_destructor{
3647             my (undef, $metaclass) = @_;
3648 0         0  
3649 0         0 my $demolishall = '';
3650 0 0       0 for my $class ($metaclass->linearized_isa) {
3651 0         0 if (Mouse::Util::get_code_ref($class, 'DEMOLISH')) {
3652             $demolishall .= ' ' . $class
3653             . '::DEMOLISH($self, Mouse::Util::in_global_destruction());'
3654             . "\n",
3655             }
3656             }
3657 0 0       0  
3658 0         0 if($demolishall) {
3659             $demolishall = sprintf <<'EOT', $demolishall;
3660             my $e = do{
3661             local $?;
3662             local $@;
3663             eval{
3664             %s;
3665             };
3666             $@;
3667             };
3668             no warnings 'misc';
3669             die $e if $e; # rethrow
3670             EOT
3671             }
3672 0         0  
3673 0         0 my $name = $metaclass->name;
3674             my $source = sprintf(<<'EOT', __FILE__, $name, $demolishall);
3675             #line 1 "%s"
3676             package %s;
3677             sub {
3678             my($self) = @_;
3679             return $self->Mouse::Object::DESTROY()
3680             if ref($self) ne __PACKAGE__;
3681             # DEMOLISHALL
3682             %s;
3683             return;
3684             }
3685             EOT
3686 0         0  
3687             warn $source if _MOUSE_DEBUG;
3688 0         0  
3689 0         0 my $code;
3690 0         0 my $e = do{
3691 0         0 local $@;
3692 0         0 $code = eval $source;
3693             $@;
3694 0 0       0 };
3695 0         0 die $e if $e;
3696             return $code;
3697             }
3698              
3699 0         0 }
3700             BEGIN{ # lib/Mouse/Meta/Module.pm
3701 2     2   12 package Mouse::Meta::Module;
  2         3  
  2         7  
3702             use Mouse::Util qw/:meta/; # enables strict and warnings
3703 2     2   9  
  2         6  
  2         30  
3704 2     2   7 use Carp ();
  2         3  
  2         1742  
3705             use Scalar::Util ();
3706 2     2   7  
3707             my %METAS;
3708 2         2  
3709             if(Mouse::Util::MOUSE_XS){
3710             # register meta storage for performance
3711             Mouse::Util::__register_metaclass_storage(\%METAS, 0);
3712              
3713             # ensure thread safety
3714             *CLONE = sub { Mouse::Util::__register_metaclass_storage(\%METAS, 1) };
3715             }
3716              
3717 12     12 0 39 sub initialize {
3718             my($class, $package_name, @args) = @_;
3719 12 50 33     72  
3720             ($package_name && !ref($package_name))
3721             || $class->throw_error("You must pass a package name and it cannot be blessed");
3722 12   66     80  
3723             return $METAS{$package_name}
3724             ||= $class->_construct_meta(package => $package_name, @args);
3725             }
3726              
3727 0     0 0 0 sub reinitialize {
3728             my($class, $package_name, @args) = @_;
3729 0 0       0  
3730             $package_name = $package_name->name if ref $package_name;
3731 0 0 0     0  
3732             ($package_name && !ref($package_name))
3733             || $class->throw_error("You must pass a package name and it cannot be blessed");
3734 0 0       0  
3735 0         0 if(exists $METAS{$package_name}) {
  0         0  
3736             unshift @args, %{ $METAS{$package_name} };
3737 0         0 }
3738 0         0 delete $METAS{$package_name};
3739             return $class->initialize($package_name, @args);
3740             }
3741              
3742 0     0   0 sub _class_of{
3743 0 0       0 my($class_or_instance) = @_;
3744 0   0     0 return undef unless defined $class_or_instance;
3745             return $METAS{ ref($class_or_instance) || $class_or_instance };
3746             }
3747              
3748             # Means of accessing all the metaclasses that have
3749             # been initialized thus far.
3750             # The public versions are aliased into Mouse::Util::*.
3751 0     0   0 #sub _get_all_metaclasses { %METAS }
3752 0     0   0 sub _get_all_metaclass_instances { values %METAS }
3753 20     20   69 sub _get_all_metaclass_names { keys %METAS }
3754             sub _get_metaclass_by_name { $METAS{$_[0]} }
3755             #sub _store_metaclass_by_name { $METAS{$_[0]} = $_[1] }
3756             #sub _weaken_metaclass { weaken($METAS{$_[0]}) }
3757             #sub _does_metaclass_exist { defined $METAS{$_[0]} }
3758             #sub _remove_metaclass_by_name { delete $METAS{$_[0]} }
3759              
3760             sub name;
3761              
3762             sub namespace;
3763              
3764             # add_attribute is an abstract method
3765              
3766 0     0 0   sub get_attribute_map { # DEPRECATED
3767 0           Carp::cluck('get_attribute_map() has been deprecated. Use get_attribute_list() and get_attribute() instead');
3768             return $_[0]->{attributes};
3769             }
3770 0     0 0    
3771 0     0 0   sub has_attribute { exists $_[0]->{attributes}->{$_[1]} }
3772 0     0 0   sub get_attribute { $_[0]->{attributes}->{$_[1]} }
3773             sub remove_attribute { delete $_[0]->{attributes}->{$_[1]} }
3774 0     0 0    
  0            
3775             sub get_attribute_list{ keys %{$_[0]->{attributes}} }
3776              
3777 2         4 # XXX: not completely compatible with Moose
  14         34  
3778             my %foreign = map{ $_ => undef } qw(
3779             Mouse Mouse::Role Mouse::Util Mouse::Util::TypeConstraints
3780             Carp Scalar::Util List::Util
3781             );
3782 0     0     sub _get_method_body {
3783 0           my($self, $method_name) = @_;
3784 0 0 0       my $code = Mouse::Util::get_code_ref($self->{package}, $method_name);
3785             return $code && !exists $foreign{ Mouse::Util::get_code_package($code) }
3786             ? $code
3787             : undef;
3788             }
3789              
3790             sub add_method;
3791              
3792 0     0 0   sub has_method {
3793 0 0         my($self, $method_name) = @_;
3794             defined($method_name)
3795             or $self->throw_error('You must define a method name');
3796 0   0        
3797             return defined( $self->{methods}{$method_name} )
3798             || defined( $self->_get_method_body($method_name) );
3799             }
3800              
3801 0     0 0   sub get_method_body {
3802 0 0         my($self, $method_name) = @_;
3803             defined($method_name)
3804             or $self->throw_error('You must define a method name');
3805 0   0        
3806             return $self->{methods}{$method_name}
3807             ||= $self->_get_method_body($method_name);
3808             }
3809              
3810 0     0 0   sub get_method {
3811             my($self, $method_name) = @_;
3812 0 0          
3813 0           if(my $code = $self->get_method_body($method_name)){
3814             return Mouse::Util::load_class($self->method_metaclass)->wrap(
3815             body => $code,
3816             name => $method_name,
3817             package => $self->name,
3818             associated_metaclass => $self,
3819             );
3820             }
3821 0            
3822             return undef;
3823             }
3824              
3825 0     0 0   sub get_method_list {
3826             my($self) = @_;
3827 0            
  0            
  0            
3828             return grep { $self->has_method($_) } keys %{ $self->namespace };
3829             }
3830              
3831 0     0     sub _collect_methods { # Mouse specific, used for method modifiers
3832             my($meta, @args) = @_;
3833 0            
3834 0           my @methods;
3835 0 0         foreach my $arg(@args){
3836 0 0         if(my $type = ref $arg){
    0          
3837 0           if($type eq 'Regexp'){
  0            
3838             push @methods, grep { $_ =~ $arg } $meta->get_all_method_names;
3839             }
3840 0           elsif($type eq 'ARRAY'){
  0            
3841             push @methods, @{$arg};
3842             }
3843 0           else{
3844 0           my $subname = ( caller(1) )[3];
3845             $meta->throw_error(
3846             sprintf(
3847             'Methods passed to %s must be provided as a list,'
3848             . ' ArrayRef or regular expression, not %s',
3849             $subname,
3850             $type,
3851             )
3852             );
3853             }
3854             }
3855 0           else{
3856             push @methods, $arg;
3857             }
3858 0           }
3859             return @methods;
3860             }
3861 2         5  
3862 2         49 my $ANON_SERIAL = 0; # anonymous class/role id
3863             my %IMMORTALS; # immortal anonymous classes
3864              
3865 0     0 0   sub create {
3866             my($self, $package_name, %options) = @_;
3867 0   0        
3868 0 0         my $class = ref($self) || $self;
3869             $self->throw_error('You must pass a package name') if @_ < 2;
3870 0            
3871 0 0         my $superclasses;
3872 0 0         if(exists $options{superclasses}){
3873 0           if(Mouse::Util::is_a_metarole($self)){
3874             delete $options{superclasses};
3875             }
3876 0           else{
3877 0 0         $superclasses = delete $options{superclasses};
3878             (ref $superclasses eq 'ARRAY')
3879             || $self->throw_error("You must pass an ARRAY ref of superclasses");
3880             }
3881             }
3882 0            
3883 0 0         my $attributes = delete $options{attributes};
3884 0 0 0       if(defined $attributes){
3885             (ref $attributes eq 'ARRAY' || ref $attributes eq 'HASH')
3886             || $self->throw_error("You must pass an ARRAY ref of attributes");
3887 0           }
3888 0 0         my $methods = delete $options{methods};
3889 0 0         if(defined $methods){
3890             (ref $methods eq 'HASH')
3891             || $self->throw_error("You must pass a HASH ref of methods");
3892 0           }
3893 0 0         my $roles = delete $options{roles};
3894 0 0         if(defined $roles){
3895             (ref $roles eq 'ARRAY')
3896             || $self->throw_error("You must pass an ARRAY ref of roles");
3897 0           }
3898             my $mortal;
3899             my $cache_key;
3900 0 0          
3901 0           if(!defined $package_name){ # anonymous
3902             $mortal = !$options{cache};
3903              
3904 0 0         # anonymous but immortal
3905             if(!$mortal){
3906             # something like Super::Class|Super::Class::2=Role|Role::1
3907 0 0         $cache_key = join '=' => (
3908 0 0         join('|', @{$superclasses || []}),
  0            
3909             join('|', sort @{$roles || []}),
3910 0 0         );
3911             return $IMMORTALS{$cache_key} if exists $IMMORTALS{$cache_key};
3912 0           }
3913 0           $options{anon_serial_id} = ++$ANON_SERIAL;
3914             $package_name = $class . '::__ANON__::' . $ANON_SERIAL;
3915             }
3916              
3917              
3918             # instantiate a module
3919 2     2   14 {
  2         4  
  2         687  
  0            
3920 0 0         no strict 'refs';
  0            
3921 0 0         ${ $package_name . '::VERSION' } = delete $options{version} if exists $options{version};
  0            
3922             ${ $package_name . '::AUTHORITY' } = delete $options{authority} if exists $options{authority};
3923             }
3924 0            
3925             my $meta = $self->initialize( $package_name, %options);
3926 0 0          
3927             Scalar::Util::weaken($METAS{$package_name})
3928             if $mortal;
3929              
3930 0   0 0     $meta->add_method(meta => sub {
3931 0           $self->initialize(ref($_[0]) || $_[0]);
3932             });
3933 0 0          
  0            
3934             $meta->superclasses(@{$superclasses})
3935             if defined $superclasses;
3936              
3937             # NOTE:
3938             # process attributes first, so that they can
3939             # install accessors, but locally defined methods
3940             # can then overwrite them. It is maybe a little odd, but
3941 0 0         # I think this should be the order of things.
3942 0 0         if (defined $attributes) {
3943             if(ref($attributes) eq 'ARRAY'){
3944 0           # array of Mouse::Meta::Attribute
  0            
3945 0           foreach my $attr (@{$attributes}) {
3946             $meta->add_attribute($attr);
3947             }
3948             }
3949             else{
3950 0           # hash map of name and attribute spec pairs
  0            
3951 0           while(my($name, $attr) = each %{$attributes}){
3952             $meta->add_attribute($name => $attr);
3953             }
3954             }
3955 0 0         }
3956 0           if (defined $methods) {
  0            
3957 0           while(my($method_name, $method_body) = each %{$methods}){
3958             $meta->add_method($method_name, $method_body);
3959             }
3960 0 0 0       }
3961 0           if (defined $roles and !$options{in_application_to_instance}){
  0            
3962             Mouse::Util::apply_all_roles($package_name, @{$roles});
3963             }
3964 0 0          
3965 0           if($cache_key){
3966             $IMMORTALS{$cache_key} = $meta;
3967             }
3968 0            
3969             return $meta;
3970             }
3971              
3972 0     0     sub DESTROY{
3973             my($self) = @_;
3974 0 0          
3975             return if Mouse::Util::in_global_destruction();
3976 0            
3977 0 0         my $serial_id = $self->{anon_serial_id};
3978             return if !$serial_id;
3979              
3980 0 0         # XXX: cleaning stash with threads causes panic/SEGV on legacy perls.
3981             if(exists $INC{'threads.pm'}) {
3982             # (caller)[2] indicates the caller's line number,
3983 0 0         # which is zero when the current thread is joining (destroying).
3984             return if( (caller)[2] == 0);
3985             }
3986              
3987             # clean up mortal anonymous class stuff
3988              
3989 0 0         # @ISA is a magical variable, so we must clear it manually.
  0            
3990             @{$self->{superclasses}} = () if exists $self->{superclasses};
3991              
3992 0           # Then, clear the symbol table hash
  0            
3993             %{$self->namespace} = ();
3994 0            
3995 0           my $name = $self->name;
3996             delete $METAS{$name};
3997 0            
3998 2     2   14 $name =~ s/ $serial_id \z//xms;
  2         4  
  2         105  
3999 0           no strict 'refs';
  0            
4000 0           delete ${$name}{ $serial_id . '::' };
4001             return;
4002             }
4003              
4004              
4005 0         0 }
4006             BEGIN{ # lib/Mouse/Meta/Role.pm
4007 2     2   10 package Mouse::Meta::Role;
  2         4  
  2         6  
4008             use Mouse::Util qw(:meta); # enables strict and warnings
4009 2     2   15  
  2         5  
  2         1532  
4010 2     2   81 use Mouse::Meta::Module;
4011             our @ISA = qw(Mouse::Meta::Module);
4012              
4013             sub method_metaclass;
4014              
4015 0     0     sub _construct_meta {
4016             my $class = shift;
4017 0            
4018             my %args = @_;
4019 0            
4020 0           $args{methods} = {};
4021 0           $args{attributes} = {};
4022 0           $args{required_methods} = [];
4023             $args{roles} = [];
4024 0   0        
4025 0 0         my $self = bless \%args, ref($class) || $class;
4026 0           if($class ne __PACKAGE__){
4027             $self->meta->_initialize_object($self, \%args);
4028 0           }
4029             return $self;
4030             }
4031              
4032 0     0 0   sub create_anon_role{
4033 0           my $self = shift;
4034             return $self->create(undef, @_);
4035             }
4036              
4037             sub is_anon_role;
4038              
4039             sub get_roles;
4040              
4041 0     0 0   sub calculate_all_roles {
4042 0           my $self = shift;
4043 0           my %seen;
4044 0           return grep { !$seen{ $_->name }++ }
  0            
  0            
4045             ($self, map { $_->calculate_all_roles } @{ $self->get_roles });
4046             }
4047              
4048 0     0 0   sub get_required_method_list{
  0            
4049             return @{ $_[0]->{required_methods} };
4050             }
4051              
4052 0     0 0   sub add_required_methods {
4053 0           my($self, @methods) = @_;
  0            
  0            
4054 0   0       my %required = map{ $_ => 1 } @{$self->{required_methods}};
  0            
  0            
4055 0           push @{$self->{required_methods}}, grep{ !$required{$_}++ && !$self->has_method($_) } @methods;
4056             return;
4057             }
4058              
4059 0     0 0   sub requires_method {
4060 0           my($self, $name) = @_;
  0            
  0            
4061             return scalar( grep{ $_ eq $name } @{ $self->{required_methods} } ) != 0;
4062             }
4063              
4064 0     0 0   sub add_attribute {
4065 0           my $self = shift;
4066             my $name = shift;
4067 0 0          
4068 0           $self->{attributes}->{$name} = (@_ == 1) ? $_[0] : { @_ };
4069             return;
4070             }
4071              
4072 0     0 0   sub apply {
4073 0           my $self = shift;
4074             my $consumer = shift;
4075 0            
4076 0           require 'Mouse/Meta/Role/Application.pm';
4077             return Mouse::Meta::Role::Application->new(@_)->apply($self, $consumer);
4078             }
4079              
4080 0     0 0   sub combine {
4081             my($self, @role_specs) = @_;
4082 0            
4083 0           require 'Mouse/Meta/Role/Composite.pm';
4084             return Mouse::Meta::Role::Composite->new(roles => \@role_specs);
4085             }
4086              
4087             sub add_before_method_modifier;
4088             sub add_around_method_modifier;
4089             sub add_after_method_modifier;
4090              
4091             sub get_before_method_modifiers;
4092             sub get_around_method_modifiers;
4093             sub get_after_method_modifiers;
4094              
4095 0     0 0   sub add_override_method_modifier{
4096             my($self, $method_name, $method) = @_;
4097 0 0          
4098             if($self->has_method($method_name)){
4099             # This error happens in the override keyword or during role composition,
4100 0           # so I added a message, "A local method of ...", only for compatibility (gfx)
4101             $self->throw_error("Cannot add an override of method '$method_name' "
4102             . "because there is a local version of '$method_name'"
4103             . "(A local method of the same name as been found)");
4104             }
4105 0            
4106             $self->{override_method_modifiers}->{$method_name} = $method;
4107             }
4108              
4109 0     0 0   sub get_override_method_modifier {
4110 0           my ($self, $method_name) = @_;
4111             return $self->{override_method_modifiers}->{$method_name};
4112             }
4113              
4114 0     0 0   sub does_role {
4115             my ($self, $role_name) = @_;
4116 0 0          
4117             (defined $role_name)
4118             || $self->throw_error("You must supply a role name to look for");
4119 0 0          
4120             $role_name = $role_name->name if ref $role_name;
4121              
4122 0 0         # if we are it,.. then return true
4123             return 1 if $role_name eq $self->name;
4124 0           # otherwise.. check our children
  0            
4125 0 0         for my $role (@{ $self->get_roles }) {
4126             return 1 if $role->does_role($role_name);
4127 0           }
4128             return 0;
4129             }
4130              
4131 0         0 }
4132             BEGIN{ # lib/Mouse/Meta/Role/Application.pm
4133 2     2   32 package Mouse::Meta::Role::Application;
  2     0   4  
  2         6  
4134             use Mouse::Util qw(:meta);
4135              
4136 0     0 0   sub new {
4137 0           my $class = shift;
4138             my $args = $class->Mouse::Object::BUILDARGS(@_);
4139 0 0 0        
4140 0           if(exists $args->{exclude} or exists $args->{alias}) {
4141             warnings::warnif(deprecated =>
4142             'The alias and excludes options for role application have been'
4143             . ' renamed -alias and -exclude');
4144 0 0 0        
4145 0           if($args->{alias} && !exists $args->{-alias}){
4146             $args->{-alias} = $args->{alias};
4147 0 0 0       }
4148 0           if($args->{excludes} && !exists $args->{-excludes}){
4149             $args->{-excludes} = $args->{excludes};
4150             }
4151             }
4152 0            
4153 0 0         $args->{aliased_methods} = {};
4154 0           if(my $alias = $args->{-alias}){
  0            
  0            
4155             @{$args->{aliased_methods}}{ values %{$alias} } = ();
4156             }
4157 0 0          
4158 0           if(my $excludes = $args->{-excludes}){
4159 0 0         $args->{-excludes} = {}; # replace with a hash ref
4160 0           if(ref $excludes){
  0            
  0            
  0            
4161             %{$args->{-excludes}} = (map{ $_ => undef } @{$excludes});
4162             }
4163 0           else{
4164             $args->{-excludes}{$excludes} = undef;
4165             }
4166 0           }
4167 0 0         my $self = bless $args, $class;
4168 0           if($class ne __PACKAGE__){
4169             $self->meta->_initialize_object($self, $args);
4170 0           }
4171             return $self;
4172             }
4173              
4174 0     0 0   sub apply {
4175 0           my($self, $role, $consumer, @extra) = @_;
4176             my $instance;
4177 0 0          
    0          
4178 0           if(Mouse::Util::is_a_metaclass($consumer)) { # Application::ToClass
4179             $self->{_to} = 'class';
4180             }
4181 0           elsif(Mouse::Util::is_a_metarole($consumer)) { # Application::ToRole
4182             $self->{_to} = 'role';
4183             }
4184 0           else { # Appplication::ToInstance
4185 0           $self->{_to} = 'instance';
4186             $instance = $consumer;
4187 0            
4188 0   0       my $meta = Mouse::Util::class_of($instance);
4189             $consumer = ($meta || 'Mouse::Meta::Class')
4190             ->create_anon_class(
4191             superclasses => [ref $instance],
4192             roles => [$role],
4193             cache => 0,
4194              
4195             in_application_to_instance => 1, # suppress to apply roles
4196             );
4197             }
4198              
4199 0           #$self->check_role_exclusions($role, $consumer, @extra);
4200             $self->check_required_methods($role, $consumer, @extra);
4201             #$self->check_required_attributes($role, $consumer, @extra);
4202 0            
4203 0           $self->apply_attributes($role, $consumer, @extra);
4204             $self->apply_methods($role, $consumer, @extra);
4205             #$self->apply_override_method_modifiers($role, $consumer, @extra);
4206             #$self->apply_before_method_modifiers($role, $consumer, @extra);
4207             #$self->apply_around_method_modifiers($role, $consumer, @extra);
4208 0           #$self->apply_after_method_modifiers($role, $consumer, @extra);
4209             $self->apply_modifiers($role, $consumer, @extra);
4210 0            
4211             $self->_append_roles($role, $consumer);
4212 0 0          
4213             if(defined $instance){ # Application::ToInstance
4214 0           # rebless instance
4215 0           bless $instance, $consumer->name;
4216             $consumer->_initialize_object($instance, $instance, 1);
4217             }
4218 0            
4219             return;
4220             }
4221              
4222 0     0 0   sub check_required_methods {
4223             my($self, $role, $consumer) = @_;
4224 0 0          
4225 0           if($self->{_to} eq 'role'){
4226             $consumer->add_required_methods($role->get_required_method_list);
4227             }
4228 0           else{ # to class or instance
4229             my $consumer_class_name = $consumer->name;
4230 0            
4231 0           my @missing;
  0            
4232 0 0         foreach my $method_name(@{$role->{required_methods}}){
4233 0 0         next if exists $self->{aliased_methods}{$method_name};
4234 0 0         next if exists $role->{methods}{$method_name};
4235             next if $consumer_class_name->can($method_name);
4236 0            
4237             push @missing, $method_name;
4238 0 0         }
4239 0 0         if(@missing){
4240             $role->throw_error(sprintf "'%s' requires the method%s %s to be implemented by '%s'",
4241             $role->name,
4242             (@missing == 1 ? '' : 's'), # method or methods
4243             Mouse::Util::quoted_english_list(@missing),
4244             $consumer_class_name);
4245             }
4246             }
4247 0            
4248             return;
4249             }
4250              
4251 0     0 0   sub apply_methods {
4252             my($self, $role, $consumer) = @_;
4253 0            
4254 0           my $alias = $self->{-alias};
4255             my $excludes = $self->{-excludes};
4256 0            
4257 0 0         foreach my $method_name($role->get_method_list){
4258             next if $method_name eq 'meta';
4259 0            
4260             my $code = $role->get_method_body($method_name);
4261 0 0          
4262 0 0         if(!exists $excludes->{$method_name}){
4263             if(!$consumer->has_method($method_name)){
4264 0           # The third argument $role is used in Role::Composite
4265             $consumer->add_method($method_name => $code, $role);
4266             }
4267             }
4268 0 0          
4269 0           if(exists $alias->{$method_name}){
4270             my $dstname = $alias->{$method_name};
4271 0            
4272             my $dstcode = $consumer->get_method_body($dstname);
4273 0 0 0        
4274 0           if(defined($dstcode) && $dstcode != $code){
4275             $role->throw_error("Cannot create a method alias if a local method of the same name exists");
4276             }
4277 0           else{
4278             $consumer->add_method($dstname => $code, $role);
4279             }
4280             }
4281             }
4282 0            
4283             return;
4284             }
4285              
4286 0     0 0   sub apply_attributes {
4287             my($self, $role, $consumer) = @_;
4288 0            
4289 0 0         for my $attr_name ($role->get_attribute_list) {
4290             next if $consumer->has_attribute($attr_name);
4291 0            
4292             $consumer->add_attribute($attr_name
4293             => $role->get_attribute($attr_name));
4294 0           }
4295             return;
4296             }
4297              
4298 0     0 0   sub apply_modifiers {
4299             my($self, $role, $consumer) = @_;
4300 0 0          
4301 0           if(my $modifiers = $role->{override_method_modifiers}){
  0            
4302             foreach my $method_name (keys %{$modifiers}){
4303 0           $consumer->add_override_method_modifier(
4304             $method_name => $modifiers->{$method_name});
4305             }
4306             }
4307 0            
4308 0 0         for my $modifier_type (qw/before around after/) {
4309             my $table = $role->{"${modifier_type}_method_modifiers"}
4310             or next;
4311 0            
4312             my $add_modifier = "add_${modifier_type}_method_modifier";
4313 0            
  0            
4314 0           while(my($method_name, $modifiers) = each %{$table}){
  0            
4315             foreach my $code(@{ $modifiers }) {
4316 0 0         # skip if the modifier is already applied
4317 0           next if $consumer->{"_applied_$modifier_type"}{$method_name, $code}++;
4318             $consumer->$add_modifier($method_name => $code);
4319             }
4320             }
4321 0           }
4322             return;
4323             }
4324              
4325 0     0     sub _append_roles {
4326             my($self, $role, $metaclass_or_role) = @_;
4327 0            
4328 0           my $roles = $metaclass_or_role->{roles};
  0            
4329 0 0         foreach my $r($role, @{$role->get_roles}){
4330 0           if(!$metaclass_or_role->does_role($r)){
  0            
4331             push @{$roles}, $r;
4332             }
4333 0           }
4334             return;
4335             }
4336 0         0 }
4337             BEGIN{ # lib/Mouse/Meta/Role/Composite.pm
4338 2     2   15 package Mouse::Meta::Role::Composite;
  2         4  
  2         32  
4339 2     2   8 use Carp ();
  2         3  
  2         8  
4340 2     2   11 use Mouse::Util; # enables strict and warnings
  2         7  
  2         41  
4341 2     2   10 use Mouse::Meta::Role;
  2         4  
  2         1449  
4342 2     2   29 use Mouse::Meta::Role::Application;
4343             our @ISA = qw(Mouse::Meta::Role);
4344              
4345             # FIXME: Mouse::Meta::Role::Composite does things in different way from Moose's
4346             # Moose: creates a new class for the consumer, and applies roles to it.
4347             # Mouse: creates a composite role and apply roles to the role,
4348             # and then applies it to the consumer.
4349              
4350 0     0 0   sub new {
4351 0           my $class = shift;
4352 0           my $args = $class->Mouse::Object::BUILDARGS(@_);
4353 0           my $roles = delete $args->{roles};
  0            
4354 0           my $self = $class->create_anon_role(%{$args});
  0            
4355             foreach my $role_spec(@{$roles}) {
4356 0 0         my($role, $args) = ref($role_spec) eq 'ARRAY'
  0            
4357             ? @{$role_spec}
4358 0           : ($role_spec, {});
  0            
4359             $role->apply($self, %{$args});
4360 0           }
4361             return $self;
4362             }
4363              
4364 0     0 0   sub get_method_list {
4365 0           my($self) = @_;
4366 0           return grep { ! $self->{conflicting_methods}{$_} }
  0            
4367             keys %{ $self->{methods} };
4368             }
4369              
4370 0     0 0   sub add_method {
4371             my($self, $method_name, $code, $role) = @_;
4372 0 0 0        
4373             if( ($self->{methods}{$method_name} || 0) == $code){
4374 0           # This role already has the same method.
4375             return;
4376             }
4377 0 0          
4378 0           if($method_name eq 'meta'){
4379             $self->SUPER::add_method($method_name => $code);
4380             }
4381             else{
4382 0   0       # no need to add a subroutine to the stash
4383 0           my $roles = $self->{composed_roles_by_method}{$method_name} ||= [];
  0            
4384 0 0         push @{$roles}, $role;
  0            
4385 0           if(@{$roles} > 1){
4386             $self->{conflicting_methods}{$method_name}++;
4387 0           }
4388             $self->{methods}{$method_name} = $code;
4389 0           }
4390             return;
4391             }
4392              
4393 0     0 0   sub get_method_body {
4394 0           my($self, $method_name) = @_;
4395             return $self->{methods}{$method_name};
4396             }
4397              
4398             sub has_method {
4399 0     0 0   # my($self, $method_name) = @_;
4400             return 0; # to fool apply_methods() in combine()
4401             }
4402              
4403             sub has_attribute {
4404 0     0 0   # my($self, $method_name) = @_;
4405             return 0; # to fool appply_attributes() in combine()
4406             }
4407              
4408             sub has_override_method_modifier {
4409 0     0 0   # my($self, $method_name) = @_;
4410             return 0; # to fool apply_modifiers() in combine()
4411             }
4412              
4413 0     0 0   sub add_attribute {
4414 0           my $self = shift;
4415 0 0         my $attr_name = shift;
4416             my $spec = (@_ == 1 ? $_[0] : {@_});
4417 0            
4418 0 0 0       my $existing = $self->{attributes}{$attr_name};
4419 0           if($existing && $existing != $spec){
4420             $self->throw_error("We have encountered an attribute conflict with '$attr_name' "
4421             . "during composition. This is fatal error and cannot be disambiguated.");
4422 0           }
4423 0           $self->SUPER::add_attribute($attr_name, $spec);
4424             return;
4425             }
4426              
4427 0     0 0   sub add_override_method_modifier {
4428             my($self, $method_name, $code) = @_;
4429 0            
4430 0 0 0       my $existing = $self->{override_method_modifiers}{$method_name};
4431 0           if($existing && $existing != $code){
4432             $self->throw_error( "We have encountered an 'override' method conflict with '$method_name' during "
4433             . "composition (Two 'override' methods of the same name encountered). "
4434             . "This is fatal error.")
4435 0           }
4436 0           $self->SUPER::add_override_method_modifier($method_name, $code);
4437             return;
4438             }
4439              
4440 0     0 0   sub apply {
4441 0           my $self = shift;
4442             my $consumer = shift;
4443 0            
4444 0           Mouse::Meta::Role::Application::RoleSummation->new(@_)->apply($self, $consumer);
4445             return;
4446             }
4447              
4448 2         98 package Mouse::Meta::Role::Application::RoleSummation;
4449             our @ISA = qw(Mouse::Meta::Role::Application);
4450              
4451 0     0     sub apply_methods {
4452             my($self, $role, $consumer, @extra) = @_;
4453 0 0          
4454 0           if(exists $role->{conflicting_methods}){
4455             my $consumer_class_name = $consumer->name;
4456 0            
4457 0           my @conflicting = grep{ !$consumer_class_name->can($_) }
  0            
4458             keys %{ $role->{conflicting_methods} };
4459 0 0          
4460 0 0         if(@conflicting) {
4461             my $method_name_conflict = (@conflicting == 1
4462             ? 'a method name conflict'
4463             : 'method name conflicts');
4464 0            
4465             my %seen;
4466 0           my $roles = Mouse::Util::quoted_english_list(
4467 0           grep{ !$seen{$_}++ } # uniq
4468 0           map { $_->name }
  0            
4469 0           map { @{$_} }
  0            
4470             @{ $role->{composed_roles_by_method} }{@conflicting}
4471             );
4472 0 0          
4473             $self->throw_error(sprintf
4474             q{Due to %s in roles %s,}
4475             . q{ the method%s %s must be implemented or excluded by '%s'},
4476             $method_name_conflict,
4477             $roles,
4478             (@conflicting > 1 ? 's' : ''),
4479             Mouse::Util::quoted_english_list(@conflicting),
4480             $consumer_class_name);
4481             }
4482              
4483 0 0         my @changed_in_v2_0_0 = grep {
4484 0           $consumer_class_name->can($_) && ! $consumer->has_method($_)
  0            
4485 0 0         } keys %{ $role->{conflicting_methods} };
4486 0 0         if (@changed_in_v2_0_0) {
4487             my $method_name_conflict = (@changed_in_v2_0_0 == 1
4488             ? 'a method name conflict'
4489             : 'method name conflicts');
4490 0            
4491             my %seen;
4492 0           my $roles = Mouse::Util::quoted_english_list(
4493 0           grep{ !$seen{$_}++ } # uniq
4494 0           map { $_->name }
  0            
4495 0           map { @{$_} }
  0            
4496             @{ $role->{composed_roles_by_method} }{@changed_in_v2_0_0}
4497             );
4498 0 0          
4499             Carp::cluck(sprintf
4500             q{Due to %s in roles %s,}
4501             . q{ the behavior of method%s %s might be incompatible with Moose}
4502             . q{, check out %s},
4503             $method_name_conflict,
4504             $roles,
4505             (@changed_in_v2_0_0 > 1 ? 's' : ''),
4506             Mouse::Util::quoted_english_list(@changed_in_v2_0_0),
4507             $consumer_class_name);
4508             }
4509             }
4510 0            
4511 0           $self->SUPER::apply_methods($role, $consumer, @extra);
4512             return;
4513             }
4514              
4515             package Mouse::Meta::Role::Composite;
4516 0         0 }
4517             BEGIN{ # lib/Mouse/Meta/Role/Method.pm
4518 2     2   16 package Mouse::Meta::Role::Method;
  2         4  
  2         11  
4519             use Mouse::Util; # enables strict and warnings
4520 2     2   15  
  2         5  
  2         191  
4521 2     2   94 use Mouse::Meta::Method;
4522             our @ISA = qw(Mouse::Meta::Method);
4523              
4524 0     0     sub _new{
4525 0           my($class, %args) = @_;
4526             my $self = bless \%args, $class;
4527 0 0          
4528 0           if($class ne __PACKAGE__){
4529             $self->meta->_initialize_object($self, \%args);
4530 0           }
4531             return $self;
4532             }
4533              
4534 0         0 }
4535             BEGIN{ # lib/Mouse/Object.pm
4536 2     2   14 package Mouse::Object;
  2     0   4  
  2         9  
4537             use Mouse::Util qw(does dump meta); # enables strict and warnings
4538             # all the stuff are defined in XS or PP
4539              
4540 0     0 0   sub DOES {
4541 0   0       my($self, $class_or_role_name) = @_;
4542             return $self->isa($class_or_role_name) || $self->does($class_or_role_name);
4543             }
4544              
4545 0         0 }
4546             BEGIN{ # lib/Mouse/Role.pm
4547 2     2   18 package Mouse::Role;
  2         5  
  2         10  
4548             use Mouse::Exporter; # enables strict and warnings
4549 2     2   9  
4550             our $VERSION = 'v2.4.10';
4551 2     2   12  
  2         6  
  2         38  
4552 2     2   11 use Carp ();
  2         5  
  2         39  
4553             use Scalar::Util ();
4554 2     2   11  
  2         4  
  2         1261  
4555             use Mouse ();
4556 2         21  
4557             Mouse::Exporter->setup_import_methods(
4558             as_is => [qw(
4559             extends with
4560             has
4561             before after around
4562             override super
4563             augment inner
4564              
4565             requires excludes
4566             ),
4567             \&Scalar::Util::blessed,
4568             \&Carp::confess,
4569             ],
4570             );
4571              
4572              
4573 0     0 0   sub extends {
4574             Carp::croak "Roles do not support 'extends'";
4575             }
4576              
4577 0     0 0   sub with {
4578 0           Mouse::Util::apply_all_roles(scalar(caller), @_);
4579             return;
4580             }
4581              
4582 0     0 0   sub has {
4583 0           my $meta = Mouse::Meta::Role->initialize(scalar caller);
4584             my $name = shift;
4585 0 0          
4586             $meta->throw_error(q{Usage: has 'name' => ( key => value, ... )})
4587             if @_ % 2; # odd number of arguments
4588 0 0          
  0            
4589 0           for my $n(ref($name) ? @{$name} : $name){
4590             $meta->add_attribute($n => @_);
4591 0           }
4592             return;
4593             }
4594              
4595 0     0 0   sub before {
4596 0           my $meta = Mouse::Meta::Role->initialize(scalar caller);
4597 0           my $code = pop;
4598 0           for my $name($meta->_collect_methods(@_)) {
4599             $meta->add_before_method_modifier($name => $code);
4600 0           }
4601             return;
4602             }
4603              
4604 0     0 0   sub after {
4605 0           my $meta = Mouse::Meta::Role->initialize(scalar caller);
4606 0           my $code = pop;
4607 0           for my $name($meta->_collect_methods(@_)) {
4608             $meta->add_after_method_modifier($name => $code);
4609 0           }
4610             return;
4611             }
4612              
4613 0     0 0   sub around {
4614 0           my $meta = Mouse::Meta::Role->initialize(scalar caller);
4615 0           my $code = pop;
4616 0           for my $name($meta->_collect_methods(@_)) {
4617             $meta->add_around_method_modifier($name => $code);
4618 0           }
4619             return;
4620             }
4621              
4622              
4623 0 0   0 0   sub super {
4624 0           return if !defined $Mouse::SUPER_BODY;
4625             $Mouse::SUPER_BODY->(@Mouse::SUPER_ARGS);
4626             }
4627              
4628             sub override {
4629 0     0 0   # my($name, $code) = @_;
4630 0           Mouse::Meta::Role->initialize(scalar caller)->add_override_method_modifier(@_);
4631             return;
4632             }
4633              
4634             # We keep the same errors messages as Moose::Role emits, here.
4635 0     0 0   sub inner {
4636             Carp::croak "Roles cannot support 'inner'";
4637             }
4638              
4639 0     0 0   sub augment {
4640             Carp::croak "Roles cannot support 'augment'";
4641             }
4642              
4643 0     0 1   sub requires {
4644 0 0         my $meta = Mouse::Meta::Role->initialize(scalar caller);
4645 0           $meta->throw_error("Must specify at least one method") unless @_;
4646 0           $meta->add_required_methods(@_);
4647             return;
4648             }
4649              
4650 0     0 1   sub excludes {
4651             Mouse::Util::not_supported();
4652             }
4653              
4654 0     0 0   sub init_meta{
4655 0           shift;
4656             my %args = @_;
4657              
4658 0 0         my $class = $args{for_class}
4659             or Carp::confess("Cannot call init_meta without specifying a for_class");
4660 0   0        
4661             my $metaclass = $args{metaclass} || 'Mouse::Meta::Role';
4662 0            
4663 0           my $meta = $metaclass->initialize($class);
4664             my $filename = Mouse::Util::module_notional_filename($meta->name);
4665 0 0         $INC{$filename} = '(set by Mouse)'
4666             unless exists $INC{$filename};
4667              
4668 0   0 0     $meta->add_method(meta => sub{
4669 0           $metaclass->initialize(ref($_[0]) || $_[0]);
4670             });
4671              
4672 0 0         # make a role type for each Mouse role
4673             Mouse::Util::TypeConstraints::role_type($class)
4674             unless Mouse::Util::TypeConstraints::find_type_constraint($class);
4675 0            
4676             return $meta;
4677             }
4678              
4679 0         0 }
4680             BEGIN{ # lib/Mouse/Util/MetaRole.pm
4681 2     2   10 package Mouse::Util::MetaRole;
  2         5  
  2         7  
4682 2     2   13 use Mouse::Util; # enables strict and warnings
  2     0   5  
  2         1282  
4683             use Scalar::Util ();
4684              
4685 0     0 0   sub apply_metaclass_roles {
4686 0           my %args = @_;
4687             _fixup_old_style_args(\%args);
4688 0            
4689             return apply_metaroles(%args);
4690             }
4691              
4692 0     0 1   sub apply_metaroles {
4693             my %args = @_;
4694              
4695             my $for = Scalar::Util::blessed($args{for})
4696 0 0         ? $args{for}
4697             : Mouse::Util::get_metaclass_by_name( $args{for} );
4698 0 0          
4699 0           if(!$for){
4700             Carp::confess("You must pass an initialized class, but '$args{for}' has no metaclass");
4701             }
4702 0 0          
4703 0           if ( Mouse::Util::is_a_metarole($for) ) {
4704             return _make_new_metaclass( $for, $args{role_metaroles}, 'role' );
4705             }
4706 0           else {
4707             return _make_new_metaclass( $for, $args{class_metaroles}, 'class' );
4708             }
4709             }
4710              
4711 0     0     sub _make_new_metaclass {
4712             my($for, $roles, $primary) = @_;
4713 0 0          
  0            
4714             return $for unless keys %{$roles};
4715              
4716 0 0         my $new_metaclass = exists($roles->{$primary})
4717             ? _make_new_class( ref $for, $roles->{$primary} ) # new class with traits
4718             : ref $for;
4719 0            
4720             my %classes;
4721 0            
  0            
  0            
4722 0           for my $key ( grep { $_ ne $primary } keys %{$roles} ) {
4723 0   0       my $metaclass;
4724             my $attr = $for->can($metaclass = ($key . '_metaclass'))
4725             || $for->can($metaclass = ($key . '_class'))
4726             || $for->throw_error("Unknown metaclass '$key'");
4727              
4728 0           $classes{ $metaclass }
4729             = _make_new_class( $for->$attr(), $roles->{$key} );
4730             }
4731 0            
4732             return $new_metaclass->reinitialize( $for, %classes );
4733             }
4734              
4735              
4736 0     0     sub _fixup_old_style_args {
4737             my $args = shift;
4738 0 0 0        
4739             return if $args->{class_metaroles} || $args->{roles_metaroles};
4740              
4741 0 0         $args->{for} = delete $args->{for_class}
4742             if exists $args->{for_class};
4743 0            
4744             my @old_keys = qw(
4745             attribute_metaclass_roles
4746             method_metaclass_roles
4747             wrapped_method_metaclass_roles
4748             instance_metaclass_roles
4749             constructor_class_roles
4750             destructor_class_roles
4751             error_class_roles
4752              
4753             application_to_class_class_roles
4754             application_to_role_class_roles
4755             application_to_instance_class_roles
4756             application_role_summation_class_roles
4757             );
4758              
4759             my $for = Scalar::Util::blessed($args->{for})
4760 0 0         ? $args->{for}
4761             : Mouse::Util::get_metaclass_by_name( $args->{for} );
4762 0            
4763 0 0         my $top_key;
4764 0           if( Mouse::Util::is_a_metaclass($for) ){
4765             $top_key = 'class_metaroles';
4766              
4767 0 0         $args->{class_metaroles}{class} = delete $args->{metaclass_roles}
4768             if exists $args->{metaclass_roles};
4769             }
4770 0           else {
4771             $top_key = 'role_metaroles';
4772              
4773 0 0         $args->{role_metaroles}{role} = delete $args->{metaclass_roles}
4774             if exists $args->{metaclass_roles};
4775             }
4776 0            
4777 0           for my $old_key (@old_keys) {
4778             my ($new_key) = $old_key =~ /^(.+)_(?:class|metaclass)_roles$/;
4779              
4780 0 0         $args->{$top_key}{$new_key} = delete $args->{$old_key}
4781             if exists $args->{$old_key};
4782             }
4783 0            
4784             return;
4785             }
4786              
4787              
4788 0     0 1   sub apply_base_class_roles {
4789             my %options = @_;
4790 0            
4791             my $for = $options{for_class};
4792 0            
4793             my $meta = Mouse::Util::class_of($for);
4794              
4795             my $new_base = _make_new_class(
4796             $for,
4797 0           $options{roles},
4798             [ $meta->superclasses() ],
4799             );
4800 0 0          
4801             $meta->superclasses($new_base)
4802 0           if $new_base ne $meta->name();
4803             return;
4804             }
4805              
4806 0     0     sub _make_new_class {
4807             my($existing_class, $roles, $superclasses) = @_;
4808 0 0          
4809 0 0         if(!$superclasses){
4810             return $existing_class if !$roles;
4811 0            
4812             my $meta = Mouse::Meta::Class->initialize($existing_class);
4813              
4814 0 0 0       return $existing_class
  0            
  0            
4815             if !grep { !ref($_) && !$meta->does_role($_) } @{$roles};
4816             }
4817 0 0          
4818             return Mouse::Meta::Class->create_anon_class(
4819             superclasses => $superclasses ? $superclasses : [$existing_class],
4820             roles => $roles,
4821             cache => 1,
4822             )->name();
4823             }
4824              
4825             }
4826             END_OF_TINY
4827             die $@ if $@;
4828             } # unless Mouse.pm is loaded
4829             package Mouse::Tiny;
4830              
4831             our $VERSION = 'v2.4.10';
4832              
4833             Mouse::Exporter->setup_import_methods(also => 'Mouse');
4834              
4835             1;