X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FClass%2FMOP%2FClass.pm;h=2ac726eed7218e8f7b404b373b2c0df6df818da1;hb=0bfc85b88523ddd75e0868d6ec1244f4365bda07;hp=64c1ec43867cd1a9f7d44d93b6625f071c78d77d;hpb=3ec92caa8d7679fb1a2785c9269598776f3bade9;p=gitmo%2FClass-MOP.git diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm index 64c1ec4..2ac726e 100644 --- a/lib/Class/MOP/Class.pm +++ b/lib/Class/MOP/Class.pm @@ -54,8 +54,8 @@ sub reinitialize { # normal &construct_instance. sub construct_class_instance { my $class = shift; - my %options = @_; - my $package_name = $options{'package'}; + my $options = @_ == 1 ? $_[0] : {@_}; + my $package_name = $options->{package}; (defined $package_name && $package_name) || confess "You must pass a package name"; # NOTE: @@ -72,57 +72,24 @@ sub construct_class_instance { # we need to deal with the possibility # of class immutability here, and then # get the name of the class appropriately - $class = (blessed($class) + $class = (ref($class) ? ($class->is_immutable ? $class->get_mutable_metaclass_name() - : blessed($class)) + : ref($class)) : $class); # now create the metaclass my $meta; if ($class eq 'Class::MOP::Class') { no strict 'refs'; - $meta = bless { - # inherited from Class::MOP::Package - 'package' => $package_name, - - # NOTE: - # since the following attributes will - # actually be loaded from the symbol - # table, and actually bypass the instance - # entirely, we can just leave these things - # listed here for reference, because they - # should not actually have a value associated - # with the slot. - 'namespace' => \undef, - # inherited from Class::MOP::Module - 'version' => \undef, - 'authority' => \undef, - # defined in Class::MOP::Class - 'superclasses' => \undef, - - 'methods' => {}, - 'attributes' => {}, - 'attribute_metaclass' => $options{'attribute_metaclass'} || 'Class::MOP::Attribute', - 'method_metaclass' => $options{'method_metaclass'} || 'Class::MOP::Method', - 'instance_metaclass' => $options{'instance_metaclass'} || 'Class::MOP::Instance', - - ## uber-private variables - # NOTE: - # this starts out as undef so that - # we can tell the first time the - # methods are fetched - # - SL - '_package_cache_flag' => undef, - '_meta_instance' => undef, - } => $class; + $meta = $class->_new($options) } else { # NOTE: # it is safe to use meta here because # class will always be a subclass of # Class::MOP::Class, which defines meta - $meta = $class->meta->construct_instance(%options) + $meta = $class->meta->construct_instance($options) } # and check the metaclass compatibility @@ -138,6 +105,37 @@ sub construct_class_instance { $meta; } +sub _new { + my $class = shift; + my $options = @_ == 1 ? $_[0] : {@_}; + + bless { + # inherited from Class::MOP::Package + 'package' => $options->{package}, + + # NOTE: + # since the following attributes will + # actually be loaded from the symbol + # table, and actually bypass the instance + # entirely, we can just leave these things + # listed here for reference, because they + # should not actually have a value associated + # with the slot. + 'namespace' => \undef, + # inherited from Class::MOP::Module + 'version' => \undef, + 'authority' => \undef, + # defined in Class::MOP::Class + 'superclasses' => \undef, + + 'methods' => {}, + 'attributes' => {}, + 'attribute_metaclass' => $options->{'attribute_metaclass'} || 'Class::MOP::Attribute', + 'method_metaclass' => $options->{'method_metaclass'} || 'Class::MOP::Method', + 'instance_metaclass' => $options->{'instance_metaclass'} || 'Class::MOP::Instance', + }, $class; +} + sub reset_package_cache_flag { (shift)->{'_package_cache_flag'} = undef } sub update_package_cache_flag { my $self = shift; @@ -154,7 +152,7 @@ sub check_metaclass_compatability { my $self = shift; # this is always okay ... - return if blessed($self) eq 'Class::MOP::Class' && + return if ref($self) eq 'Class::MOP::Class' && $self->instance_metaclass eq 'Class::MOP::Instance'; my @class_list = $self->linearized_isa; @@ -169,10 +167,10 @@ sub check_metaclass_compatability { # get the name of the class appropriately my $meta_type = ($meta->is_immutable ? $meta->get_mutable_metaclass_name() - : blessed($meta)); + : ref($meta)); ($self->isa($meta_type)) - || confess $self->name . "->meta => (" . (blessed($self)) . ")" . + || confess $self->name . "->meta => (" . (ref($self)) . ")" . " is not compatible with the " . $class_name . "->meta => (" . ($meta_type) . ")"; # NOTE: @@ -204,7 +202,7 @@ sub check_metaclass_compatability { sub is_anon_class { my $self = shift; no warnings 'uninitialized'; - $self->name =~ /^$ANON_CLASS_PREFIX/ ? 1 : 0; + $self->name =~ /^$ANON_CLASS_PREFIX/; } sub create_anon_class { @@ -213,15 +211,6 @@ sub check_metaclass_compatability { return $class->create($package_name, %options); } - BEGIN { - local $@; - eval { - require Devel::GlobalDestruction; - Devel::GlobalDestruction->import("in_global_destruction"); - 1; - } or *in_global_destruction = sub () { '' }; - } - # NOTE: # this will only get called for # anon-classes, all other calls @@ -231,7 +220,7 @@ sub check_metaclass_compatability { sub DESTROY { my $self = shift; - return if in_global_destruction; # it'll happen soon anyway and this just makes things more complicated + return if Class::MOP::in_global_destruction; # it'll happen soon anyway and this just makes things more complicated no warnings 'uninitialized'; return unless $self->name =~ /^$ANON_CLASS_PREFIX/; @@ -283,7 +272,7 @@ sub create { # FIXME totally lame $meta->add_method('meta' => sub { - $class->initialize(blessed($_[0]) || $_[0]); + $class->initialize(ref($_[0]) || $_[0]); }); $meta->superclasses(@{$options{superclasses}}) @@ -385,11 +374,12 @@ sub new_object { } sub construct_instance { - my ($class, %params) = @_; + my $class = shift; + my $params = @_ == 1 ? $_[0] : {@_}; my $meta_instance = $class->get_meta_instance(); my $instance = $meta_instance->create_instance(); foreach my $attr ($class->compute_all_applicable_attributes()) { - $attr->initialize_instance_slot($meta_instance, $instance, \%params); + $attr->initialize_instance_slot($meta_instance, $instance, $params); } # NOTE: # this will only work for a HASH instance type @@ -430,7 +420,7 @@ sub clone_object { my $class = shift; my $instance = shift; (blessed($instance) && $instance->isa($class->name)) - || confess "You must pass an instance of the metaclass (" . $class->name . "), not ($instance)"; + || confess "You must pass an instance of the metaclass (" . (ref $class ? $class->name : $class) . "), not ($instance)"; # NOTE: # we need to protect the integrity of the @@ -466,7 +456,7 @@ sub rebless_instance { $old_metaclass = $instance->meta; } else { - $old_metaclass = $self->initialize(blessed($instance)); + $old_metaclass = $self->initialize(ref($instance)); } my $meta_instance = $self->get_meta_instance(); @@ -793,17 +783,21 @@ sub find_method_by_name { return; } -sub compute_all_applicable_methods { +sub get_all_methods { my $self = shift; my %methods = map { %{ $self->initialize($_)->get_method_map } } reverse $self->linearized_isa; - # return values %methods # TODO make some new API that does this + return values %methods; +} + +# compatibility +sub compute_all_applicable_methods { return map { { name => $_->name, class => $_->package_name, code => $_, # sigh, overloading }, - } values %methods; + } shift->get_all_methods(@_); } sub find_all_methods_by_name { @@ -942,7 +936,7 @@ sub has_attribute { my ($self, $attribute_name) = @_; (defined $attribute_name && $attribute_name) || confess "You must define an attribute name"; - exists $self->get_attribute_map->{$attribute_name} ? 1 : 0; + exists $self->get_attribute_map->{$attribute_name}; } sub get_attribute { @@ -974,6 +968,10 @@ sub get_attribute_list { keys %{$self->get_attribute_map}; } +sub get_all_attributes { + shift->compute_all_applicable_attributes(@_); +} + sub compute_all_applicable_attributes { my $self = shift; my %attrs = map { %{ $self->initialize($_)->get_attribute_map } } reverse $self->linearized_isa; @@ -1032,7 +1030,7 @@ sub is_immutable { 0 } sub get_immutable_transformer { my $self = shift; if( $self->is_mutable ){ - my $class = blessed $self || $self; + my $class = ref $self || $self; return $IMMUTABLE_TRANSFORMERS{$class} ||= $self->create_immutable_transformer; } confess "unable to find transformer for immutable class" @@ -1507,13 +1505,20 @@ methods. It does B provide a list of all applicable methods, including any inherited ones. If you want a list of all applicable methods, use the C method. +=item B + +This will traverse the inheritance heirachy and return a list of all +the applicable L objects for this class. + =item B -This will return a list of all the methods names this class will -respond to, taking into account inheritance. The list will be a list of -HASH references, each one containing the following information; method -name, the name of the class in which the method lives and a CODE -reference for the actual method. +Deprecated. + +This method returns a list of hashes describing the all the methods of the +class. + +Use L, which is easier/better/faster. This method predates +L. =item B @@ -1708,11 +1713,12 @@ use the C method. =item B +=item B + This will traverse the inheritance heirachy and return a list of all -the applicable attributes for this class. It does not construct a -HASH reference like C because all -that same information is discoverable through the attribute -meta-object itself. +the applicable L objects for this class. + +C is an alias for consistency with C. =item B