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 Scalar::Util 'weaken', 'blessed';
  11
  12 our $VERSION   = '0.57';
  13 $VERSION = eval $VERSION;
  14 our $AUTHORITY = 'cpan:STEVAN';
  15
  16 use Moose::Meta::Method::Overriden;
  17 use Moose::Meta::Method::Augmented;
  18
  19 use base 'Class::MOP::Class';
  20
  21 __PACKAGE__->meta->add_attribute('roles' => (
  22     reader  => 'roles',
  23     default => sub { [] }
  24 ));
  25
  26 __PACKAGE__->meta->add_attribute('constructor_class' => (
  27     accessor => 'constructor_class',
  28     default  => sub { 'Moose::Meta::Method::Constructor' }
  29 ));
  30
  31 __PACKAGE__->meta->add_attribute('destructor_class' => (
  32     accessor => 'destructor_class',
  33     default  => sub { 'Moose::Meta::Method::Destructor' }
  34 ));
  35
  36 __PACKAGE__->meta->add_attribute('error_builder' => (
  37     reader  => 'error_builder',
  38     default => 'confess',
  39 ));
  40
  41 __PACKAGE__->meta->add_attribute('error_class' => (
  42     reader  => 'error_class',
  43 ));
  44
  45
  46 sub initialize {
  47     my $class = shift;
  48     my $pkg   = shift;
  49     return Class::MOP::get_metaclass_by_name($pkg)
  50         || $class->SUPER::initialize($pkg,
  51                 'attribute_metaclass' => 'Moose::Meta::Attribute',
  52                 'method_metaclass'    => 'Moose::Meta::Method',
  53                 'instance_metaclass'  => 'Moose::Meta::Instance',
  54                 @_
  55             );
  56 }
  57
  58 sub create {
  59     my ($self, $package_name, %options) = @_;
  60
  61     (ref $options{roles} eq 'ARRAY')
  62         || $self->throw_error("You must pass an ARRAY ref of roles", data => $options{roles})
  63             if exists $options{roles};
  64
  65     my $class = $self->SUPER::create($package_name, %options);
  66
  67     if (exists $options{roles}) {
  68         Moose::Util::apply_all_roles($class, @{$options{roles}});
  69     }
  70
  71     return $class;
  72 }
  73
  74 my %ANON_CLASSES;
  75
  76 sub create_anon_class {
  77     my ($self, %options) = @_;
  78
  79     my $cache_ok = delete $options{cache};
  80
  81     # something like Super::Class|Super::Class::2=Role|Role::1
  82     my $cache_key = join '=' => (
  83         join('|', sort @{$options{superclasses} || []}),
  84         join('|', sort @{$options{roles}        || []}),
  85     );
  86
  87     if ($cache_ok && defined $ANON_CLASSES{$cache_key}) {
  88         return $ANON_CLASSES{$cache_key};
  89     }
  90
  91     my $new_class = $self->SUPER::create_anon_class(%options);
  92
  93     $ANON_CLASSES{$cache_key} = $new_class
  94         if $cache_ok;
  95
  96     return $new_class;
  97 }
  98
  99 sub add_role {
 100     my ($self, $role) = @_;
 101     (blessed($role) && $role->isa('Moose::Meta::Role'))
 102         || $self->throw_error("Roles must be instances of Moose::Meta::Role", data => $role);
 103     push @{$self->roles} => $role;
 104 }
 105
 106 sub calculate_all_roles {
 107     my $self = shift;
 108     my %seen;
 109     grep { !$seen{$_->name}++ } map { $_->calculate_all_roles } @{ $self->roles };
 110 }
 111
 112 sub does_role {
 113     my ($self, $role_name) = @_;
 114     (defined $role_name)
 115         || $self->throw_error("You must supply a role name to look for");
 116     foreach my $class ($self->class_precedence_list) {
 117         next unless $class->can('meta') && $class->meta->can('roles');
 118         foreach my $role (@{$class->meta->roles}) {
 119             return 1 if $role->does_role($role_name);
 120         }
 121     }
 122     return 0;
 123 }
 124
 125 sub excludes_role {
 126     my ($self, $role_name) = @_;
 127     (defined $role_name)
 128         || $self->throw_error("You must supply a role name to look for");
 129     foreach my $class ($self->class_precedence_list) {
 130         next unless $class->can('meta');
 131         # NOTE:
 132         # in the pretty rare instance when a Moose metaclass
 133         # is itself extended with a role, this check needs to
 134         # be done since some items in the class_precedence_list
 135         # might in fact be Class::MOP based still.
 136         next unless $class->meta->can('roles');
 137         foreach my $role (@{$class->meta->roles}) {
 138             return 1 if $role->excludes_role($role_name);
 139         }
 140     }
 141     return 0;
 142 }
 143
 144 sub new_object {
 145     my $class = shift;
 146     my $params = @_ == 1 ? $_[0] : {@_};
 147     my $self = $class->SUPER::new_object($params);
 148     foreach my $attr ($class->compute_all_applicable_attributes()) {
 149         # if we have a trigger, then ...
 150         if ($attr->can('has_trigger') && $attr->has_trigger) {
 151             # make sure we have an init-arg ...
 152             if (defined(my $init_arg = $attr->init_arg)) {
 153                 # now make sure an init-arg was passes ...
 154                 if (exists $params->{$init_arg}) {
 155                     # and if get here, fire the trigger
 156                     $attr->trigger->(
 157                         $self,
 158                         # check if there is a coercion
 159                         ($attr->should_coerce
 160                             # and if so, we need to grab the
 161                             # value that is actually been stored
 162                             ? $attr->get_read_method_ref->($self)
 163                             # otherwise, just get the value from
 164                             # the constructor params
 165                             : $params->{$init_arg}),
 166                         $attr
 167                     );
 168                 }
 169             }
 170         }
 171     }
 172     return $self;
 173 }
 174
 175 sub construct_instance {
 176     my $class = shift;
 177     my $params = @_ == 1 ? $_[0] : {@_};
 178     my $meta_instance = $class->get_meta_instance;
 179     # FIXME:
 180     # the code below is almost certainly incorrect
 181     # but this is foreign inheritence, so we might
 182     # have to kludge it in the end.
 183     my $instance = $params->{'__INSTANCE__'} || $meta_instance->create_instance();
 184     foreach my $attr ($class->compute_all_applicable_attributes()) {
 185         $attr->initialize_instance_slot($meta_instance, $instance, $params);
 186     }
 187     return $instance;
 188 }
 189
 190 # FIXME:
 191 # This is ugly
 192 sub get_method_map {
 193     my $self = shift;
 194
 195     my $current = Class::MOP::check_package_cache_flag($self->name);
 196
 197     if (defined $self->{'_package_cache_flag'} && $self->{'_package_cache_flag'} == $current) {
 198         return $self->{'methods'};
 199     }
 200
 201     $self->{_package_cache_flag} = $current;
 202
 203     my $map  = $self->{'methods'};
 204
 205     my $class_name       = $self->name;
 206     my $method_metaclass = $self->method_metaclass;
 207
 208     my %all_code = $self->get_all_package_symbols('CODE');
 209
 210     foreach my $symbol (keys %all_code) {
 211         my $code = $all_code{$symbol};
 212
 213         next if exists  $map->{$symbol} &&
 214                 defined $map->{$symbol} &&
 215                         $map->{$symbol}->body == $code;
 216
 217         my ($pkg, $name) = Class::MOP::get_code_info($code);
 218
 219         if ($pkg->can('meta')
 220             # NOTE:
 221             # we don't know what ->meta we are calling
 222             # here, so we need to be careful cause it
 223             # just might blow up at us, or just complain
 224             # loudly (in the case of Curses.pm) so we
 225             # just be a little overly cautious here.
 226             # - SL
 227             && eval { no warnings; blessed($pkg->meta) }
 228             && $pkg->meta->isa('Moose::Meta::Role')) {
 229             #my $role = $pkg->meta->name;
 230             #next unless $self->does_role($role);
 231         }
 232         else {
 233
 234             # NOTE:
 235             # in 5.10 constant.pm the constants show up
 236             # as being in the right package, but in pre-5.10
 237             # they show up as constant::__ANON__ so we
 238             # make an exception here to be sure that things
 239             # work as expected in both.
 240             # - SL
 241             unless ($pkg eq 'constant' && $name eq '__ANON__') {
 242                 next if ($pkg  || '') ne $class_name ||
 243                         (($name || '') ne '__ANON__' && ($pkg  || '') ne $class_name);
 244             }
 245
 246         }
 247
 248         $map->{$symbol} = $method_metaclass->wrap(
 249             $code,
 250             package_name => $class_name,
 251             name         => $symbol
 252         );
 253     }
 254
 255     return $map;
 256 }
 257
 258 ### ---------------------------------------------
 259
 260 sub add_attribute {
 261     my $self = shift;
 262     $self->SUPER::add_attribute(
 263         (blessed $_[0] && $_[0]->isa('Class::MOP::Attribute')
 264             ? $_[0]
 265             : $self->_process_attribute(@_))
 266     );
 267 }
 268
 269 sub add_override_method_modifier {
 270     my ($self, $name, $method, $_super_package) = @_;
 271
 272     (!$self->has_method($name))
 273         || $self->throw_error("Cannot add an override method if a local method is already present");
 274
 275     $self->add_method($name => Moose::Meta::Method::Overriden->new(
 276         method  => $method,
 277         class   => $self,
 278         package => $_super_package, # need this for roles
 279         name    => $name,
 280     ));
 281 }
 282
 283 sub add_augment_method_modifier {
 284     my ($self, $name, $method) = @_;
 285     (!$self->has_method($name))
 286         || $self->throw_error("Cannot add an augment method if a local method is already present");
 287
 288     $self->add_method($name => Moose::Meta::Method::Augmented->new(
 289         method  => $method,
 290         class   => $self,
 291         name    => $name,
 292     ));
 293 }
 294
 295 ## Private Utility methods ...
 296
 297 sub _find_next_method_by_name_which_is_not_overridden {
 298     my ($self, $name) = @_;
 299     foreach my $method ($self->find_all_methods_by_name($name)) {
 300         return $method->{code}
 301             if blessed($method->{code}) && !$method->{code}->isa('Moose::Meta::Method::Overriden');
 302     }
 303     return undef;
 304 }
 305
 306 # Right now, this method does not handle the case where two
 307 # metaclasses differ only in roles applied against a common parent
 308 # class. This can happen fairly easily when ClassA applies metaclass
 309 # Role1, and then a subclass, ClassB, applies a metaclass Role2. In
 310 # reality, the way to resolve the problem is to apply Role1 to
 311 # ClassB's metaclass. However, we cannot currently detect this, and so
 312 # we simply fail to fix the incompatibility.
 313 #
 314 # The algorithm for fixing it is not that complicated.
 315 #
 316 # First, we see if the two metaclasses share a common parent (probably
 317 # Moose::Meta::Class).
 318 #
 319 # Second, we see if the metaclasses only differ in terms of roles
 320 # applied. This second point is where things break down. There is no
 321 # easy way to determine if the difference is from roles only. To do
 322 # that, we'd need to able to reliably determine the origin of each
 323 # method and attribute in each metaclass. If all the unshared methods
 324 # & attributes come from roles, and there is no name collision, then
 325 # we can apply the missing roles to the child's metaclass.
 326 #
 327 # Tracking the origin of these things will require some fairly
 328 # invasive changes to various parts of Moose & Class::MOP.
 329 #
 330 # For now, the workaround is for ClassB to subclass ClassA _and then_
 331 # apply metaclass roles to its metaclass.
 332 sub _fix_metaclass_incompatability {
 333     my ($self, @superclasses) = @_;
 334
 335     foreach my $super (@superclasses) {
 336         # don't bother if it does not have a meta.
 337         my $super_meta = Class::MOP::Class->initialize($super) or next;
 338         next unless $super_meta->isa("Class::MOP::Class");
 339
 340         # get the name, make sure we take
 341         # immutable classes into account
 342         my $super_meta_name
 343             = $super_meta->is_immutable
 344             ? $super_meta->get_mutable_metaclass_name
 345             : ref($super_meta);
 346
 347         next if
 348             # if our metaclass is compatible
 349             $self->isa($super_meta_name)
 350                 and
 351             # and our instance metaclass is also compatible then no
 352             # fixes are needed
 353             $self->instance_metaclass->isa( $super_meta->instance_metaclass );
 354
 355         next unless $super_meta->isa( ref($self) );
 356
 357         unless ( $self->is_pristine ) {
 358             $self->throw_error("Not reinitializing metaclass for "
 359                 . $self->name
 360                 . ", it isn't pristine");
 361         }
 362
 363         $self = $super_meta->reinitialize(
 364             $self->name,
 365             attribute_metaclass => $super_meta->attribute_metaclass,
 366             method_metaclass    => $super_meta->method_metaclass,
 367             instance_metaclass  => $super_meta->instance_metaclass,
 368         );
 369
 370         $self->$_( $super_meta->$_ )
 371             for qw( constructor_class destructor_class );
 372     }
 373
 374     return $self;
 375 }
 376
 377 # NOTE:
 378 # this was crap anyway, see
 379 # Moose::Util::apply_all_roles
 380 # instead
 381 sub _apply_all_roles {
 382     Carp::croak 'DEPRECATED: use Moose::Util::apply_all_roles($meta, @roles) instead'
 383 }
 384
 385 sub _process_attribute {
 386     my ( $self, $name, @args ) = @_;
 387
 388     @args = %{$args[0]} if scalar @args == 1 && ref($args[0]) eq 'HASH';
 389
 390     if ($name =~ /^\+(.*)/) {
 391         return $self->_process_inherited_attribute($1, @args);
 392     }
 393     else {
 394         return $self->_process_new_attribute($name, @args);
 395     }
 396 }
 397
 398 sub _process_new_attribute {
 399     my ( $self, $name, @args ) = @_;
 400
 401     $self->attribute_metaclass->interpolate_class_and_new($name, @args);
 402 }
 403
 404 sub _process_inherited_attribute {
 405     my ($self, $attr_name, %options) = @_;
 406     my $inherited_attr = $self->find_attribute_by_name($attr_name);
 407     (defined $inherited_attr)
 408         || $self->throw_error("Could not find an attribute by the name of '$attr_name' to inherit from", data => $attr_name);
 409     if ($inherited_attr->isa('Moose::Meta::Attribute')) {
 410         return $inherited_attr->clone_and_inherit_options(%options);
 411     }
 412     else {
 413         # NOTE:
 414         # kind of a kludge to handle Class::MOP::Attributes
 415         return $inherited_attr->Moose::Meta::Attribute::clone_and_inherit_options(%options);
 416     }
 417 }
 418
 419 ## -------------------------------------------------
 420
 421 use Moose::Meta::Method::Constructor;
 422 use Moose::Meta::Method::Destructor;
 423
 424 # This could be done by using SUPER and altering ->options
 425 # I am keeping it this way to make it more explicit.
 426 sub create_immutable_transformer {
 427     my $self = shift;
 428     my $class = Class::MOP::Immutable->new($self, {
 429        read_only   => [qw/superclasses/],
 430        cannot_call => [qw/
 431            add_method
 432            alias_method
 433            remove_method
 434            add_attribute
 435            remove_attribute
 436            remove_package_symbol
 437            add_role
 438        /],
 439        memoize     => {
 440            class_precedence_list             => 'ARRAY',
 441            linearized_isa                    => 'ARRAY', # FIXME perl 5.10 memoizes this on its own, no need?
 442            get_all_methods                   => 'ARRAY',
 443            #get_all_attributes               => 'ARRAY', # it's an alias, no need, but maybe in the future
 444            compute_all_applicable_attributes => 'ARRAY',
 445            get_meta_instance                 => 'SCALAR',
 446            get_method_map                    => 'SCALAR',
 447            calculate_all_roles               => 'ARRAY',
 448        },
 449        # NOTE:
 450        # this is ugly, but so are typeglobs,
 451        # so whattayahgonnadoboutit
 452        # - SL
 453        wrapped => {
 454            add_package_symbol => sub {
 455                my $original = shift;
 456                $self->throw_error("Cannot add package symbols to an immutable metaclass")
 457                    unless (caller(2))[3] eq 'Class::MOP::Package::get_package_symbol';
 458                goto $original->body;
 459            },
 460        },
 461     });
 462     return $class;
 463 }
 464
 465 sub make_immutable {
 466     my $self = shift;
 467     $self->SUPER::make_immutable
 468       (
 469        constructor_class => $self->constructor_class,
 470        destructor_class  => $self->destructor_class,
 471        inline_destructor => 1,
 472        # NOTE:
 473        # no need to do this,
 474        # Moose always does it
 475        inline_accessors  => 0,
 476        @_,
 477       );
 478 }
 479
 480 #{ package Moose::Meta::Class::ErrorRoutines; %Carp::Internal?
 481
 482 our $level;
 483
 484 sub throw_error {
 485     my ( $self, @args ) = @_;
 486     local $level = 1;
 487     $self->raise_error($self->create_error(@args));
 488 }
 489
 490 sub raise_error {
 491     my ( $self, @args ) = @_;
 492     die @args;
 493 }
 494
 495 sub create_error {
 496     my ( $self, @args ) = @_;
 497
 498     if ( @args % 2 == 1 ) {
 499         unshift @args, "message";
 500     }
 501
 502     my %args = ( meta => $self, error => $@, @args );
 503
 504     local $level = $level + 1;
 505
 506     if ( my $class = $args{class} || ( ref $self && $self->error_class ) ) {
 507         return $self->create_error_object( %args, class => $class );
 508     } else {
 509         my $builder = $args{builder} || ( ref($self) ? $self->error_builder : "confess" );
 510
 511         my $builder_method = ( ( ref($builder) && ref($builder) eq 'CODE' )
 512             ? $builder
 513             : ( $self->can("create_error_$builder") || "create_error_confess" ));
 514
 515         return $self->$builder_method(%args);
 516     }
 517 }
 518
 519 sub create_error_object {
 520     my ( $self, %args ) = @_;
 521
 522     my $class = delete $args{class};
 523
 524     $class->new(
 525         %args,
 526         depth => ( ($args{depth} || 1) + ( $level + 1 ) ),
 527     );
 528 }
 529
 530 sub create_error_croak {
 531     my ( $self, @args ) = @_;
 532     $self->_create_error_carpmess( @args );
 533 }
 534
 535 sub create_error_confess {
 536     my ( $self, @args ) = @_;
 537     $self->_create_error_carpmess( @args, longmess => 1 );
 538 }
 539
 540 sub _create_error_carpmess {
 541     my ( $self, %args ) = @_;
 542
 543     my $carp_level = $level + 1 + ( $args{depth} || 1 );
 544
 545     local $Carp::CarpLevel = $carp_level; # $Carp::CarpLevel + $carp_level ?
 546     local $Carp::MaxArgNums = 20;         # default is 8, usually we use named args which gets messier though
 547
 548     my @args = exists $args{message} ? $args{message} : ();
 549
 550     if ( $args{longmess} ) {
 551         return Carp::longmess(@args);
 552     } else {
 553         return Carp::shortmess(@args);
 554     }
 555 }
 556
 557 1;
 558
 559 __END__
 560
 561 =pod
 562
 563 =head1 NAME
 564
 565 Moose::Meta::Class - The Moose metaclass
 566
 567 =head1 DESCRIPTION
 568
 569 This is a subclass of L<Class::MOP::Class> with Moose specific
 570 extensions.
 571
 572 For the most part, the only time you will ever encounter an
 573 instance of this class is if you are doing some serious deep
 574 introspection. To really understand this class, you need to refer
 575 to the L<Class::MOP::Class> documentation.
 576
 577 =head1 METHODS
 578
 579 =over 4
 580
 581 =item B<initialize>
 582
 583 =item B<create>
 584
 585 Overrides original to accept a list of roles to apply to
 586 the created class.
 587
 588    my $metaclass = Moose::Meta::Class->create( 'New::Class', roles => [...] );
 589
 590 =item B<create_anon_class>
 591
 592 Overrides original to support roles and caching.
 593
 594    my $metaclass = Moose::Meta::Class->create_anon_class(
 595        superclasses => ['Foo'],
 596        roles        => [qw/Some Roles Go Here/],
 597        cache        => 1,
 598    );
 599
 600 =item B<make_immutable>
 601
 602 Override original to add default options for inlining destructor
 603 and altering the Constructor metaclass.
 604
 605 =item B<create_immutable_transformer>
 606
 607 Override original to lock C<add_role> and memoize C<calculate_all_roles>
 608
 609 =item B<new_object>
 610
 611 We override this method to support the C<trigger> attribute option.
 612
 613 =item B<construct_instance>
 614
 615 This provides some Moose specific extensions to this method, you
 616 almost never call this method directly unless you really know what
 617 you are doing.
 618
 619 This method makes sure to handle the moose weak-ref, type-constraint
 620 and type coercion features.
 621
 622 =item B<get_method_map>
 623
 624 This accommodates Moose::Meta::Role::Method instances, which are
 625 aliased, instead of added, but still need to be counted as valid
 626 methods.
 627
 628 =item B<add_override_method_modifier ($name, $method)>
 629
 630 This will create an C<override> method modifier for you, and install
 631 it in the package.
 632
 633 =item B<add_augment_method_modifier ($name, $method)>
 634
 635 This will create an C<augment> method modifier for you, and install
 636 it in the package.
 637
 638 =item B<calculate_all_roles>
 639
 640 =item B<roles>
 641
 642 This will return an array of C<Moose::Meta::Role> instances which are
 643 attached to this class.
 644
 645 =item B<add_role ($role)>
 646
 647 This takes an instance of C<Moose::Meta::Role> in C<$role>, and adds it
 648 to the list of associated roles.
 649
 650 =item B<does_role ($role_name)>
 651
 652 This will test if this class C<does> a given C<$role_name>. It will
 653 not only check it's local roles, but ask them as well in order to
 654 cascade down the role hierarchy.
 655
 656 =item B<excludes_role ($role_name)>
 657
 658 This will test if this class C<excludes> a given C<$role_name>. It will
 659 not only check it's local roles, but ask them as well in order to
 660 cascade down the role hierarchy.
 661
 662 =item B<add_attribute ($attr_name, %params|$params)>
 663
 664 This method does the same thing as L<Class::MOP::Class::add_attribute>, but adds
 665 support for taking the C<$params> as a HASH ref.
 666
 667 =item B<constructor_class ($class_name)>
 668
 669 =item B<destructor_class ($class_name)>
 670
 671 These are the names of classes used when making a class
 672 immutable. These default to L<Moose::Meta::Method::Constructor> and
 673 L<Moose::Meta::Method::Destructor> respectively. These accessors are
 674 read-write, so you can use them to change the class name.
 675
 676 =item B<throw_error $message, %extra>
 677
 678 Throws the error created by C<create_error> using C<raise_error>
 679
 680 =item B<create_error $message, %extra>
 681
 682 Creates an error message or object.
 683
 684 The default behavior is C<create_error_confess>.
 685
 686 If C<error_class> is set uses C<create_error_object>. Otherwise uses
 687 C<error_builder> (a code reference or variant name), and calls the appropriate
 688 C<create_error_$builder> method.
 689
 690 =item B<error_builder $builder_name>
 691
 692 Get or set the error builder. Defaults to C<confess>.
 693
 694 =item B<error_class $class_name>
 695
 696 Get or set the error class. Has no default.
 697
 698 =item B<create_error_confess %args>
 699
 700 Creates an error using L<Carp/longmess>
 701
 702 =item B<create_error_croak %args>
 703
 704 Creates an error using L<Carp/shortmess>
 705
 706 =item B<create_error_object %args>
 707
 708 Calls C<new> on the C<class> parameter in C<%args>. Usable with C<error_class>
 709 to support custom error objects for your meta class.
 710
 711 =item B<raise_error $error>
 712
 713 Dies with an error object or string.
 714
 715 =back
 716
 717 =head1 BUGS
 718
 719 All complex software has bugs lurking in it, and this module is no
 720 exception. If you find a bug please either email me, or add the bug
 721 to cpan-RT.
 722
 723 =head1 AUTHOR
 724
 725 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 726
 727 =head1 COPYRIGHT AND LICENSE
 728
 729 Copyright 2006-2008 by Infinity Interactive, Inc.
 730
 731 L<http://www.iinteractive.com>
 732
 733 This library is free software; you can redistribute it and/or modify
 734 it under the same terms as Perl itself.
 735
 736 =cut
 737