File Coverage

blib/lib/Mouse/Tiny.pm
Criterion Covered Total %
statement 812 2341 34.6
branch 175 946 18.5
condition 44 402 10.9
subroutine 168 456 36.8
pod 63 251 25.1
total 1262 4396 28.7


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