lib/Moose/Meta/Class.pm

   1
   2 package Moose::Meta::Class;
   3
   4 use strict;
   5 use warnings;
   6
   7 use Class::MOP;
   8
   9 use Carp qw( confess );
  10 use Data::OptList;
  11 use List::Util qw( first );
  12 use List::MoreUtils qw( any all uniq first_index );
  13 use Scalar::Util '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         Class::MOP::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
 750 sub _fixup_attributes_after_rebless {
 751     my $self = shift;
 752     my ($instance, $rebless_from, %params) = @_;
 753
 754     $self->SUPER::_fixup_attributes_after_rebless($instance, $rebless_from, %params);
 755
 756     $self->call_all_triggers($instance, \%params);
 757 }
 758
 759
 760
 761 ## -------------------------------------------------
 762
 763 our $error_level;
 764
 765 sub throw_error {
 766     my ( $self, @args ) = @_;
 767     local $error_level = ($error_level || 0) + 1;
 768     $self->raise_error($self->create_error(@args));
 769 }
 770
 771 sub _inline_throw_error {
 772     my ( $self, @args ) = @_;
 773     $self->_inline_raise_error($self->_inline_create_error(@args));
 774 }
 775
 776 sub raise_error {
 777     my ( $self, @args ) = @_;
 778     die @args;
 779 }
 780
 781 sub _inline_raise_error {
 782     my ( $self, $message ) = @_;
 783
 784     return 'die ' . $message;
 785 }
 786
 787 sub create_error {
 788     my ( $self, @args ) = @_;
 789
 790     require Carp::Heavy;
 791
 792     local $error_level = ($error_level || 0 ) + 1;
 793
 794     if ( @args % 2 == 1 ) {
 795         unshift @args, "message";
 796     }
 797
 798     my %args = ( metaclass => $self, last_error => $@, @args );
 799
 800     $args{depth} += $error_level;
 801
 802     my $class = ref $self ? $self->error_class : "Moose::Error::Default";
 803
 804     Class::MOP::load_class($class);
 805
 806     $class->new(
 807         Carp::caller_info($args{depth}),
 808         %args
 809     );
 810 }
 811
 812 sub _inline_create_error {
 813     my ( $self, $msg, $args ) = @_;
 814     # XXX ignore $args for now, nothing currently uses it anyway
 815
 816     require Carp::Heavy;
 817
 818     my %args = (
 819         metaclass  => $self,
 820         last_error => $@,
 821         message    => $msg,
 822     );
 823
 824     my $class = ref $self ? $self->error_class : "Moose::Error::Default";
 825
 826     Class::MOP::load_class($class);
 827
 828     # don't check inheritance here - the intention is that the class needs
 829     # to provide a non-inherited inlining method, because falling back to
 830     # the default inlining method is most likely going to be wrong
 831     # yes, this is a huge hack, but so is the entire error system, so.
 832     return '$meta->create_error(' . $msg . ', ' . $args . ');'
 833         unless $class->meta->has_method('_inline_new');
 834
 835     $class->_inline_new(
 836         # XXX ignore this for now too
 837         # Carp::caller_info($args{depth}),
 838         %args
 839     );
 840 }
 841
 842 1;
 843
 844 # ABSTRACT: The Moose metaclass
 845
 846 __END__
 847
 848 =pod
 849
 850 =head1 DESCRIPTION
 851
 852 This class is a subclass of L<Class::MOP::Class> that provides
 853 additional Moose-specific functionality.
 854
 855 To really understand this class, you will need to start with the
 856 L<Class::MOP::Class> documentation. This class can be understood as a
 857 set of additional features on top of the basic feature provided by
 858 that parent class.
 859
 860 =head1 INHERITANCE
 861
 862 C<Moose::Meta::Class> is a subclass of L<Class::MOP::Class>.
 863
 864 =head1 METHODS
 865
 866 =over 4
 867
 868 =item B<< Moose::Meta::Class->initialize($package_name, %options) >>
 869
 870 This overrides the parent's method in order to provide its own
 871 defaults for the C<attribute_metaclass>, C<instance_metaclass>, and
 872 C<method_metaclass> options.
 873
 874 These all default to the appropriate Moose class.
 875
 876 =item B<< Moose::Meta::Class->create($package_name, %options) >>
 877
 878 This overrides the parent's method in order to accept a C<roles>
 879 option. This should be an array reference containing roles
 880 that the class does, each optionally followed by a hashref of options
 881 (C<-excludes> and C<-alias>).
 882
 883   my $metaclass = Moose::Meta::Class->create( 'New::Class', roles => [...] );
 884
 885 =item B<< Moose::Meta::Class->create_anon_class >>
 886
 887 This overrides the parent's method to accept a C<roles> option, just
 888 as C<create> does.
 889
 890 It also accepts a C<cache> option. If this is true, then the anonymous
 891 class will be cached based on its superclasses and roles. If an
 892 existing anonymous class in the cache has the same superclasses and
 893 roles, it will be reused.
 894
 895   my $metaclass = Moose::Meta::Class->create_anon_class(
 896       superclasses => ['Foo'],
 897       roles        => [qw/Some Roles Go Here/],
 898       cache        => 1,
 899   );
 900
 901 Each entry in both the C<superclasses> and the C<roles> option can be
 902 followed by a hash reference with arguments. The C<superclasses>
 903 option can be supplied with a L<-version|Class::MOP/Class Loading
 904 Options> option that ensures the loaded superclass satisfies the
 905 required version. The C<role> option also takes the C<-version> as an
 906 argument, but the option hash reference can also contain any other
 907 role relevant values like exclusions or parameterized role arguments.
 908
 909 =item B<< $metaclass->make_immutable(%options) >>
 910
 911 This overrides the parent's method to add a few options. Specifically,
 912 it uses the Moose-specific constructor and destructor classes, and
 913 enables inlining the destructor.
 914
 915 Since Moose always inlines attributes, it sets the C<inline_accessors> option
 916 to false.
 917
 918 =item B<< $metaclass->new_object(%params) >>
 919
 920 This overrides the parent's method in order to add support for
 921 attribute triggers.
 922
 923 =item B<< $metaclass->superclasses(@superclasses) >>
 924
 925 This is the accessor allowing you to read or change the parents of
 926 the class.
 927
 928 Each superclass can be followed by a hash reference containing a
 929 L<-version|Class::MOP/Class Loading Options> value. If the version
 930 requirement is not satisfied an error will be thrown.
 931
 932 =item B<< $metaclass->add_override_method_modifier($name, $sub) >>
 933
 934 This adds an C<override> method modifier to the package.
 935
 936 =item B<< $metaclass->add_augment_method_modifier($name, $sub) >>
 937
 938 This adds an C<augment> method modifier to the package.
 939
 940 =item B<< $metaclass->calculate_all_roles >>
 941
 942 This will return a unique array of C<Moose::Meta::Role> instances
 943 which are attached to this class.
 944
 945 =item B<< $metaclass->calculate_all_roles_with_inheritance >>
 946
 947 This will return a unique array of C<Moose::Meta::Role> instances
 948 which are attached to this class, and each of this class's ancestors.
 949
 950 =item B<< $metaclass->add_role($role) >>
 951
 952 This takes a L<Moose::Meta::Role> object, and adds it to the class's
 953 list of roles. This I<does not> actually apply the role to the class.
 954
 955 =item B<< $metaclass->role_applications >>
 956
 957 Returns a list of L<Moose::Meta::Role::Application::ToClass>
 958 objects, which contain the arguments to role application.
 959
 960 =item B<< $metaclass->add_role_application($application) >>
 961
 962 This takes a L<Moose::Meta::Role::Application::ToClass> object, and
 963 adds it to the class's list of role applications. This I<does not>
 964 actually apply any role to the class; it is only for tracking role
 965 applications.
 966
 967 =item B<< $metaclass->does_role($role) >>
 968
 969 This returns a boolean indicating whether or not the class does the specified
 970 role. The role provided can be either a role name or a L<Moose::Meta::Role>
 971 object. This tests both the class and its parents.
 972
 973 =item B<< $metaclass->excludes_role($role_name) >>
 974
 975 A class excludes a role if it has already composed a role which
 976 excludes the named role. This tests both the class and its parents.
 977
 978 =item B<< $metaclass->add_attribute($attr_name, %params|$params) >>
 979
 980 This overrides the parent's method in order to allow the parameters to
 981 be provided as a hash reference.
 982
 983 =item B<< $metaclass->constructor_class($class_name) >>
 984
 985 =item B<< $metaclass->destructor_class($class_name) >>
 986
 987 These are the names of classes used when making a class immutable. These
 988 default to L<Moose::Meta::Method::Constructor> and
 989 L<Moose::Meta::Method::Destructor> respectively. These accessors are
 990 read-write, so you can use them to change the class name.
 991
 992 =item B<< $metaclass->error_class($class_name) >>
 993
 994 The name of the class used to throw errors. This defaults to
 995 L<Moose::Error::Default>, which generates an error with a stacktrace
 996 just like C<Carp::confess>.
 997
 998 =item B<< $metaclass->throw_error($message, %extra) >>
 999
1000 Throws the error created by C<create_error> using C<raise_error>
1001
1002 =back
1003
1004 =head1 BUGS
1005
1006 See L<Moose/BUGS> for details on reporting bugs.
1007
1008 =cut
1009