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 _find_common_base {
 352     my $self = shift;
 353     my ($meta1, $meta2) = map { Class::MOP::class_of($_) } @_;
 354     return unless defined $meta1 && defined $meta2;
 355
 356     # FIXME? This doesn't account for multiple inheritance (not sure
 357     # if it needs to though). For example, if somewhere in $meta1's
 358     # history it inherits from both ClassA and ClassB, and $meta2
 359     # inherits from ClassB & ClassA, does it matter? And what crazy
 360     # fool would do that anyway?
 361
 362     my %meta1_parents = map { $_ => 1 } $meta1->linearized_isa;
 363
 364     return first { $meta1_parents{$_} } $meta2->linearized_isa;
 365 }
 366
 367 sub _get_ancestors_until {
 368     my $self = shift;
 369     my ($start_name, $until_name) = @_;
 370
 371     my @ancestor_names;
 372     for my $ancestor_name (Class::MOP::class_of($start_name)->linearized_isa) {
 373         last if $ancestor_name eq $until_name;
 374         push @ancestor_names, $ancestor_name;
 375     }
 376     return @ancestor_names;
 377 }
 378
 379 sub _is_role_only_subclass {
 380     my $self = shift;
 381     my ($meta_name) = @_;
 382     my $meta = Class::MOP::Class->initialize($meta_name);
 383     my @parent_names = $meta->superclasses;
 384
 385     # XXX: don't feel like messing with multiple inheritance here... what would
 386     # that even do?
 387     return unless @parent_names == 1;
 388     my ($parent_name) = @parent_names;
 389     my $parent_meta = Class::MOP::Class->initialize($parent_name);
 390
 391     my @roles = $meta->can('calculate_all_roles_with_inheritance')
 392                     ? $meta->calculate_all_roles_with_inheritance
 393                     : ();
 394
 395     # loop over all methods that are a part of the current class
 396     # (not inherited)
 397     for my $method ( $meta->_get_local_methods ) {
 398         # always ignore meta
 399         next if $method->name eq 'meta';
 400         # we'll deal with attributes below
 401         next if $method->can('associated_attribute');
 402         # if the method comes from a role we consumed, ignore it
 403         next if $meta->can('does_role')
 404              && $meta->does_role($method->original_package_name);
 405         # FIXME - this really isn't right. Just because a modifier is
 406         # defined in a role doesn't mean it isn't _also_ defined in the
 407         # subclass.
 408         next if $method->isa('Class::MOP::Method::Wrapped')
 409              && (
 410                  (!scalar($method->around_modifiers)
 411                || any { $_->has_around_method_modifiers($method->name) } @roles)
 412               && (!scalar($method->before_modifiers)
 413                || any { $_->has_before_method_modifiers($method->name) } @roles)
 414               && (!scalar($method->after_modifiers)
 415                || any { $_->has_after_method_modifiers($method->name) } @roles)
 416                 );
 417
 418         return 0;
 419     }
 420
 421     # loop over all attributes that are a part of the current class
 422     # (not inherited)
 423     # FIXME - this really isn't right. Just because an attribute is
 424     # defined in a role doesn't mean it isn't _also_ defined in the
 425     # subclass.
 426     for my $attr (map { $meta->get_attribute($_) } $meta->get_attribute_list) {
 427         next if any { $_->has_attribute($attr->name) } @roles;
 428
 429         return 0;
 430     }
 431
 432     return 1;
 433 }
 434
 435 sub _can_fix_class_metaclass_incompatibility_by_role_reconciliation {
 436     my $self = shift;
 437     my ($super_meta) = @_;
 438
 439     my $super_meta_name = $super_meta->_real_ref_name;
 440
 441     return $self->_classes_differ_by_roles_only(
 442         blessed($self),
 443         $super_meta_name,
 444         'Moose::Meta::Class',
 445     );
 446 }
 447
 448 sub _can_fix_single_metaclass_incompatibility_by_role_reconciliation {
 449     my $self = shift;
 450     my ($metaclass_type, $super_meta) = @_;
 451
 452     my $class_specific_meta_name = $self->$metaclass_type;
 453     return unless $super_meta->can($metaclass_type);
 454     my $super_specific_meta_name = $super_meta->$metaclass_type;
 455     my %metaclasses = $self->_base_metaclasses;
 456
 457     return $self->_classes_differ_by_roles_only(
 458         $class_specific_meta_name,
 459         $super_specific_meta_name,
 460         $metaclasses{$metaclass_type},
 461     );
 462 }
 463
 464 sub _classes_differ_by_roles_only {
 465     my $self = shift;
 466     my ( $self_meta_name, $super_meta_name, $expected_ancestor ) = @_;
 467
 468     my $common_base_name
 469         = $self->_find_common_base( $self_meta_name, $super_meta_name );
 470
 471     # If they're not both moose metaclasses, and the cmop fixing couldn't do
 472     # anything, there's nothing more we can do. The $expected_ancestor should
 473     # always be a Moose metaclass name like Moose::Meta::Class or
 474     # Moose::Meta::Attribute.
 475     return unless defined $common_base_name;
 476     return unless $common_base_name->isa($expected_ancestor);
 477
 478     my @super_meta_name_ancestor_names
 479         = $self->_get_ancestors_until( $super_meta_name, $common_base_name );
 480     my @class_meta_name_ancestor_names
 481         = $self->_get_ancestors_until( $self_meta_name, $common_base_name );
 482
 483     return
 484         unless all { $self->_is_role_only_subclass($_) }
 485         @super_meta_name_ancestor_names,
 486         @class_meta_name_ancestor_names;
 487
 488     return 1;
 489 }
 490
 491 sub _role_differences {
 492     my $self = shift;
 493     my ($class_meta_name, $super_meta_name) = @_;
 494     my @super_role_metas = $super_meta_name->meta->can('calculate_all_roles_with_inheritance')
 495                          ? $super_meta_name->meta->calculate_all_roles_with_inheritance
 496                          : ();
 497     my @role_metas       = $class_meta_name->meta->can('calculate_all_roles_with_inheritance')
 498                          ? $class_meta_name->meta->calculate_all_roles_with_inheritance
 499                          : ();
 500     my @differences;
 501     for my $role_meta (@role_metas) {
 502         push @differences, $role_meta
 503             unless any { $_->name eq $role_meta->name } @super_role_metas;
 504     }
 505     return @differences;
 506 }
 507
 508 sub _reconcile_roles_for_metaclass {
 509     my $self = shift;
 510     my ($class_meta_name, $super_meta_name) = @_;
 511
 512     my @role_differences = $self->_role_differences(
 513         $class_meta_name, $super_meta_name,
 514     );
 515
 516     # handle the case where we need to fix compatibility between a class and
 517     # its parent, but all roles in the class are already also done by the
 518     # parent
 519     # see t/050/054.t
 520     return Class::MOP::class_of($super_meta_name)
 521         unless @role_differences;
 522
 523     return Moose::Meta::Class->create_anon_class(
 524         superclasses => [$super_meta_name],
 525         roles        => [map { $_->name } @role_differences],
 526         cache        => 1,
 527     );
 528 }
 529
 530 sub _can_fix_metaclass_incompatibility_by_role_reconciliation {
 531     my $self = shift;
 532     my ($super_meta) = @_;
 533
 534     return 1 if $self->_can_fix_class_metaclass_incompatibility_by_role_reconciliation($super_meta);
 535
 536     my %base_metaclass = $self->_base_metaclasses;
 537     for my $metaclass_type (keys %base_metaclass) {
 538         next unless defined $self->$metaclass_type;
 539         return 1 if $self->_can_fix_single_metaclass_incompatibility_by_role_reconciliation($metaclass_type, $super_meta);
 540     }
 541
 542     return;
 543 }
 544
 545 sub _can_fix_metaclass_incompatibility {
 546     my $self = shift;
 547     return 1 if $self->_can_fix_metaclass_incompatibility_by_role_reconciliation(@_);
 548     return $self->SUPER::_can_fix_metaclass_incompatibility(@_);
 549 }
 550
 551 sub _fix_class_metaclass_incompatibility {
 552     my $self = shift;
 553     my ($super_meta) = @_;
 554
 555     $self->SUPER::_fix_class_metaclass_incompatibility(@_);
 556
 557     if ($self->_can_fix_class_metaclass_incompatibility_by_role_reconciliation($super_meta)) {
 558         ($self->is_pristine)
 559             || confess "Can't fix metaclass incompatibility for "
 560                      . $self->name
 561                      . " because it is not pristine.";
 562         my $super_meta_name = $super_meta->_real_ref_name;
 563         my $class_meta_subclass_meta = $self->_reconcile_roles_for_metaclass(blessed($self), $super_meta_name);
 564         my $new_self = $class_meta_subclass_meta->name->reinitialize(
 565             $self->name,
 566         );
 567
 568         $self->_replace_self( $new_self, $class_meta_subclass_meta->name );
 569     }
 570 }
 571
 572 sub _fix_single_metaclass_incompatibility {
 573     my $self = shift;
 574     my ($metaclass_type, $super_meta) = @_;
 575
 576     $self->SUPER::_fix_single_metaclass_incompatibility(@_);
 577
 578     if ($self->_can_fix_single_metaclass_incompatibility_by_role_reconciliation($metaclass_type, $super_meta)) {
 579         ($self->is_pristine)
 580             || confess "Can't fix metaclass incompatibility for "
 581                      . $self->name
 582                      . " because it is not pristine.";
 583         my $super_meta_name = $super_meta->_real_ref_name;
 584         my $class_specific_meta_subclass_meta = $self->_reconcile_roles_for_metaclass($self->$metaclass_type, $super_meta->$metaclass_type);
 585         my $new_self = $super_meta->reinitialize(
 586             $self->name,
 587             $metaclass_type => $class_specific_meta_subclass_meta->name,
 588         );
 589
 590         $self->_replace_self( $new_self, $super_meta_name );
 591     }
 592 }
 593
 594
 595 sub _replace_self {
 596     my $self      = shift;
 597     my ( $new_self, $new_class)   = @_;
 598
 599     %$self = %$new_self;
 600     bless $self, $new_class;
 601
 602     # We need to replace the cached metaclass instance or else when it goes
 603     # out of scope Class::MOP::Class destroy's the namespace for the
 604     # metaclass's class, causing much havoc.
 605     Class::MOP::store_metaclass_by_name( $self->name, $self );
 606     Class::MOP::weaken_metaclass( $self->name ) if $self->is_anon_class;
 607 }
 608
 609 sub _get_compatible_single_metaclass_by_role_reconciliation {
 610     my $self = shift;
 611     my ($single_meta_name) = @_;
 612
 613     my $current_single_meta_name = $self->_get_associated_single_metaclass($single_meta_name);
 614
 615     return $self->_reconcile_roles_for_metaclass($single_meta_name, $current_single_meta_name)->name;
 616 }
 617
 618 sub _get_compatible_single_metaclass {
 619     my $self = shift;
 620
 621     return $self->SUPER::_get_compatible_single_metaclass(@_)
 622         || $self->_get_compatible_single_metaclass_by_role_reconciliation(@_);
 623 }
 624
 625 sub _process_attribute {
 626     my ( $self, $name, @args ) = @_;
 627
 628     @args = %{$args[0]} if scalar @args == 1 && ref($args[0]) eq 'HASH';
 629
 630     if (($name || '') =~ /^\+(.*)/) {
 631         return $self->_process_inherited_attribute($1, @args);
 632     }
 633     else {
 634         return $self->_process_new_attribute($name, @args);
 635     }
 636 }
 637
 638 sub _process_new_attribute {
 639     my ( $self, $name, @args ) = @_;
 640
 641     $self->attribute_metaclass->interpolate_class_and_new($name, @args);
 642 }
 643
 644 sub _process_inherited_attribute {
 645     my ($self, $attr_name, %options) = @_;
 646     my $inherited_attr = $self->find_attribute_by_name($attr_name);
 647     (defined $inherited_attr)
 648         || $self->throw_error("Could not find an attribute by the name of '$attr_name' to inherit from in ${\$self->name}", data => $attr_name);
 649     if ($inherited_attr->isa('Moose::Meta::Attribute')) {
 650         return $inherited_attr->clone_and_inherit_options(%options);
 651     }
 652     else {
 653         # NOTE:
 654         # kind of a kludge to handle Class::MOP::Attributes
 655         return $inherited_attr->Moose::Meta::Attribute::clone_and_inherit_options(%options);
 656     }
 657 }
 658
 659 ## Immutability
 660
 661 sub _immutable_options {
 662     my ( $self, @args ) = @_;
 663
 664     $self->SUPER::_immutable_options(
 665         inline_destructor => 1,
 666
 667         # Moose always does this when an attribute is created
 668         inline_accessors => 0,
 669
 670         @args,
 671     );
 672 }
 673
 674 ## -------------------------------------------------
 675
 676 our $error_level;
 677
 678 sub throw_error {
 679     my ( $self, @args ) = @_;
 680     local $error_level = ($error_level || 0) + 1;
 681     $self->raise_error($self->create_error(@args));
 682 }
 683
 684 sub raise_error {
 685     my ( $self, @args ) = @_;
 686     die @args;
 687 }
 688
 689 sub create_error {
 690     my ( $self, @args ) = @_;
 691
 692     require Carp::Heavy;
 693
 694     local $error_level = ($error_level || 0 ) + 1;
 695
 696     if ( @args % 2 == 1 ) {
 697         unshift @args, "message";
 698     }
 699
 700     my %args = ( metaclass => $self, last_error => $@, @args );
 701
 702     $args{depth} += $error_level;
 703
 704     my $class = ref $self ? $self->error_class : "Moose::Error::Default";
 705
 706     Class::MOP::load_class($class);
 707
 708     $class->new(
 709         Carp::caller_info($args{depth}),
 710         %args
 711     );
 712 }
 713
 714 1;
 715
 716 __END__
 717
 718 =pod
 719
 720 =head1 NAME
 721
 722 Moose::Meta::Class - The Moose metaclass
 723
 724 =head1 DESCRIPTION
 725
 726 This class is a subclass of L<Class::MOP::Class> that provides
 727 additional Moose-specific functionality.
 728
 729 To really understand this class, you will need to start with the
 730 L<Class::MOP::Class> documentation. This class can be understood as a
 731 set of additional features on top of the basic feature provided by
 732 that parent class.
 733
 734 =head1 INHERITANCE
 735
 736 C<Moose::Meta::Class> is a subclass of L<Class::MOP::Class>.
 737
 738 =head1 METHODS
 739
 740 =over 4
 741
 742 =item B<< Moose::Meta::Class->initialize($package_name, %options) >>
 743
 744 This overrides the parent's method in order to provide its own
 745 defaults for the C<attribute_metaclass>, C<instance_metaclass>, and
 746 C<method_metaclass> options.
 747
 748 These all default to the appropriate Moose class.
 749
 750 =item B<< Moose::Meta::Class->create($package_name, %options) >>
 751
 752 This overrides the parent's method in order to accept a C<roles>
 753 option. This should be an array reference containing roles
 754 that the class does, each optionally followed by a hashref of options
 755 (C<-excludes> and C<-alias>).
 756
 757   my $metaclass = Moose::Meta::Class->create( 'New::Class', roles => [...] );
 758
 759 =item B<< Moose::Meta::Class->create_anon_class >>
 760
 761 This overrides the parent's method to accept a C<roles> option, just
 762 as C<create> does.
 763
 764 It also accepts a C<cache> option. If this is true, then the anonymous
 765 class will be cached based on its superclasses and roles. If an
 766 existing anonymous class in the cache has the same superclasses and
 767 roles, it will be reused.
 768
 769   my $metaclass = Moose::Meta::Class->create_anon_class(
 770       superclasses => ['Foo'],
 771       roles        => [qw/Some Roles Go Here/],
 772       cache        => 1,
 773   );
 774
 775 Each entry in both the C<superclasses> and the C<roles> option can be
 776 followed by a hash reference with arguments. The C<superclasses>
 777 option can be supplied with a L<-version|Class::MOP/Class Loading
 778 Options> option that ensures the loaded superclass satisfies the
 779 required version. The C<role> option also takes the C<-version> as an
 780 argument, but the option hash reference can also contain any other
 781 role relevant values like exclusions or parameterized role arguments.
 782
 783 =item B<< $metaclass->make_immutable(%options) >>
 784
 785 This overrides the parent's method to add a few options. Specifically,
 786 it uses the Moose-specific constructor and destructor classes, and
 787 enables inlining the destructor.
 788
 789 Since Moose always inlines attributes, it sets the C<inline_accessors> option
 790 to false.
 791
 792 =item B<< $metaclass->new_object(%params) >>
 793
 794 This overrides the parent's method in order to add support for
 795 attribute triggers.
 796
 797 =item B<< $metaclass->superclasses(@superclasses) >>
 798
 799 This is the accessor allowing you to read or change the parents of
 800 the class.
 801
 802 Each superclass can be followed by a hash reference containing a
 803 L<-version|Class::MOP/Class Loading Options> value. If the version
 804 requirement is not satisfied an error will be thrown.
 805
 806 =item B<< $metaclass->add_override_method_modifier($name, $sub) >>
 807
 808 This adds an C<override> method modifier to the package.
 809
 810 =item B<< $metaclass->add_augment_method_modifier($name, $sub) >>
 811
 812 This adds an C<augment> method modifier to the package.
 813
 814 =item B<< $metaclass->calculate_all_roles >>
 815
 816 This will return a unique array of C<Moose::Meta::Role> instances
 817 which are attached to this class.
 818
 819 =item B<< $metaclass->calculate_all_roles_with_inheritance >>
 820
 821 This will return a unique array of C<Moose::Meta::Role> instances
 822 which are attached to this class, and each of this class's ancestors.
 823
 824 =item B<< $metaclass->add_role($role) >>
 825
 826 This takes a L<Moose::Meta::Role> object, and adds it to the class's
 827 list of roles. This I<does not> actually apply the role to the class.
 828
 829 =item B<< $metaclass->role_applications >>
 830
 831 Returns a list of L<Moose::Meta::Role::Application::ToClass>
 832 objects, which contain the arguments to role application.
 833
 834 =item B<< $metaclass->add_role_application($application) >>
 835
 836 This takes a L<Moose::Meta::Role::Application::ToClass> object, and
 837 adds it to the class's list of role applications. This I<does not>
 838 actually apply any role to the class; it is only for tracking role
 839 applications.
 840
 841 =item B<< $metaclass->does_role($role) >>
 842
 843 This returns a boolean indicating whether or not the class does the specified
 844 role. The role provided can be either a role name or a L<Moose::Meta::Role>
 845 object. This tests both the class and its parents.
 846
 847 =item B<< $metaclass->excludes_role($role_name) >>
 848
 849 A class excludes a role if it has already composed a role which
 850 excludes the named role. This tests both the class and its parents.
 851
 852 =item B<< $metaclass->add_attribute($attr_name, %params|$params) >>
 853
 854 This overrides the parent's method in order to allow the parameters to
 855 be provided as a hash reference.
 856
 857 =item B<< $metaclass->constructor_class($class_name) >>
 858
 859 =item B<< $metaclass->destructor_class($class_name) >>
 860
 861 These are the names of classes used when making a class immutable. These
 862 default to L<Moose::Meta::Method::Constructor> and
 863 L<Moose::Meta::Method::Destructor> respectively. These accessors are
 864 read-write, so you can use them to change the class name.
 865
 866 =item B<< $metaclass->error_class($class_name) >>
 867
 868 The name of the class used to throw errors. This defaults to
 869 L<Moose::Error::Default>, which generates an error with a stacktrace
 870 just like C<Carp::confess>.
 871
 872 =item B<< $metaclass->throw_error($message, %extra) >>
 873
 874 Throws the error created by C<create_error> using C<raise_error>
 875
 876 =back
 877
 878 =head1 BUGS
 879
 880 See L<Moose/BUGS> for details on reporting bugs.
 881
 882 =head1 AUTHOR
 883
 884 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 885
 886 =head1 COPYRIGHT AND LICENSE
 887
 888 Copyright 2006-2010 by Infinity Interactive, Inc.
 889
 890 L<http://www.iinteractive.com>
 891
 892 This library is free software; you can redistribute it and/or modify
 893 it under the same terms as Perl itself.
 894
 895 =cut
 896