X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FClass%2FMOP.pm;h=3fd61eda374e3377ed2880b7abb8c7d6a94064c6;hb=148b469742669e1a506538200f624dcdaeeb510a;hp=932c623d8f12f6324216cbd2d8ce8d5fb0d0693b;hpb=663f81981a56fded486ffdb71bed5c5ab2e5c3fd;p=gitmo%2FClass-MOP.git diff --git a/lib/Class/MOP.pm b/lib/Class/MOP.pm index 932c623..3fd61ed 100644 --- a/lib/Class/MOP.pm +++ b/lib/Class/MOP.pm @@ -4,32 +4,26 @@ package Class::MOP; use strict; use warnings; -use Scalar::Util 'blessed'; use Carp 'confess'; -use SUPER (); +use Scalar::Util (); use Class::MOP::Class; use Class::MOP::Attribute; use Class::MOP::Method; -our $VERSION = '0.07'; - -sub import { - shift; - return unless @_; - if ($_[0] eq ':universal') { - *UNIVERSAL::meta = sub { - Class::MOP::Class->initialize(blessed($_[0]) || $_[0]) - }; - } - else { - my $pkg = caller(); - no strict 'refs'; - *{$pkg . '::' . $_[0]} = sub { - Class::MOP::Class->initialize(blessed($_[0]) || $_[0]) - }; - } -} +use Class::MOP::Class::Immutable; + +our $VERSION = '0.33'; +our $AUTHORITY = 'cpan:STEVAN'; + +## ---------------------------------------------------------------------------- +## Setting up our environment ... +## ---------------------------------------------------------------------------- +## Class::MOP needs to have a few things in the global perl environment so +## that it can operate effectively. Those things are done here. +## ---------------------------------------------------------------------------- + +# ... nothing yet actually ;) ## ---------------------------------------------------------------------------- ## Bootstrapping @@ -46,18 +40,104 @@ sub import { # 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 => { + 'namespace' => sub { (shift)->{'%:namespace'} } + }, + default => sub { + my ($class) = @_; + no strict 'refs'; + return \%{$class->name . '::'}; + }, + # NOTE: + # protect this from silliness + init_arg => '!............( DO NOT DO THIS )............!', + )) +); + +# 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 )............!', + )) +); + +# 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 )............!', + )) +); + +## -------------------------------------------------------- +## 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 { {} } )) @@ -79,17 +159,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} } + } )) ); @@ -122,6 +232,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', @@ -150,6 +267,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); @@ -157,16 +279,20 @@ Class::MOP::Attribute->meta->add_method('new' => sub { Class::MOP::Attribute->meta->add_method('clone' => sub { my $self = shift; - my $class = $self->associated_class; - $self->detach_from_class() if defined $class; - my $clone = $self->meta->clone_object($self, @_); - if (defined $class) { - $self->attach_to_class($class); - $clone->attach_to_class($class); - } - return $clone; + $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__ @@ -194,6 +320,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. @@ -296,6 +428,14 @@ are interested in why this is an issue see the paper I linked to in the L section of this document. +=head2 Using custom metaclasses + +Always use the metaclass pragma when using a custom metaclass, this +will ensure the proper initialization order and not accidentely +create an incorrect type of metaclass for you. This is a very rare +problem, and one which can only occur if you are doing deep metaclass +programming. So in other words, don't worry about it. + =head1 PROTOCOLS The protocol is divided into 3 main sub-protocols: @@ -406,6 +546,24 @@ All complex software has bugs lurking in it, and this module is no exception. If you find a bug please either email me, or add the bug to cpan-RT. +=head1 CODE COVERAGE + +I use L to test the code coverage of my tests, below is the +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 19.8 100.0 + Class/MOP/Attribute.pm 100.0 100.0 91.7 61.2 100.0 14.3 87.9 + Class/MOP/Class.pm 97.6 91.3 77.3 98.4 100.0 56.4 93.2 + Class/MOP/Instance.pm 91.1 75.0 33.3 91.7 100.0 6.8 90.7 + Class/MOP/Method.pm 97.6 60.0 52.9 76.9 100.0 1.6 82.6 + metaclass.pm 100.0 100.0 83.3 100.0 n/a 1.0 97.7 + ---------------------------- ------ ------ ------ ------ ------ ------ ------ + Total 97.5 88.5 75.5 82.8 100.0 100.0 91.2 + ---------------------------- ------ ------ ------ ------ ------ ------ ------ + =head1 ACKNOWLEDGEMENTS =over 4 @@ -416,10 +574,12 @@ 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.