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         return grep { $_->{name} =~ /$delegation/ } $delegator_meta->compute_all_applicable_methods();
 146     } else {
 147         confess "The 'handles' specification '$delegation' is not supported";
 148     }
 149 }
 150
 151 sub _guess_attr_class_or_role {
 152     my ( $self, $attr, $params ) = @_;
 153
 154     my ( $isa, $does ) = @{ $params }{qw/isa does/};
 155
 156     confess "Generative delegations must explicitly specify a class or a role for the attribute's type"
 157         unless $isa || $does;
 158
 159     # if it's a class/role name make it into a meta object
 160     for (grep { defined && !ref($_) } $isa, $does) {
 161         confess "Generative delegations must refer to Moose class/role types"
 162             unless $_->can("meta");
 163         $_ = $_->meta;
 164     }
 165
 166     for (grep { blessed($_) } $isa, $does) {
 167         confess "You must use classes/roles, not type constraints to use delegation"
 168             unless $_->isa( "Moose::Meta::Class" );
 169     }
 170
 171     confess "Cannot have an isa option and a does option if the isa does not do the does"
 172         if $isa && $does and !confess->does( $does );
 173
 174     return $isa || $does;
 175 }
 176
 177 sub add_override_method_modifier {
 178     my ($self, $name, $method, $_super_package) = @_;
 179     # need this for roles ...
 180     $_super_package ||= $self->name;
 181     my $super = $self->find_next_method_by_name($name);
 182     (defined $super)
 183         || confess "You cannot override '$name' because it has no super method";
 184     $self->add_method($name => bless sub {
 185         my @args = @_;
 186         no strict   'refs';
 187         no warnings 'redefine';
 188         local *{$_super_package . '::super'} = sub { $super->(@args) };
 189         return $method->(@args);
 190     } => 'Moose::Meta::Method::Overriden');
 191 }
 192
 193 sub add_augment_method_modifier {
 194     my ($self, $name, $method) = @_;
 195     my $super = $self->find_next_method_by_name($name);
 196     (defined $super)
 197         || confess "You cannot augment '$name' because it has no super method";
 198     my $_super_package = $super->package_name;
 199     # BUT!,... if this is an overriden method ....
 200     if ($super->isa('Moose::Meta::Method::Overriden')) {
 201         # we need to be sure that we actually
 202         # find the next method, which is not
 203         # an 'override' method, the reason is
 204         # that an 'override' method will not
 205         # be the one calling inner()
 206         my $real_super = $self->_find_next_method_by_name_which_is_not_overridden($name);
 207         $_super_package = $real_super->package_name;
 208     }
 209     $self->add_method($name => sub {
 210         my @args = @_;
 211         no strict   'refs';
 212         no warnings 'redefine';
 213         local *{$_super_package . '::inner'} = sub { $method->(@args) };
 214         return $super->(@args);
 215     });
 216 }
 217
 218 sub _find_next_method_by_name_which_is_not_overridden {
 219     my ($self, $name) = @_;
 220     my @methods = $self->find_all_methods_by_name($name);
 221     foreach my $method (@methods) {
 222         return $method->{code}
 223             if blessed($method->{code}) && !$method->{code}->isa('Moose::Meta::Method::Overriden');
 224     }
 225     return undef;
 226 }
 227
 228 package Moose::Meta::Method::Overriden;
 229
 230 use strict;
 231 use warnings;
 232
 233 our $VERSION = '0.01';
 234
 235 use base 'Class::MOP::Method';
 236
 237 1;
 238
 239 __END__
 240
 241 =pod
 242
 243 =head1 NAME
 244
 245 Moose::Meta::Class - The Moose metaclass
 246
 247 =head1 DESCRIPTION
 248
 249 This is a subclass of L<Class::MOP::Class> with Moose specific
 250 extensions.
 251
 252 For the most part, the only time you will ever encounter an
 253 instance of this class is if you are doing some serious deep
 254 introspection. To really understand this class, you need to refer
 255 to the L<Class::MOP::Class> documentation.
 256
 257 =head1 METHODS
 258
 259 =over 4
 260
 261 =item B<initialize>
 262
 263 =item B<new_object>
 264
 265 We override this method to support the C<trigger> attribute option.
 266
 267 =item B<construct_instance>
 268
 269 This provides some Moose specific extensions to this method, you
 270 almost never call this method directly unless you really know what
 271 you are doing.
 272
 273 This method makes sure to handle the moose weak-ref, type-constraint
 274 and type coercion features.
 275
 276 =item B<has_method ($name)>
 277
 278 This accomidates Moose::Meta::Role::Method instances, which are
 279 aliased, instead of added, but still need to be counted as valid
 280 methods.
 281
 282 =item B<add_override_method_modifier ($name, $method)>
 283
 284 This will create an C<override> method modifier for you, and install
 285 it in the package.
 286
 287 =item B<add_augment_method_modifier ($name, $method)>
 288
 289 This will create an C<augment> method modifier for you, and install
 290 it in the package.
 291
 292 =item B<roles>
 293
 294 This will return an array of C<Moose::Meta::Role> instances which are
 295 attached to this class.
 296
 297 =item B<add_role ($role)>
 298
 299 This takes an instance of C<Moose::Meta::Role> in C<$role>, and adds it
 300 to the list of associated roles.
 301
 302 =item B<does_role ($role_name)>
 303
 304 This will test if this class C<does> a given C<$role_name>. It will
 305 not only check it's local roles, but ask them as well in order to
 306 cascade down the role hierarchy.
 307
 308 =back
 309
 310 =head1 BUGS
 311
 312 All complex software has bugs lurking in it, and this module is no
 313 exception. If you find a bug please either email me, or add the bug
 314 to cpan-RT.
 315
 316 =head1 AUTHOR
 317
 318 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 319
 320 =head1 COPYRIGHT AND LICENSE
 321
 322 Copyright 2006 by Infinity Interactive, Inc.
 323
 324 L<http://www.iinteractive.com>
 325
 326 This library is free software; you can redistribute it and/or modify
 327 it under the same terms as Perl itself.
 328
 329 =cut