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