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::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     my $new_class = $self->SUPER::create_anon_class(%options);
 109
 110     $ANON_CLASSES{$cache_key} = $new_class
 111         if $cache_ok;
 112
 113     return $new_class;
 114 }
 115
 116 sub _meta_method_class { 'Moose::Meta::Method::Meta' }
 117
 118 sub _anon_cache_key {
 119     # Makes something like Super::Class|Super::Class::2=Role|Role::1
 120     return join '=' => (
 121         join( '|', @{ $_[0]      || [] } ),
 122         join( '|', sort @{ $_[1] || [] } ),
 123     );
 124 }
 125
 126 sub reinitialize {
 127     my $self = shift;
 128     my $pkg  = shift;
 129
 130     my $meta = blessed $pkg ? $pkg : Class::MOP::class_of($pkg);
 131
 132     my $cache_key;
 133
 134     my %existing_classes;
 135     if ($meta) {
 136         %existing_classes = map { $_ => $meta->$_() } qw(
 137             attribute_metaclass
 138             method_metaclass
 139             wrapped_method_metaclass
 140             instance_metaclass
 141             constructor_class
 142             destructor_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 _fix_class_metaclass_incompatibility {
 359     my $self = shift;
 360     my ($super_meta) = @_;
 361
 362     $self->SUPER::_fix_class_metaclass_incompatibility(@_);
 363
 364     if ($self->_class_metaclass_can_be_made_compatible($super_meta)) {
 365         ($self->is_pristine)
 366             || confess "Can't fix metaclass incompatibility for "
 367                      . $self->name
 368                      . " because it is not pristine.";
 369         my $super_meta_name = $super_meta->_real_ref_name;
 370         my $class_meta_subclass_meta_name = Moose::Util::_reconcile_roles_for_metaclass(blessed($self), $super_meta_name);
 371         my $new_self = $class_meta_subclass_meta_name->reinitialize(
 372             $self->name,
 373         );
 374
 375         $self->_replace_self( $new_self, $class_meta_subclass_meta_name );
 376     }
 377 }
 378
 379 sub _fix_single_metaclass_incompatibility {
 380     my $self = shift;
 381     my ($metaclass_type, $super_meta) = @_;
 382
 383     $self->SUPER::_fix_single_metaclass_incompatibility(@_);
 384
 385     if ($self->_single_metaclass_can_be_made_compatible($super_meta, $metaclass_type)) {
 386         ($self->is_pristine)
 387             || confess "Can't fix metaclass incompatibility for "
 388                      . $self->name
 389                      . " because it is not pristine.";
 390         my $super_meta_name = $super_meta->_real_ref_name;
 391         my $class_specific_meta_subclass_meta_name = Moose::Util::_reconcile_roles_for_metaclass($self->$metaclass_type, $super_meta->$metaclass_type);
 392         my $new_self = $super_meta->reinitialize(
 393             $self->name,
 394             $metaclass_type => $class_specific_meta_subclass_meta_name,
 395         );
 396
 397         $self->_replace_self( $new_self, $super_meta_name );
 398     }
 399 }
 400
 401 sub _replace_self {
 402     my $self      = shift;
 403     my ( $new_self, $new_class)   = @_;
 404
 405     %$self = %$new_self;
 406     bless $self, $new_class;
 407
 408     # We need to replace the cached metaclass instance or else when it goes
 409     # out of scope Class::MOP::Class destroy's the namespace for the
 410     # metaclass's class, causing much havoc.
 411     Class::MOP::store_metaclass_by_name( $self->name, $self );
 412     Class::MOP::weaken_metaclass( $self->name ) if $self->is_anon_class;
 413 }
 414
 415 sub _process_attribute {
 416     my ( $self, $name, @args ) = @_;
 417
 418     @args = %{$args[0]} if scalar @args == 1 && ref($args[0]) eq 'HASH';
 419
 420     if (($name || '') =~ /^\+(.*)/) {
 421         return $self->_process_inherited_attribute($1, @args);
 422     }
 423     else {
 424         return $self->_process_new_attribute($name, @args);
 425     }
 426 }
 427
 428 sub _process_new_attribute {
 429     my ( $self, $name, @args ) = @_;
 430
 431     $self->attribute_metaclass->interpolate_class_and_new($name, @args);
 432 }
 433
 434 sub _process_inherited_attribute {
 435     my ($self, $attr_name, %options) = @_;
 436     my $inherited_attr = $self->find_attribute_by_name($attr_name);
 437     (defined $inherited_attr)
 438         || $self->throw_error("Could not find an attribute by the name of '$attr_name' to inherit from in ${\$self->name}", data => $attr_name);
 439     if ($inherited_attr->isa('Moose::Meta::Attribute')) {
 440         return $inherited_attr->clone_and_inherit_options(%options);
 441     }
 442     else {
 443         # NOTE:
 444         # kind of a kludge to handle Class::MOP::Attributes
 445         return $inherited_attr->Moose::Meta::Attribute::clone_and_inherit_options(%options);
 446     }
 447 }
 448
 449 ## Immutability
 450
 451 sub _immutable_options {
 452     my ( $self, @args ) = @_;
 453
 454     $self->SUPER::_immutable_options(
 455         inline_destructor => 1,
 456
 457         # Moose always does this when an attribute is created
 458         inline_accessors => 0,
 459
 460         @args,
 461     );
 462 }
 463
 464 ## -------------------------------------------------
 465
 466 our $error_level;
 467
 468 sub throw_error {
 469     my ( $self, @args ) = @_;
 470     local $error_level = ($error_level || 0) + 1;
 471     $self->raise_error($self->create_error(@args));
 472 }
 473
 474 sub raise_error {
 475     my ( $self, @args ) = @_;
 476     die @args;
 477 }
 478
 479 sub create_error {
 480     my ( $self, @args ) = @_;
 481
 482     require Carp::Heavy;
 483
 484     local $error_level = ($error_level || 0 ) + 1;
 485
 486     if ( @args % 2 == 1 ) {
 487         unshift @args, "message";
 488     }
 489
 490     my %args = ( metaclass => $self, last_error => $@, @args );
 491
 492     $args{depth} += $error_level;
 493
 494     my $class = ref $self ? $self->error_class : "Moose::Error::Default";
 495
 496     Class::MOP::load_class($class);
 497
 498     $class->new(
 499         Carp::caller_info($args{depth}),
 500         %args
 501     );
 502 }
 503
 504 1;
 505
 506 __END__
 507
 508 =pod
 509
 510 =head1 NAME
 511
 512 Moose::Meta::Class - The Moose metaclass
 513
 514 =head1 DESCRIPTION
 515
 516 This class is a subclass of L<Class::MOP::Class> that provides
 517 additional Moose-specific functionality.
 518
 519 To really understand this class, you will need to start with the
 520 L<Class::MOP::Class> documentation. This class can be understood as a
 521 set of additional features on top of the basic feature provided by
 522 that parent class.
 523
 524 =head1 INHERITANCE
 525
 526 C<Moose::Meta::Class> is a subclass of L<Class::MOP::Class>.
 527
 528 =head1 METHODS
 529
 530 =over 4
 531
 532 =item B<< Moose::Meta::Class->initialize($package_name, %options) >>
 533
 534 This overrides the parent's method in order to provide its own
 535 defaults for the C<attribute_metaclass>, C<instance_metaclass>, and
 536 C<method_metaclass> options.
 537
 538 These all default to the appropriate Moose class.
 539
 540 =item B<< Moose::Meta::Class->create($package_name, %options) >>
 541
 542 This overrides the parent's method in order to accept a C<roles>
 543 option. This should be an array reference containing roles
 544 that the class does, each optionally followed by a hashref of options
 545 (C<-excludes> and C<-alias>).
 546
 547   my $metaclass = Moose::Meta::Class->create( 'New::Class', roles => [...] );
 548
 549 =item B<< Moose::Meta::Class->create_anon_class >>
 550
 551 This overrides the parent's method to accept a C<roles> option, just
 552 as C<create> does.
 553
 554 It also accepts a C<cache> option. If this is true, then the anonymous
 555 class will be cached based on its superclasses and roles. If an
 556 existing anonymous class in the cache has the same superclasses and
 557 roles, it will be reused.
 558
 559   my $metaclass = Moose::Meta::Class->create_anon_class(
 560       superclasses => ['Foo'],
 561       roles        => [qw/Some Roles Go Here/],
 562       cache        => 1,
 563   );
 564
 565 Each entry in both the C<superclasses> and the C<roles> option can be
 566 followed by a hash reference with arguments. The C<superclasses>
 567 option can be supplied with a L<-version|Class::MOP/Class Loading
 568 Options> option that ensures the loaded superclass satisfies the
 569 required version. The C<role> option also takes the C<-version> as an
 570 argument, but the option hash reference can also contain any other
 571 role relevant values like exclusions or parameterized role arguments.
 572
 573 =item B<< $metaclass->make_immutable(%options) >>
 574
 575 This overrides the parent's method to add a few options. Specifically,
 576 it uses the Moose-specific constructor and destructor classes, and
 577 enables inlining the destructor.
 578
 579 Since Moose always inlines attributes, it sets the C<inline_accessors> option
 580 to false.
 581
 582 =item B<< $metaclass->new_object(%params) >>
 583
 584 This overrides the parent's method in order to add support for
 585 attribute triggers.
 586
 587 =item B<< $metaclass->superclasses(@superclasses) >>
 588
 589 This is the accessor allowing you to read or change the parents of
 590 the class.
 591
 592 Each superclass can be followed by a hash reference containing a
 593 L<-version|Class::MOP/Class Loading Options> value. If the version
 594 requirement is not satisfied an error will be thrown.
 595
 596 =item B<< $metaclass->add_override_method_modifier($name, $sub) >>
 597
 598 This adds an C<override> method modifier to the package.
 599
 600 =item B<< $metaclass->add_augment_method_modifier($name, $sub) >>
 601
 602 This adds an C<augment> method modifier to the package.
 603
 604 =item B<< $metaclass->calculate_all_roles >>
 605
 606 This will return a unique array of C<Moose::Meta::Role> instances
 607 which are attached to this class.
 608
 609 =item B<< $metaclass->calculate_all_roles_with_inheritance >>
 610
 611 This will return a unique array of C<Moose::Meta::Role> instances
 612 which are attached to this class, and each of this class's ancestors.
 613
 614 =item B<< $metaclass->add_role($role) >>
 615
 616 This takes a L<Moose::Meta::Role> object, and adds it to the class's
 617 list of roles. This I<does not> actually apply the role to the class.
 618
 619 =item B<< $metaclass->role_applications >>
 620
 621 Returns a list of L<Moose::Meta::Role::Application::ToClass>
 622 objects, which contain the arguments to role application.
 623
 624 =item B<< $metaclass->add_role_application($application) >>
 625
 626 This takes a L<Moose::Meta::Role::Application::ToClass> object, and
 627 adds it to the class's list of role applications. This I<does not>
 628 actually apply any role to the class; it is only for tracking role
 629 applications.
 630
 631 =item B<< $metaclass->does_role($role) >>
 632
 633 This returns a boolean indicating whether or not the class does the specified
 634 role. The role provided can be either a role name or a L<Moose::Meta::Role>
 635 object. This tests both the class and its parents.
 636
 637 =item B<< $metaclass->excludes_role($role_name) >>
 638
 639 A class excludes a role if it has already composed a role which
 640 excludes the named role. This tests both the class and its parents.
 641
 642 =item B<< $metaclass->add_attribute($attr_name, %params|$params) >>
 643
 644 This overrides the parent's method in order to allow the parameters to
 645 be provided as a hash reference.
 646
 647 =item B<< $metaclass->constructor_class($class_name) >>
 648
 649 =item B<< $metaclass->destructor_class($class_name) >>
 650
 651 These are the names of classes used when making a class immutable. These
 652 default to L<Moose::Meta::Method::Constructor> and
 653 L<Moose::Meta::Method::Destructor> respectively. These accessors are
 654 read-write, so you can use them to change the class name.
 655
 656 =item B<< $metaclass->error_class($class_name) >>
 657
 658 The name of the class used to throw errors. This defaults to
 659 L<Moose::Error::Default>, which generates an error with a stacktrace
 660 just like C<Carp::confess>.
 661
 662 =item B<< $metaclass->throw_error($message, %extra) >>
 663
 664 Throws the error created by C<create_error> using C<raise_error>
 665
 666 =back
 667
 668 =head1 BUGS
 669
 670 See L<Moose/BUGS> for details on reporting bugs.
 671
 672 =head1 AUTHOR
 673
 674 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 675
 676 =head1 COPYRIGHT AND LICENSE
 677
 678 Copyright 2006-2010 by Infinity Interactive, Inc.
 679
 680 L<http://www.iinteractive.com>
 681
 682 This library is free software; you can redistribute it and/or modify
 683 it under the same terms as Perl itself.
 684
 685 =cut
 686