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