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         'confess';
  10 use Scalar::Util 'weaken', 'blessed', 'reftype';
  11
  12 our $VERSION   = '0.13';
  13 our $AUTHORITY = 'cpan:STEVAN';
  14
  15 use Moose::Meta::Method::Overriden;
  16
  17 use base 'Class::MOP::Class';
  18
  19 __PACKAGE__->meta->add_attribute('roles' => (
  20     reader  => 'roles',
  21     default => sub { [] }
  22 ));
  23
  24 sub initialize {
  25     my $class = shift;
  26     my $pkg   = shift;
  27     $class->SUPER::initialize($pkg,
  28         'attribute_metaclass' => 'Moose::Meta::Attribute',
  29         'method_metaclass'    => 'Moose::Meta::Method',
  30         'instance_metaclass'  => 'Moose::Meta::Instance',
  31         @_);
  32 }
  33
  34 sub add_role {
  35     my ($self, $role) = @_;
  36     (blessed($role) && $role->isa('Moose::Meta::Role'))
  37         || confess "Roles must be instances of Moose::Meta::Role";
  38     push @{$self->roles} => $role;
  39 }
  40
  41 sub calculate_all_roles {
  42     my $self = shift;
  43     my %seen;
  44     grep { !$seen{$_->name}++ } map { $_->calculate_all_roles } @{ $self->roles };
  45 }
  46
  47 sub does_role {
  48     my ($self, $role_name) = @_;
  49     (defined $role_name)
  50         || confess "You must supply a role name to look for";
  51     foreach my $class ($self->class_precedence_list) {
  52         next unless $class->can('meta');
  53         foreach my $role (@{$class->meta->roles}) {
  54             return 1 if $role->does_role($role_name);
  55         }
  56     }
  57     return 0;
  58 }
  59
  60 sub excludes_role {
  61     my ($self, $role_name) = @_;
  62     (defined $role_name)
  63         || confess "You must supply a role name to look for";
  64     foreach my $class ($self->class_precedence_list) {
  65         next unless $class->can('meta');
  66         # NOTE:
  67         # in the pretty rare instance when a Moose metaclass
  68         # is itself extended with a role, this check needs to
  69         # be done since some items in the class_precedence_list
  70         # might in fact be Class::MOP based still.
  71         next unless $class->meta->can('roles');
  72         foreach my $role (@{$class->meta->roles}) {
  73             return 1 if $role->excludes_role($role_name);
  74         }
  75     }
  76     return 0;
  77 }
  78
  79 sub new_object {
  80     my ($class, %params) = @_;
  81     my $self = $class->SUPER::new_object(%params);
  82     foreach my $attr ($class->compute_all_applicable_attributes()) {
  83         # FIXME:
  84         # this does not accept undefined
  85         # values, nor does it accept false
  86         # values to be passed into the init-arg
  87         next unless $params{$attr->init_arg} && $attr->can('has_trigger') && $attr->has_trigger;
  88         $attr->trigger->($self, $params{$attr->init_arg}, $attr);
  89     }
  90     return $self;
  91 }
  92
  93 sub construct_instance {
  94     my ($class, %params) = @_;
  95     my $meta_instance = $class->get_meta_instance;
  96     # FIXME:
  97     # the code below is almost certainly incorrect
  98     # but this is foreign inheritence, so we might
  99     # have to kludge it in the end.
 100     my $instance = $params{'__INSTANCE__'} || $meta_instance->create_instance();
 101     foreach my $attr ($class->compute_all_applicable_attributes()) {
 102         $attr->initialize_instance_slot($meta_instance, $instance, \%params)
 103     }
 104     return $instance;
 105 }
 106
 107
 108 # FIXME:
 109 # This is ugly
 110 sub get_method_map {
 111     my $self = shift;
 112     my $map  = $self->{'%!methods'};
 113
 114     my $class_name       = $self->name;
 115     my $method_metaclass = $self->method_metaclass;
 116
 117     foreach my $symbol ($self->list_all_package_symbols('CODE')) {
 118
 119         my $code = $self->get_package_symbol('&' . $symbol);
 120
 121         next if exists  $map->{$symbol} &&
 122                 defined $map->{$symbol} &&
 123                         $map->{$symbol}->body == $code;
 124
 125         my $gv = B::svref_2object($code)->GV;
 126
 127         my $pkg = $gv->STASH->NAME;
 128         if ($pkg->can('meta') && $pkg->meta && $pkg->meta->isa('Moose::Meta::Role')) {
 129             #my $role = $pkg->meta->name;
 130             #next unless $self->does_role($role);
 131         }
 132         else {
 133             next if ($gv->STASH->NAME || '') ne $class_name &&
 134                     ($gv->NAME        || '') ne '__ANON__';
 135         }
 136
 137         $map->{$symbol} = $method_metaclass->wrap($code);
 138     }
 139
 140     return $map;
 141 }
 142
 143 ### ---------------------------------------------
 144
 145 sub add_attribute {
 146     my $self = shift;
 147     my $name = shift;
 148     if (scalar @_ == 1 && ref($_[0]) eq 'HASH') {
 149         # NOTE:
 150         # if it is a HASH ref, we de-ref it.
 151         # this will usually mean that it is
 152         # coming from a role
 153         $self->SUPER::add_attribute($name => %{$_[0]});
 154     }
 155     else {
 156         # otherwise we just pass the args
 157         $self->SUPER::add_attribute($name => @_);
 158     }
 159 }
 160
 161 sub add_override_method_modifier {
 162     my ($self, $name, $method, $_super_package) = @_;
 163     (!$self->has_method($name))
 164         || confess "Cannot add an override method if a local method is already present";
 165     # need this for roles ...
 166     $_super_package ||= $self->name;
 167     my $super = $self->find_next_method_by_name($name);
 168     (defined $super)
 169         || confess "You cannot override '$name' because it has no super method";
 170     $self->add_method($name => Moose::Meta::Method::Overriden->wrap(sub {
 171         my @args = @_;
 172         no strict   'refs';
 173         no warnings 'redefine';
 174         local *{$_super_package . '::super'} = sub { $super->(@args) };
 175         return $method->(@args);
 176     }));
 177 }
 178
 179 sub add_augment_method_modifier {
 180     my ($self, $name, $method) = @_;
 181     (!$self->has_method($name))
 182         || confess "Cannot add an augment method if a local method is already present";
 183     my $super = $self->find_next_method_by_name($name);
 184     (defined $super)
 185         || confess "You cannot augment '$name' because it has no super method";
 186     my $_super_package = $super->package_name;
 187     # BUT!,... if this is an overriden method ....
 188     if ($super->isa('Moose::Meta::Method::Overriden')) {
 189         # we need to be sure that we actually
 190         # find the next method, which is not
 191         # an 'override' method, the reason is
 192         # that an 'override' method will not
 193         # be the one calling inner()
 194         my $real_super = $self->_find_next_method_by_name_which_is_not_overridden($name);
 195         $_super_package = $real_super->package_name;
 196     }
 197     $self->add_method($name => sub {
 198         my @args = @_;
 199         no strict   'refs';
 200         no warnings 'redefine';
 201         local *{$_super_package . '::inner'} = sub { $method->(@args) };
 202         return $super->(@args);
 203     });
 204 }
 205
 206 ## Private Utility methods ...
 207
 208 sub _find_next_method_by_name_which_is_not_overridden {
 209     my ($self, $name) = @_;
 210     foreach my $method ($self->find_all_methods_by_name($name)) {
 211         return $method->{code}
 212             if blessed($method->{code}) && !$method->{code}->isa('Moose::Meta::Method::Overriden');
 213     }
 214     return undef;
 215 }
 216
 217 sub _fix_metaclass_incompatability {
 218     my ($self, @superclasses) = @_;
 219     foreach my $super (@superclasses) {
 220         # don't bother if it does not have a meta.
 221         next unless $super->can('meta');
 222         # get the name, make sure we take
 223         # immutable classes into account
 224         my $super_meta_name = ($super->meta->is_immutable
 225                                 ? $super->meta->get_mutable_metaclass_name
 226                                 : blessed($super->meta));
 227         # if it's meta is a vanilla Moose,
 228         # then we can safely ignore it.
 229         next if $super_meta_name eq 'Moose::Meta::Class';
 230         # but if we have anything else,
 231         # we need to check it out ...
 232         unless (# see if of our metaclass is incompatible
 233                 ($self->isa($super_meta_name) &&
 234                  # and see if our instance metaclass is incompatible
 235                  $self->instance_metaclass->isa($super->meta->instance_metaclass)) &&
 236                 # ... and if we are just a vanilla Moose
 237                 $self->isa('Moose::Meta::Class')) {
 238             # re-initialize the meta ...
 239             my $super_meta = $super->meta;
 240             # NOTE:
 241             # We might want to consider actually
 242             # transfering any attributes from the
 243             # original meta into this one, but in
 244             # general you should not have any there
 245             # at this point anyway, so it's very
 246             # much an obscure edge case anyway
 247             $self = $super_meta->reinitialize($self->name => (
 248                 'attribute_metaclass' => $super_meta->attribute_metaclass,
 249                 'method_metaclass'    => $super_meta->method_metaclass,
 250                 'instance_metaclass'  => $super_meta->instance_metaclass,
 251             ));
 252         }
 253     }
 254     return $self;
 255 }
 256
 257 sub _apply_all_roles {
 258     my ($self, @roles) = @_;
 259     ($_->can('meta') && $_->meta->isa('Moose::Meta::Role'))
 260         || confess "You can only consume roles, $_ is not a Moose role"
 261             foreach @roles;
 262     if (scalar @roles == 1) {
 263         $roles[0]->meta->apply($self);
 264     }
 265     else {
 266         # FIXME
 267         # we should make a Moose::Meta::Role::Composite
 268         # which is a smaller version of Moose::Meta::Role
 269         # which does not use any package stuff
 270         Moose::Meta::Role->combine(
 271             map { $_->meta } @roles
 272         )->apply($self);
 273     }
 274 }
 275
 276 sub _process_attribute {
 277     my ($self, $name, %options) = @_;
 278     if ($name =~ /^\+(.*)/) {
 279         my $new_attr = $self->_process_inherited_attribute($1, %options);
 280         $self->add_attribute($new_attr);
 281     }
 282     else {
 283         if ($options{metaclass}) {
 284             my $metaclass_name = $options{metaclass};
 285             eval {
 286                 my $possible_full_name = 'Moose::Meta::Attribute::Custom::' . $metaclass_name;
 287                 Class::MOP::load_class($possible_full_name);
 288                 $metaclass_name = $possible_full_name->can('register_implementation')
 289                     ? $possible_full_name->register_implementation
 290                     : $possible_full_name;
 291             };
 292             if ($@) {
 293                 Class::MOP::load_class($metaclass_name);
 294             }
 295             $self->add_attribute($metaclass_name->new($name, %options));
 296         }
 297         else {
 298             $self->add_attribute($name, %options);
 299         }
 300     }
 301 }
 302
 303 sub _process_inherited_attribute {
 304     my ($self, $attr_name, %options) = @_;
 305     my $inherited_attr = $self->find_attribute_by_name($attr_name);
 306     (defined $inherited_attr)
 307         || confess "Could not find an attribute by the name of '$attr_name' to inherit from";
 308     my $new_attr;
 309     if ($inherited_attr->isa('Moose::Meta::Attribute')) {
 310         $new_attr = $inherited_attr->clone_and_inherit_options(%options);
 311     }
 312     else {
 313         # NOTE:
 314         # kind of a kludge to handle Class::MOP::Attributes
 315         $new_attr = Moose::Meta::Attribute::clone_and_inherit_options(
 316             $inherited_attr, %options
 317         );
 318     }
 319     return $new_attr;
 320 }
 321
 322 ## -------------------------------------------------
 323
 324 use Moose::Meta::Method::Constructor;
 325 use Moose::Meta::Method::Destructor;
 326
 327 {
 328     # NOTE:
 329     # the immutable version of a
 330     # particular metaclass is
 331     # really class-level data so
 332     # we don't want to regenerate
 333     # it any more than we need to
 334     my $IMMUTABLE_METACLASS;
 335     sub make_immutable {
 336         my $self = shift;
 337
 338         $IMMUTABLE_METACLASS ||= Class::MOP::Immutable->new($self, {
 339             read_only   => [qw/superclasses/],
 340             cannot_call => [qw/
 341                 add_method
 342                 alias_method
 343                 remove_method
 344                 add_attribute
 345                 remove_attribute
 346                 add_package_symbol
 347                 remove_package_symbol
 348                 add_role
 349             /],
 350             memoize     => {
 351                 class_precedence_list             => 'ARRAY',
 352                 compute_all_applicable_attributes => 'ARRAY',
 353                 get_meta_instance                 => 'SCALAR',
 354                 get_method_map                    => 'SCALAR',
 355                 # maybe ....
 356                 calculate_all_roles               => 'ARRAY',
 357             }
 358         });
 359
 360         $IMMUTABLE_METACLASS->make_metaclass_immutable(
 361             $self,
 362             constructor_class => 'Moose::Meta::Method::Constructor',
 363             destructor_class  => 'Moose::Meta::Method::Destructor',
 364             inline_destructor => 1,
 365             # NOTE:
 366             # no need to do this,
 367             # Moose always does it
 368             inline_accessors  => 0,
 369             @_,
 370         )
 371     }
 372 }
 373
 374 1;
 375
 376 __END__
 377
 378 =pod
 379
 380 =head1 NAME
 381
 382 Moose::Meta::Class - The Moose metaclass
 383
 384 =head1 DESCRIPTION
 385
 386 This is a subclass of L<Class::MOP::Class> with Moose specific
 387 extensions.
 388
 389 For the most part, the only time you will ever encounter an
 390 instance of this class is if you are doing some serious deep
 391 introspection. To really understand this class, you need to refer
 392 to the L<Class::MOP::Class> documentation.
 393
 394 =head1 METHODS
 395
 396 =over 4
 397
 398 =item B<initialize>
 399
 400 =item B<make_immutable>
 401
 402 =item B<new_object>
 403
 404 We override this method to support the C<trigger> attribute option.
 405
 406 =item B<construct_instance>
 407
 408 This provides some Moose specific extensions to this method, you
 409 almost never call this method directly unless you really know what
 410 you are doing.
 411
 412 This method makes sure to handle the moose weak-ref, type-constraint
 413 and type coercion features.
 414
 415 =item B<get_method_map>
 416
 417 This accommodates Moose::Meta::Role::Method instances, which are
 418 aliased, instead of added, but still need to be counted as valid
 419 methods.
 420
 421 =item B<add_override_method_modifier ($name, $method)>
 422
 423 This will create an C<override> method modifier for you, and install
 424 it in the package.
 425
 426 =item B<add_augment_method_modifier ($name, $method)>
 427
 428 This will create an C<augment> method modifier for you, and install
 429 it in the package.
 430
 431 =item B<calculate_all_roles>
 432
 433 =item B<roles>
 434
 435 This will return an array of C<Moose::Meta::Role> instances which are
 436 attached to this class.
 437
 438 =item B<add_role ($role)>
 439
 440 This takes an instance of C<Moose::Meta::Role> in C<$role>, and adds it
 441 to the list of associated roles.
 442
 443 =item B<does_role ($role_name)>
 444
 445 This will test if this class C<does> a given C<$role_name>. It will
 446 not only check it's local roles, but ask them as well in order to
 447 cascade down the role hierarchy.
 448
 449 =item B<excludes_role ($role_name)>
 450
 451 This will test if this class C<excludes> a given C<$role_name>. It will
 452 not only check it's local roles, but ask them as well in order to
 453 cascade down the role hierarchy.
 454
 455 =item B<add_attribute ($attr_name, %params|$params)>
 456
 457 This method does the same thing as L<Class::MOP::Class::add_attribute>, but adds
 458 support for taking the C<$params> as a HASH ref.
 459
 460 =back
 461
 462 =head1 BUGS
 463
 464 All complex software has bugs lurking in it, and this module is no
 465 exception. If you find a bug please either email me, or add the bug
 466 to cpan-RT.
 467
 468 =head1 AUTHOR
 469
 470 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 471
 472 =head1 COPYRIGHT AND LICENSE
 473
 474 Copyright 2006, 2007 by Infinity Interactive, Inc.
 475
 476 L<http://www.iinteractive.com>
 477
 478 This library is free software; you can redistribute it and/or modify
 479 it under the same terms as Perl itself.
 480
 481 =cut
 482