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.05';
  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 does_role {
  38     my ($self, $role_name) = @_;
  39     (defined $role_name)
  40         || confess "You must supply a role name to look for";
  41     foreach my $role (@{$self->roles}) {
  42         return 1 if $role->does_role($role_name);
  43     }
  44     return 0;
  45 }
  46
  47 sub new_object {
  48     my ($class, %params) = @_;
  49     my $self = $class->SUPER::new_object(%params);
  50     foreach my $attr ($class->compute_all_applicable_attributes()) {
  51         next unless $params{$attr->init_arg} && $attr->can('has_trigger') && $attr->has_trigger;
  52         $attr->trigger->($self, $params{$attr->init_arg}, $attr);
  53     }
  54     return $self;
  55 }
  56
  57 sub construct_instance {
  58     my ($class, %params) = @_;
  59     my $meta_instance = $class->get_meta_instance;
  60     # FIXME:
  61     # the code below is almost certainly incorrect
  62     # but this is foreign inheritence, so we might
  63     # have to kludge it in the end.
  64     my $instance = $params{'__INSTANCE__'} || $meta_instance->create_instance();
  65     foreach my $attr ($class->compute_all_applicable_attributes()) {
  66         $attr->initialize_instance_slot($meta_instance, $instance, \%params)
  67     }
  68     return $instance;
  69 }
  70
  71 sub has_method {
  72     my ($self, $method_name) = @_;
  73     (defined $method_name && $method_name)
  74         || confess "You must define a method name";
  75
  76     my $sub_name = ($self->name . '::' . $method_name);
  77
  78     no strict 'refs';
  79     return 0 if !defined(&{$sub_name});
  80         my $method = \&{$sub_name};
  81
  82         return 1 if blessed($method) && $method->isa('Moose::Meta::Role::Method');
  83     return $self->SUPER::has_method($method_name);
  84 }
  85
  86 sub add_attribute {
  87     my ($self, $name, %params) = @_;
  88
  89     my @delegations;
  90     if ( my $delegation = delete $params{handles} ) {
  91         my @method_names_or_hashes = $self->compute_delegation( $name, $delegation, \%params );
  92         @delegations = $self->get_delegatable_methods( @method_names_or_hashes );
  93     }
  94
  95     my $ret = $self->SUPER::add_attribute( $name, %params );
  96
  97     if ( @delegations ) {
  98         my $attr = $self->get_attribute( $name );
  99         $self->generate_delgate_method( $attr, $_ ) for $self->filter_delegations( $attr, @delegations );
 100     }
 101
 102     return $ret;
 103 }
 104
 105 sub filter_delegations {
 106     my ( $self, $attr, @delegations ) = @_;
 107     grep {
 108         my $new_name = $_->{new_name} || $_->{name};
 109         no warnings "uninitialized";
 110         $_->{no_filter} or (
 111             !$self->name->can( $new_name ) and
 112             $attr->accessor ne $new_name and
 113             $attr->reader ne $new_name and
 114             $attr->writer ne $new_name
 115         );
 116     } @delegations;
 117 }
 118
 119 sub generate_delgate_method {
 120     my ( $self, $attr, $method ) = @_;
 121
 122     # FIXME like generated accessors these methods must be regenerated
 123     # FIXME the reader may not work for subclasses with weird instances
 124
 125     my $make = $method->{generator} || sub {
 126         my ( $self, $attr, $method ) = @_;
 127
 128         my $method_name = $method->{name};
 129         my $reader = $attr->generate_reader_method();
 130
 131         return sub {
 132             if ( Scalar::Util::blessed( my $delegate = shift->$reader ) ) {
 133                 return $delegate->$method_name( @_ );
 134             }
 135             return;
 136         };
 137     };
 138
 139     my $new_name = $method->{new_name} || $method->{name};
 140     $self->add_method( $new_name, $make->( $self, $attr, $method  ) );
 141 }
 142
 143 sub compute_delegation {
 144     my ( $self, $attr_name, $delegation, $params ) = @_;
 145
 146
 147     # either it's a concrete list of method names
 148     return $delegation unless ref $delegation; # single method name
 149     return @$delegation if reftype($delegation) eq "ARRAY";
 150
 151     # or it's a generative api
 152     my $delegator_meta = $self->_guess_attr_class_or_role( $attr_name, $params );
 153     $self->generate_delegation_list( $delegation, $delegator_meta );
 154 }
 155
 156 sub get_delegatable_methods {
 157     my ( $self, @names_or_hashes ) = @_;
 158     map { ref($_) ? $_ : { name => $_ } } @names_or_hashes;
 159 }
 160
 161 sub generate_delegation_list {
 162     my ( $self, $delegation, $delegator_meta ) = @_;
 163
 164     if ( reftype($delegation) eq "CODE" ) {
 165         return $delegation->( $self, $delegator_meta );
 166     } elsif ( blessed($delegation) eq "Regexp" ) {
 167         confess "For regular expression support the delegator class/role must use a Class::MOP::Class metaclass"
 168             unless $delegator_meta->isa( "Class::MOP::Class" );
 169         return grep { $_->{name} =~ /$delegation/ } $delegator_meta->compute_all_applicable_methods();
 170     } else {
 171         confess "The 'handles' specification '$delegation' is not supported";
 172     }
 173 }
 174
 175 sub _guess_attr_class_or_role {
 176     my ( $self, $attr, $params ) = @_;
 177
 178     my ( $isa, $does ) = @{ $params }{qw/isa does/};
 179
 180     confess "Generative delegations must explicitly specify a class or a role for the attribute's type"
 181         unless $isa || $does;
 182
 183     for (grep { blessed($_) } $isa, $does) {
 184         confess "You must use classes/roles, not type constraints to use delegation ($_)"
 185             unless $_->isa( "Moose::Meta::Class" );
 186     }
 187
 188     confess "Cannot have an isa option and a does option if the isa does not do the does"
 189         if $isa and $does and $isa->can("does") and !$isa->does( $does );
 190
 191     # if it's a class/role name make it into a meta object
 192     for ($isa, $does) {
 193         $_ = $_->meta if defined and !ref and $_->can("meta");
 194     }
 195
 196     $isa = Class::MOP::Class->initialize($isa) if $isa and !ref($isa);
 197
 198     return $isa || $does;
 199 }
 200
 201 sub add_override_method_modifier {
 202     my ($self, $name, $method, $_super_package) = @_;
 203     # need this for roles ...
 204     $_super_package ||= $self->name;
 205     my $super = $self->find_next_method_by_name($name);
 206     (defined $super)
 207         || confess "You cannot override '$name' because it has no super method";
 208     $self->add_method($name => bless sub {
 209         my @args = @_;
 210         no strict   'refs';
 211         no warnings 'redefine';
 212         local *{$_super_package . '::super'} = sub { $super->(@args) };
 213         return $method->(@args);
 214     } => 'Moose::Meta::Method::Overriden');
 215 }
 216
 217 sub add_augment_method_modifier {
 218     my ($self, $name, $method) = @_;
 219     my $super = $self->find_next_method_by_name($name);
 220     (defined $super)
 221         || confess "You cannot augment '$name' because it has no super method";
 222     my $_super_package = $super->package_name;
 223     # BUT!,... if this is an overriden method ....
 224     if ($super->isa('Moose::Meta::Method::Overriden')) {
 225         # we need to be sure that we actually
 226         # find the next method, which is not
 227         # an 'override' method, the reason is
 228         # that an 'override' method will not
 229         # be the one calling inner()
 230         my $real_super = $self->_find_next_method_by_name_which_is_not_overridden($name);
 231         $_super_package = $real_super->package_name;
 232     }
 233     $self->add_method($name => sub {
 234         my @args = @_;
 235         no strict   'refs';
 236         no warnings 'redefine';
 237         local *{$_super_package . '::inner'} = sub { $method->(@args) };
 238         return $super->(@args);
 239     });
 240 }
 241
 242 sub _find_next_method_by_name_which_is_not_overridden {
 243     my ($self, $name) = @_;
 244     my @methods = $self->find_all_methods_by_name($name);
 245     foreach my $method (@methods) {
 246         return $method->{code}
 247             if blessed($method->{code}) && !$method->{code}->isa('Moose::Meta::Method::Overriden');
 248     }
 249     return undef;
 250 }
 251
 252 package Moose::Meta::Method::Overriden;
 253
 254 use strict;
 255 use warnings;
 256
 257 our $VERSION = '0.01';
 258
 259 use base 'Class::MOP::Method';
 260
 261 1;
 262
 263 __END__
 264
 265 =pod
 266
 267 =head1 NAME
 268
 269 Moose::Meta::Class - The Moose metaclass
 270
 271 =head1 DESCRIPTION
 272
 273 This is a subclass of L<Class::MOP::Class> with Moose specific
 274 extensions.
 275
 276 For the most part, the only time you will ever encounter an
 277 instance of this class is if you are doing some serious deep
 278 introspection. To really understand this class, you need to refer
 279 to the L<Class::MOP::Class> documentation.
 280
 281 =head1 METHODS
 282
 283 =over 4
 284
 285 =item B<initialize>
 286
 287 =item B<new_object>
 288
 289 We override this method to support the C<trigger> attribute option.
 290
 291 =item B<construct_instance>
 292
 293 This provides some Moose specific extensions to this method, you
 294 almost never call this method directly unless you really know what
 295 you are doing.
 296
 297 This method makes sure to handle the moose weak-ref, type-constraint
 298 and type coercion features.
 299
 300 =item B<has_method ($name)>
 301
 302 This accomidates Moose::Meta::Role::Method instances, which are
 303 aliased, instead of added, but still need to be counted as valid
 304 methods.
 305
 306 =item B<add_override_method_modifier ($name, $method)>
 307
 308 This will create an C<override> method modifier for you, and install
 309 it in the package.
 310
 311 =item B<add_augment_method_modifier ($name, $method)>
 312
 313 This will create an C<augment> method modifier for you, and install
 314 it in the package.
 315
 316 =item B<roles>
 317
 318 This will return an array of C<Moose::Meta::Role> instances which are
 319 attached to this class.
 320
 321 =item B<add_role ($role)>
 322
 323 This takes an instance of C<Moose::Meta::Role> in C<$role>, and adds it
 324 to the list of associated roles.
 325
 326 =item B<does_role ($role_name)>
 327
 328 This will test if this class C<does> a given C<$role_name>. It will
 329 not only check it's local roles, but ask them as well in order to
 330 cascade down the role hierarchy.
 331
 332 =item B<add_attribute $attr_name, %params>
 333
 334 This method does the same thing as L<Class::MOP::Class/add_attribute>, but adds
 335 suport for delegation.
 336
 337 =back
 338
 339 =head1 INTERNAL METHODS
 340
 341 =over 4
 342
 343 =item compute_delegation
 344
 345 =item generate_delegation_list
 346
 347 =item generate_delgate_method
 348
 349 =item get_delegatable_methods
 350
 351 =item filter_delegations
 352
 353 =back
 354
 355 =head1 BUGS
 356
 357 All complex software has bugs lurking in it, and this module is no
 358 exception. If you find a bug please either email me, or add the bug
 359 to cpan-RT.
 360
 361 =head1 AUTHOR
 362
 363 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 364
 365 =head1 COPYRIGHT AND LICENSE
 366
 367 Copyright 2006 by Infinity Interactive, Inc.
 368
 369 L<http://www.iinteractive.com>
 370
 371 This library is free software; you can redistribute it and/or modify
 372 it under the same terms as Perl itself.
 373
 374 =cut
 375