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
 834           '$meta->create_error('
 835         . $msg
 836         . ( defined $args ? ', ' . $args : q{} ) . ');'
 837         unless $class->meta->has_method('_inline_new');
 838
 839     $class->_inline_new(
 840         # XXX ignore this for now too
 841         # Carp::caller_info($args{depth}),
 842         %args
 843     );
 844 }
 845
 846 1;
 847
 848 # ABSTRACT: The Moose metaclass
 849
 850 __END__
 851
 852 =pod
 853
 854 =head1 DESCRIPTION
 855
 856 This class is a subclass of L<Class::MOP::Class> that provides
 857 additional Moose-specific functionality.
 858
 859 To really understand this class, you will need to start with the
 860 L<Class::MOP::Class> documentation. This class can be understood as a
 861 set of additional features on top of the basic feature provided by
 862 that parent class.
 863
 864 =head1 INHERITANCE
 865
 866 C<Moose::Meta::Class> is a subclass of L<Class::MOP::Class>.
 867
 868 =head1 METHODS
 869
 870 =over 4
 871
 872 =item B<< Moose::Meta::Class->initialize($package_name, %options) >>
 873
 874 This overrides the parent's method in order to provide its own
 875 defaults for the C<attribute_metaclass>, C<instance_metaclass>, and
 876 C<method_metaclass> options.
 877
 878 These all default to the appropriate Moose class.
 879
 880 =item B<< Moose::Meta::Class->create($package_name, %options) >>
 881
 882 This overrides the parent's method in order to accept a C<roles>
 883 option. This should be an array reference containing roles
 884 that the class does, each optionally followed by a hashref of options
 885 (C<-excludes> and C<-alias>).
 886
 887   my $metaclass = Moose::Meta::Class->create( 'New::Class', roles => [...] );
 888
 889 =item B<< Moose::Meta::Class->create_anon_class >>
 890
 891 This overrides the parent's method to accept a C<roles> option, just
 892 as C<create> does.
 893
 894 It also accepts a C<cache> option. If this is true, then the anonymous
 895 class will be cached based on its superclasses and roles. If an
 896 existing anonymous class in the cache has the same superclasses and
 897 roles, it will be reused.
 898
 899   my $metaclass = Moose::Meta::Class->create_anon_class(
 900       superclasses => ['Foo'],
 901       roles        => [qw/Some Roles Go Here/],
 902       cache        => 1,
 903   );
 904
 905 Each entry in both the C<superclasses> and the C<roles> option can be
 906 followed by a hash reference with arguments. The C<superclasses>
 907 option can be supplied with a L<-version|Class::MOP/Class Loading
 908 Options> option that ensures the loaded superclass satisfies the
 909 required version. The C<role> option also takes the C<-version> as an
 910 argument, but the option hash reference can also contain any other
 911 role relevant values like exclusions or parameterized role arguments.
 912
 913 =item B<< $metaclass->make_immutable(%options) >>
 914
 915 This overrides the parent's method to add a few options. Specifically,
 916 it uses the Moose-specific constructor and destructor classes, and
 917 enables inlining the destructor.
 918
 919 Since Moose always inlines attributes, it sets the C<inline_accessors> option
 920 to false.
 921
 922 =item B<< $metaclass->new_object(%params) >>
 923
 924 This overrides the parent's method in order to add support for
 925 attribute triggers.
 926
 927 =item B<< $metaclass->superclasses(@superclasses) >>
 928
 929 This is the accessor allowing you to read or change the parents of
 930 the class.
 931
 932 Each superclass can be followed by a hash reference containing a
 933 L<-version|Class::MOP/Class Loading Options> value. If the version
 934 requirement is not satisfied an error will be thrown.
 935
 936 =item B<< $metaclass->add_override_method_modifier($name, $sub) >>
 937
 938 This adds an C<override> method modifier to the package.
 939
 940 =item B<< $metaclass->add_augment_method_modifier($name, $sub) >>
 941
 942 This adds an C<augment> method modifier to the package.
 943
 944 =item B<< $metaclass->calculate_all_roles >>
 945
 946 This will return a unique array of C<Moose::Meta::Role> instances
 947 which are attached to this class.
 948
 949 =item B<< $metaclass->calculate_all_roles_with_inheritance >>
 950
 951 This will return a unique array of C<Moose::Meta::Role> instances
 952 which are attached to this class, and each of this class's ancestors.
 953
 954 =item B<< $metaclass->add_role($role) >>
 955
 956 This takes a L<Moose::Meta::Role> object, and adds it to the class's
 957 list of roles. This I<does not> actually apply the role to the class.
 958
 959 =item B<< $metaclass->role_applications >>
 960
 961 Returns a list of L<Moose::Meta::Role::Application::ToClass>
 962 objects, which contain the arguments to role application.
 963
 964 =item B<< $metaclass->add_role_application($application) >>
 965
 966 This takes a L<Moose::Meta::Role::Application::ToClass> object, and
 967 adds it to the class's list of role applications. This I<does not>
 968 actually apply any role to the class; it is only for tracking role
 969 applications.
 970
 971 =item B<< $metaclass->does_role($role) >>
 972
 973 This returns a boolean indicating whether or not the class does the specified
 974 role. The role provided can be either a role name or a L<Moose::Meta::Role>
 975 object. This tests both the class and its parents.
 976
 977 =item B<< $metaclass->excludes_role($role_name) >>
 978
 979 A class excludes a role if it has already composed a role which
 980 excludes the named role. This tests both the class and its parents.
 981
 982 =item B<< $metaclass->add_attribute($attr_name, %params|$params) >>
 983
 984 This overrides the parent's method in order to allow the parameters to
 985 be provided as a hash reference.
 986
 987 =item B<< $metaclass->constructor_class($class_name) >>
 988
 989 =item B<< $metaclass->destructor_class($class_name) >>
 990
 991 These are the names of classes used when making a class immutable. These
 992 default to L<Moose::Meta::Method::Constructor> and
 993 L<Moose::Meta::Method::Destructor> respectively. These accessors are
 994 read-write, so you can use them to change the class name.
 995
 996 =item B<< $metaclass->error_class($class_name) >>
 997
 998 The name of the class used to throw errors. This defaults to
 999 L<Moose::Error::Default>, which generates an error with a stacktrace
1000 just like C<Carp::confess>.
1001
1002 =item B<< $metaclass->throw_error($message, %extra) >>
1003
1004 Throws the error created by C<create_error> using C<raise_error>
1005
1006 =back
1007
1008 =head1 BUGS
1009
1010 See L<Moose/BUGS> for details on reporting bugs.
1011
1012 =cut
1013