X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMouse%2FMeta%2FClass.pm;h=661aad06ff3754fd584bd8576df4c47a63de494e;hb=4e31595cef06f35cd442a54206f3c1a05c1ac31f;hp=8ecb8282e7268d317964bd70890fa3fcdd0472d9;hpb=f7b11a21869769d2b49bba4fa72d33fa54ad0c2e;p=gitmo%2FMouse.git diff --git a/lib/Mouse/Meta/Class.pm b/lib/Mouse/Meta/Class.pm index 8ecb828..661aad0 100644 --- a/lib/Mouse/Meta/Class.pm +++ b/lib/Mouse/Meta/Class.pm @@ -3,11 +3,9 @@ package Mouse::Meta::Class; use strict; use warnings; -use Scalar::Util 'blessed'; +use Mouse::Util qw/get_linear_isa blessed/; use Carp 'confess'; -use MRO::Compat; - do { my %METACLASS_CACHE; @@ -54,6 +52,17 @@ sub superclasses { @{ $self->{superclasses} }; } +sub add_method { + my $self = shift; + my $name = shift; + my $code = shift; + + my $pkg = $self->name; + + no strict 'refs'; + *{ $pkg . '::' . $name } = $code; +} + sub add_attribute { my $self = shift; my $attr = shift; @@ -82,14 +91,14 @@ sub get_attribute_map { $_[0]->{attributes} } sub has_attribute { exists $_[0]->{attributes}->{$_[1]} } sub get_attribute { $_[0]->{attributes}->{$_[1]} } -sub linearized_isa { @{ mro::get_linear_isa($_[0]->name) } } +sub linearized_isa { @{ get_linear_isa($_[0]->name) } } sub clone_object { my $class = shift; my $instance = shift; (blessed($instance) && $instance->isa($class->name)) - || confess "You must pass an instance ($instance) of the metaclass (" . $class->name . ")"; + || confess "You must pass an instance of the metaclass (" . $class->name . "), not ($instance)"; $class->clone_instance($instance, @_); } @@ -98,7 +107,7 @@ sub clone_instance { my ($class, $instance, %params) = @_; (blessed($instance)) - || confess "You can only clone instances, \$self is not a blessed instance"; + || confess "You can only clone instances, ($instance) is not a blessed instance"; my $clone = bless { %$instance }, ref $instance; @@ -114,6 +123,43 @@ sub clone_instance { } +sub make_immutable {} +sub is_immutable { 0 } + +sub attribute_metaclass { "Mouse::Meta::Class" } + +sub add_before_method_modifier { + my ($self, $name, $code) = @_; + require Class::Method::Modifiers; + Class::Method::Modifiers::_install_modifier( + $self->name, + 'before', + $name, + $code, + ); +} + +sub add_around_method_modifier { + my ($self, $name, $code) = @_; + require Class::Method::Modifiers; + Class::Method::Modifiers::_install_modifier( + $self->name, + 'around', + $name, + $code, + ); +} + +sub add_after_method_modifier { + my ($self, $name, $code) = @_; + require Class::Method::Modifiers; + Class::Method::Modifiers::_install_modifier( + $self->name, + 'after', + $name, + $code, + ); +} 1;