X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FClass%2FMOP.pm;h=b7d634ccbd67c74a9c34cbf68ed522faeabe6bfe;hb=91e0eb4ac2962e557cddb12683d6cf3ad339409f;hp=49cea2e75ff56325eadc82335f2866ba49a8d4d1;hpb=587aca2327241221ca99551fbb2c4b0035888ef7;p=gitmo%2FClass-MOP.git diff --git a/lib/Class/MOP.pm b/lib/Class/MOP.pm index 49cea2e..b7d634c 100644 --- a/lib/Class/MOP.pm +++ b/lib/Class/MOP.pm @@ -5,13 +5,41 @@ use strict; use warnings; use Carp 'confess'; -use Scalar::Util (); +use Scalar::Util 'weaken'; use Class::MOP::Class; use Class::MOP::Attribute; use Class::MOP::Method; -our $VERSION = '0.25'; +use Class::MOP::Class::Immutable; + +our $VERSION = '0.34'; +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 ... @@ -37,24 +65,136 @@ our $VERSION = '0.25'; # any subclass of Class::MOP::* will be able to # inherit them using &construct_instance -## Class::MOP::Class +## -------------------------------------------------------- +## Class::MOP::Package -Class::MOP::Class->meta->add_attribute( +Class::MOP::Package->meta->add_attribute( Class::MOP::Attribute->new('$:package' => ( - reader => 'name', + reader => { + # NOTE: we need to do this in order + # for the instance meta-object to + # not fall into meta-circular death + 'name' => sub { (shift)->{'$:package'} } + }, init_arg => ':package', )) ); +Class::MOP::Package->meta->add_attribute( + Class::MOP::Attribute->new('%:namespace' => ( + reader => { + # NOTE: + # because of issues with the Perl API + # to the typeglob in some versions, we + # need to just always grab a new + # reference to the hash here. Ideally + # we could just store a ref and it would + # Just Work, but oh well :\ + 'namespace' => sub { + no strict 'refs'; + \%{$_[0]->name . '::'} + } + }, + # NOTE: + # protect this from silliness + init_arg => '!............( DO NOT DO THIS )............!', + default => sub { \undef } + )) +); + +# NOTE: +# use the metaclass to construct the meta-package +# which is a superclass of the metaclass itself :P +Class::MOP::Package->meta->add_method('initialize' => sub { + my $class = shift; + my $package_name = shift; + $class->meta->new_object(':package' => $package_name, @_); +}); + +## -------------------------------------------------------- +## Class::MOP::Module + +# NOTE: +# yeah this is kind of stretching things a bit, +# but truthfully the version should be an attribute +# of the Module, the weirdness comes from having to +# stick to Perl 5 convention and store it in the +# $VERSION package variable. Basically if you just +# squint at it, it will look how you want it to look. +# Either as a package variable, or as a attribute of +# the metaclass, isn't abstraction great :) + +Class::MOP::Module->meta->add_attribute( + Class::MOP::Attribute->new('$:version' => ( + reader => { + 'version' => sub { + my $self = shift; + ${$self->get_package_symbol('$VERSION')}; + } + }, + # NOTE: + # protect this from silliness + init_arg => '!............( DO NOT DO THIS )............!', + default => sub { \undef } + )) +); + +# NOTE: +# By following the same conventions as version here, +# we are opening up the possibility that people can +# use the $AUTHORITY in non-Class::MOP modules as +# well. + +Class::MOP::Module->meta->add_attribute( + Class::MOP::Attribute->new('$:authority' => ( + reader => { + 'authority' => sub { + my $self = shift; + ${$self->get_package_symbol('$AUTHORITY')}; + } + }, + # NOTE: + # protect this from silliness + init_arg => '!............( DO NOT DO THIS )............!', + default => sub { \undef } + )) +); + +## -------------------------------------------------------- +## Class::MOP::Class + Class::MOP::Class->meta->add_attribute( Class::MOP::Attribute->new('%:attributes' => ( - reader => 'get_attribute_map', + reader => { + # NOTE: we need to do this in order + # for the instance meta-object to + # not fall into meta-circular death + 'get_attribute_map' => sub { (shift)->{'%:attributes'} } + }, init_arg => ':attributes', default => sub { {} } )) ); Class::MOP::Class->meta->add_attribute( + Class::MOP::Attribute->new('%:methods' => ( + reader => { + 'get_method_map' => sub { + my $self = shift; + my $map = $self->{'%:methods'}; + foreach my $symbol ($self->list_all_package_symbols('CODE')) { + my $code = $self->get_package_symbol('&' . $symbol); + next if exists $map->{$symbol} && $map->{$symbol}->body == $code; + $map->{$symbol} = $self->method_metaclass->wrap($code); + } + return $map; + } + }, + default => sub { {} } + )) +); + +Class::MOP::Class->meta->add_attribute( Class::MOP::Attribute->new('$:attribute_metaclass' => ( reader => 'attribute_metaclass', init_arg => ':attribute_metaclass', @@ -70,17 +210,47 @@ Class::MOP::Class->meta->add_attribute( )) ); +Class::MOP::Class->meta->add_attribute( + Class::MOP::Attribute->new('$:instance_metaclass' => ( + reader => { + # NOTE: we need to do this in order + # for the instance meta-object to + # not fall into meta-circular death + 'instance_metaclass' => sub { (shift)->{'$:instance_metaclass'} } + }, + init_arg => ':instance_metaclass', + default => 'Class::MOP::Instance', + )) +); + +# NOTE: +# we don't actually need to tie the knot with +# Class::MOP::Class here, it is actually handled +# within Class::MOP::Class itself in the +# construct_class_instance method. + +## -------------------------------------------------------- ## Class::MOP::Attribute Class::MOP::Attribute->meta->add_attribute( Class::MOP::Attribute->new('name' => ( - reader => 'name' + reader => { + # NOTE: we need to do this in order + # for the instance meta-object to + # not fall into meta-circular death + 'name' => sub { (shift)->{name} } + } )) ); Class::MOP::Attribute->meta->add_attribute( Class::MOP::Attribute->new('associated_class' => ( - reader => 'associated_class' + reader => { + # NOTE: we need to do this in order + # for the instance meta-object to + # not fall into meta-circular death + 'associated_class' => sub { (shift)->{associated_class} } + } )) ); @@ -113,6 +283,13 @@ Class::MOP::Attribute->meta->add_attribute( ); Class::MOP::Attribute->meta->add_attribute( + Class::MOP::Attribute->new('clearer' => ( + reader => 'clearer', + predicate => 'has_clearer', + )) +); + +Class::MOP::Attribute->meta->add_attribute( Class::MOP::Attribute->new('init_arg' => ( reader => 'init_arg', predicate => 'has_init_arg', @@ -141,6 +318,11 @@ Class::MOP::Attribute->meta->add_method('new' => sub { || confess "You must provide a name for the attribute"; $options{init_arg} = $name if not exists $options{init_arg}; + + (Class::MOP::Attribute::is_default_a_coderef(\%options)) + || confess("References are not allowed as default values, you must ". + "wrap then in a CODE reference (ex: sub { [] } and not [])") + if exists $options{default} && ref $options{default}; # return the new object $class->meta->new_object(name => $name, %options); @@ -151,6 +333,17 @@ Class::MOP::Attribute->meta->add_method('clone' => sub { $self->meta->clone_object($self, @_); }); +## -------------------------------------------------------- +## Now close all the Class::MOP::* classes + +Class::MOP::Package ->meta->make_immutable(inline_constructor => 0); +Class::MOP::Module ->meta->make_immutable(inline_constructor => 0); +Class::MOP::Class ->meta->make_immutable(inline_constructor => 0); +Class::MOP::Attribute->meta->make_immutable(inline_constructor => 0); +Class::MOP::Method ->meta->make_immutable(inline_constructor => 0); +Class::MOP::Instance ->meta->make_immutable(inline_constructor => 0); +Class::MOP::Object ->meta->make_immutable(inline_constructor => 0); + 1; __END__ @@ -178,6 +371,12 @@ set of extensions to the Perl 5 object system. Every attempt has been made for these tools to keep to the spirit of the Perl 5 object system that we all know and love. +This documentation is admittedly sparse on details, as time permits +I will try to improve them. For now, I suggest looking at the items +listed in the L section for more information. In particular +the book "The Art of the Meta Object Protocol" was very influential +in the development of this system. + =head2 What is a Meta Object Protocol? A meta object protocol is an API to an object system. @@ -323,6 +522,42 @@ 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 + +This will return an hash of all the metaclass instances that have +been cached by B keyed by the package name. + +=item B + +This will return an array of all the metaclass instances that have +been cached by B. + +=item B + +This will return an array of all the metaclass names that have +been cached by B. + +=item B + +=item B + +=item B + +=item B + +=item B + +=back + =head1 SEE ALSO =head2 Books @@ -406,29 +641,36 @@ L report on this module's test suite. ---------------------------- ------ ------ ------ ------ ------ ------ ------ File stmt bran cond sub pod time total ---------------------------- ------ ------ ------ ------ ------ ------ ------ - Class/MOP.pm 100.0 100.0 100.0 100.0 n/a 21.4 100.0 - Class/MOP/Attribute.pm 100.0 100.0 88.9 100.0 100.0 27.1 99.3 - Class/MOP/Class.pm 100.0 100.0 93.7 100.0 100.0 44.8 99.1 - Class/MOP/Method.pm 100.0 100.0 83.3 100.0 100.0 4.8 97.1 - metaclass.pm 100.0 100.0 80.0 100.0 n/a 1.9 97.3 + Class/MOP.pm 78.0 87.5 55.6 71.4 100.0 12.4 76.8 + Class/MOP/Attribute.pm 83.4 75.6 86.7 94.4 100.0 8.9 85.2 + Class/MOP/Class.pm 96.9 75.8 43.2 98.0 100.0 55.3 83.6 + Class/MOP/Class/Immutable.pm 88.5 53.8 n/a 95.8 100.0 1.1 84.7 + Class/MOP/Instance.pm 87.9 75.0 33.3 89.7 100.0 10.1 89.1 + Class/MOP/Method.pm 97.6 60.0 57.9 76.9 100.0 1.5 82.8 + Class/MOP/Module.pm 87.5 n/a 11.1 83.3 100.0 0.3 66.7 + Class/MOP/Object.pm 100.0 n/a 33.3 100.0 100.0 0.1 89.5 + Class/MOP/Package.pm 95.1 69.0 33.3 100.0 100.0 9.9 85.5 + metaclass.pm 100.0 100.0 83.3 100.0 n/a 0.5 97.7 ---------------------------- ------ ------ ------ ------ ------ ------ ------ - Total 100.0 100.0 92.2 100.0 100.0 100.0 99.0 + Total 91.5 72.1 48.8 90.7 100.0 100.0 84.2 ---------------------------- ------ ------ ------ ------ ------ ------ ------ =head1 ACKNOWLEDGEMENTS =over 4 -=item Rob Kinyon Erob@iinteractive.comE +=item Rob Kinyon Thanks to Rob for actually getting the development of this module kick-started. =back -=head1 AUTHOR +=head1 AUTHORS Stevan Little Estevan@iinteractive.comE +Yuval Kogman Enothingmuch@woobling.comE + =head1 COPYRIGHT AND LICENSE Copyright 2006 by Infinity Interactive, Inc.