X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FClass%2FMOP%2FClass.pm;h=fa2c92009b985e33e11a58cf1f156bd9c846abea;hb=f3938c217bb3ff340d2744a56385df03b6847c3f;hp=c5075dc0617c92596cf89618568291bfd039a0d5;hpb=09ea7f8d2f3e9c7189c0c52762e7c0cab9fd914b;p=gitmo%2FClass-MOP.git diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm index c5075dc..fa2c920 100644 --- a/lib/Class/MOP/Class.pm +++ b/lib/Class/MOP/Class.pm @@ -72,50 +72,17 @@ 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: @@ -138,6 +105,35 @@ sub construct_class_instance { $meta; } +sub _new { + my ( $class, %options ) = @_; + 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 +150,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 +165,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 +200,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 +209,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 +218,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 +270,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}}) @@ -430,7 +417,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 +453,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 +780,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 +933,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,19 +965,14 @@ 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, %seen_attr); - foreach my $class ($self->linearized_isa) { - # fetch the meta-class ... - my $meta = $self->initialize($class); - foreach my $attr_name ($meta->get_attribute_list()) { - next if exists $seen_attr{$attr_name}; - $seen_attr{$attr_name}++; - push @attrs => $meta->get_attribute($attr_name); - } - } - return @attrs; + my %attrs = map { %{ $self->initialize($_)->get_attribute_map } } reverse $self->linearized_isa; + return values %attrs; } sub find_attribute_by_name { @@ -1041,7 +1027,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" @@ -1516,13 +1502,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 @@ -1717,11 +1710,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