X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FClass%2FMOP%2FClass.pm;h=274ffd51c94f6da25e11fe0e2bb393e965a343a4;hb=ec52b37ad0cba41a9770c8971ee16f54bbfdfc89;hp=d073c2b8902904fa6251342f0e4893576a3cf3ac;hpb=41ffa8a4aa857c1af10e51521b1b37c7d33826c8;p=gitmo%2FClass-MOP.git diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm index d073c2b..274ffd5 100644 --- a/lib/Class/MOP/Class.pm +++ b/lib/Class/MOP/Class.pm @@ -11,10 +11,11 @@ use Class::MOP::Method::Constructor; use Carp 'confess'; use Scalar::Util 'blessed', 'reftype', 'weaken'; -use Sub::Name 'subname'; +use Sub::Name 'subname'; use Devel::GlobalDestruction 'in_global_destruction'; +use Try::Tiny; -our $VERSION = '0.90'; +our $VERSION = '0.97'; $VERSION = eval $VERSION; our $AUTHORITY = 'cpan:STEVAN'; @@ -41,12 +42,6 @@ sub initialize { || $class->_construct_class_instance(package => $package_name, @_); } -sub construct_class_instance { - Carp::cluck('The construct_class_instance method has been made private.' - . " The public version is deprecated and will be removed in a future release.\n"); - shift->_construct_class_instance(@_); -} - # NOTE: (meta-circularity) # this is a special form of _construct_instance # (see below), which is used to construct class @@ -75,7 +70,7 @@ sub _construct_class_instance { # get the name of the class appropriately $class = (ref($class) ? ($class->is_immutable - ? $class->get_mutable_metaclass_name() + ? $class->_get_mutable_metaclass_name() : ref($class)) : $class); @@ -126,6 +121,7 @@ sub _new { # should not actually have a value associated # with the slot. 'namespace' => \undef, + 'methods' => {}, # inherited from Class::MOP::Module 'version' => \undef, @@ -134,7 +130,6 @@ sub _new { # defined in Class::MOP::Class 'superclasses' => \undef, - 'methods' => {}, 'attributes' => {}, 'attribute_metaclass' => ( $options->{'attribute_metaclass'} || 'Class::MOP::Attribute' ), @@ -170,13 +165,6 @@ sub update_package_cache_flag { $self->{'_package_cache_flag'} = Class::MOP::check_package_cache_flag($self->name); } - -sub check_metaclass_compatibility { - Carp::cluck('The check_metaclass_compatibility method has been made private.' - . " The public version is deprecated and will be removed in a future release.\n"); - shift->_check_metaclass_compatibility(@_); -} - sub _check_metaclass_compatibility { my $self = shift; @@ -196,7 +184,7 @@ sub _check_metaclass_compatibility { # get the name of the class appropriately my $super_meta_type = $super_meta->is_immutable - ? $super_meta->get_mutable_metaclass_name() + ? $super_meta->_get_mutable_metaclass_name() : ref($super_meta); ($self->isa($super_meta_type)) @@ -341,18 +329,14 @@ sub create { # all these attribute readers will be bootstrapped # away in the Class::MOP bootstrap section -sub get_attribute_map { $_[0]->{'attributes'} } +sub _attribute_map { $_[0]->{'attributes'} } sub attribute_metaclass { $_[0]->{'attribute_metaclass'} } -sub method_metaclass { $_[0]->{'method_metaclass'} } -sub wrapped_method_metaclass { $_[0]->{'wrapped_method_metaclass'} } sub instance_metaclass { $_[0]->{'instance_metaclass'} } sub immutable_trait { $_[0]->{'immutable_trait'} } sub constructor_class { $_[0]->{'constructor_class'} } sub constructor_name { $_[0]->{'constructor_name'} } sub destructor_class { $_[0]->{'destructor_class'} } -sub _method_map { $_[0]->{'methods'} } - # Instance Construction & Cloning sub new_object { @@ -368,12 +352,6 @@ sub new_object { return $class->_construct_instance(@_); } -sub construct_instance { - Carp::cluck('The construct_instance method has been made private.' - . " The public version is deprecated and will be removed in a future release.\n"); - shift->_construct_instance(@_); -} - sub _construct_instance { my $class = shift; my $params = @_ == 1 ? $_[0] : {@_}; @@ -407,12 +385,6 @@ sub get_meta_instance { $self->{'_meta_instance'} ||= $self->_create_meta_instance(); } -sub create_meta_instance { - Carp::cluck('The create_meta_instance method has been made private.' - . " The public version is deprecated and will be removed in a future release.\n"); - shift->_create_meta_instance(@_); -} - sub _create_meta_instance { my $self = shift; @@ -441,12 +413,6 @@ sub clone_object { $class->_clone_instance($instance, @_); } -sub clone_instance { - Carp::cluck('The clone_instance method has been made private.' - . " The public version is deprecated and will be removed in a future release.\n"); - shift->_clone_instance(@_); -} - sub _clone_instance { my ($class, $instance, %params) = @_; (blessed($instance)) @@ -596,56 +562,6 @@ sub class_precedence_list { ## Methods -sub wrap_method_body { - my ( $self, %args ) = @_; - - ('CODE' eq ref $args{body}) - || confess "Your code block must be a CODE reference"; - - $self->method_metaclass->wrap( - package_name => $self->name, - %args, - ); -} - -sub add_method { - my ($self, $method_name, $method) = @_; - (defined $method_name && $method_name) - || confess "You must define a method name"; - - my $body; - if (blessed($method)) { - $body = $method->body; - if ($method->package_name ne $self->name) { - $method = $method->clone( - package_name => $self->name, - name => $method_name - ) if $method->can('clone'); - } - - $method->attach_to_class($self); - $self->_method_map->{$method_name} = $method; - } - else { - # If a raw code reference is supplied, its method object is not created. - # The method object won't be created until required. - $body = $method; - } - - - my ( $current_package, $current_name ) = Class::MOP::get_code_info($body); - - if ( !defined $current_name || $current_name eq '__ANON__' ) { - my $full_method_name = ($self->name . '::' . $method_name); - subname($full_method_name => $body); - } - - $self->add_package_symbol( - { sigil => '&', type => 'CODE', name => $method_name }, - $body, - ); -} - { my $fetch_and_prepare_method = sub { my ($self, $method_name) = @_; @@ -680,7 +596,7 @@ sub add_method { sub add_before_method_modifier { my ($self, $method_name, $method_modifier) = @_; - (defined $method_name && $method_name) + (defined $method_name && length $method_name) || confess "You must pass in a method name"; my $method = $fetch_and_prepare_method->($self, $method_name); $method->add_before_modifier( @@ -690,7 +606,7 @@ sub add_method { sub add_after_method_modifier { my ($self, $method_name, $method_modifier) = @_; - (defined $method_name && $method_name) + (defined $method_name && length $method_name) || confess "You must pass in a method name"; my $method = $fetch_and_prepare_method->($self, $method_name); $method->add_after_modifier( @@ -700,7 +616,7 @@ sub add_method { sub add_around_method_modifier { my ($self, $method_name, $method_modifier) = @_; - (defined $method_name && $method_name) + (defined $method_name && length $method_name) || confess "You must pass in a method name"; my $method = $fetch_and_prepare_method->($self, $method_name); $method->add_around_modifier( @@ -722,86 +638,9 @@ sub add_method { # to, and so don't need the fully qualified name. } -sub alias_method { - Carp::cluck("The alias_method method is deprecated. Use add_method instead.\n"); - - shift->add_method(@_); -} - -sub _code_is_mine { - my ( $self, $code ) = @_; - - my ( $code_package, $code_name ) = Class::MOP::get_code_info($code); - - return $code_package && $code_package eq $self->name - || ( $code_package eq 'constant' && $code_name eq '__ANON__' ); -} - -sub has_method { - my ($self, $method_name) = @_; - (defined $method_name && $method_name) - || confess "You must define a method name"; - - return defined($self->get_method($method_name)); -} - -sub get_method { - my ($self, $method_name) = @_; - (defined $method_name && $method_name) - || confess "You must define a method name"; - - my $method_map = $self->_method_map; - my $method_object = $method_map->{$method_name}; - my $code = $self->get_package_symbol({ - name => $method_name, - sigil => '&', - type => 'CODE', - }); - - unless ( $method_object && $method_object->body == ( $code || 0 ) ) { - if ( $code && $self->_code_is_mine($code) ) { - $method_object = $method_map->{$method_name} - = $self->wrap_method_body( - body => $code, - name => $method_name, - associated_metaclass => $self, - ); - } - else { - delete $method_map->{$method_name}; - return undef; - } - } - - return $method_object; -} - -sub remove_method { - my ($self, $method_name) = @_; - (defined $method_name && $method_name) - || confess "You must define a method name"; - - my $removed_method = delete $self->get_method_map->{$method_name}; - - $self->remove_package_symbol( - { sigil => '&', type => 'CODE', name => $method_name } - ); - - $removed_method->detach_from_class if $removed_method; - - $self->update_package_cache_flag; # still valid, since we just removed the method from the map - - return $removed_method; -} - -sub get_method_list { - my $self = shift; - return grep { $self->has_method($_) } keys %{ $self->namespace }; -} - sub find_method_by_name { my ($self, $method_name) = @_; - (defined $method_name && $method_name) + (defined $method_name && length $method_name) || confess "You must define a method name to find"; foreach my $class ($self->linearized_isa) { my $method = $self->initialize($class)->get_method($method_name); @@ -812,21 +651,16 @@ sub find_method_by_name { sub get_all_methods { my $self = shift; - my %methods = map { %{ $self->initialize($_)->get_method_map } } reverse $self->linearized_isa; - return values %methods; -} -sub compute_all_applicable_methods { - Carp::cluck('The compute_all_applicable_methods method is deprecated.' - . " Use get_all_methods instead.\n"); - - return map { - { - name => $_->name, - class => $_->package_name, - code => $_, # sigh, overloading - }, - } shift->get_all_methods(@_); + my %methods; + for my $class ( reverse $self->linearized_isa ) { + my $meta = $self->initialize($class); + + $methods{$_} = $meta->get_method($_) + for $meta->get_method_list; + } + + return values %methods; } sub get_all_method_names { @@ -837,7 +671,7 @@ sub get_all_method_names { sub find_all_methods_by_name { my ($self, $method_name) = @_; - (defined $method_name && $method_name) + (defined $method_name && length $method_name) || confess "You must define a method name to find"; my @methods; foreach my $class ($self->linearized_isa) { @@ -854,7 +688,7 @@ sub find_all_methods_by_name { sub find_next_method_by_name { my ($self, $method_name) = @_; - (defined $method_name && $method_name) + (defined $method_name && length $method_name) || confess "You must define a method name to find"; my @cpl = $self->linearized_isa; shift @cpl; # discard ourselves @@ -895,23 +729,21 @@ sub add_attribute { # get our count of previously inserted attributes and # increment by one so this attribute knows its order - my $order = (scalar keys %{$self->get_attribute_map}); + my $order = (scalar keys %{$self->_attribute_map}); $attribute->_set_insertion_order($order); # then onto installing the new accessors - $self->get_attribute_map->{$attr_name} = $attribute; + $self->_attribute_map->{$attr_name} = $attribute; # invalidate package flag here - my $e = do { - local $@; + try { local $SIG{__DIE__}; - eval { $attribute->install_accessors() }; - $@; - }; - if ( $e ) { - $self->remove_attribute($attr_name); - die $e; + $attribute->install_accessors(); } + catch { + $self->remove_attribute($attr_name); + die $_; + }; return $attribute; } @@ -979,16 +811,16 @@ sub invalidate_meta_instance { sub has_attribute { my ($self, $attribute_name) = @_; - (defined $attribute_name && $attribute_name) + (defined $attribute_name) || confess "You must define an attribute name"; - exists $self->get_attribute_map->{$attribute_name}; + exists $self->_attribute_map->{$attribute_name}; } sub get_attribute { my ($self, $attribute_name) = @_; - (defined $attribute_name && $attribute_name) + (defined $attribute_name) || confess "You must define an attribute name"; - return $self->get_attribute_map->{$attribute_name} + return $self->_attribute_map->{$attribute_name} # NOTE: # this will return undef anyway, so no need ... # if $self->has_attribute($attribute_name); @@ -997,11 +829,11 @@ sub get_attribute { sub remove_attribute { my ($self, $attribute_name) = @_; - (defined $attribute_name && $attribute_name) + (defined $attribute_name) || confess "You must define an attribute name"; - my $removed_attribute = $self->get_attribute_map->{$attribute_name}; + my $removed_attribute = $self->_attribute_map->{$attribute_name}; return unless defined $removed_attribute; - delete $self->get_attribute_map->{$attribute_name}; + delete $self->_attribute_map->{$attribute_name}; $self->invalidate_meta_instances(); $removed_attribute->remove_accessors(); $removed_attribute->detach_from_class(); @@ -1010,22 +842,15 @@ sub remove_attribute { sub get_attribute_list { my $self = shift; - keys %{$self->get_attribute_map}; + keys %{$self->_attribute_map}; } sub get_all_attributes { my $self = shift; - my %attrs = map { %{ $self->initialize($_)->get_attribute_map } } reverse $self->linearized_isa; + my %attrs = map { %{ $self->initialize($_)->_attribute_map } } reverse $self->linearized_isa; return values %attrs; } -sub compute_all_applicable_attributes { - Carp::cluck('The compute_all_applicable_attributes method has been deprecated.' - . " Use get_all_attributes instead.\n"); - - shift->get_all_attributes(@_); -} - sub find_attribute_by_name { my ($self, $attr_name) = @_; foreach my $class ($self->linearized_isa) { @@ -1045,12 +870,9 @@ sub is_pristine { return if $self->get_attribute_list; # or any non-declared methods - if ( my @methods = values %{ $self->get_method_map } ) { - my $metaclass = $self->method_metaclass; - foreach my $method ( @methods ) { - return if $method->isa("Class::MOP::Method::Generated"); - # FIXME do we need to enforce this too? return unless $method->isa($metaclass); - } + for my $method ( map { $self->get_method($_) } $self->get_method_list ) { + return if $method->isa("Class::MOP::Method::Generated"); + # FIXME do we need to enforce this too? return unless $method->isa( $self->method_metaclass ); } return 1; @@ -1061,6 +883,8 @@ sub is_pristine { sub is_mutable { 1 } sub is_immutable { 0 } +sub immutable_options { %{ $_[0]{__immutable}{options} || {} } } + sub _immutable_options { my ( $self, @args ) = @_; @@ -1147,7 +971,7 @@ sub _immutable_metaclass { # example of where this matters). my $meta_name = $meta->is_immutable - ? $meta->get_mutable_metaclass_name + ? $meta->_get_mutable_metaclass_name : ref $meta; my $immutable_meta = $meta_name->create( @@ -1210,7 +1034,7 @@ sub _install_inlined_code { sub _rebless_as_mutable { my $self = shift; - bless $self, $self->get_mutable_metaclass_name; + bless $self, $self->_get_mutable_metaclass_name; return $self; } @@ -1338,7 +1162,7 @@ Class::MOP::Class - Class Meta Object The Class Protocol is the largest and most complex part of the Class::MOP meta-object protocol. It controls the introspection and manipulation of Perl 5 classes, and it can create them as well. The -best way to understand what this module can do, is to read the +best way to understand what this module can do is to read the documentation for each of its methods. =head1 INHERITANCE @@ -1350,7 +1174,7 @@ C is a subclass of L. =head2 Class construction These methods all create new C objects. These -objects can represent existing classes, or they can be used to create +objects can represent existing classes or they can be used to create new classes from scratch. The metaclass object for a given class is a singleton. If you attempt @@ -1362,7 +1186,7 @@ existing object. =item B<< Class::MOP::Class->create($package_name, %options) >> This method creates a new C object with the given -package name. It accepts a number of options. +package name. It accepts a number of options: =over 8 @@ -1381,7 +1205,7 @@ An optional array reference of superclass names. =item * methods An optional hash reference of methods for the class. The keys of the -hash reference are method names, and values are subroutine references. +hash reference are method names and values are subroutine references. =item * attributes @@ -1406,7 +1230,7 @@ All instances of an anonymous class keep a special reference to the metaclass object, which prevents the metaclass from going out of scope while any instances exist. -This only works if the instance if based on a hash reference, however. +This only works if the instance is based on a hash reference, however. =item B<< Class::MOP::Class->initialize($package_name, %options) >> @@ -1476,12 +1300,11 @@ class. Any parameters you provide are used to initialize the instance's attributes. A special C<__INSTANCE__> key can be passed to provide an already generated instance, rather than having Class::MOP generate it for you. This is mostly useful for using Class::MOP with -foreign classes, which generally generate instances using their own -constructor. +foreign classes which generate instances using their own constructors. =item B<< $metaclass->instance_metaclass >> -Returns the class name of the instance metaclass, see +Returns the class name of the instance metaclass. See L for more information on the instance metaclass. @@ -1552,50 +1375,14 @@ include indirect subclasses. =back -=head2 Method introspection and creation - -These methods allow you to introspect a class's methods, as well as -add, remove, or change methods. - -Determining what is truly a method in a Perl 5 class requires some -heuristics (aka guessing). - -Methods defined outside the package with a fully qualified name (C) will be included. Similarly, methods named -with a fully qualified name using L are also included. - -However, we attempt to ignore imported functions. +=head2 Method introspection -Ultimately, we are using heuristics to determine what truly is a -method in a class, and these heuristics may get the wrong answer in -some edge cases. However, for most "normal" cases the heuristics work -correctly. +See L for +methods that operate only on the current class. Class::MOP::Class adds +introspection capabilities that take inheritance into account. =over 4 -=item B<< $metaclass->get_method($method_name) >> - -This will return a L for the specified -C<$method_name>. If the class does not have the specified method, it -returns C - -=item B<< $metaclass->has_method($method_name) >> - -Returns a boolean indicating whether or not the class defines the -named method. It does not include methods inherited from parent -classes. - -=item B<< $metaclass->get_method_map >> - -Returns a hash reference representing the methods defined in this -class. The keys are method names and the values are -L objects. - -=item B<< $metaclass->get_method_list >> - -This will return a list of method I for all methods defined in -this class. - =item B<< $metaclass->get_all_methods >> This will traverse the inheritance hierarchy and return a list of all @@ -1633,38 +1420,6 @@ This method returns the first method in any superclass matching the given name. It is effectively the method that C would dispatch to. -=item B<< $metaclass->add_method($method_name, $method) >> - -This method takes a method name and a subroutine reference, and adds -the method to the class. - -The subroutine reference can be a L, and you are -strongly encouraged to pass a meta method object instead of a code -reference. If you do so, that object gets stored as part of the -class's method map directly. If not, the meta information will have to -be recreated later, and may be incorrect. - -If you provide a method object, this method will clone that object if -the object's package name does not match the class name. This lets us -track the original source of any methods added from other classes -(notably Moose roles). - -=item B<< $metaclass->remove_method($method_name) >> - -Remove the named method from the class. This method returns the -L object for the method. - -=item B<< $metaclass->method_metaclass >> - -Returns the class name of the method metaclass, see -L for more information on the method metaclass. - -=item B<< $metaclass->wrapped_method_metaclass >> - -Returns the class name of the wrapped method metaclass, see -L for more information on the wrapped -method metaclass. - =back =head2 Attribute introspection and creation @@ -1691,12 +1446,6 @@ Returns a boolean indicating whether or not the class defines the named attribute. It does not include attributes inherited from parent classes. -=item B<< $metaclass->get_attribute_map >> - -Returns a hash reference representing the attributes defined in this -class. The keys are attribute names and the values are -L objects. - =item B<< $metaclass->get_attribute_list >> This will return a list of attributes I for all attributes @@ -1711,7 +1460,7 @@ the L objects for this class and its parents. This will return a L for the specified C<$attribute_name>. If the class does not have the specified -attribute, it returns C +attribute, it returns C. Unlike C, this attribute I look for the named attribute in superclasses. @@ -1719,7 +1468,7 @@ attribute in superclasses. =item B<< $metaclass->add_attribute(...) >> This method accepts either an existing L -object, or parameters suitable for passing to that class's C +object or parameters suitable for passing to that class's C method. The attribute provided will be added to the class. @@ -1744,7 +1493,7 @@ object instances created for this class, not existing instances. =item B<< $metaclass->attribute_metaclass >> Returns the class name of the attribute metaclass for this class. By -default, this is L. for more information on +default, this is L. =back @@ -1758,11 +1507,10 @@ Making a class immutable lets us optimize the class by inlining some methods, and also allows us to optimize some methods on the metaclass object itself. -After immutabilization, the metaclass object will cache most -informational methods such as C and -C. Methods which would alter the class, such as -C, C, and so on will throw an error on an -immutable metaclass object. +After immutabilization, the metaclass object will cache most informational +methods that returns information about methods or attributes. Methods which +would alter the class, such as C and C, will +throw an error on an immutable metaclass object. The immutabilization system in L takes much greater advantage of the inlining features than Class::MOP itself does. @@ -1771,7 +1519,7 @@ of the inlining features than Class::MOP itself does. =item B<< $metaclass->make_immutable(%options) >> -This method will create an immutable transformer and uses it to make +This method will create an immutable transformer and use it to make the class and its metaclass object immutable. This method accepts the following options: @@ -1827,6 +1575,13 @@ replaced when inlining a destructor. This defaults to false. =back +=item B<< $metaclass->immutable_options >> + +Returns a hash of the options used when making the class immutable, including +both defaults and anything supplied by the user in the call to C<< +$metaclass->make_immutable >>. This is useful if you need to temporarily make +a class mutable and then restore immutability as it was before. + =item B<< $metaclass->make_mutable >> Calling this method reverse the immutabilization transformation. @@ -1837,7 +1592,7 @@ Calling this method reverse the immutabilization transformation. Method modifiers are hooks which allow a method to be wrapped with I, I and I method modifiers. Every time a -method is called, it's modifiers are also called. +method is called, its modifiers are also called. A class can modify its own methods, as well as methods defined in parent classes. @@ -1881,9 +1636,9 @@ order. So the call tree might looks something like this: Of course there is a performance cost associated with method modifiers, but we have made every effort to make that cost directly -proportional to the number of modifier features you utilize. +proportional to the number of modifier features you use. -The wrapping method does it's best to B do as much work as it +The wrapping method does its best to B do as much work as it absolutely needs to. In order to do this we have moved some of the performance costs to set-up time, where they are easier to amortize.