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