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 'weaken', 'blessed';
  14
  15 our $VERSION   = '1.12';
  16 $VERSION = eval $VERSION;
  17 our $AUTHORITY = 'cpan:STEVAN';
  18
  19 use Moose::Meta::Method::Overridden;
  20 use Moose::Meta::Method::Augmented;
  21 use Moose::Error::Default;
  22 use Moose::Meta::Class::Immutable::Trait;
  23 use Moose::Meta::Method::Constructor;
  24 use Moose::Meta::Method::Destructor;
  25 use Moose::Meta::Method::Does;
  26
  27 use base 'Class::MOP::Class';
  28
  29 __PACKAGE__->meta->add_attribute('roles' => (
  30     reader  => 'roles',
  31     default => sub { [] }
  32 ));
  33
  34 __PACKAGE__->meta->add_attribute('role_applications' => (
  35     reader  => '_get_role_applications',
  36     default => sub { [] }
  37 ));
  38
  39 __PACKAGE__->meta->add_attribute(
  40     Class::MOP::Attribute->new('immutable_trait' => (
  41         accessor => "immutable_trait",
  42         default  => 'Moose::Meta::Class::Immutable::Trait',
  43     ))
  44 );
  45
  46 __PACKAGE__->meta->add_attribute('constructor_class' => (
  47     accessor => 'constructor_class',
  48     default  => 'Moose::Meta::Method::Constructor',
  49 ));
  50
  51 __PACKAGE__->meta->add_attribute('destructor_class' => (
  52     accessor => 'destructor_class',
  53     default  => 'Moose::Meta::Method::Destructor',
  54 ));
  55
  56 __PACKAGE__->meta->add_attribute('does_class' => (
  57     accessor => 'does_class',
  58     default  => 'Moose::Meta::Method::Does',
  59 ));
  60
  61 __PACKAGE__->meta->add_attribute('error_class' => (
  62     accessor => 'error_class',
  63     default  => 'Moose::Error::Default',
  64 ));
  65
  66 sub initialize {
  67     my $class = shift;
  68     my $pkg   = shift;
  69     return Class::MOP::get_metaclass_by_name($pkg)
  70         || $class->SUPER::initialize($pkg,
  71                 'attribute_metaclass' => 'Moose::Meta::Attribute',
  72                 'method_metaclass'    => 'Moose::Meta::Method',
  73                 'instance_metaclass'  => 'Moose::Meta::Instance',
  74                 @_
  75             );
  76 }
  77
  78 sub create {
  79     my ($class, $package_name, %options) = @_;
  80
  81     (ref $options{roles} eq 'ARRAY')
  82         || $class->throw_error("You must pass an ARRAY ref of roles", data => $options{roles})
  83             if exists $options{roles};
  84     my $roles = delete $options{roles};
  85
  86     my $new_meta = $class->SUPER::create($package_name, %options);
  87
  88     if ($roles) {
  89         Moose::Util::apply_all_roles( $new_meta, @$roles );
  90     }
  91
  92     return $new_meta;
  93 }
  94
  95 my %ANON_CLASSES;
  96
  97 sub create_anon_class {
  98     my ($self, %options) = @_;
  99
 100     my $cache_ok = delete $options{cache};
 101
 102     my $cache_key
 103         = _anon_cache_key( $options{superclasses}, $options{roles} );
 104
 105     if ($cache_ok && defined $ANON_CLASSES{$cache_key}) {
 106         return $ANON_CLASSES{$cache_key};
 107     }
 108
 109     my $new_class = $self->SUPER::create_anon_class(%options);
 110
 111     $ANON_CLASSES{$cache_key} = $new_class
 112         if $cache_ok;
 113
 114     return $new_class;
 115 }
 116
 117 sub _anon_cache_key {
 118     # Makes something like Super::Class|Super::Class::2=Role|Role::1
 119     return join '=' => (
 120         join( '|', @{ $_[0]      || [] } ),
 121         join( '|', sort @{ $_[1] || [] } ),
 122     );
 123 }
 124
 125 sub reinitialize {
 126     my $self = shift;
 127     my $pkg  = shift;
 128
 129     my $meta = blessed $pkg ? $pkg : Class::MOP::class_of($pkg);
 130
 131     my $cache_key;
 132
 133     my %existing_classes;
 134     if ($meta) {
 135         %existing_classes = map { $_ => $meta->$_() } qw(
 136             attribute_metaclass
 137             method_metaclass
 138             wrapped_method_metaclass
 139             instance_metaclass
 140             constructor_class
 141             destructor_class
 142             does_class
 143             error_class
 144         );
 145
 146         $cache_key = _anon_cache_key(
 147             [ $meta->superclasses ],
 148             [ map { $_->name } @{ $meta->roles } ],
 149         ) if $meta->is_anon_class;
 150     }
 151
 152     my $new_meta = $self->SUPER::reinitialize(
 153         $pkg,
 154         %existing_classes,
 155         @_,
 156     );
 157
 158     return $new_meta unless defined $cache_key;
 159
 160     my $new_cache_key = _anon_cache_key(
 161         [ $meta->superclasses ],
 162         [ map { $_->name } @{ $meta->roles } ],
 163     );
 164
 165     delete $ANON_CLASSES{$cache_key};
 166     $ANON_CLASSES{$new_cache_key} = $new_meta;
 167
 168     return $new_meta;
 169 }
 170
 171 sub add_role {
 172     my ($self, $role) = @_;
 173     (blessed($role) && $role->isa('Moose::Meta::Role'))
 174         || $self->throw_error("Roles must be instances of Moose::Meta::Role", data => $role);
 175     push @{$self->roles} => $role;
 176 }
 177
 178 sub role_applications {
 179     my ($self) = @_;
 180
 181     return @{$self->_get_role_applications};
 182 }
 183
 184 sub add_role_application {
 185     my ($self, $application) = @_;
 186     (blessed($application) && $application->isa('Moose::Meta::Role::Application::ToClass'))
 187         || $self->throw_error("Role applications must be instances of Moose::Meta::Role::Application::ToClass", data => $application);
 188     push @{$self->_get_role_applications} => $application;
 189 }
 190
 191 sub calculate_all_roles {
 192     my $self = shift;
 193     my %seen;
 194     grep { !$seen{$_->name}++ } map { $_->calculate_all_roles } @{ $self->roles };
 195 }
 196
 197 sub calculate_all_roles_with_inheritance {
 198     my $self = shift;
 199     my %seen;
 200     grep { !$seen{$_->name}++ }
 201          map { Class::MOP::class_of($_)->can('calculate_all_roles')
 202                    ? Class::MOP::class_of($_)->calculate_all_roles
 203                    : () }
 204              $self->linearized_isa;
 205 }
 206
 207 sub does_role {
 208     my ($self, $role_name) = @_;
 209
 210     (defined $role_name)
 211         || $self->throw_error("You must supply a role name to look for");
 212
 213     foreach my $class ($self->class_precedence_list) {
 214         my $meta = Class::MOP::class_of($class);
 215         # when a Moose metaclass is itself extended with a role,
 216         # this check needs to be done since some items in the
 217         # class_precedence_list might in fact be Class::MOP
 218         # based still.
 219         next unless $meta && $meta->can('roles');
 220         foreach my $role (@{$meta->roles}) {
 221             return 1 if $role->does_role($role_name);
 222         }
 223     }
 224     return 0;
 225 }
 226
 227 sub excludes_role {
 228     my ($self, $role_name) = @_;
 229
 230     (defined $role_name)
 231         || $self->throw_error("You must supply a role name to look for");
 232
 233     foreach my $class ($self->class_precedence_list) {
 234         my $meta = Class::MOP::class_of($class);
 235         # when a Moose metaclass is itself extended with a role,
 236         # this check needs to be done since some items in the
 237         # class_precedence_list might in fact be Class::MOP
 238         # based still.
 239         next unless $meta && $meta->can('roles');
 240         foreach my $role (@{$meta->roles}) {
 241             return 1 if $role->excludes_role($role_name);
 242         }
 243     }
 244     return 0;
 245 }
 246
 247 sub new_object {
 248     my $self   = shift;
 249     my $params = @_ == 1 ? $_[0] : {@_};
 250     my $object = $self->SUPER::new_object($params);
 251
 252     foreach my $attr ( $self->get_all_attributes() ) {
 253
 254         next unless $attr->can('has_trigger') && $attr->has_trigger;
 255
 256         my $init_arg = $attr->init_arg;
 257
 258         next unless defined $init_arg;
 259
 260         next unless exists $params->{$init_arg};
 261
 262         $attr->trigger->(
 263             $object,
 264             (
 265                   $attr->should_coerce
 266                 ? $attr->get_read_method_ref->($object)
 267                 : $params->{$init_arg}
 268             ),
 269         );
 270     }
 271
 272     $object->BUILDALL($params) if $object->can('BUILDALL');
 273
 274     return $object;
 275 }
 276
 277 sub superclasses {
 278     my $self = shift;
 279     my $supers = Data::OptList::mkopt(\@_);
 280     foreach my $super (@{ $supers }) {
 281         my ($name, $opts) = @{ $super };
 282         Class::MOP::load_class($name, $opts);
 283         my $meta = Class::MOP::class_of($name);
 284         $self->throw_error("You cannot inherit from a Moose Role ($name)")
 285             if $meta && $meta->isa('Moose::Meta::Role')
 286     }
 287     return $self->SUPER::superclasses(map { $_->[0] } @{ $supers });
 288 }
 289
 290 ### ---------------------------------------------
 291
 292 sub add_attribute {
 293     my $self = shift;
 294     my $attr =
 295         (blessed $_[0] && $_[0]->isa('Class::MOP::Attribute')
 296             ? $_[0]
 297             : $self->_process_attribute(@_));
 298     $self->SUPER::add_attribute($attr);
 299     # it may be a Class::MOP::Attribute, theoretically, which doesn't have
 300     # 'bare' and doesn't implement this method
 301     if ($attr->can('_check_associated_methods')) {
 302         $attr->_check_associated_methods;
 303     }
 304     return $attr;
 305 }
 306
 307 sub add_override_method_modifier {
 308     my ($self, $name, $method, $_super_package) = @_;
 309
 310     (!$self->has_method($name))
 311         || $self->throw_error("Cannot add an override method if a local method is already present");
 312
 313     $self->add_method($name => Moose::Meta::Method::Overridden->new(
 314         method  => $method,
 315         class   => $self,
 316         package => $_super_package, # need this for roles
 317         name    => $name,
 318     ));
 319 }
 320
 321 sub add_augment_method_modifier {
 322     my ($self, $name, $method) = @_;
 323     (!$self->has_method($name))
 324         || $self->throw_error("Cannot add an augment method if a local method is already present");
 325
 326     $self->add_method($name => Moose::Meta::Method::Augmented->new(
 327         method  => $method,
 328         class   => $self,
 329         name    => $name,
 330     ));
 331 }
 332
 333 ## Private Utility methods ...
 334
 335 sub _find_next_method_by_name_which_is_not_overridden {
 336     my ($self, $name) = @_;
 337     foreach my $method ($self->find_all_methods_by_name($name)) {
 338         return $method->{code}
 339             if blessed($method->{code}) && !$method->{code}->isa('Moose::Meta::Method::Overridden');
 340     }
 341     return undef;
 342 }
 343
 344 ## Metaclass compatibility
 345
 346 sub _base_metaclasses {
 347     my $self = shift;
 348     my %metaclasses = $self->SUPER::_base_metaclasses;
 349     for my $class (keys %metaclasses) {
 350         $metaclasses{$class} =~ s/^Class::MOP/Moose::Meta/;
 351     }
 352     return (
 353         %metaclasses,
 354         error_class => 'Moose::Error::Default',
 355     );
 356 }
 357
 358 sub _find_common_base {
 359     my $self = shift;
 360     my ($meta1, $meta2) = map { Class::MOP::class_of($_) } @_;
 361     return unless defined $meta1 && defined $meta2;
 362
 363     # FIXME? This doesn't account for multiple inheritance (not sure
 364     # if it needs to though). For example, if somewhere in $meta1's
 365     # history it inherits from both ClassA and ClassB, and $meta2
 366     # inherits from ClassB & ClassA, does it matter? And what crazy
 367     # fool would do that anyway?
 368
 369     my %meta1_parents = map { $_ => 1 } $meta1->linearized_isa;
 370
 371     return first { $meta1_parents{$_} } $meta2->linearized_isa;
 372 }
 373
 374 sub _get_ancestors_until {
 375     my $self = shift;
 376     my ($start_name, $until_name) = @_;
 377
 378     my @ancestor_names;
 379     for my $ancestor_name (Class::MOP::class_of($start_name)->linearized_isa) {
 380         last if $ancestor_name eq $until_name;
 381         push @ancestor_names, $ancestor_name;
 382     }
 383     return @ancestor_names;
 384 }
 385
 386 sub _is_role_only_subclass {
 387     my $self = shift;
 388     my ($meta_name) = @_;
 389     my $meta = Class::MOP::Class->initialize($meta_name);
 390     my @parent_names = $meta->superclasses;
 391
 392     # XXX: don't feel like messing with multiple inheritance here... what would
 393     # that even do?
 394     return unless @parent_names == 1;
 395     my ($parent_name) = @parent_names;
 396     my $parent_meta = Class::MOP::Class->initialize($parent_name);
 397
 398     my @roles = $meta->can('calculate_all_roles_with_inheritance')
 399                     ? $meta->calculate_all_roles_with_inheritance
 400                     : ();
 401
 402     # loop over all methods that are a part of the current class
 403     # (not inherited)
 404     for my $method ( $meta->_get_local_methods ) {
 405         # always ignore meta
 406         next if $method->name eq 'meta';
 407         # we'll deal with attributes below
 408         next if $method->can('associated_attribute');
 409         # if the method comes from a role we consumed, ignore it
 410         next if $meta->can('does_role')
 411              && $meta->does_role($method->original_package_name);
 412         # FIXME - this really isn't right. Just because a modifier is
 413         # defined in a role doesn't mean it isn't _also_ defined in the
 414         # subclass.
 415         next if $method->isa('Class::MOP::Method::Wrapped')
 416              && (
 417                  (!scalar($method->around_modifiers)
 418                || any { $_->has_around_method_modifiers($method->name) } @roles)
 419               && (!scalar($method->before_modifiers)
 420                || any { $_->has_before_method_modifiers($method->name) } @roles)
 421               && (!scalar($method->after_modifiers)
 422                || any { $_->has_after_method_modifiers($method->name) } @roles)
 423                 );
 424
 425         return 0;
 426     }
 427
 428     # loop over all attributes that are a part of the current class
 429     # (not inherited)
 430     # FIXME - this really isn't right. Just because an attribute is
 431     # defined in a role doesn't mean it isn't _also_ defined in the
 432     # subclass.
 433     for my $attr (map { $meta->get_attribute($_) } $meta->get_attribute_list) {
 434         next if any { $_->has_attribute($attr->name) } @roles;
 435
 436         return 0;
 437     }
 438
 439     return 1;
 440 }
 441
 442 sub _can_fix_class_metaclass_incompatibility_by_role_reconciliation {
 443     my $self = shift;
 444     my ($super_meta) = @_;
 445
 446     my $super_meta_name = $super_meta->_real_ref_name;
 447
 448     return $self->_classes_differ_by_roles_only(
 449         blessed($self),
 450         $super_meta_name,
 451         'Moose::Meta::Class',
 452     );
 453 }
 454
 455 sub _can_fix_single_metaclass_incompatibility_by_role_reconciliation {
 456     my $self = shift;
 457     my ($metaclass_type, $super_meta) = @_;
 458
 459     my $class_specific_meta_name = $self->$metaclass_type;
 460     return unless $super_meta->can($metaclass_type);
 461     my $super_specific_meta_name = $super_meta->$metaclass_type;
 462     my %metaclasses = $self->_base_metaclasses;
 463
 464     return $self->_classes_differ_by_roles_only(
 465         $class_specific_meta_name,
 466         $super_specific_meta_name,
 467         $metaclasses{$metaclass_type},
 468     );
 469 }
 470
 471 sub _classes_differ_by_roles_only {
 472     my $self = shift;
 473     my ( $self_meta_name, $super_meta_name, $expected_ancestor ) = @_;
 474
 475     my $common_base_name
 476         = $self->_find_common_base( $self_meta_name, $super_meta_name );
 477
 478     # If they're not both moose metaclasses, and the cmop fixing couldn't do
 479     # anything, there's nothing more we can do. The $expected_ancestor should
 480     # always be a Moose metaclass name like Moose::Meta::Class or
 481     # Moose::Meta::Attribute.
 482     return unless defined $common_base_name;
 483     return unless $common_base_name->isa($expected_ancestor);
 484
 485     my @super_meta_name_ancestor_names
 486         = $self->_get_ancestors_until( $super_meta_name, $common_base_name );
 487     my @class_meta_name_ancestor_names
 488         = $self->_get_ancestors_until( $self_meta_name, $common_base_name );
 489
 490     return
 491         unless all { $self->_is_role_only_subclass($_) }
 492         @super_meta_name_ancestor_names,
 493         @class_meta_name_ancestor_names;
 494
 495     return 1;
 496 }
 497
 498 sub _role_differences {
 499     my $self = shift;
 500     my ($class_meta_name, $super_meta_name) = @_;
 501     my @super_role_metas = $super_meta_name->meta->can('calculate_all_roles_with_inheritance')
 502                          ? $super_meta_name->meta->calculate_all_roles_with_inheritance
 503                          : ();
 504     my @role_metas       = $class_meta_name->meta->can('calculate_all_roles_with_inheritance')
 505                          ? $class_meta_name->meta->calculate_all_roles_with_inheritance
 506                          : ();
 507     my @differences;
 508     for my $role_meta (@role_metas) {
 509         push @differences, $role_meta
 510             unless any { $_->name eq $role_meta->name } @super_role_metas;
 511     }
 512     return @differences;
 513 }
 514
 515 sub _reconcile_roles_for_metaclass {
 516     my $self = shift;
 517     my ($class_meta_name, $super_meta_name) = @_;
 518
 519     my @role_differences = $self->_role_differences(
 520         $class_meta_name, $super_meta_name,
 521     );
 522
 523     # handle the case where we need to fix compatibility between a class and
 524     # its parent, but all roles in the class are already also done by the
 525     # parent
 526     # see t/050/054.t
 527     return Class::MOP::class_of($super_meta_name)
 528         unless @role_differences;
 529
 530     return Moose::Meta::Class->create_anon_class(
 531         superclasses => [$super_meta_name],
 532         roles        => \@role_differences,
 533         cache        => 1,
 534     );
 535 }
 536
 537 sub _can_fix_metaclass_incompatibility_by_role_reconciliation {
 538     my $self = shift;
 539     my ($super_meta) = @_;
 540
 541     return 1 if $self->_can_fix_class_metaclass_incompatibility_by_role_reconciliation($super_meta);
 542
 543     my %base_metaclass = $self->_base_metaclasses;
 544     for my $metaclass_type (keys %base_metaclass) {
 545         next unless defined $self->$metaclass_type;
 546         return 1 if $self->_can_fix_single_metaclass_incompatibility_by_role_reconciliation($metaclass_type, $super_meta);
 547     }
 548
 549     return;
 550 }
 551
 552 sub _can_fix_metaclass_incompatibility {
 553     my $self = shift;
 554     return 1 if $self->_can_fix_metaclass_incompatibility_by_role_reconciliation(@_);
 555     return $self->SUPER::_can_fix_metaclass_incompatibility(@_);
 556 }
 557
 558 sub _fix_class_metaclass_incompatibility {
 559     my $self = shift;
 560     my ($super_meta) = @_;
 561
 562     $self->SUPER::_fix_class_metaclass_incompatibility(@_);
 563
 564     if ($self->_can_fix_class_metaclass_incompatibility_by_role_reconciliation($super_meta)) {
 565         ($self->is_pristine)
 566             || confess "Can't fix metaclass incompatibility for "
 567                      . $self->name
 568                      . " because it is not pristine.";
 569         my $super_meta_name = $super_meta->_real_ref_name;
 570         my $class_meta_subclass_meta = $self->_reconcile_roles_for_metaclass(blessed($self), $super_meta_name);
 571         my $new_self = $class_meta_subclass_meta->name->reinitialize(
 572             $self->name,
 573         );
 574
 575         $self->_replace_self( $new_self, $class_meta_subclass_meta->name );
 576     }
 577 }
 578
 579 sub _fix_single_metaclass_incompatibility {
 580     my $self = shift;
 581     my ($metaclass_type, $super_meta) = @_;
 582
 583     $self->SUPER::_fix_single_metaclass_incompatibility(@_);
 584
 585     if ($self->_can_fix_single_metaclass_incompatibility_by_role_reconciliation($metaclass_type, $super_meta)) {
 586         ($self->is_pristine)
 587             || confess "Can't fix metaclass incompatibility for "
 588                      . $self->name
 589                      . " because it is not pristine.";
 590         my $super_meta_name = $super_meta->_real_ref_name;
 591         my $class_specific_meta_subclass_meta = $self->_reconcile_roles_for_metaclass($self->$metaclass_type, $super_meta->$metaclass_type);
 592         my $new_self = $super_meta->reinitialize(
 593             $self->name,
 594             $metaclass_type => $class_specific_meta_subclass_meta->name,
 595         );
 596
 597         $self->_replace_self( $new_self, $super_meta_name );
 598     }
 599 }
 600
 601
 602 sub _replace_self {
 603     my $self      = shift;
 604     my ( $new_self, $new_class)   = @_;
 605
 606     %$self = %$new_self;
 607     bless $self, $new_class;
 608
 609     # We need to replace the cached metaclass instance or else when it goes
 610     # out of scope Class::MOP::Class destroy's the namespace for the
 611     # metaclass's class, causing much havoc.
 612     Class::MOP::store_metaclass_by_name( $self->name, $self );
 613     Class::MOP::weaken_metaclass( $self->name ) if $self->is_anon_class;
 614 }
 615
 616 sub _process_attribute {
 617     my ( $self, $name, @args ) = @_;
 618
 619     @args = %{$args[0]} if scalar @args == 1 && ref($args[0]) eq 'HASH';
 620
 621     if (($name || '') =~ /^\+(.*)/) {
 622         return $self->_process_inherited_attribute($1, @args);
 623     }
 624     else {
 625         return $self->_process_new_attribute($name, @args);
 626     }
 627 }
 628
 629 sub _process_new_attribute {
 630     my ( $self, $name, @args ) = @_;
 631
 632     $self->attribute_metaclass->interpolate_class_and_new($name, @args);
 633 }
 634
 635 sub _process_inherited_attribute {
 636     my ($self, $attr_name, %options) = @_;
 637     my $inherited_attr = $self->find_attribute_by_name($attr_name);
 638     (defined $inherited_attr)
 639         || $self->throw_error("Could not find an attribute by the name of '$attr_name' to inherit from in ${\$self->name}", data => $attr_name);
 640     if ($inherited_attr->isa('Moose::Meta::Attribute')) {
 641         return $inherited_attr->clone_and_inherit_options(%options);
 642     }
 643     else {
 644         # NOTE:
 645         # kind of a kludge to handle Class::MOP::Attributes
 646         return $inherited_attr->Moose::Meta::Attribute::clone_and_inherit_options(%options);
 647     }
 648 }
 649
 650 ## Immutability
 651
 652 sub _immutable_options {
 653     my ( $self, @args ) = @_;
 654
 655     $self->SUPER::_immutable_options(
 656         inline_destructor => 1,
 657         inline_does       => 1,
 658
 659         # Moose always does this when an attribute is created
 660         inline_accessors => 0,
 661
 662         @args,
 663     );
 664 }
 665
 666 sub _install_inlined_code {
 667     my ( $self, %args ) = @_;
 668
 669     $self->SUPER::_install_inlined_code(%args);
 670
 671     $self->_inline_does(%args) if $args{inline_does};
 672 }
 673
 674 sub _inline_does {
 675     my ( $self, %args ) = @_;
 676
 677     if ( $self->has_method('does') ) {
 678         my $class = $self->name;
 679         warn "Not inlining a does method for $class since it defines"
 680             . " its own does().\n";
 681         return;
 682     }
 683
 684     my $does = $self->does_class->new(
 685         options      => \%args,
 686         metaclass    => $self,
 687         is_inline    => 1,
 688         package_name => $self->name,
 689     );
 690
 691     if ( $args{replace_does} or $does->can_be_inlined ) {
 692         $self->add_method( 'does' => $does );
 693         $self->_add_inlined_method($does);
 694     }
 695 }
 696
 697 ## -------------------------------------------------
 698
 699 our $error_level;
 700
 701 sub throw_error {
 702     my ( $self, @args ) = @_;
 703     local $error_level = ($error_level || 0) + 1;
 704     $self->raise_error($self->create_error(@args));
 705 }
 706
 707 sub raise_error {
 708     my ( $self, @args ) = @_;
 709     die @args;
 710 }
 711
 712 sub create_error {
 713     my ( $self, @args ) = @_;
 714
 715     require Carp::Heavy;
 716
 717     local $error_level = ($error_level || 0 ) + 1;
 718
 719     if ( @args % 2 == 1 ) {
 720         unshift @args, "message";
 721     }
 722
 723     my %args = ( metaclass => $self, last_error => $@, @args );
 724
 725     $args{depth} += $error_level;
 726
 727     my $class = ref $self ? $self->error_class : "Moose::Error::Default";
 728
 729     Class::MOP::load_class($class);
 730
 731     $class->new(
 732         Carp::caller_info($args{depth}),
 733         %args
 734     );
 735 }
 736
 737 1;
 738
 739 __END__
 740
 741 =pod
 742
 743 =head1 NAME
 744
 745 Moose::Meta::Class - The Moose metaclass
 746
 747 =head1 DESCRIPTION
 748
 749 This class is a subclass of L<Class::MOP::Class> that provides
 750 additional Moose-specific functionality.
 751
 752 To really understand this class, you will need to start with the
 753 L<Class::MOP::Class> documentation. This class can be understood as a
 754 set of additional features on top of the basic feature provided by
 755 that parent class.
 756
 757 =head1 INHERITANCE
 758
 759 C<Moose::Meta::Class> is a subclass of L<Class::MOP::Class>.
 760
 761 =head1 METHODS
 762
 763 =over 4
 764
 765 =item B<< Moose::Meta::Class->initialize($package_name, %options) >>
 766
 767 This overrides the parent's method in order to provide its own
 768 defaults for the C<attribute_metaclass>, C<instance_metaclass>, and
 769 C<method_metaclass> options.
 770
 771 These all default to the appropriate Moose class.
 772
 773 =item B<< Moose::Meta::Class->create($package_name, %options) >>
 774
 775 This overrides the parent's method in order to accept a C<roles>
 776 option. This should be an array reference containing roles
 777 that the class does, each optionally followed by a hashref of options
 778 (C<-excludes> and C<-alias>).
 779
 780   my $metaclass = Moose::Meta::Class->create( 'New::Class', roles => [...] );
 781
 782 =item B<< Moose::Meta::Class->create_anon_class >>
 783
 784 This overrides the parent's method to accept a C<roles> option, just
 785 as C<create> does.
 786
 787 It also accepts a C<cache> option. If this is true, then the anonymous
 788 class will be cached based on its superclasses and roles. If an
 789 existing anonymous class in the cache has the same superclasses and
 790 roles, it will be reused.
 791
 792   my $metaclass = Moose::Meta::Class->create_anon_class(
 793       superclasses => ['Foo'],
 794       roles        => [qw/Some Roles Go Here/],
 795       cache        => 1,
 796   );
 797
 798 Each entry in both the C<superclasses> and the C<roles> option can be
 799 followed by a hash reference with arguments. The C<superclasses>
 800 option can be supplied with a L<-version|Class::MOP/Class Loading
 801 Options> option that ensures the loaded superclass satisfies the
 802 required version. The C<role> option also takes the C<-version> as an
 803 argument, but the option hash reference can also contain any other
 804 role relevant values like exclusions or parameterized role arguments.
 805
 806 =item B<< $metaclass->make_immutable(%options) >>
 807
 808 This overrides the parent's method to add a few options. Specifically,
 809 it uses the Moose-specific constructor and destructor classes, and
 810 enables inlining the destructor.
 811
 812 Since Moose always inlines attributes, it sets the C<inline_accessors> option
 813 to false.
 814
 815 Because Moose attempts to inline C<does> when possible, this method accepts
 816 C<inline_does> and C<replace_does> options. The default is to inline the does
 817 method, but an existing does method in a parent will not be replaced.
 818
 819 =item B<< $metaclass->new_object(%params) >>
 820
 821 This overrides the parent's method in order to add support for
 822 attribute triggers.
 823
 824 =item B<< $metaclass->superclasses(@superclasses) >>
 825
 826 This is the accessor allowing you to read or change the parents of
 827 the class.
 828
 829 Each superclass can be followed by a hash reference containing a
 830 L<-version|Class::MOP/Class Loading Options> value. If the version
 831 requirement is not satisfied an error will be thrown.
 832
 833 =item B<< $metaclass->add_override_method_modifier($name, $sub) >>
 834
 835 This adds an C<override> method modifier to the package.
 836
 837 =item B<< $metaclass->add_augment_method_modifier($name, $sub) >>
 838
 839 This adds an C<augment> method modifier to the package.
 840
 841 =item B<< $metaclass->calculate_all_roles >>
 842
 843 This will return a unique array of C<Moose::Meta::Role> instances
 844 which are attached to this class.
 845
 846 =item B<< $metaclass->calculate_all_roles_with_inheritance >>
 847
 848 This will return a unique array of C<Moose::Meta::Role> instances
 849 which are attached to this class, and each of this class's ancestors.
 850
 851 =item B<< $metaclass->add_role($role) >>
 852
 853 This takes a L<Moose::Meta::Role> object, and adds it to the class's
 854 list of roles. This I<does not> actually apply the role to the class.
 855
 856 =item B<< $metaclass->role_applications >>
 857
 858 Returns a list of L<Moose::Meta::Role::Application::ToClass>
 859 objects, which contain the arguments to role application.
 860
 861 =item B<< $metaclass->add_role_application($application) >>
 862
 863 This takes a L<Moose::Meta::Role::Application::ToClass> object, and
 864 adds it to the class's list of role applications. This I<does not>
 865 actually apply any role to the class; it is only for tracking role
 866 applications.
 867
 868 =item B<< $metaclass->does_role($role) >>
 869
 870 This returns a boolean indicating whether or not the class does the specified
 871 role. The role provided can be either a role name or a L<Moose::Meta::Role>
 872 object. This tests both the class and its parents.
 873
 874 =item B<< $metaclass->excludes_role($role_name) >>
 875
 876 A class excludes a role if it has already composed a role which
 877 excludes the named role. This tests both the class and its parents.
 878
 879 =item B<< $metaclass->add_attribute($attr_name, %params|$params) >>
 880
 881 This overrides the parent's method in order to allow the parameters to
 882 be provided as a hash reference.
 883
 884 =item B<< $metaclass->constructor_class($class_name) >>
 885
 886 =item B<< $metaclass->destructor_class($class_name) >>
 887
 888 =item B<< $metaclass->does_class($class_name) >>
 889
 890 These are the names of classes used when making a class immutable. These
 891 default to L<Moose::Meta::Method::Constructor>,
 892 L<Moose::Meta::Method::Destructor>, and L<Moose::Meta::Method::Does>
 893 respectively. These accessors are read-write, so you can use them to change
 894 the class name.
 895
 896 =item B<< $metaclass->error_class($class_name) >>
 897
 898 The name of the class used to throw errors. This defaults to
 899 L<Moose::Error::Default>, which generates an error with a stacktrace
 900 just like C<Carp::confess>.
 901
 902 =item B<< $metaclass->throw_error($message, %extra) >>
 903
 904 Throws the error created by C<create_error> using C<raise_error>
 905
 906 =back
 907
 908 =head1 BUGS
 909
 910 See L<Moose/BUGS> for details on reporting bugs.
 911
 912 =head1 AUTHOR
 913
 914 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 915
 916 =head1 COPYRIGHT AND LICENSE
 917
 918 Copyright 2006-2010 by Infinity Interactive, Inc.
 919
 920 L<http://www.iinteractive.com>
 921
 922 This library is free software; you can redistribute it and/or modify
 923 it under the same terms as Perl itself.
 924
 925 =cut
 926