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.19';
  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 ## Immutability
 457
 458 sub _immutable_options {
 459     my ( $self, @args ) = @_;
 460
 461     $self->SUPER::_immutable_options(
 462         inline_destructor => 1,
 463
 464         # Moose always does this when an attribute is created
 465         inline_accessors => 0,
 466
 467         @args,
 468     );
 469 }
 470
 471 ## -------------------------------------------------
 472
 473 our $error_level;
 474
 475 sub throw_error {
 476     my ( $self, @args ) = @_;
 477     local $error_level = ($error_level || 0) + 1;
 478     $self->raise_error($self->create_error(@args));
 479 }
 480
 481 sub raise_error {
 482     my ( $self, @args ) = @_;
 483     die @args;
 484 }
 485
 486 sub create_error {
 487     my ( $self, @args ) = @_;
 488
 489     require Carp::Heavy;
 490
 491     local $error_level = ($error_level || 0 ) + 1;
 492
 493     if ( @args % 2 == 1 ) {
 494         unshift @args, "message";
 495     }
 496
 497     my %args = ( metaclass => $self, last_error => $@, @args );
 498
 499     $args{depth} += $error_level;
 500
 501     my $class = ref $self ? $self->error_class : "Moose::Error::Default";
 502
 503     Class::MOP::load_class($class);
 504
 505     $class->new(
 506         Carp::caller_info($args{depth}),
 507         %args
 508     );
 509 }
 510
 511 1;
 512
 513 __END__
 514
 515 =pod
 516
 517 =head1 NAME
 518
 519 Moose::Meta::Class - The Moose metaclass
 520
 521 =head1 DESCRIPTION
 522
 523 This class is a subclass of L<Class::MOP::Class> that provides
 524 additional Moose-specific functionality.
 525
 526 To really understand this class, you will need to start with the
 527 L<Class::MOP::Class> documentation. This class can be understood as a
 528 set of additional features on top of the basic feature provided by
 529 that parent class.
 530
 531 =head1 INHERITANCE
 532
 533 C<Moose::Meta::Class> is a subclass of L<Class::MOP::Class>.
 534
 535 =head1 METHODS
 536
 537 =over 4
 538
 539 =item B<< Moose::Meta::Class->initialize($package_name, %options) >>
 540
 541 This overrides the parent's method in order to provide its own
 542 defaults for the C<attribute_metaclass>, C<instance_metaclass>, and
 543 C<method_metaclass> options.
 544
 545 These all default to the appropriate Moose class.
 546
 547 =item B<< Moose::Meta::Class->create($package_name, %options) >>
 548
 549 This overrides the parent's method in order to accept a C<roles>
 550 option. This should be an array reference containing roles
 551 that the class does, each optionally followed by a hashref of options
 552 (C<-excludes> and C<-alias>).
 553
 554   my $metaclass = Moose::Meta::Class->create( 'New::Class', roles => [...] );
 555
 556 =item B<< Moose::Meta::Class->create_anon_class >>
 557
 558 This overrides the parent's method to accept a C<roles> option, just
 559 as C<create> does.
 560
 561 It also accepts a C<cache> option. If this is true, then the anonymous
 562 class will be cached based on its superclasses and roles. If an
 563 existing anonymous class in the cache has the same superclasses and
 564 roles, it will be reused.
 565
 566   my $metaclass = Moose::Meta::Class->create_anon_class(
 567       superclasses => ['Foo'],
 568       roles        => [qw/Some Roles Go Here/],
 569       cache        => 1,
 570   );
 571
 572 Each entry in both the C<superclasses> and the C<roles> option can be
 573 followed by a hash reference with arguments. The C<superclasses>
 574 option can be supplied with a L<-version|Class::MOP/Class Loading
 575 Options> option that ensures the loaded superclass satisfies the
 576 required version. The C<role> option also takes the C<-version> as an
 577 argument, but the option hash reference can also contain any other
 578 role relevant values like exclusions or parameterized role arguments.
 579
 580 =item B<< $metaclass->make_immutable(%options) >>
 581
 582 This overrides the parent's method to add a few options. Specifically,
 583 it uses the Moose-specific constructor and destructor classes, and
 584 enables inlining the destructor.
 585
 586 Since Moose always inlines attributes, it sets the C<inline_accessors> option
 587 to false.
 588
 589 =item B<< $metaclass->new_object(%params) >>
 590
 591 This overrides the parent's method in order to add support for
 592 attribute triggers.
 593
 594 =item B<< $metaclass->superclasses(@superclasses) >>
 595
 596 This is the accessor allowing you to read or change the parents of
 597 the class.
 598
 599 Each superclass can be followed by a hash reference containing a
 600 L<-version|Class::MOP/Class Loading Options> value. If the version
 601 requirement is not satisfied an error will be thrown.
 602
 603 =item B<< $metaclass->add_override_method_modifier($name, $sub) >>
 604
 605 This adds an C<override> method modifier to the package.
 606
 607 =item B<< $metaclass->add_augment_method_modifier($name, $sub) >>
 608
 609 This adds an C<augment> method modifier to the package.
 610
 611 =item B<< $metaclass->calculate_all_roles >>
 612
 613 This will return a unique array of C<Moose::Meta::Role> instances
 614 which are attached to this class.
 615
 616 =item B<< $metaclass->calculate_all_roles_with_inheritance >>
 617
 618 This will return a unique array of C<Moose::Meta::Role> instances
 619 which are attached to this class, and each of this class's ancestors.
 620
 621 =item B<< $metaclass->add_role($role) >>
 622
 623 This takes a L<Moose::Meta::Role> object, and adds it to the class's
 624 list of roles. This I<does not> actually apply the role to the class.
 625
 626 =item B<< $metaclass->role_applications >>
 627
 628 Returns a list of L<Moose::Meta::Role::Application::ToClass>
 629 objects, which contain the arguments to role application.
 630
 631 =item B<< $metaclass->add_role_application($application) >>
 632
 633 This takes a L<Moose::Meta::Role::Application::ToClass> object, and
 634 adds it to the class's list of role applications. This I<does not>
 635 actually apply any role to the class; it is only for tracking role
 636 applications.
 637
 638 =item B<< $metaclass->does_role($role) >>
 639
 640 This returns a boolean indicating whether or not the class does the specified
 641 role. The role provided can be either a role name or a L<Moose::Meta::Role>
 642 object. This tests both the class and its parents.
 643
 644 =item B<< $metaclass->excludes_role($role_name) >>
 645
 646 A class excludes a role if it has already composed a role which
 647 excludes the named role. This tests both the class and its parents.
 648
 649 =item B<< $metaclass->add_attribute($attr_name, %params|$params) >>
 650
 651 This overrides the parent's method in order to allow the parameters to
 652 be provided as a hash reference.
 653
 654 =item B<< $metaclass->constructor_class($class_name) >>
 655
 656 =item B<< $metaclass->destructor_class($class_name) >>
 657
 658 These are the names of classes used when making a class immutable. These
 659 default to L<Moose::Meta::Method::Constructor> and
 660 L<Moose::Meta::Method::Destructor> respectively. These accessors are
 661 read-write, so you can use them to change the class name.
 662
 663 =item B<< $metaclass->error_class($class_name) >>
 664
 665 The name of the class used to throw errors. This defaults to
 666 L<Moose::Error::Default>, which generates an error with a stacktrace
 667 just like C<Carp::confess>.
 668
 669 =item B<< $metaclass->throw_error($message, %extra) >>
 670
 671 Throws the error created by C<create_error> using C<raise_error>
 672
 673 =back
 674
 675 =head1 BUGS
 676
 677 See L<Moose/BUGS> for details on reporting bugs.
 678
 679 =head1 AUTHOR
 680
 681 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 682
 683 =head1 COPYRIGHT AND LICENSE
 684
 685 Copyright 2006-2010 by Infinity Interactive, Inc.
 686
 687 L<http://www.iinteractive.com>
 688
 689 This library is free software; you can redistribute it and/or modify
 690 it under the same terms as Perl itself.
 691
 692 =cut
 693