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