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