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