lib/Moose/Meta/Class.pm

   1
   2 package Moose::Meta::Class;
   3
   4 use strict;
   5 use warnings;
   6
   7 use Class::MOP;
   8
   9 use Carp qw( confess );
  10 use Data::OptList;
  11 use List::Util qw( first );
  12 use List::MoreUtils qw( any all uniq first_index );
  13 use Scalar::Util 'weaken', 'blessed';
  14
  15 our $VERSION   = '1.14';
  16 $VERSION = eval $VERSION;
  17 our $AUTHORITY = 'cpan:STEVAN';
  18
  19 use Moose::Meta::Method::Overridden;
  20 use Moose::Meta::Method::Augmented;
  21 use Moose::Error::Default;
  22 use Moose::Meta::Class::Immutable::Trait;
  23 use Moose::Meta::Method::Constructor;
  24 use Moose::Meta::Method::Destructor;
  25
  26 use base 'Class::MOP::Class';
  27
  28 __PACKAGE__->meta->add_attribute('roles' => (
  29     reader  => 'roles',
  30     default => sub { [] }
  31 ));
  32
  33 __PACKAGE__->meta->add_attribute('role_applications' => (
  34     reader  => '_get_role_applications',
  35     default => sub { [] }
  36 ));
  37
  38 __PACKAGE__->meta->add_attribute(
  39     Class::MOP::Attribute->new('immutable_trait' => (
  40         accessor => "immutable_trait",
  41         default  => 'Moose::Meta::Class::Immutable::Trait',
  42     ))
  43 );
  44
  45 __PACKAGE__->meta->add_attribute('constructor_class' => (
  46     accessor => 'constructor_class',
  47     default  => 'Moose::Meta::Method::Constructor',
  48 ));
  49
  50 __PACKAGE__->meta->add_attribute('destructor_class' => (
  51     accessor => 'destructor_class',
  52     default  => 'Moose::Meta::Method::Destructor',
  53 ));
  54
  55 __PACKAGE__->meta->add_attribute('error_class' => (
  56     accessor => 'error_class',
  57     default  => 'Moose::Error::Default',
  58 ));
  59
  60 sub initialize {
  61     my $class = shift;
  62     my $pkg   = shift;
  63     return Class::MOP::get_metaclass_by_name($pkg)
  64         || $class->SUPER::initialize($pkg,
  65                 'attribute_metaclass' => 'Moose::Meta::Attribute',
  66                 'method_metaclass'    => 'Moose::Meta::Method',
  67                 'instance_metaclass'  => 'Moose::Meta::Instance',
  68                 @_
  69             );
  70 }
  71
  72 sub create {
  73     my ($class, $package_name, %options) = @_;
  74
  75     (ref $options{roles} eq 'ARRAY')
  76         || $class->throw_error("You must pass an ARRAY ref of roles", data => $options{roles})
  77             if exists $options{roles};
  78     my $roles = delete $options{roles};
  79
  80     my $new_meta = $class->SUPER::create($package_name, %options);
  81
  82     if ($roles) {
  83         Moose::Util::apply_all_roles( $new_meta, @$roles );
  84     }
  85
  86     return $new_meta;
  87 }
  88
  89 my %ANON_CLASSES;
  90
  91 sub create_anon_class {
  92     my ($self, %options) = @_;
  93
  94     my $cache_ok = delete $options{cache};
  95
  96     my $cache_key
  97         = _anon_cache_key( $options{superclasses}, $options{roles} );
  98
  99     if ($cache_ok && defined $ANON_CLASSES{$cache_key}) {
 100         return $ANON_CLASSES{$cache_key};
 101     }
 102
 103     my $new_class = $self->SUPER::create_anon_class(%options);
 104
 105     $ANON_CLASSES{$cache_key} = $new_class
 106         if $cache_ok;
 107
 108     return $new_class;
 109 }
 110
 111 sub _anon_cache_key {
 112     # Makes something like Super::Class|Super::Class::2=Role|Role::1
 113     return join '=' => (
 114         join( '|', @{ $_[0]      || [] } ),
 115         join( '|', sort @{ $_[1] || [] } ),
 116     );
 117 }
 118
 119 sub reinitialize {
 120     my $self = shift;
 121     my $pkg  = shift;
 122
 123     my $meta = blessed $pkg ? $pkg : Class::MOP::class_of($pkg);
 124
 125     my $cache_key;
 126
 127     my %existing_classes;
 128     if ($meta) {
 129         %existing_classes = map { $_ => $meta->$_() } qw(
 130             attribute_metaclass
 131             method_metaclass
 132             wrapped_method_metaclass
 133             instance_metaclass
 134             constructor_class
 135             destructor_class
 136             error_class
 137         );
 138
 139         $cache_key = _anon_cache_key(
 140             [ $meta->superclasses ],
 141             [ map { $_->name } @{ $meta->roles } ],
 142         ) if $meta->is_anon_class;
 143     }
 144
 145     my $new_meta = $self->SUPER::reinitialize(
 146         $pkg,
 147         %existing_classes,
 148         @_,
 149     );
 150
 151     return $new_meta unless defined $cache_key;
 152
 153     my $new_cache_key = _anon_cache_key(
 154         [ $meta->superclasses ],
 155         [ map { $_->name } @{ $meta->roles } ],
 156     );
 157
 158     delete $ANON_CLASSES{$cache_key};
 159     $ANON_CLASSES{$new_cache_key} = $new_meta;
 160
 161     return $new_meta;
 162 }
 163
 164 sub add_role {
 165     my ($self, $role) = @_;
 166     (blessed($role) && $role->isa('Moose::Meta::Role'))
 167         || $self->throw_error("Roles must be instances of Moose::Meta::Role", data => $role);
 168     push @{$self->roles} => $role;
 169 }
 170
 171 sub role_applications {
 172     my ($self) = @_;
 173
 174     return @{$self->_get_role_applications};
 175 }
 176
 177 sub add_role_application {
 178     my ($self, $application) = @_;
 179     (blessed($application) && $application->isa('Moose::Meta::Role::Application::ToClass'))
 180         || $self->throw_error("Role applications must be instances of Moose::Meta::Role::Application::ToClass", data => $application);
 181     push @{$self->_get_role_applications} => $application;
 182 }
 183
 184 sub calculate_all_roles {
 185     my $self = shift;
 186     my %seen;
 187     grep { !$seen{$_->name}++ } map { $_->calculate_all_roles } @{ $self->roles };
 188 }
 189
 190 sub calculate_all_roles_with_inheritance {
 191     my $self = shift;
 192     my %seen;
 193     grep { !$seen{$_->name}++ }
 194          map { Class::MOP::class_of($_)->can('calculate_all_roles')
 195                    ? Class::MOP::class_of($_)->calculate_all_roles
 196                    : () }
 197              $self->linearized_isa;
 198 }
 199
 200 sub does_role {
 201     my ($self, $role_name) = @_;
 202
 203     (defined $role_name)
 204         || $self->throw_error("You must supply a role name to look for");
 205
 206     foreach my $class ($self->class_precedence_list) {
 207         my $meta = Class::MOP::class_of($class);
 208         # when a Moose metaclass is itself extended with a role,
 209         # this check needs to be done since some items in the
 210         # class_precedence_list might in fact be Class::MOP
 211         # based still.
 212         next unless $meta && $meta->can('roles');
 213         foreach my $role (@{$meta->roles}) {
 214             return 1 if $role->does_role($role_name);
 215         }
 216     }
 217     return 0;
 218 }
 219
 220 sub excludes_role {
 221     my ($self, $role_name) = @_;
 222
 223     (defined $role_name)
 224         || $self->throw_error("You must supply a role name to look for");
 225
 226     foreach my $class ($self->class_precedence_list) {
 227         my $meta = Class::MOP::class_of($class);
 228         # when a Moose metaclass is itself extended with a role,
 229         # this check needs to be done since some items in the
 230         # class_precedence_list might in fact be Class::MOP
 231         # based still.
 232         next unless $meta && $meta->can('roles');
 233         foreach my $role (@{$meta->roles}) {
 234             return 1 if $role->excludes_role($role_name);
 235         }
 236     }
 237     return 0;
 238 }
 239
 240 sub new_object {
 241     my $self   = shift;
 242     my $params = @_ == 1 ? $_[0] : {@_};
 243     my $object = $self->SUPER::new_object($params);
 244
 245     foreach my $attr ( $self->get_all_attributes() ) {
 246
 247         next unless $attr->can('has_trigger') && $attr->has_trigger;
 248
 249         my $init_arg = $attr->init_arg;
 250
 251         next unless defined $init_arg;
 252
 253         next unless exists $params->{$init_arg};
 254
 255         $attr->trigger->(
 256             $object,
 257             (
 258                   $attr->should_coerce
 259                 ? $attr->get_read_method_ref->($object)
 260                 : $params->{$init_arg}
 261             ),
 262         );
 263     }
 264
 265     $object->BUILDALL($params) if $object->can('BUILDALL');
 266
 267     return $object;
 268 }
 269
 270 sub superclasses {
 271     my $self = shift;
 272     my $supers = Data::OptList::mkopt(\@_);
 273     foreach my $super (@{ $supers }) {
 274         my ($name, $opts) = @{ $super };
 275         Class::MOP::load_class($name, $opts);
 276         my $meta = Class::MOP::class_of($name);
 277         $self->throw_error("You cannot inherit from a Moose Role ($name)")
 278             if $meta && $meta->isa('Moose::Meta::Role')
 279     }
 280     return $self->SUPER::superclasses(map { $_->[0] } @{ $supers });
 281 }
 282
 283 ### ---------------------------------------------
 284
 285 sub add_attribute {
 286     my $self = shift;
 287     my $attr =
 288         (blessed $_[0] && $_[0]->isa('Class::MOP::Attribute')
 289             ? $_[0]
 290             : $self->_process_attribute(@_));
 291     $self->SUPER::add_attribute($attr);
 292     # it may be a Class::MOP::Attribute, theoretically, which doesn't have
 293     # 'bare' and doesn't implement this method
 294     if ($attr->can('_check_associated_methods')) {
 295         $attr->_check_associated_methods;
 296     }
 297     return $attr;
 298 }
 299
 300 sub add_override_method_modifier {
 301     my ($self, $name, $method, $_super_package) = @_;
 302
 303     (!$self->has_method($name))
 304         || $self->throw_error("Cannot add an override method if a local method is already present");
 305
 306     $self->add_method($name => Moose::Meta::Method::Overridden->new(
 307         method  => $method,
 308         class   => $self,
 309         package => $_super_package, # need this for roles
 310         name    => $name,
 311     ));
 312 }
 313
 314 sub add_augment_method_modifier {
 315     my ($self, $name, $method) = @_;
 316     (!$self->has_method($name))
 317         || $self->throw_error("Cannot add an augment method if a local method is already present");
 318
 319     $self->add_method($name => Moose::Meta::Method::Augmented->new(
 320         method  => $method,
 321         class   => $self,
 322         name    => $name,
 323     ));
 324 }
 325
 326 ## Private Utility methods ...
 327
 328 sub _find_next_method_by_name_which_is_not_overridden {
 329     my ($self, $name) = @_;
 330     foreach my $method ($self->find_all_methods_by_name($name)) {
 331         return $method->{code}
 332             if blessed($method->{code}) && !$method->{code}->isa('Moose::Meta::Method::Overridden');
 333     }
 334     return undef;
 335 }
 336
 337 ## Metaclass compatibility
 338
 339 sub _base_metaclasses {
 340     my $self = shift;
 341     my %metaclasses = $self->SUPER::_base_metaclasses;
 342     for my $class (keys %metaclasses) {
 343         $metaclasses{$class} =~ s/^Class::MOP/Moose::Meta/;
 344     }
 345     return (
 346         %metaclasses,
 347         error_class => 'Moose::Error::Default',
 348     );
 349 }
 350
 351 sub _can_fix_metaclass_incompatibility {
 352     my $self = shift;
 353     return 1 if $self->_can_fix_metaclass_incompatibility_by_role_reconciliation(@_);
 354     return $self->SUPER::_can_fix_metaclass_incompatibility(@_);
 355 }
 356
 357 sub _can_fix_metaclass_incompatibility_by_role_reconciliation {
 358     my $self = shift;
 359     my ($super_meta) = @_;
 360
 361     return 1 if $self->_can_fix_class_metaclass_incompatibility_by_role_reconciliation($super_meta);
 362
 363     my %base_metaclass = $self->_base_metaclasses;
 364     for my $metaclass_type (keys %base_metaclass) {
 365         next unless defined $self->$metaclass_type;
 366         return 1 if $self->_can_fix_single_metaclass_incompatibility_by_role_reconciliation($metaclass_type, $super_meta);
 367     }
 368
 369     return;
 370 }
 371
 372 sub _can_fix_class_metaclass_incompatibility_by_role_reconciliation {
 373     my $self = shift;
 374     my ($super_meta) = @_;
 375
 376     my $super_meta_name = $super_meta->_real_ref_name;
 377
 378     return $self->_classes_differ_by_roles_only(
 379         blessed($self),
 380         $super_meta_name,
 381         'Moose::Meta::Class',
 382     );
 383 }
 384
 385 sub _can_fix_single_metaclass_incompatibility_by_role_reconciliation {
 386     my $self = shift;
 387     my ($metaclass_type, $super_meta) = @_;
 388
 389     my $class_specific_meta_name = $self->$metaclass_type;
 390     return unless $super_meta->can($metaclass_type);
 391     my $super_specific_meta_name = $super_meta->$metaclass_type;
 392     my %metaclasses = $self->_base_metaclasses;
 393
 394     return $self->_classes_differ_by_roles_only(
 395         $class_specific_meta_name,
 396         $super_specific_meta_name,
 397         $metaclasses{$metaclass_type},
 398     );
 399 }
 400
 401 sub _classes_differ_by_roles_only {
 402     my $self = shift;
 403     my ( $self_meta_name, $super_meta_name, $expected_ancestor ) = @_;
 404
 405     my $common_base_name
 406         = $self->_find_common_base( $self_meta_name, $super_meta_name );
 407
 408     # If they're not both moose metaclasses, and the cmop fixing couldn't do
 409     # anything, there's nothing more we can do. The $expected_ancestor should
 410     # always be a Moose metaclass name like Moose::Meta::Class or
 411     # Moose::Meta::Attribute.
 412     return unless defined $common_base_name;
 413     return unless $common_base_name->isa($expected_ancestor);
 414
 415     my @super_meta_name_ancestor_names
 416         = $self->_get_ancestors_until( $super_meta_name, $common_base_name );
 417     my @class_meta_name_ancestor_names
 418         = $self->_get_ancestors_until( $self_meta_name, $common_base_name );
 419
 420     return
 421         unless all { $self->_is_role_only_subclass($_) }
 422         @super_meta_name_ancestor_names,
 423         @class_meta_name_ancestor_names;
 424
 425     return 1;
 426 }
 427
 428 sub _find_common_base {
 429     my $self = shift;
 430     my ($meta1, $meta2) = map { Class::MOP::class_of($_) } @_;
 431     return unless defined $meta1 && defined $meta2;
 432
 433     # FIXME? This doesn't account for multiple inheritance (not sure
 434     # if it needs to though). For example, if somewhere in $meta1's
 435     # history it inherits from both ClassA and ClassB, and $meta2
 436     # inherits from ClassB & ClassA, does it matter? And what crazy
 437     # fool would do that anyway?
 438
 439     my %meta1_parents = map { $_ => 1 } $meta1->linearized_isa;
 440
 441     return first { $meta1_parents{$_} } $meta2->linearized_isa;
 442 }
 443
 444 sub _get_ancestors_until {
 445     my $self = shift;
 446     my ($start_name, $until_name) = @_;
 447
 448     my @ancestor_names;
 449     for my $ancestor_name (Class::MOP::class_of($start_name)->linearized_isa) {
 450         last if $ancestor_name eq $until_name;
 451         push @ancestor_names, $ancestor_name;
 452     }
 453     return @ancestor_names;
 454 }
 455
 456 sub _is_role_only_subclass {
 457     my $self = shift;
 458     my ($meta_name) = @_;
 459     my $meta = Class::MOP::Class->initialize($meta_name);
 460     my @parent_names = $meta->superclasses;
 461
 462     # XXX: don't feel like messing with multiple inheritance here... what would
 463     # that even do?
 464     return unless @parent_names == 1;
 465     my ($parent_name) = @parent_names;
 466     my $parent_meta = Class::MOP::Class->initialize($parent_name);
 467
 468     my @roles = $meta->can('calculate_all_roles_with_inheritance')
 469                     ? $meta->calculate_all_roles_with_inheritance
 470                     : ();
 471
 472     # loop over all methods that are a part of the current class
 473     # (not inherited)
 474     for my $method ( $meta->_get_local_methods ) {
 475         # always ignore meta
 476         next if $method->name eq 'meta';
 477         # we'll deal with attributes below
 478         next if $method->can('associated_attribute');
 479         # if the method comes from a role we consumed, ignore it
 480         next if $meta->can('does_role')
 481              && $meta->does_role($method->original_package_name);
 482         # FIXME - this really isn't right. Just because a modifier is
 483         # defined in a role doesn't mean it isn't _also_ defined in the
 484         # subclass.
 485         next if $method->isa('Class::MOP::Method::Wrapped')
 486              && (
 487                  (!scalar($method->around_modifiers)
 488                || any { $_->has_around_method_modifiers($method->name) } @roles)
 489               && (!scalar($method->before_modifiers)
 490                || any { $_->has_before_method_modifiers($method->name) } @roles)
 491               && (!scalar($method->after_modifiers)
 492                || any { $_->has_after_method_modifiers($method->name) } @roles)
 493                 );
 494
 495         return 0;
 496     }
 497
 498     # loop over all attributes that are a part of the current class
 499     # (not inherited)
 500     # FIXME - this really isn't right. Just because an attribute is
 501     # defined in a role doesn't mean it isn't _also_ defined in the
 502     # subclass.
 503     for my $attr (map { $meta->get_attribute($_) } $meta->get_attribute_list) {
 504         next if any { $_->has_attribute($attr->name) } @roles;
 505
 506         return 0;
 507     }
 508
 509     return 1;
 510 }
 511
 512 sub _fix_class_metaclass_incompatibility {
 513     my $self = shift;
 514     my ($super_meta) = @_;
 515
 516     $self->SUPER::_fix_class_metaclass_incompatibility(@_);
 517
 518     if ($self->_can_fix_class_metaclass_incompatibility_by_role_reconciliation($super_meta)) {
 519         ($self->is_pristine)
 520             || confess "Can't fix metaclass incompatibility for "
 521                      . $self->name
 522                      . " because it is not pristine.";
 523         my $super_meta_name = $super_meta->_real_ref_name;
 524         my $class_meta_subclass_meta_name = $self->_reconcile_roles_for_metaclass(blessed($self), $super_meta_name);
 525         my $new_self = $class_meta_subclass_meta_name->reinitialize(
 526             $self->name,
 527         );
 528
 529         $self->_replace_self( $new_self, $class_meta_subclass_meta_name );
 530     }
 531 }
 532
 533 sub _fix_single_metaclass_incompatibility {
 534     my $self = shift;
 535     my ($metaclass_type, $super_meta) = @_;
 536
 537     $self->SUPER::_fix_single_metaclass_incompatibility(@_);
 538
 539     if ($self->_can_fix_single_metaclass_incompatibility_by_role_reconciliation($metaclass_type, $super_meta)) {
 540         ($self->is_pristine)
 541             || confess "Can't fix metaclass incompatibility for "
 542                      . $self->name
 543                      . " because it is not pristine.";
 544         my $super_meta_name = $super_meta->_real_ref_name;
 545         my $class_specific_meta_subclass_meta_name = $self->_reconcile_roles_for_metaclass($self->$metaclass_type, $super_meta->$metaclass_type);
 546         my $new_self = $super_meta->reinitialize(
 547             $self->name,
 548             $metaclass_type => $class_specific_meta_subclass_meta_name,
 549         );
 550
 551         $self->_replace_self( $new_self, $super_meta_name );
 552     }
 553 }
 554
 555 sub _reconcile_roles_for_metaclass {
 556     my $self = shift;
 557     my ($class_meta_name, $super_meta_name) = @_;
 558
 559     my @role_differences = $self->_role_differences(
 560         $class_meta_name, $super_meta_name,
 561     );
 562
 563     # handle the case where we need to fix compatibility between a class and
 564     # its parent, but all roles in the class are already also done by the
 565     # parent
 566     # see t/050/054.t
 567     return $super_meta_name
 568         unless @role_differences;
 569
 570     return Moose::Meta::Class->create_anon_class(
 571         superclasses => [$super_meta_name],
 572         roles        => [map { $_->name } @role_differences],
 573         cache        => 1,
 574     )->name;
 575 }
 576
 577 sub _role_differences {
 578     my $self = shift;
 579     my ($class_meta_name, $super_meta_name) = @_;
 580     my @super_role_metas = $super_meta_name->meta->can('calculate_all_roles_with_inheritance')
 581                          ? $super_meta_name->meta->calculate_all_roles_with_inheritance
 582                          : ();
 583     my @role_metas       = $class_meta_name->meta->can('calculate_all_roles_with_inheritance')
 584                          ? $class_meta_name->meta->calculate_all_roles_with_inheritance
 585                          : ();
 586     my @differences;
 587     for my $role_meta (@role_metas) {
 588         push @differences, $role_meta
 589             unless any { $_->name eq $role_meta->name } @super_role_metas;
 590     }
 591     return @differences;
 592 }
 593
 594 sub _replace_self {
 595     my $self      = shift;
 596     my ( $new_self, $new_class)   = @_;
 597
 598     %$self = %$new_self;
 599     bless $self, $new_class;
 600
 601     # We need to replace the cached metaclass instance or else when it goes
 602     # out of scope Class::MOP::Class destroy's the namespace for the
 603     # metaclass's class, causing much havoc.
 604     Class::MOP::store_metaclass_by_name( $self->name, $self );
 605     Class::MOP::weaken_metaclass( $self->name ) if $self->is_anon_class;
 606 }
 607
 608 sub _get_compatible_single_metaclass {
 609     my $self = shift;
 610
 611     return $self->SUPER::_get_compatible_single_metaclass(@_)
 612         || $self->_get_compatible_single_metaclass_by_role_reconciliation(@_);
 613 }
 614
 615 sub _get_compatible_single_metaclass_by_role_reconciliation {
 616     my $self = shift;
 617     my ($single_meta_name) = @_;
 618
 619     my $current_single_meta_name = $self->_get_associated_single_metaclass($single_meta_name);
 620
 621     return $self->_reconcile_roles_for_metaclass($single_meta_name, $current_single_meta_name);
 622 }
 623
 624 sub _process_attribute {
 625     my ( $self, $name, @args ) = @_;
 626
 627     @args = %{$args[0]} if scalar @args == 1 && ref($args[0]) eq 'HASH';
 628
 629     if (($name || '') =~ /^\+(.*)/) {
 630         return $self->_process_inherited_attribute($1, @args);
 631     }
 632     else {
 633         return $self->_process_new_attribute($name, @args);
 634     }
 635 }
 636
 637 sub _process_new_attribute {
 638     my ( $self, $name, @args ) = @_;
 639
 640     $self->attribute_metaclass->interpolate_class_and_new($name, @args);
 641 }
 642
 643 sub _process_inherited_attribute {
 644     my ($self, $attr_name, %options) = @_;
 645     my $inherited_attr = $self->find_attribute_by_name($attr_name);
 646     (defined $inherited_attr)
 647         || $self->throw_error("Could not find an attribute by the name of '$attr_name' to inherit from in ${\$self->name}", data => $attr_name);
 648     if ($inherited_attr->isa('Moose::Meta::Attribute')) {
 649         return $inherited_attr->clone_and_inherit_options(%options);
 650     }
 651     else {
 652         # NOTE:
 653         # kind of a kludge to handle Class::MOP::Attributes
 654         return $inherited_attr->Moose::Meta::Attribute::clone_and_inherit_options(%options);
 655     }
 656 }
 657
 658 ## Immutability
 659
 660 sub _immutable_options {
 661     my ( $self, @args ) = @_;
 662
 663     $self->SUPER::_immutable_options(
 664         inline_destructor => 1,
 665
 666         # Moose always does this when an attribute is created
 667         inline_accessors => 0,
 668
 669         @args,
 670     );
 671 }
 672
 673 ## -------------------------------------------------
 674
 675 our $error_level;
 676
 677 sub throw_error {
 678     my ( $self, @args ) = @_;
 679     local $error_level = ($error_level || 0) + 1;
 680     $self->raise_error($self->create_error(@args));
 681 }
 682
 683 sub raise_error {
 684     my ( $self, @args ) = @_;
 685     die @args;
 686 }
 687
 688 sub create_error {
 689     my ( $self, @args ) = @_;
 690
 691     require Carp::Heavy;
 692
 693     local $error_level = ($error_level || 0 ) + 1;
 694
 695     if ( @args % 2 == 1 ) {
 696         unshift @args, "message";
 697     }
 698
 699     my %args = ( metaclass => $self, last_error => $@, @args );
 700
 701     $args{depth} += $error_level;
 702
 703     my $class = ref $self ? $self->error_class : "Moose::Error::Default";
 704
 705     Class::MOP::load_class($class);
 706
 707     $class->new(
 708         Carp::caller_info($args{depth}),
 709         %args
 710     );
 711 }
 712
 713 1;
 714
 715 __END__
 716
 717 =pod
 718
 719 =head1 NAME
 720
 721 Moose::Meta::Class - The Moose metaclass
 722
 723 =head1 DESCRIPTION
 724
 725 This class is a subclass of L<Class::MOP::Class> that provides
 726 additional Moose-specific functionality.
 727
 728 To really understand this class, you will need to start with the
 729 L<Class::MOP::Class> documentation. This class can be understood as a
 730 set of additional features on top of the basic feature provided by
 731 that parent class.
 732
 733 =head1 INHERITANCE
 734
 735 C<Moose::Meta::Class> is a subclass of L<Class::MOP::Class>.
 736
 737 =head1 METHODS
 738
 739 =over 4
 740
 741 =item B<< Moose::Meta::Class->initialize($package_name, %options) >>
 742
 743 This overrides the parent's method in order to provide its own
 744 defaults for the C<attribute_metaclass>, C<instance_metaclass>, and
 745 C<method_metaclass> options.
 746
 747 These all default to the appropriate Moose class.
 748
 749 =item B<< Moose::Meta::Class->create($package_name, %options) >>
 750
 751 This overrides the parent's method in order to accept a C<roles>
 752 option. This should be an array reference containing roles
 753 that the class does, each optionally followed by a hashref of options
 754 (C<-excludes> and C<-alias>).
 755
 756   my $metaclass = Moose::Meta::Class->create( 'New::Class', roles => [...] );
 757
 758 =item B<< Moose::Meta::Class->create_anon_class >>
 759
 760 This overrides the parent's method to accept a C<roles> option, just
 761 as C<create> does.
 762
 763 It also accepts a C<cache> option. If this is true, then the anonymous
 764 class will be cached based on its superclasses and roles. If an
 765 existing anonymous class in the cache has the same superclasses and
 766 roles, it will be reused.
 767
 768   my $metaclass = Moose::Meta::Class->create_anon_class(
 769       superclasses => ['Foo'],
 770       roles        => [qw/Some Roles Go Here/],
 771       cache        => 1,
 772   );
 773
 774 Each entry in both the C<superclasses> and the C<roles> option can be
 775 followed by a hash reference with arguments. The C<superclasses>
 776 option can be supplied with a L<-version|Class::MOP/Class Loading
 777 Options> option that ensures the loaded superclass satisfies the
 778 required version. The C<role> option also takes the C<-version> as an
 779 argument, but the option hash reference can also contain any other
 780 role relevant values like exclusions or parameterized role arguments.
 781
 782 =item B<< $metaclass->make_immutable(%options) >>
 783
 784 This overrides the parent's method to add a few options. Specifically,
 785 it uses the Moose-specific constructor and destructor classes, and
 786 enables inlining the destructor.
 787
 788 Since Moose always inlines attributes, it sets the C<inline_accessors> option
 789 to false.
 790
 791 =item B<< $metaclass->new_object(%params) >>
 792
 793 This overrides the parent's method in order to add support for
 794 attribute triggers.
 795
 796 =item B<< $metaclass->superclasses(@superclasses) >>
 797
 798 This is the accessor allowing you to read or change the parents of
 799 the class.
 800
 801 Each superclass can be followed by a hash reference containing a
 802 L<-version|Class::MOP/Class Loading Options> value. If the version
 803 requirement is not satisfied an error will be thrown.
 804
 805 =item B<< $metaclass->add_override_method_modifier($name, $sub) >>
 806
 807 This adds an C<override> method modifier to the package.
 808
 809 =item B<< $metaclass->add_augment_method_modifier($name, $sub) >>
 810
 811 This adds an C<augment> method modifier to the package.
 812
 813 =item B<< $metaclass->calculate_all_roles >>
 814
 815 This will return a unique array of C<Moose::Meta::Role> instances
 816 which are attached to this class.
 817
 818 =item B<< $metaclass->calculate_all_roles_with_inheritance >>
 819
 820 This will return a unique array of C<Moose::Meta::Role> instances
 821 which are attached to this class, and each of this class's ancestors.
 822
 823 =item B<< $metaclass->add_role($role) >>
 824
 825 This takes a L<Moose::Meta::Role> object, and adds it to the class's
 826 list of roles. This I<does not> actually apply the role to the class.
 827
 828 =item B<< $metaclass->role_applications >>
 829
 830 Returns a list of L<Moose::Meta::Role::Application::ToClass>
 831 objects, which contain the arguments to role application.
 832
 833 =item B<< $metaclass->add_role_application($application) >>
 834
 835 This takes a L<Moose::Meta::Role::Application::ToClass> object, and
 836 adds it to the class's list of role applications. This I<does not>
 837 actually apply any role to the class; it is only for tracking role
 838 applications.
 839
 840 =item B<< $metaclass->does_role($role) >>
 841
 842 This returns a boolean indicating whether or not the class does the specified
 843 role. The role provided can be either a role name or a L<Moose::Meta::Role>
 844 object. This tests both the class and its parents.
 845
 846 =item B<< $metaclass->excludes_role($role_name) >>
 847
 848 A class excludes a role if it has already composed a role which
 849 excludes the named role. This tests both the class and its parents.
 850
 851 =item B<< $metaclass->add_attribute($attr_name, %params|$params) >>
 852
 853 This overrides the parent's method in order to allow the parameters to
 854 be provided as a hash reference.
 855
 856 =item B<< $metaclass->constructor_class($class_name) >>
 857
 858 =item B<< $metaclass->destructor_class($class_name) >>
 859
 860 These are the names of classes used when making a class immutable. These
 861 default to L<Moose::Meta::Method::Constructor> and
 862 L<Moose::Meta::Method::Destructor> respectively. These accessors are
 863 read-write, so you can use them to change the class name.
 864
 865 =item B<< $metaclass->error_class($class_name) >>
 866
 867 The name of the class used to throw errors. This defaults to
 868 L<Moose::Error::Default>, which generates an error with a stacktrace
 869 just like C<Carp::confess>.
 870
 871 =item B<< $metaclass->throw_error($message, %extra) >>
 872
 873 Throws the error created by C<create_error> using C<raise_error>
 874
 875 =back
 876
 877 =head1 BUGS
 878
 879 See L<Moose/BUGS> for details on reporting bugs.
 880
 881 =head1 AUTHOR
 882
 883 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 884
 885 =head1 COPYRIGHT AND LICENSE
 886
 887 Copyright 2006-2010 by Infinity Interactive, Inc.
 888
 889 L<http://www.iinteractive.com>
 890
 891 This library is free software; you can redistribute it and/or modify
 892 it under the same terms as Perl itself.
 893
 894 =cut
 895