use warnings;
use Carp 'confess';
-use Scalar::Util ();
+use Scalar::Util 'weaken';
use Class::MOP::Class;
use Class::MOP::Attribute;
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 ...
## ----------------------------------------------------------------------------
=back
+=head1 FUNCTIONS
+
+Class::MOP holds a cache of metaclasses, the following are functions
+(B<not methods>) 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<get_all_metaclasses>
+
+=item B<get_all_metaclass_instances>
+
+=item B<get_all_metaclass_names>
+
+=item B<get_metaclass_by_name ($name)>
+
+=item B<store_metaclass_by_name ($name, $meta)>
+
+=item B<weaken_metaclass ($name)>
+
+=item B<does_metaclass_exist ($name)>
+
+=item B<remove_metaclass_by_name ($name)>
+
+=back
+
=head1 SEE ALSO
=head2 Books
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';
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
projects / gitmo/Class-MOP.git / commitdiff