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 ();
  10 use List::Util qw( first );
  11 use List::MoreUtils qw( any all uniq );
  12 use Scalar::Util 'weaken', 'blessed';
  13
  14 our $VERSION   = '0.74';
  15 $VERSION = eval $VERSION;
  16 our $AUTHORITY = 'cpan:STEVAN';
  17
  18 use Moose::Meta::Method::Overridden;
  19 use Moose::Meta::Method::Augmented;
  20 use Moose::Error::Default;
  21
  22 use base 'Class::MOP::Class';
  23
  24 __PACKAGE__->meta->add_attribute('roles' => (
  25     reader  => 'roles',
  26     default => sub { [] }
  27 ));
  28
  29 __PACKAGE__->meta->add_attribute('constructor_class' => (
  30     accessor => 'constructor_class',
  31     default  => 'Moose::Meta::Method::Constructor',
  32 ));
  33
  34 __PACKAGE__->meta->add_attribute('destructor_class' => (
  35     accessor => 'destructor_class',
  36     default  => 'Moose::Meta::Method::Destructor',
  37 ));
  38
  39 __PACKAGE__->meta->add_attribute('error_class' => (
  40     accessor => 'error_class',
  41     default  => 'Moose::Error::Default',
  42 ));
  43
  44
  45 sub initialize {
  46     my $class = shift;
  47     my $pkg   = shift;
  48     return Class::MOP::get_metaclass_by_name($pkg)
  49         || $class->SUPER::initialize($pkg,
  50                 'attribute_metaclass' => 'Moose::Meta::Attribute',
  51                 'method_metaclass'    => 'Moose::Meta::Method',
  52                 'instance_metaclass'  => 'Moose::Meta::Instance',
  53                 @_
  54             );
  55 }
  56
  57 sub create {
  58     my ($self, $package_name, %options) = @_;
  59
  60     (ref $options{roles} eq 'ARRAY')
  61         || $self->throw_error("You must pass an ARRAY ref of roles", data => $options{roles})
  62             if exists $options{roles};
  63     my $roles = delete $options{roles};
  64
  65     my $class = $self->SUPER::create($package_name, %options);
  66
  67     if ($roles) {
  68         Moose::Util::apply_all_roles( $class, @$roles );
  69     }
  70
  71     return $class;
  72 }
  73
  74 sub _check_metaclass_compatibility {
  75     my $self = shift;
  76
  77     if ( my @supers = $self->superclasses ) {
  78         $self->_fix_metaclass_incompatibility(@supers);
  79     }
  80
  81     $self->SUPER::_check_metaclass_compatibility(@_);
  82 }
  83
  84 my %ANON_CLASSES;
  85
  86 sub create_anon_class {
  87     my ($self, %options) = @_;
  88
  89     my $cache_ok = delete $options{cache};
  90
  91     # something like Super::Class|Super::Class::2=Role|Role::1
  92     my $cache_key = join '=' => (
  93         join('|', @{$options{superclasses} || []}),
  94         join('|', sort @{$options{roles}   || []}),
  95     );
  96
  97     if ($cache_ok && defined $ANON_CLASSES{$cache_key}) {
  98         return $ANON_CLASSES{$cache_key};
  99     }
 100
 101     my $new_class = $self->SUPER::create_anon_class(%options);
 102
 103     $ANON_CLASSES{$cache_key} = $new_class
 104         if $cache_ok;
 105
 106     return $new_class;
 107 }
 108
 109 sub add_role {
 110     my ($self, $role) = @_;
 111     (blessed($role) && $role->isa('Moose::Meta::Role'))
 112         || $self->throw_error("Roles must be instances of Moose::Meta::Role", data => $role);
 113     push @{$self->roles} => $role;
 114 }
 115
 116 sub calculate_all_roles {
 117     my $self = shift;
 118     my %seen;
 119     grep { !$seen{$_->name}++ } map { $_->calculate_all_roles } @{ $self->roles };
 120 }
 121
 122 sub does_role {
 123     my ($self, $role_name) = @_;
 124
 125     (defined $role_name)
 126         || $self->throw_error("You must supply a role name to look for");
 127
 128     foreach my $class ($self->class_precedence_list) {
 129         my $meta = Class::MOP::class_of($class);
 130         # when a Moose metaclass is itself extended with a role,
 131         # this check needs to be done since some items in the
 132         # class_precedence_list might in fact be Class::MOP
 133         # based still.
 134         next unless $meta && $meta->can('roles');
 135         foreach my $role (@{$meta->roles}) {
 136             return 1 if $role->does_role($role_name);
 137         }
 138     }
 139     return 0;
 140 }
 141
 142 sub excludes_role {
 143     my ($self, $role_name) = @_;
 144
 145     (defined $role_name)
 146         || $self->throw_error("You must supply a role name to look for");
 147
 148     foreach my $class ($self->class_precedence_list) {
 149         my $meta = Class::MOP::class_of($class);
 150         # when a Moose metaclass is itself extended with a role,
 151         # this check needs to be done since some items in the
 152         # class_precedence_list might in fact be Class::MOP
 153         # based still.
 154         next unless $meta && $meta->can('roles');
 155         foreach my $role (@{$meta->roles}) {
 156             return 1 if $role->excludes_role($role_name);
 157         }
 158     }
 159     return 0;
 160 }
 161
 162 sub new_object {
 163     my $class  = shift;
 164     my $params = @_ == 1 ? $_[0] : {@_};
 165     my $self   = $class->SUPER::new_object($params);
 166
 167     foreach my $attr ( $class->get_all_attributes() ) {
 168
 169         next unless $attr->can('has_trigger') && $attr->has_trigger;
 170
 171         my $init_arg = $attr->init_arg;
 172
 173         next unless defined $init_arg;
 174
 175         next unless exists $params->{$init_arg};
 176
 177         $attr->trigger->(
 178             $self,
 179             (
 180                   $attr->should_coerce
 181                 ? $attr->get_read_method_ref->($self)
 182                 : $params->{$init_arg}
 183             ),
 184         );
 185     }
 186
 187     return $self;
 188 }
 189
 190 sub _construct_instance {
 191     my $class = shift;
 192     my $params = @_ == 1 ? $_[0] : {@_};
 193     my $meta_instance = $class->get_meta_instance;
 194     # FIXME:
 195     # the code below is almost certainly incorrect
 196     # but this is foreign inheritance, so we might
 197     # have to kludge it in the end.
 198     my $instance = $params->{'__INSTANCE__'} || $meta_instance->create_instance();
 199     foreach my $attr ($class->get_all_attributes()) {
 200         $attr->initialize_instance_slot($meta_instance, $instance, $params);
 201     }
 202     return $instance;
 203 }
 204
 205 ### ---------------------------------------------
 206
 207 sub add_attribute {
 208     my $self = shift;
 209     $self->SUPER::add_attribute(
 210         (blessed $_[0] && $_[0]->isa('Class::MOP::Attribute')
 211             ? $_[0]
 212             : $self->_process_attribute(@_))
 213     );
 214 }
 215
 216 sub add_override_method_modifier {
 217     my ($self, $name, $method, $_super_package) = @_;
 218
 219     (!$self->has_method($name))
 220         || $self->throw_error("Cannot add an override method if a local method is already present");
 221
 222     $self->add_method($name => Moose::Meta::Method::Overridden->new(
 223         method  => $method,
 224         class   => $self,
 225         package => $_super_package, # need this for roles
 226         name    => $name,
 227     ));
 228 }
 229
 230 sub add_augment_method_modifier {
 231     my ($self, $name, $method) = @_;
 232     (!$self->has_method($name))
 233         || $self->throw_error("Cannot add an augment method if a local method is already present");
 234
 235     $self->add_method($name => Moose::Meta::Method::Augmented->new(
 236         method  => $method,
 237         class   => $self,
 238         name    => $name,
 239     ));
 240 }
 241
 242 ## Private Utility methods ...
 243
 244 sub _find_next_method_by_name_which_is_not_overridden {
 245     my ($self, $name) = @_;
 246     foreach my $method ($self->find_all_methods_by_name($name)) {
 247         return $method->{code}
 248             if blessed($method->{code}) && !$method->{code}->isa('Moose::Meta::Method::Overridden');
 249     }
 250     return undef;
 251 }
 252
 253 sub _fix_metaclass_incompatibility {
 254     my ($self, @superclasses) = @_;
 255
 256     foreach my $super (@superclasses) {
 257         next if $self->_superclass_meta_is_compatible($super);
 258
 259         unless ( $self->is_pristine ) {
 260             $self->throw_error(
 261                       "Cannot attempt to reinitialize metaclass for "
 262                     . $self->name
 263                     . ", it isn't pristine" );
 264         }
 265
 266         $self->_reconcile_with_superclass_meta($super);
 267     }
 268 }
 269
 270 sub _superclass_meta_is_compatible {
 271     my ($self, $super) = @_;
 272
 273     my $super_meta = Class::MOP::Class->initialize($super)
 274         or return 1;
 275
 276     next unless $super_meta->isa("Class::MOP::Class");
 277
 278     my $super_meta_name
 279         = $super_meta->is_immutable
 280         ? $super_meta->get_mutable_metaclass_name
 281         : ref($super_meta);
 282
 283     return 1
 284         if $self->isa($super_meta_name)
 285             and
 286            $self->instance_metaclass->isa( $super_meta->instance_metaclass );
 287 }
 288
 289 # I don't want to have to type this >1 time
 290 my @MetaClassTypes =
 291     qw( attribute_metaclass method_metaclass instance_metaclass
 292         constructor_class destructor_class error_class );
 293
 294 sub _reconcile_with_superclass_meta {
 295     my ($self, $super) = @_;
 296
 297     my $super_meta = Class::MOP::class_of($super);
 298
 299     my $super_meta_name
 300         = $super_meta->is_immutable
 301         ? $super_meta->get_mutable_metaclass_name
 302         : ref($super_meta);
 303
 304     my $self_metaclass = ref $self;
 305
 306     # If neither of these is true we have a more serious
 307     # incompatibility that we just cannot fix (yet?).
 308     if ( $super_meta_name->isa( ref $self )
 309         && all { $super_meta->$_->isa( $self->$_ ) } @MetaClassTypes ) {
 310         $self->_reinitialize_with($super_meta);
 311     }
 312     elsif ( $self->_all_metaclasses_differ_by_roles_only($super_meta) ) {
 313         $self->_reconcile_role_differences($super_meta);
 314     }
 315 }
 316
 317 sub _reinitialize_with {
 318     my ( $self, $new_meta ) = @_;
 319
 320     my $new_self = $new_meta->reinitialize(
 321         $self->name,
 322         attribute_metaclass => $new_meta->attribute_metaclass,
 323         method_metaclass    => $new_meta->method_metaclass,
 324         instance_metaclass  => $new_meta->instance_metaclass,
 325     );
 326
 327     $new_self->$_( $new_meta->$_ )
 328         for qw( constructor_class destructor_class error_class );
 329
 330     %$self = %$new_self;
 331
 332     bless $self, ref $new_self;
 333
 334     # We need to replace the cached metaclass instance or else when it
 335     # goes out of scope Class::MOP::Class destroy's the namespace for
 336     # the metaclass's class, causing much havoc.
 337     Class::MOP::store_metaclass_by_name( $self->name, $self );
 338     Class::MOP::weaken_metaclass( $self->name ) if $self->is_anon_class;
 339 }
 340
 341 # In the more complex case, we share a common ancestor with our
 342 # superclass's metaclass, but each metaclass (ours and the parent's)
 343 # has a different set of roles applied. We reconcile this by first
 344 # reinitializing into the parent class, and _then_ applying our own
 345 # roles.
 346 sub _all_metaclasses_differ_by_roles_only {
 347     my ($self, $super_meta) = @_;
 348
 349     for my $pair (
 350         [ ref $self, ref $super_meta ],
 351         map { [ $self->$_, $super_meta->$_ ] } @MetaClassTypes
 352         ) {
 353
 354         next if $pair->[0] eq $pair->[1];
 355
 356         my $self_meta_meta  = Class::MOP::Class->initialize( $pair->[0] );
 357         my $super_meta_meta = Class::MOP::Class->initialize( $pair->[1] );
 358
 359         my $common_ancestor
 360             = _find_common_ancestor( $self_meta_meta, $super_meta_meta );
 361
 362         return unless $common_ancestor;
 363
 364         return
 365             unless _is_role_only_subclass_of(
 366             $self_meta_meta,
 367             $common_ancestor,
 368             )
 369             && _is_role_only_subclass_of(
 370             $super_meta_meta,
 371             $common_ancestor,
 372             );
 373     }
 374
 375     return 1;
 376 }
 377
 378 # This, and some other functions, could be called as methods, but
 379 # they're not for two reasons. One, we just end up ignoring the first
 380 # argument, because we can't call these directly on one of the real
 381 # arguments, because one of them could be a Class::MOP::Class object
 382 # and not a Moose::Meta::Class. Second, only a completely insane
 383 # person would attempt to subclass this stuff!
 384 sub _find_common_ancestor {
 385     my ($meta1, $meta2) = @_;
 386
 387     # FIXME? This doesn't account for multiple inheritance (not sure
 388     # if it needs to though). For example, is somewhere in $meta1's
 389     # history it inherits from both ClassA and ClassB, and $meta2
 390     # inherits from ClassB & ClassA, does it matter? And what crazy
 391     # fool would do that anyway?
 392
 393     my %meta1_parents = map { $_ => 1 } $meta1->linearized_isa;
 394
 395     return first { $meta1_parents{$_} } $meta2->linearized_isa;
 396 }
 397
 398 sub _is_role_only_subclass_of {
 399     my ($meta, $ancestor) = @_;
 400
 401     return 1 if $meta->name eq $ancestor;
 402
 403     my @roles = _all_roles_until( $meta, $ancestor );
 404
 405     my %role_packages = map { $_->name => 1 } @roles;
 406
 407     my $ancestor_meta = Class::MOP::Class->initialize($ancestor);
 408
 409     my %shared_ancestors = map { $_ => 1 } $ancestor_meta->linearized_isa;
 410
 411     for my $method ( $meta->get_all_methods() ) {
 412         next if $method->name eq 'meta';
 413         next if $method->can('associated_attribute');
 414
 415         next
 416             if $role_packages{ $method->original_package_name }
 417                 || $shared_ancestors{ $method->original_package_name };
 418
 419         return 0;
 420     }
 421
 422     # FIXME - this really isn't right. Just because an attribute is
 423     # defined in a role doesn't mean it isn't _also_ defined in the
 424     # subclass.
 425     for my $attr ( $meta->get_all_attributes ) {
 426         next if $shared_ancestors{ $attr->associated_class->name };
 427
 428         next if any { $_->has_attribute( $attr->name ) } @roles;
 429
 430         return 0;
 431     }
 432
 433     return 1;
 434 }
 435
 436 sub _all_roles {
 437     my $meta = shift;
 438
 439     return _all_roles_until($meta);
 440 }
 441
 442 sub _all_roles_until {
 443     my ($meta, $stop_at_class) = @_;
 444
 445     return unless $meta->can('calculate_all_roles');
 446
 447     my @roles = $meta->calculate_all_roles;
 448
 449     for my $class ( $meta->linearized_isa ) {
 450         last if $stop_at_class && $stop_at_class eq $class;
 451
 452         my $meta = Class::MOP::Class->initialize($class);
 453         last unless $meta->can('calculate_all_roles');
 454
 455         push @roles, $meta->calculate_all_roles;
 456     }
 457
 458     return uniq @roles;
 459 }
 460
 461 sub _reconcile_role_differences {
 462     my ($self, $super_meta) = @_;
 463
 464     my $self_meta = Class::MOP::class_of($self);
 465
 466     my %roles;
 467
 468     if ( my @roles = map { $_->name } _all_roles($self_meta) ) {
 469         $roles{metaclass_roles} = \@roles;
 470     }
 471
 472     for my $thing (@MetaClassTypes) {
 473         my $name = $self->$thing();
 474
 475         my $thing_meta = Class::MOP::Class->initialize($name);
 476
 477         my @roles = map { $_->name } _all_roles($thing_meta)
 478             or next;
 479
 480         $roles{ $thing . '_roles' } = \@roles;
 481     }
 482
 483     $self->_reinitialize_with($super_meta);
 484
 485     Moose::Util::MetaRole::apply_metaclass_roles(
 486         for_class => $self->name,
 487         %roles,
 488     );
 489
 490     return $self;
 491 }
 492
 493 sub _process_attribute {
 494     my ( $self, $name, @args ) = @_;
 495
 496     @args = %{$args[0]} if scalar @args == 1 && ref($args[0]) eq 'HASH';
 497
 498     if (($name || '') =~ /^\+(.*)/) {
 499         return $self->_process_inherited_attribute($1, @args);
 500     }
 501     else {
 502         return $self->_process_new_attribute($name, @args);
 503     }
 504 }
 505
 506 sub _process_new_attribute {
 507     my ( $self, $name, @args ) = @_;
 508
 509     $self->attribute_metaclass->interpolate_class_and_new($name, @args);
 510 }
 511
 512 sub _process_inherited_attribute {
 513     my ($self, $attr_name, %options) = @_;
 514     my $inherited_attr = $self->find_attribute_by_name($attr_name);
 515     (defined $inherited_attr)
 516         || $self->throw_error("Could not find an attribute by the name of '$attr_name' to inherit from in ${\$self->name}", data => $attr_name);
 517     if ($inherited_attr->isa('Moose::Meta::Attribute')) {
 518         return $inherited_attr->clone_and_inherit_options(%options);
 519     }
 520     else {
 521         # NOTE:
 522         # kind of a kludge to handle Class::MOP::Attributes
 523         return $inherited_attr->Moose::Meta::Attribute::clone_and_inherit_options(%options);
 524     }
 525 }
 526
 527 ## -------------------------------------------------
 528
 529 use Moose::Meta::Method::Constructor;
 530 use Moose::Meta::Method::Destructor;
 531
 532
 533 sub _default_immutable_transformer_options {
 534     my $self = shift;
 535
 536     my %options = $self->SUPER::_default_immutable_transformer_options;
 537
 538     # We need to copy the references as we do not want to alter the
 539     # superclass's references.
 540     $options{cannot_call} = [ @{ $options{cannot_call} }, 'add_role' ];
 541     $options{memoize} = {
 542         %{ $options{memoize} },
 543         calculate_all_roles => 'ARRAY',
 544     };
 545
 546     %options = (
 547         %options,
 548         constructor_class => $self->constructor_class,
 549         destructor_class  => $self->destructor_class,
 550         inline_destructor => 1,
 551
 552         # Moose always does this when an attribute is created
 553         inline_accessors => 0,
 554     );
 555
 556     return %options
 557 }
 558
 559 our $error_level;
 560
 561 sub throw_error {
 562     my ( $self, @args ) = @_;
 563     local $error_level = ($error_level || 0) + 1;
 564     $self->raise_error($self->create_error(@args));
 565 }
 566
 567 sub raise_error {
 568     my ( $self, @args ) = @_;
 569     die @args;
 570 }
 571
 572 sub create_error {
 573     my ( $self, @args ) = @_;
 574
 575     require Carp::Heavy;
 576
 577     local $error_level = ($error_level || 0 ) + 1;
 578
 579     if ( @args % 2 == 1 ) {
 580         unshift @args, "message";
 581     }
 582
 583     my %args = ( metaclass => $self, last_error => $@, @args );
 584
 585     $args{depth} += $error_level;
 586
 587     my $class = ref $self ? $self->error_class : "Moose::Error::Default";
 588
 589     Class::MOP::load_class($class);
 590
 591     $class->new(
 592         Carp::caller_info($args{depth}),
 593         %args
 594     );
 595 }
 596
 597 1;
 598
 599 __END__
 600
 601 =pod
 602
 603 =head1 NAME
 604
 605 Moose::Meta::Class - The Moose metaclass
 606
 607 =head1 DESCRIPTION
 608
 609 This class is a subclass of L<Class::MOP::Class> that provides
 610 additional Moose-specific functionality.
 611
 612 To really understand this class, you will need to start with the
 613 L<Class::MOP::Class> documentation. This class can be understood as a
 614 set of additional features on top of the basic feature provided by
 615 that parent class.
 616
 617 =head1 INHERITANCE
 618
 619 C<Moose::Meta::Class> is a subclass of L<Class::MOP::Class>.
 620
 621 =head1 METHODS
 622
 623 =over 4
 624
 625 =item B<< Moose::Meta::Class->initialize($package_name, %options) >>
 626
 627 This overrides the parent's method in order to provide its own
 628 defaults for the C<attribute_metaclass>, C<instance_metaclass>, and
 629 C<method_metaclass> options.
 630
 631 These all default to the appropriate Moose class.
 632
 633 =item B<< Moose::Meta::Class->create($package_name, %options) >>
 634
 635 This overrides the parent's method in order to accept a C<roles>
 636 option. This should be an array reference containing one more roles
 637 that the class does.
 638
 639   my $metaclass = Moose::Meta::Class->create( 'New::Class', roles => [...] );
 640
 641 =item B<< Moose::Meta::Class->create_anon_class >>
 642
 643 This overrides the parent's method to accept a C<roles> option, just
 644 as C<create> does.
 645
 646 It also accepts a C<cache> option. If this is true, then the anonymous
 647 class will be cached based on its superclasses and roles. If an
 648 existing anonymous class in the cache has the same superclasses and
 649 roles, it will be reused.
 650
 651   my $metaclass = Moose::Meta::Class->create_anon_class(
 652       superclasses => ['Foo'],
 653       roles        => [qw/Some Roles Go Here/],
 654       cache        => 1,
 655   );
 656
 657 =item B<< $metaclass->make_immutable(%options) >>
 658
 659 This overrides the parent's method to add a few options. Specifically,
 660 it uses the Moose-specific constructor and destructor classes, and
 661 enables inlining the destructor.
 662
 663 Also, since Moose always inlines attributes, it sets the
 664 C<inline_accessors> option to false.
 665
 666 =item B<< $metaclass->new_object(%params) >>
 667
 668 This overrides the parent's method in order to add support for
 669 attribute triggers.
 670
 671 =item B<< $metaclass->add_override_method_modifier($name, $sub) >>
 672
 673 This adds an C<override> method modifier to the package.
 674
 675 =item B<< $metaclass->add_augment_method_modifier($name, $sub) >>
 676
 677 This adds an C<augment> method modifier to the package.
 678
 679 =item B<< $metaclass->calculate_all_roles >>
 680
 681 This will return a unique array of C<Moose::Meta::Role> instances
 682 which are attached to this class.
 683
 684 =item B<< $metaclass->add_role($role) >>
 685
 686 This takes a L<Moose::Meta::Role> object, and adds it to the class's
 687 list of roles. This I<does not> actually apply the role to the class.
 688
 689 =item B<< $metaclass->does_role($role_name) >>
 690
 691 This returns a boolean indicating whether or not the class does the
 692 specified role. This tests both the class and its parents.
 693
 694 =item B<< $metaclass->excludes_role($role_name) >>
 695
 696 A class excludes a role if it has already composed a role which
 697 excludes the named role. This tests both the class and its parents.
 698
 699 =item B<< $metaclass->add_attribute($attr_name, %params|$params) >>
 700
 701 This overrides the parent's method in order to allow the parameters to
 702 be provided as a hash reference.
 703
 704 =item B<< $metaclass->constructor_class ($class_name) >>
 705
 706 =item B<< $metaclass->destructor_class ($class_name) >>
 707
 708 These are the names of classes used when making a class
 709 immutable. These default to L<Moose::Meta::Method::Constructor> and
 710 L<Moose::Meta::Method::Destructor> respectively. These accessors are
 711 read-write, so you can use them to change the class name.
 712
 713 =item B<< $metaclass->error_class($class_name) >>
 714
 715 The name of the class used to throw errors. This defaults to
 716 L<Moose::Error::Default>, which generates an error with a stacktrace
 717 just like C<Carp::confess>.
 718
 719 =item B<< $metaclass->throw_error($message, %extra) >>
 720
 721 Throws the error created by C<create_error> using C<raise_error>
 722
 723 =back
 724
 725 =head1 BUGS
 726
 727 All complex software has bugs lurking in it, and this module is no
 728 exception. If you find a bug please either email me, or add the bug
 729 to cpan-RT.
 730
 731 =head1 AUTHOR
 732
 733 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 734
 735 =head1 COPYRIGHT AND LICENSE
 736
 737 Copyright 2006-2009 by Infinity Interactive, Inc.
 738
 739 L<http://www.iinteractive.com>
 740
 741 This library is free software; you can redistribute it and/or modify
 742 it under the same terms as Perl itself.
 743
 744 =cut
 745