From: Stevan Little Date: Thu, 17 Aug 2006 14:07:27 +0000 (+0000) Subject: moved all the metaclass cache stuff to Class::MOP so that we are not polluting the... X-Git-Tag: 0_33~5 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=be7677c7dd446a9fef66fab0f258f5c1826ecc90;p=gitmo%2FClass-MOP.git moved all the metaclass cache stuff to Class::MOP so that we are not polluting the Class::MOP::Class namespace --- diff --git a/Changes b/Changes index f7ddf66..2789204 100644 --- a/Changes +++ b/Changes @@ -1,6 +1,10 @@ Revision history for Perl extension Class-MOP. 0.33 + * Class::MOP::Class + - moved the metaclass cache out of here + and it is now in Class::MOP itself. + * Class::MOP::Attribute - reference values (other than CODE refs) are no longer allowed for defaults diff --git a/lib/Class/MOP.pm b/lib/Class/MOP.pm index 3fd61ed..df79f29 100644 --- a/lib/Class/MOP.pm +++ b/lib/Class/MOP.pm @@ -5,7 +5,7 @@ use strict; use warnings; use Carp 'confess'; -use Scalar::Util (); +use Scalar::Util 'weaken'; use Class::MOP::Class; use Class::MOP::Attribute; @@ -16,6 +16,31 @@ use Class::MOP::Class::Immutable; our $VERSION = '0.33'; our $AUTHORITY = 'cpan:STEVAN'; +{ + # Metaclasses are singletons, so we cache them here. + # there is no need to worry about destruction though + # because they should die only when the program dies. + # After all, do package definitions even get reaped? + my %METAS; + + # means of accessing all the metaclasses that have + # been initialized thus far (for mugwumps obj browser) + sub get_all_metaclasses { %METAS } + sub get_all_metaclass_instances { values %METAS } + sub get_all_metaclass_names { keys %METAS } + sub get_metaclass_by_name { $METAS{$_[0]} } + sub store_metaclass_by_name { $METAS{$_[0]} = $_[1] } + sub weaken_metaclass { weaken($METAS{$_[0]}) } + sub does_metaclass_exist { exists $METAS{$_[0]} && defined $METAS{$_[0]} } + sub remove_metaclass_by_name { $METAS{$_[0]} = undef } + + # NOTE: + # We only cache metaclasses, meaning instances of + # Class::MOP::Class. We do not cache instance of + # Class::MOP::Package or Class::MOP::Module. Mostly + # because I don't yet see a good reason to do so. +} + ## ---------------------------------------------------------------------------- ## Setting up our environment ... ## ---------------------------------------------------------------------------- @@ -471,6 +496,33 @@ See L for more details. =back +=head1 FUNCTIONS + +Class::MOP holds a cache of metaclasses, the following are functions +(B) which can be used to access that cache. It is not +recommended that you mess with this, bad things could happen. But if +you are brave and willing to risk it, go for it. + +=over 4 + +=item B + +=item B + +=item B + +=item B + +=item B + +=item B + +=item B + +=item B + +=back + =head1 SEE ALSO =head2 Books diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm index f5e8ca7..17f36f3 100644 --- a/lib/Class/MOP/Class.pm +++ b/lib/Class/MOP/Class.pm @@ -9,7 +9,7 @@ use Scalar::Util 'blessed', 'reftype', 'weaken'; use Sub::Name 'subname'; use B 'svref_2object'; -our $VERSION = '0.17'; +our $VERSION = '0.18'; our $AUTHORITY = 'cpan:STEVAN'; use base 'Class::MOP::Module'; @@ -30,140 +30,127 @@ sub meta { Class::MOP::Class->initialize(blessed($_[0]) || $_[0]) } my $ANON_CLASS_PREFIX = 'Class::MOP::Class::__ANON__::SERIAL::'; # Creation - -{ - # Metaclasses are singletons, so we cache them here. - # there is no need to worry about destruction though - # because they should die only when the program dies. - # After all, do package definitions even get reaped? - my %METAS; - # means of accessing all the metaclasses that have - # been initialized thus far (for mugwumps obj browser) - sub get_all_metaclasses { %METAS } - sub get_all_metaclass_instances { values %METAS } - sub get_all_metaclass_names { keys %METAS } +sub initialize { + my $class = shift; + my $package_name = shift; + (defined $package_name && $package_name && !blessed($package_name)) + || confess "You must pass a package name and it cannot be blessed"; + $class->construct_class_instance(':package' => $package_name, @_); +} + +sub reinitialize { + my $class = shift; + my $package_name = shift; + (defined $package_name && $package_name && !blessed($package_name)) + || confess "You must pass a package name and it cannot be blessed"; + Class::MOP::remove_metaclass_by_name($package_name); + $class->construct_class_instance(':package' => $package_name, @_); +} - sub initialize { - my $class = shift; - my $package_name = shift; - (defined $package_name && $package_name && !blessed($package_name)) - || confess "You must pass a package name and it cannot be blessed"; - $class->construct_class_instance(':package' => $package_name, @_); +# NOTE: (meta-circularity) +# this is a special form of &construct_instance +# (see below), which is used to construct class +# meta-object instances for any Class::MOP::* +# class. All other classes will use the more +# normal &construct_instance. +sub construct_class_instance { + my $class = shift; + my %options = @_; + my $package_name = $options{':package'}; + (defined $package_name && $package_name) + || confess "You must pass a package name"; + # NOTE: + # return the metaclass if we have it cached, + # and it is still defined (it has not been + # reaped by DESTROY yet, which can happen + # annoyingly enough during global destruction) + return Class::MOP::get_metaclass_by_name($package_name) + if Class::MOP::does_metaclass_exist($package_name); + + # NOTE: + # we need to deal with the possibility + # of class immutability here, and then + # get the name of the class appropriately + $class = (blessed($class) + ? ($class->is_immutable + ? $class->get_mutable_metaclass_name() + : blessed($class)) + : $class); + + $class = blessed($class) || $class; + # now create the metaclass + my $meta; + if ($class =~ /^Class::MOP::Class$/) { + no strict 'refs'; + $meta = bless { + # inherited from Class::MOP::Package + '$:package' => $package_name, + '%:namespace' => \%{$package_name . '::'}, + # inherited from Class::MOP::Module + '$:version' => (exists ${$package_name . '::'}{'VERSION'} ? ${$package_name . '::VERSION'} : undef), + '$:authority' => (exists ${$package_name . '::'}{'AUTHORITY'} ? ${$package_name . '::AUTHORITY'} : undef), + # defined here ... + '%: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; + } + 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) } - sub reinitialize { - my $class = shift; - my $package_name = shift; - (defined $package_name && $package_name && !blessed($package_name)) - || confess "You must pass a package name and it cannot be blessed"; - $METAS{$package_name} = undef; - $class->construct_class_instance(':package' => $package_name, @_); - } + # and check the metaclass compatibility + $meta->check_metaclass_compatability(); - # NOTE: (meta-circularity) - # this is a special form of &construct_instance - # (see below), which is used to construct class - # meta-object instances for any Class::MOP::* - # class. All other classes will use the more - # normal &construct_instance. - sub construct_class_instance { - my $class = shift; - my %options = @_; - my $package_name = $options{':package'}; - (defined $package_name && $package_name) - || confess "You must pass a package name"; - # NOTE: - # return the metaclass if we have it cached, - # and it is still defined (it has not been - # reaped by DESTROY yet, which can happen - # annoyingly enough during global destruction) - return $METAS{$package_name} - if exists $METAS{$package_name} && defined $METAS{$package_name}; + Class::MOP::store_metaclass_by_name($package_name, $meta); + # NOTE: + # we need to weaken any anon classes + # so that they can call DESTROY properly + Class::MOP::weaken_metaclass($package_name) + if $package_name =~ /^$ANON_CLASS_PREFIX/; + $meta; +} + +sub check_metaclass_compatability { + my $self = shift; + + # this is always okay ... + return if blessed($self) eq 'Class::MOP::Class' && + $self->instance_metaclass eq 'Class::MOP::Instance'; + + my @class_list = $self->class_precedence_list; + shift @class_list; # shift off $self->name + foreach my $class_name (@class_list) { + my $meta = Class::MOP::get_metaclass_by_name($class_name) || next; + # NOTE: # we need to deal with the possibility # of class immutability here, and then - # get the name of the class appropriately - $class = (blessed($class) - ? ($class->is_immutable - ? $class->get_mutable_metaclass_name() - : blessed($class)) - : $class); - - $class = blessed($class) || $class; - # now create the metaclass - my $meta; - if ($class =~ /^Class::MOP::Class$/) { - no strict 'refs'; - $meta = bless { - # inherited from Class::MOP::Package - '$:package' => $package_name, - '%:namespace' => \%{$package_name . '::'}, - # inherited from Class::MOP::Module - '$:version' => (exists ${$package_name . '::'}{'VERSION'} ? ${$package_name . '::VERSION'} : undef), - '$:authority' => (exists ${$package_name . '::'}{'AUTHORITY'} ? ${$package_name . '::AUTHORITY'} : undef), - # defined here ... - '%: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; - } - 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) - } - - # and check the metaclass compatibility - $meta->check_metaclass_compatability(); - $METAS{$package_name} = $meta; + # get the name of the class appropriately + my $meta_type = ($meta->is_immutable + ? $meta->get_mutable_metaclass_name() + : blessed($meta)); + + ($self->isa($meta_type)) + || confess $self->name . "->meta => (" . (blessed($self)) . ")" . + " is not compatible with the " . + $class_name . "->meta => (" . ($meta_type) . ")"; # NOTE: - # we need to weaken any anon classes - # so that they can call DESTROY properly - weaken($METAS{$package_name}) - if $package_name =~ /^$ANON_CLASS_PREFIX/; - $meta; - } - - sub check_metaclass_compatability { - my $self = shift; - - # this is always okay ... - return if blessed($self) eq 'Class::MOP::Class' && - $self->instance_metaclass eq 'Class::MOP::Instance'; - - my @class_list = $self->class_precedence_list; - shift @class_list; # shift off $self->name - - foreach my $class_name (@class_list) { - my $meta = $METAS{$class_name} || next; - - # NOTE: - # we need to deal with the possibility - # of class immutability here, and then - # get the name of the class appropriately - my $meta_type = ($meta->is_immutable - ? $meta->get_mutable_metaclass_name() - : blessed($meta)); - - ($self->isa($meta_type)) - || confess $self->name . "->meta => (" . (blessed($self)) . ")" . - " is not compatible with the " . - $class_name . "->meta => (" . ($meta_type) . ")"; - # NOTE: - # we also need to check that instance metaclasses - # are compatabile in the same the class. - ($self->instance_metaclass->isa($meta->instance_metaclass)) - || confess $self->name . "->meta => (" . ($self->instance_metaclass) . ")" . - " is not compatible with the " . - $class_name . "->meta => (" . ($meta->instance_metaclass) . ")"; - } - } -} + # we also need to check that instance metaclasses + # are compatabile in the same the class. + ($self->instance_metaclass->isa($meta->instance_metaclass)) + || confess $self->name . "->meta => (" . ($self->instance_metaclass) . ")" . + " is not compatible with the " . + $class_name . "->meta => (" . ($meta->instance_metaclass) . ")"; + } +} ## ANON classes diff --git a/t/000_load.t b/t/000_load.t index 61be01a..31bd482 100644 --- a/t/000_load.t +++ b/t/000_load.t @@ -29,12 +29,12 @@ my %METAS = ( ok($_->is_immutable(), '... ' . $_->name . ' is immutable') for values %METAS; is_deeply( - { Class::MOP::Class->get_all_metaclasses }, + { Class::MOP::get_all_metaclasses }, \%METAS, '... got all the metaclasses'); is_deeply( - [ sort { $a->name cmp $b->name } Class::MOP::Class->get_all_metaclass_instances ], + [ sort { $a->name cmp $b->name } Class::MOP::get_all_metaclass_instances ], [ Class::MOP::Attribute->meta, Class::MOP::Class->meta, @@ -47,7 +47,7 @@ is_deeply( '... got all the metaclass instances'); is_deeply( - [ sort Class::MOP::Class->get_all_metaclass_names ], + [ sort { $a cmp $b } Class::MOP::get_all_metaclass_names() ], [ qw/ Class::MOP::Attribute Class::MOP::Class diff --git a/t/010_self_introspection.t b/t/010_self_introspection.t index 570084e..24572a5 100644 --- a/t/010_self_introspection.t +++ b/t/010_self_introspection.t @@ -3,7 +3,7 @@ use strict; use warnings; -use Test::More tests => 189; +use Test::More tests => 183; use Test::Exception; BEGIN { @@ -50,8 +50,6 @@ my @class_mop_module_methods = qw( my @class_mop_class_methods = qw( meta - get_all_metaclasses get_all_metaclass_names get_all_metaclass_instances - initialize reinitialize create create_anon_class instance_metaclass get_meta_instance