lib/Moose/Meta/Class.pm

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