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