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.24';
  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::Meta;
  26 use Moose::Util;
  27 use Class::MOP::MiniTrait;
  28
  29 use base 'Class::MOP::Class';
  30
  31 Class::MOP::MiniTrait::apply(__PACKAGE__, 'Moose::Meta::Object::Trait');
  32
  33 __PACKAGE__->meta->add_attribute('roles' => (
  34     reader  => 'roles',
  35     default => sub { [] }
  36 ));
  37
  38 __PACKAGE__->meta->add_attribute('role_applications' => (
  39     reader  => '_get_role_applications',
  40     default => sub { [] }
  41 ));
  42
  43 __PACKAGE__->meta->add_attribute(
  44     Class::MOP::Attribute->new('immutable_trait' => (
  45         accessor => "immutable_trait",
  46         default  => 'Moose::Meta::Class::Immutable::Trait',
  47     ))
  48 );
  49
  50 __PACKAGE__->meta->add_attribute('constructor_class' => (
  51     accessor => 'constructor_class',
  52     default  => 'Moose::Meta::Method::Constructor',
  53 ));
  54
  55 __PACKAGE__->meta->add_attribute('destructor_class' => (
  56     accessor => 'destructor_class',
  57     default  => 'Moose::Meta::Method::Destructor',
  58 ));
  59
  60 __PACKAGE__->meta->add_attribute('error_class' => (
  61     accessor => 'error_class',
  62     default  => 'Moose::Error::Default',
  63 ));
  64
  65 sub initialize {
  66     my $class = shift;
  67     my $pkg   = shift;
  68     return Class::MOP::get_metaclass_by_name($pkg)
  69         || $class->SUPER::initialize($pkg,
  70                 'attribute_metaclass' => 'Moose::Meta::Attribute',
  71                 'method_metaclass'    => 'Moose::Meta::Method',
  72                 'instance_metaclass'  => 'Moose::Meta::Instance',
  73                 @_
  74             );
  75 }
  76
  77 sub create {
  78     my ($class, $package_name, %options) = @_;
  79
  80     (ref $options{roles} eq 'ARRAY')
  81         || $class->throw_error("You must pass an ARRAY ref of roles", data => $options{roles})
  82             if exists $options{roles};
  83     my $roles = delete $options{roles};
  84
  85     my $new_meta = $class->SUPER::create($package_name, %options);
  86
  87     if ($roles) {
  88         Moose::Util::apply_all_roles( $new_meta, @$roles );
  89     }
  90
  91     return $new_meta;
  92 }
  93
  94 my %ANON_CLASSES;
  95
  96 sub create_anon_class {
  97     my ($self, %options) = @_;
  98
  99     my $cache_ok = delete $options{cache};
 100
 101     my $cache_key
 102         = _anon_cache_key( $options{superclasses}, $options{roles} );
 103
 104     if ($cache_ok && defined $ANON_CLASSES{$cache_key}) {
 105         return $ANON_CLASSES{$cache_key};
 106     }
 107
 108     $options{weaken} = !$cache_ok
 109         unless exists $options{weaken};
 110
 111     my $new_class = $self->SUPER::create_anon_class(%options);
 112
 113     if ($cache_ok) {
 114         $ANON_CLASSES{$cache_key} = $new_class;
 115         weaken($ANON_CLASSES{$cache_key});
 116     }
 117
 118     return $new_class;
 119 }
 120
 121 sub _meta_method_class { 'Moose::Meta::Method::Meta' }
 122
 123 sub _anon_cache_key {
 124     # Makes something like Super::Class|Super::Class::2=Role|Role::1
 125     return join '=' => (
 126         join( '|', @{ $_[0]      || [] } ),
 127         join( '|', sort @{ $_[1] || [] } ),
 128     );
 129 }
 130
 131 sub reinitialize {
 132     my $self = shift;
 133     my $pkg  = shift;
 134
 135     my $meta = blessed $pkg ? $pkg : Class::MOP::class_of($pkg);
 136
 137     my $cache_key;
 138
 139     my %existing_classes;
 140     if ($meta) {
 141         %existing_classes = map { $_ => $meta->$_() } qw(
 142             attribute_metaclass
 143             method_metaclass
 144             wrapped_method_metaclass
 145             instance_metaclass
 146             constructor_class
 147             destructor_class
 148             error_class
 149         );
 150
 151         $cache_key = _anon_cache_key(
 152             [ $meta->superclasses ],
 153             [ map { $_->name } @{ $meta->roles } ],
 154         ) if $meta->is_anon_class;
 155     }
 156
 157     my $new_meta = $self->SUPER::reinitialize(
 158         $pkg,
 159         %existing_classes,
 160         @_,
 161     );
 162
 163     return $new_meta unless defined $cache_key;
 164
 165     my $new_cache_key = _anon_cache_key(
 166         [ $meta->superclasses ],
 167         [ map { $_->name } @{ $meta->roles } ],
 168     );
 169
 170     delete $ANON_CLASSES{$cache_key};
 171     $ANON_CLASSES{$new_cache_key} = $new_meta;
 172     weaken($ANON_CLASSES{$new_cache_key});
 173
 174     return $new_meta;
 175 }
 176
 177 sub add_role {
 178     my ($self, $role) = @_;
 179     (blessed($role) && $role->isa('Moose::Meta::Role'))
 180         || $self->throw_error("Roles must be instances of Moose::Meta::Role", data => $role);
 181     push @{$self->roles} => $role;
 182 }
 183
 184 sub role_applications {
 185     my ($self) = @_;
 186
 187     return @{$self->_get_role_applications};
 188 }
 189
 190 sub add_role_application {
 191     my ($self, $application) = @_;
 192     (blessed($application) && $application->isa('Moose::Meta::Role::Application::ToClass'))
 193         || $self->throw_error("Role applications must be instances of Moose::Meta::Role::Application::ToClass", data => $application);
 194     push @{$self->_get_role_applications} => $application;
 195 }
 196
 197 sub calculate_all_roles {
 198     my $self = shift;
 199     my %seen;
 200     grep { !$seen{$_->name}++ } map { $_->calculate_all_roles } @{ $self->roles };
 201 }
 202
 203 sub calculate_all_roles_with_inheritance {
 204     my $self = shift;
 205     my %seen;
 206     grep { !$seen{$_->name}++ }
 207          map { Class::MOP::class_of($_)->can('calculate_all_roles')
 208                    ? Class::MOP::class_of($_)->calculate_all_roles
 209                    : () }
 210              $self->linearized_isa;
 211 }
 212
 213 sub does_role {
 214     my ($self, $role_name) = @_;
 215
 216     (defined $role_name)
 217         || $self->throw_error("You must supply a role name to look for");
 218
 219     foreach my $class ($self->class_precedence_list) {
 220         my $meta = Class::MOP::class_of($class);
 221         # when a Moose metaclass is itself extended with a role,
 222         # this check needs to be done since some items in the
 223         # class_precedence_list might in fact be Class::MOP
 224         # based still.
 225         next unless $meta && $meta->can('roles');
 226         foreach my $role (@{$meta->roles}) {
 227             return 1 if $role->does_role($role_name);
 228         }
 229     }
 230     return 0;
 231 }
 232
 233 sub excludes_role {
 234     my ($self, $role_name) = @_;
 235
 236     (defined $role_name)
 237         || $self->throw_error("You must supply a role name to look for");
 238
 239     foreach my $class ($self->class_precedence_list) {
 240         my $meta = Class::MOP::class_of($class);
 241         # when a Moose metaclass is itself extended with a role,
 242         # this check needs to be done since some items in the
 243         # class_precedence_list might in fact be Class::MOP
 244         # based still.
 245         next unless $meta && $meta->can('roles');
 246         foreach my $role (@{$meta->roles}) {
 247             return 1 if $role->excludes_role($role_name);
 248         }
 249     }
 250     return 0;
 251 }
 252
 253 sub new_object {
 254     my $self   = shift;
 255     my $params = @_ == 1 ? $_[0] : {@_};
 256     my $object = $self->SUPER::new_object($params);
 257
 258     foreach my $attr ( $self->get_all_attributes() ) {
 259
 260         next unless $attr->can('has_trigger') && $attr->has_trigger;
 261
 262         my $init_arg = $attr->init_arg;
 263
 264         next unless defined $init_arg;
 265
 266         next unless exists $params->{$init_arg};
 267
 268         $attr->trigger->(
 269             $object,
 270             (
 271                   $attr->should_coerce
 272                 ? $attr->get_read_method_ref->($object)
 273                 : $params->{$init_arg}
 274             ),
 275         );
 276     }
 277
 278     $object->BUILDALL($params) if $object->can('BUILDALL');
 279
 280     return $object;
 281 }
 282
 283 sub superclasses {
 284     my $self = shift;
 285     my $supers = Data::OptList::mkopt(\@_);
 286     foreach my $super (@{ $supers }) {
 287         my ($name, $opts) = @{ $super };
 288         Class::MOP::load_class($name, $opts);
 289         my $meta = Class::MOP::class_of($name);
 290         $self->throw_error("You cannot inherit from a Moose Role ($name)")
 291             if $meta && $meta->isa('Moose::Meta::Role')
 292     }
 293     return $self->SUPER::superclasses(map { $_->[0] } @{ $supers });
 294 }
 295
 296 ### ---------------------------------------------
 297
 298 sub add_attribute {
 299     my $self = shift;
 300     my $attr =
 301         (blessed $_[0] && $_[0]->isa('Class::MOP::Attribute')
 302             ? $_[0]
 303             : $self->_process_attribute(@_));
 304     $self->SUPER::add_attribute($attr);
 305     # it may be a Class::MOP::Attribute, theoretically, which doesn't have
 306     # 'bare' and doesn't implement this method
 307     if ($attr->can('_check_associated_methods')) {
 308         $attr->_check_associated_methods;
 309     }
 310     return $attr;
 311 }
 312
 313 sub add_override_method_modifier {
 314     my ($self, $name, $method, $_super_package) = @_;
 315
 316     (!$self->has_method($name))
 317         || $self->throw_error("Cannot add an override method if a local method is already present");
 318
 319     $self->add_method($name => Moose::Meta::Method::Overridden->new(
 320         method  => $method,
 321         class   => $self,
 322         package => $_super_package, # need this for roles
 323         name    => $name,
 324     ));
 325 }
 326
 327 sub add_augment_method_modifier {
 328     my ($self, $name, $method) = @_;
 329     (!$self->has_method($name))
 330         || $self->throw_error("Cannot add an augment method if a local method is already present");
 331
 332     $self->add_method($name => Moose::Meta::Method::Augmented->new(
 333         method  => $method,
 334         class   => $self,
 335         name    => $name,
 336     ));
 337 }
 338
 339 ## Private Utility methods ...
 340
 341 sub _find_next_method_by_name_which_is_not_overridden {
 342     my ($self, $name) = @_;
 343     foreach my $method ($self->find_all_methods_by_name($name)) {
 344         return $method->{code}
 345             if blessed($method->{code}) && !$method->{code}->isa('Moose::Meta::Method::Overridden');
 346     }
 347     return undef;
 348 }
 349
 350 ## Metaclass compatibility
 351
 352 sub _base_metaclasses {
 353     my $self = shift;
 354     my %metaclasses = $self->SUPER::_base_metaclasses;
 355     for my $class (keys %metaclasses) {
 356         $metaclasses{$class} =~ s/^Class::MOP/Moose::Meta/;
 357     }
 358     return (
 359         %metaclasses,
 360         error_class => 'Moose::Error::Default',
 361     );
 362 }
 363
 364 sub _fix_class_metaclass_incompatibility {
 365     my $self = shift;
 366     my ($super_meta) = @_;
 367
 368     $self->SUPER::_fix_class_metaclass_incompatibility(@_);
 369
 370     if ($self->_class_metaclass_can_be_made_compatible($super_meta)) {
 371         ($self->is_pristine)
 372             || confess "Can't fix metaclass incompatibility for "
 373                      . $self->name
 374                      . " because it is not pristine.";
 375         my $super_meta_name = $super_meta->_real_ref_name;
 376         my $class_meta_subclass_meta_name = Moose::Util::_reconcile_roles_for_metaclass(blessed($self), $super_meta_name);
 377         my $new_self = $class_meta_subclass_meta_name->reinitialize(
 378             $self->name,
 379         );
 380
 381         $self->_replace_self( $new_self, $class_meta_subclass_meta_name );
 382     }
 383 }
 384
 385 sub _fix_single_metaclass_incompatibility {
 386     my $self = shift;
 387     my ($metaclass_type, $super_meta) = @_;
 388
 389     $self->SUPER::_fix_single_metaclass_incompatibility(@_);
 390
 391     if ($self->_single_metaclass_can_be_made_compatible($super_meta, $metaclass_type)) {
 392         ($self->is_pristine)
 393             || confess "Can't fix metaclass incompatibility for "
 394                      . $self->name
 395                      . " because it is not pristine.";
 396         my $super_meta_name = $super_meta->_real_ref_name;
 397         my $class_specific_meta_subclass_meta_name = Moose::Util::_reconcile_roles_for_metaclass($self->$metaclass_type, $super_meta->$metaclass_type);
 398         my $new_self = $super_meta->reinitialize(
 399             $self->name,
 400             $metaclass_type => $class_specific_meta_subclass_meta_name,
 401         );
 402
 403         $self->_replace_self( $new_self, $super_meta_name );
 404     }
 405 }
 406
 407 sub _replace_self {
 408     my $self      = shift;
 409     my ( $new_self, $new_class)   = @_;
 410
 411     %$self = %$new_self;
 412     bless $self, $new_class;
 413
 414     # We need to replace the cached metaclass instance or else when it goes
 415     # out of scope Class::MOP::Class destroy's the namespace for the
 416     # metaclass's class, causing much havoc.
 417     my $weaken = Class::MOP::metaclass_is_weak( $self->name );
 418     Class::MOP::store_metaclass_by_name( $self->name, $self );
 419     Class::MOP::weaken_metaclass( $self->name ) if $weaken;
 420 }
 421
 422 sub _process_attribute {
 423     my ( $self, $name, @args ) = @_;
 424
 425     @args = %{$args[0]} if scalar @args == 1 && ref($args[0]) eq 'HASH';
 426
 427     if (($name || '') =~ /^\+(.*)/) {
 428         return $self->_process_inherited_attribute($1, @args);
 429     }
 430     else {
 431         return $self->_process_new_attribute($name, @args);
 432     }
 433 }
 434
 435 sub _process_new_attribute {
 436     my ( $self, $name, @args ) = @_;
 437
 438     $self->attribute_metaclass->interpolate_class_and_new($name, @args);
 439 }
 440
 441 sub _process_inherited_attribute {
 442     my ($self, $attr_name, %options) = @_;
 443     my $inherited_attr = $self->find_attribute_by_name($attr_name);
 444     (defined $inherited_attr)
 445         || $self->throw_error("Could not find an attribute by the name of '$attr_name' to inherit from in ${\$self->name}", data => $attr_name);
 446     if ($inherited_attr->isa('Moose::Meta::Attribute')) {
 447         return $inherited_attr->clone_and_inherit_options(%options);
 448     }
 449     else {
 450         # NOTE:
 451         # kind of a kludge to handle Class::MOP::Attributes
 452         return $inherited_attr->Moose::Meta::Attribute::clone_and_inherit_options(%options);
 453     }
 454 }
 455
 456 # reinitialization support
 457
 458 sub _restore_metaobjects_from {
 459     my $self = shift;
 460     my ($old_meta) = @_;
 461
 462     $self->SUPER::_restore_metaobjects_from($old_meta);
 463
 464     for my $role ( @{ $old_meta->roles } ) {
 465         $self->add_role($role);
 466     }
 467
 468     for my $application ( @{ $old_meta->_get_role_applications } ) {
 469         $application->class($self);
 470         $self->add_role_application ($application);
 471     }
 472 }
 473
 474 ## Immutability
 475
 476 sub _immutable_options {
 477     my ( $self, @args ) = @_;
 478
 479     $self->SUPER::_immutable_options(
 480         inline_destructor => 1,
 481
 482         # Moose always does this when an attribute is created
 483         inline_accessors => 0,
 484
 485         @args,
 486     );
 487 }
 488
 489 ## -------------------------------------------------
 490
 491 our $error_level;
 492
 493 sub throw_error {
 494     my ( $self, @args ) = @_;
 495     local $error_level = ($error_level || 0) + 1;
 496     $self->raise_error($self->create_error(@args));
 497 }
 498
 499 sub raise_error {
 500     my ( $self, @args ) = @_;
 501     die @args;
 502 }
 503
 504 sub create_error {
 505     my ( $self, @args ) = @_;
 506
 507     require Carp::Heavy;
 508
 509     local $error_level = ($error_level || 0 ) + 1;
 510
 511     if ( @args % 2 == 1 ) {
 512         unshift @args, "message";
 513     }
 514
 515     my %args = ( metaclass => $self, last_error => $@, @args );
 516
 517     $args{depth} += $error_level;
 518
 519     my $class = ref $self ? $self->error_class : "Moose::Error::Default";
 520
 521     Class::MOP::load_class($class);
 522
 523     $class->new(
 524         Carp::caller_info($args{depth}),
 525         %args
 526     );
 527 }
 528
 529 1;
 530
 531 __END__
 532
 533 =pod
 534
 535 =head1 NAME
 536
 537 Moose::Meta::Class - The Moose metaclass
 538
 539 =head1 DESCRIPTION
 540
 541 This class is a subclass of L<Class::MOP::Class> that provides
 542 additional Moose-specific functionality.
 543
 544 To really understand this class, you will need to start with the
 545 L<Class::MOP::Class> documentation. This class can be understood as a
 546 set of additional features on top of the basic feature provided by
 547 that parent class.
 548
 549 =head1 INHERITANCE
 550
 551 C<Moose::Meta::Class> is a subclass of L<Class::MOP::Class>.
 552
 553 =head1 METHODS
 554
 555 =over 4
 556
 557 =item B<< Moose::Meta::Class->initialize($package_name, %options) >>
 558
 559 This overrides the parent's method in order to provide its own
 560 defaults for the C<attribute_metaclass>, C<instance_metaclass>, and
 561 C<method_metaclass> options.
 562
 563 These all default to the appropriate Moose class.
 564
 565 =item B<< Moose::Meta::Class->create($package_name, %options) >>
 566
 567 This overrides the parent's method in order to accept a C<roles>
 568 option. This should be an array reference containing roles
 569 that the class does, each optionally followed by a hashref of options
 570 (C<-excludes> and C<-alias>).
 571
 572   my $metaclass = Moose::Meta::Class->create( 'New::Class', roles => [...] );
 573
 574 =item B<< Moose::Meta::Class->create_anon_class >>
 575
 576 This overrides the parent's method to accept a C<roles> option, just
 577 as C<create> does.
 578
 579 It also accepts a C<cache> option. If this is true, then the anonymous
 580 class will be cached based on its superclasses and roles. If an
 581 existing anonymous class in the cache has the same superclasses and
 582 roles, it will be reused.
 583
 584   my $metaclass = Moose::Meta::Class->create_anon_class(
 585       superclasses => ['Foo'],
 586       roles        => [qw/Some Roles Go Here/],
 587       cache        => 1,
 588   );
 589
 590 Each entry in both the C<superclasses> and the C<roles> option can be
 591 followed by a hash reference with arguments. The C<superclasses>
 592 option can be supplied with a L<-version|Class::MOP/Class Loading
 593 Options> option that ensures the loaded superclass satisfies the
 594 required version. The C<role> option also takes the C<-version> as an
 595 argument, but the option hash reference can also contain any other
 596 role relevant values like exclusions or parameterized role arguments.
 597
 598 =item B<< $metaclass->make_immutable(%options) >>
 599
 600 This overrides the parent's method to add a few options. Specifically,
 601 it uses the Moose-specific constructor and destructor classes, and
 602 enables inlining the destructor.
 603
 604 Since Moose always inlines attributes, it sets the C<inline_accessors> option
 605 to false.
 606
 607 =item B<< $metaclass->new_object(%params) >>
 608
 609 This overrides the parent's method in order to add support for
 610 attribute triggers.
 611
 612 =item B<< $metaclass->superclasses(@superclasses) >>
 613
 614 This is the accessor allowing you to read or change the parents of
 615 the class.
 616
 617 Each superclass can be followed by a hash reference containing a
 618 L<-version|Class::MOP/Class Loading Options> value. If the version
 619 requirement is not satisfied an error will be thrown.
 620
 621 =item B<< $metaclass->add_override_method_modifier($name, $sub) >>
 622
 623 This adds an C<override> method modifier to the package.
 624
 625 =item B<< $metaclass->add_augment_method_modifier($name, $sub) >>
 626
 627 This adds an C<augment> method modifier to the package.
 628
 629 =item B<< $metaclass->calculate_all_roles >>
 630
 631 This will return a unique array of C<Moose::Meta::Role> instances
 632 which are attached to this class.
 633
 634 =item B<< $metaclass->calculate_all_roles_with_inheritance >>
 635
 636 This will return a unique array of C<Moose::Meta::Role> instances
 637 which are attached to this class, and each of this class's ancestors.
 638
 639 =item B<< $metaclass->add_role($role) >>
 640
 641 This takes a L<Moose::Meta::Role> object, and adds it to the class's
 642 list of roles. This I<does not> actually apply the role to the class.
 643
 644 =item B<< $metaclass->role_applications >>
 645
 646 Returns a list of L<Moose::Meta::Role::Application::ToClass>
 647 objects, which contain the arguments to role application.
 648
 649 =item B<< $metaclass->add_role_application($application) >>
 650
 651 This takes a L<Moose::Meta::Role::Application::ToClass> object, and
 652 adds it to the class's list of role applications. This I<does not>
 653 actually apply any role to the class; it is only for tracking role
 654 applications.
 655
 656 =item B<< $metaclass->does_role($role) >>
 657
 658 This returns a boolean indicating whether or not the class does the specified
 659 role. The role provided can be either a role name or a L<Moose::Meta::Role>
 660 object. This tests both the class and its parents.
 661
 662 =item B<< $metaclass->excludes_role($role_name) >>
 663
 664 A class excludes a role if it has already composed a role which
 665 excludes the named role. This tests both the class and its parents.
 666
 667 =item B<< $metaclass->add_attribute($attr_name, %params|$params) >>
 668
 669 This overrides the parent's method in order to allow the parameters to
 670 be provided as a hash reference.
 671
 672 =item B<< $metaclass->constructor_class($class_name) >>
 673
 674 =item B<< $metaclass->destructor_class($class_name) >>
 675
 676 These are the names of classes used when making a class immutable. These
 677 default to L<Moose::Meta::Method::Constructor> and
 678 L<Moose::Meta::Method::Destructor> respectively. These accessors are
 679 read-write, so you can use them to change the class name.
 680
 681 =item B<< $metaclass->error_class($class_name) >>
 682
 683 The name of the class used to throw errors. This defaults to
 684 L<Moose::Error::Default>, which generates an error with a stacktrace
 685 just like C<Carp::confess>.
 686
 687 =item B<< $metaclass->throw_error($message, %extra) >>
 688
 689 Throws the error created by C<create_error> using C<raise_error>
 690
 691 =back
 692
 693 =head1 BUGS
 694
 695 See L<Moose/BUGS> for details on reporting bugs.
 696
 697 =head1 AUTHOR
 698
 699 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 700
 701 =head1 COPYRIGHT AND LICENSE
 702
 703 Copyright 2006-2010 by Infinity Interactive, Inc.
 704
 705 L<http://www.iinteractive.com>
 706
 707 This library is free software; you can redistribute it and/or modify
 708 it under the same terms as Perl itself.
 709
 710 =cut
 711