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