lib/Moose/Meta/Class.pm

   1
   2 package Moose::Meta::Class;
   3
   4 use strict;
   5 use warnings;
   6
   7 use Carp         'confess';
   8 use Scalar::Util 'weaken', 'blessed';
   9
  10 our $VERSION = '0.04';
  11
  12 use base 'Class::MOP::Class';
  13
  14 sub construct_instance {
  15     my ($class, %params) = @_;
  16     my $instance = $params{'__INSTANCE__'} || {};
  17     foreach my $attr ($class->compute_all_applicable_attributes()) {
  18         my $init_arg = $attr->init_arg();
  19         # try to fetch the init arg from the %params ...
  20         my $val;
  21         if (exists $params{$init_arg}) {
  22             $val = $params{$init_arg};
  23         }
  24         else {
  25             # skip it if it's lazy
  26             next if $attr->is_lazy;
  27             # and die if it is required
  28             confess "Attribute (" . $attr->name . ") is required"
  29                 if $attr->is_required
  30         }
  31         # if nothing was in the %params, we can use the
  32         # attribute's default value (if it has one)
  33         if (!defined $val && $attr->has_default) {
  34             $val = $attr->default($instance);
  35         }
  36                 if (defined $val) {
  37                     if ($attr->has_type_constraint) {
  38                     if ($attr->should_coerce && $attr->type_constraint->has_coercion) {
  39                         $val = $attr->type_constraint->coercion->coerce($val);
  40                     }
  41                 (defined($attr->type_constraint->check($val)))
  42                     || confess "Attribute (" . $attr->name . ") does not pass the type contraint with '$val'";
  43             }
  44                 }
  45         $instance->{$attr->name} = $val;
  46         if (defined $val && $attr->is_weak_ref) {
  47             weaken($instance->{$attr->name});
  48         }
  49     }
  50     return $instance;
  51 }
  52
  53 sub has_method {
  54     my ($self, $method_name) = @_;
  55     (defined $method_name && $method_name)
  56         || confess "You must define a method name";
  57
  58     my $sub_name = ($self->name . '::' . $method_name);
  59
  60     no strict 'refs';
  61     return 0 if !defined(&{$sub_name});
  62         my $method = \&{$sub_name};
  63
  64         return 1 if blessed($method) && $method->isa('Moose::Meta::Role::Method');
  65     return $self->SUPER::has_method($method_name);
  66 }
  67
  68
  69 sub add_override_method_modifier {
  70     my ($self, $name, $method, $_super_package) = @_;
  71     # need this for roles ...
  72     $_super_package ||= $self->name;
  73     my $super = $self->find_next_method_by_name($name);
  74     (defined $super)
  75         || confess "You cannot override '$name' because it has no super method";
  76     $self->add_method($name => bless sub {
  77         my @args = @_;
  78         no strict   'refs';
  79         no warnings 'redefine';
  80         local *{$_super_package . '::super'} = sub { $super->(@args) };
  81         return $method->(@args);
  82     } => 'Moose::Meta::Method::Overriden');
  83 }
  84
  85 sub add_augment_method_modifier {
  86     my ($self, $name, $method) = @_;
  87     my $super = $self->find_next_method_by_name($name);
  88     (defined $super)
  89         || confess "You cannot augment '$name' because it has no super method";
  90     my $_super_package = $super->package_name;
  91     # BUT!,... if this is an overriden method ....
  92     if ($super->isa('Moose::Meta::Method::Overriden')) {
  93         # we need to be sure that we actually
  94         # find the next method, which is not
  95         # an 'override' method, the reason is
  96         # that an 'override' method will not
  97         # be the one calling inner()
  98         my $real_super = $self->_find_next_method_by_name_which_is_not_overridden($name);
  99         $_super_package = $real_super->package_name;
 100     }
 101     $self->add_method($name => sub {
 102         my @args = @_;
 103         no strict   'refs';
 104         no warnings 'redefine';
 105         local *{$_super_package . '::inner'} = sub { $method->(@args) };
 106         return $super->(@args);
 107     });
 108 }
 109
 110 sub _find_next_method_by_name_which_is_not_overridden {
 111     my ($self, $name) = @_;
 112     my @methods = $self->find_all_methods_by_name($name);
 113     foreach my $method (@methods) {
 114         return $method->{code}
 115             if blessed($method->{code}) && !$method->{code}->isa('Moose::Meta::Method::Overriden');
 116     }
 117     return undef;
 118 }
 119
 120 package Moose::Meta::Method::Overriden;
 121
 122 use strict;
 123 use warnings;
 124
 125 our $VERSION = '0.01';
 126
 127 use base 'Class::MOP::Method';
 128
 129 1;
 130
 131 __END__
 132
 133 =pod
 134
 135 =head1 NAME
 136
 137 Moose::Meta::Class - The Moose metaclass
 138
 139 =head1 DESCRIPTION
 140
 141 This is a subclass of L<Class::MOP::Class> with Moose specific
 142 extensions.
 143
 144 For the most part, the only time you will ever encounter an
 145 instance of this class is if you are doing some serious deep
 146 introspection. To really understand this class, you need to refer
 147 to the L<Class::MOP::Class> documentation.
 148
 149 =head1 METHODS
 150
 151 =over 4
 152
 153 =item B<construct_instance>
 154
 155 This provides some Moose specific extensions to this method, you
 156 almost never call this method directly unless you really know what
 157 you are doing.
 158
 159 This method makes sure to handle the moose weak-ref, type-constraint
 160 and type coercion features.
 161
 162 =item B<has_method ($name)>
 163
 164 This accomidates Moose::Meta::Role::Method instances, which are
 165 aliased, instead of added, but still need to be counted as valid
 166 methods.
 167
 168 =item B<add_override_method_modifier ($name, $method)>
 169
 170 =item B<add_augment_method_modifier ($name, $method)>
 171
 172 =back
 173
 174 =head1 BUGS
 175
 176 All complex software has bugs lurking in it, and this module is no
 177 exception. If you find a bug please either email me, or add the bug
 178 to cpan-RT.
 179
 180 =head1 AUTHOR
 181
 182 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 183
 184 =head1 COPYRIGHT AND LICENSE
 185
 186 Copyright 2006 by Infinity Interactive, Inc.
 187
 188 L<http://www.iinteractive.com>
 189
 190 This library is free software; you can redistribute it and/or modify
 191 it under the same terms as Perl itself.
 192
 193 =cut