}
# NOTE: (meta-circularity)
-# This method will be replaces in the
+# This method will be replaced in the
# boostrap section of Class::MOP, by
# a new version which uses the
# &Class::MOP::Class::construct_instance
# NOTE:
# this is a primative (and kludgy) clone operation
-# for now, it will be repleace in the Class::MOP
+# for now, it will be replaced in the Class::MOP
# bootstrap with a proper one, however we know
# that this one will work fine for now.
sub clone {
$self->{associated_class} = undef;
}
+## Slot management
+
+sub set_value {
+ my ( $self, $instance, $value ) = @_;
+
+ Class::MOP::Class->initialize(Scalar::Util::blessed($instance))
+ ->get_meta_instance
+ ->set_slot_value( $instance, $self->name, $value );
+}
+
+sub get_value {
+ my ( $self, $instance ) = @_;
+
+ Class::MOP::Class->initialize(Scalar::Util::blessed($instance))
+ ->get_meta_instance
+ ->get_slot_value( $instance, $self->name );
+}
+
## Method generation helpers
sub generate_accessor_method {
- my $self = shift;
- my $attr_name = $self->name;
+ my $attr = shift;
return sub {
- my $meta_instance = Class::MOP::Class->initialize(Scalar::Util::blessed($_[0]))->get_meta_instance;
- $meta_instance->set_slot_value($_[0], $attr_name, $_[1]) if scalar(@_) == 2;
- $meta_instance->get_slot_value($_[0], $attr_name);
+ $attr->set_value( $_[0], $_[1] ) if scalar(@_) == 2;
+ $attr->get_value( $_[0] );
};
}
}
sub generate_reader_method {
- my $self = shift;
- my $attr_name = $self->name;
+ my $attr = shift;
return sub {
confess "Cannot assign a value to a read-only accessor" if @_ > 1;
- Class::MOP::Class->initialize(Scalar::Util::blessed($_[0]))
- ->get_meta_instance
- ->get_slot_value($_[0], $attr_name);
+ $attr->get_value( $_[0] );
};
}
}
sub generate_writer_method {
- my $self = shift;
- my $attr_name = $self->name;
- return sub {
- Class::MOP::Class->initialize(Scalar::Util::blessed($_[0]))
- ->get_meta_instance
- ->set_slot_value($_[0], $attr_name, $_[1]);
+ my $attr = shift;
+ return sub {
+ $attr->set_value( $_[0], $_[1] );
};
}
=back
+=head2 Value management
+
+=over 4
+
+=item set_value $instance, $value
+
+Set the value without going through the accessor. Note that this may be done to
+even attributes with just read only accessors.
+
+=item get_value $instance
+
+Return the value without going through the accessor. Note that this may be done
+even to attributes with just write only accessors.
+
+=back
+
=head2 Informational
These are all basic read-only value accessors for the values
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
-=cut
\ No newline at end of file
+=cut
+
*{$full_method_name} = $method;
}
+sub find_method_by_name {
+ my ( $self, $method_name ) = @_;
+
+ return $self->name->can( $method_name );
+}
+
sub has_method {
my ($self, $method_name) = @_;
(defined $method_name && $method_name)
my $method = \&{$sub_name};
return 0 if (svref_2object($method)->GV->STASH->NAME || '') ne $self->name &&
(svref_2object($method)->GV->NAME || '') ne '__ANON__';
-
- # at this point we are relatively sure
- # it is our method, so we bless/wrap it
- $self->method_metaclass->wrap($method) unless blessed($method);
+
+ #if ( $self->name->can("meta") ) {
+ # don't bless (destructive operation) classes that didn't ask for it
+
+ # at this point we are relatively sure
+ # it is our method, so we bless/wrap it
+ $self->method_metaclass->wrap($method) unless blessed($method);
+ #}
return 1;
}
This will return a CODE reference of the specified C<$method_name>,
or return undef if that method does not exist.
+=item B<find_method_by_name ($method_name>
+
+This will return a CODE reference of the specified C<$method_name>,
+or return undef if that method does not exist.
+
+Unlike C<get_method> this will also look in the superclasses.
+
=item B<remove_method ($method_name)>
This will attempt to remove a given C<$method_name> from the class.
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
-=cut
\ No newline at end of file
+=cut
+
else {
$metaclass = shift;
($metaclass->isa('Class::MOP::Class'))
- || confess 'The metaclass must be derived from Class::MOP::Class';
+ || confess "The metaclass ($metaclass) must be derived from Class::MOP::Class";
}
my %options = @_;
my $package = caller();
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
-=cut
\ No newline at end of file
+=cut
use strict;
use warnings;
-use Test::More tests => 52;
+use Test::More tests => 56;
use Test::Exception;
+use Scalar::Util qw/reftype/;
+
BEGIN {
use_ok('Class::MOP');
use_ok('Class::MOP::Class');
# We hateses the "used only once" warnings
{ my $temp = \&Foo::baz }
+
+ package OinkyBoinky;
+ our @ISA = "Foo";
+
+ sub elk { 'OinkyBoinky::elk' }
package main;
ok($Foo->has_method('bang'), '... Foo->has_method(bang) (defined in main:: using symbol tables and Sub::Name)');
ok($Foo->has_method('evaled_foo'), '... Foo->has_method(evaled_foo) (evaled in main::)');
+my $OinkyBoinky = Class::MOP::Class->initialize('OinkyBoinky');
+
+ok($OinkyBoinky->has_method('elk'), "the method 'elk' is defined in OinkyBoinky");
+
+ok(!$OinkyBoinky->has_method('bar'), "the method 'bar' is not defined in OinkyBoinky");
+
+ok(my $bar = $OinkyBoinky->find_method_by_name('bar'), "but if you look in the inheritence chain then 'bar' does exist");
+
+is( reftype($bar), "CODE", "the returned value is a code ref" );
+
+
# calling get_method blessed them all
isa_ok($_, 'Class::MOP::Method') for (
\&Foo::FOO_CONSTANT,
use strict;
use warnings;
-use Test::More tests => 169;
+use Test::More tests => 171;
use Test::Exception;
BEGIN {
has_method get_method add_method remove_method alias_method
get_method_list compute_all_applicable_methods
- find_all_methods_by_name find_next_method_by_name
+ find_method_by_name find_all_methods_by_name find_next_method_by_name
add_before_method_modifier add_after_method_modifier add_around_method_modifier
use strict;
use warnings;
-use Test::More tests => 46;
+use Test::More tests => 48;
use Test::Exception;
BEGIN {
has_default default is_default_a_coderef
slots
+ get_value
+ set_value
associated_class
attach_to_class detach_from_class
projects / gitmo/Class-MOP.git / commitdiff