local-lib5/lib/perl5/i486-linux-gnu-thread-multi/Mouse/Tiny.pm

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