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