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