X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FClass%2FMOP.pm;h=7e228ae626aec0f330bca532e61ce8c7b1d6640a;hb=72c210741ee3aac7aa37579b16e099d5376c62a4;hp=74d76b43a938aa0df17dad5146c03dacd43a4b2f;hpb=2e41896ef928bb97cd490b03cd77f0280d802384;p=gitmo%2FClass-MOP.git diff --git a/lib/Class/MOP.pm b/lib/Class/MOP.pm index 74d76b4..7e228ae 100644 --- a/lib/Class/MOP.pm +++ b/lib/Class/MOP.pm @@ -4,31 +4,23 @@ package Class::MOP; use strict; use warnings; -use Scalar::Util 'blessed'; use Carp 'confess'; +use Scalar::Util (); use Class::MOP::Class; use Class::MOP::Attribute; use Class::MOP::Method; -our $VERSION = '0.05'; - -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]) - }; - } -} +our $VERSION = '0.13'; + +## ---------------------------------------------------------------------------- +## 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 @@ -48,27 +40,92 @@ sub import { ## Class::MOP::Class Class::MOP::Class->meta->add_attribute( - Class::MOP::Attribute->new('$:pkg' => ( - init_arg => ':pkg' + Class::MOP::Attribute->new('$:package' => ( + reader => 'name', + init_arg => ':package', )) ); Class::MOP::Class->meta->add_attribute( - Class::MOP::Attribute->new('%:attrs' => ( - init_arg => ':attrs', + Class::MOP::Attribute->new('%:attributes' => ( + reader => 'get_attribute_map', + init_arg => ':attributes', default => sub { {} } )) ); +Class::MOP::Class->meta->add_attribute( + Class::MOP::Attribute->new('$:attribute_metaclass' => ( + reader => 'attribute_metaclass', + init_arg => ':attribute_metaclass', + default => 'Class::MOP::Attribute', + )) +); + +Class::MOP::Class->meta->add_attribute( + Class::MOP::Attribute->new('$:method_metaclass' => ( + reader => 'method_metaclass', + init_arg => ':method_metaclass', + default => 'Class::MOP::Method', + )) +); + ## Class::MOP::Attribute -Class::MOP::Attribute->meta->add_attribute(Class::MOP::Attribute->new('name')); -Class::MOP::Attribute->meta->add_attribute(Class::MOP::Attribute->new('accessor')); -Class::MOP::Attribute->meta->add_attribute(Class::MOP::Attribute->new('reader')); -Class::MOP::Attribute->meta->add_attribute(Class::MOP::Attribute->new('writer')); -Class::MOP::Attribute->meta->add_attribute(Class::MOP::Attribute->new('predicate')); -Class::MOP::Attribute->meta->add_attribute(Class::MOP::Attribute->new('init_arg')); -Class::MOP::Attribute->meta->add_attribute(Class::MOP::Attribute->new('default')); +Class::MOP::Attribute->meta->add_attribute( + Class::MOP::Attribute->new('name' => ( + reader => 'name' + )) +); + +Class::MOP::Attribute->meta->add_attribute( + Class::MOP::Attribute->new('associated_class' => ( + reader => 'associated_class' + )) +); + +Class::MOP::Attribute->meta->add_attribute( + Class::MOP::Attribute->new('accessor' => ( + reader => 'accessor', + predicate => 'has_accessor', + )) +); + +Class::MOP::Attribute->meta->add_attribute( + Class::MOP::Attribute->new('reader' => ( + reader => 'reader', + predicate => 'has_reader', + )) +); + +Class::MOP::Attribute->meta->add_attribute( + Class::MOP::Attribute->new('writer' => ( + reader => 'writer', + predicate => 'has_writer', + )) +); + +Class::MOP::Attribute->meta->add_attribute( + Class::MOP::Attribute->new('predicate' => ( + reader => 'predicate', + predicate => 'has_predicate', + )) +); + +Class::MOP::Attribute->meta->add_attribute( + Class::MOP::Attribute->new('init_arg' => ( + reader => 'init_arg', + predicate => 'has_init_arg', + )) +); + +Class::MOP::Attribute->meta->add_attribute( + Class::MOP::Attribute->new('default' => ( + # default has a custom 'reader' method ... + predicate => 'has_default', + )) +); + # NOTE: (meta-circularity) # This should be one of the last things done @@ -82,11 +139,16 @@ Class::MOP::Attribute->meta->add_method('new' => sub { (defined $name && $name) || confess "You must provide a name for the attribute"; - (!exists $options{reader} && !exists $options{writer}) - || confess "You cannot declare an accessor and reader and/or writer functions" - if exists $options{accessor}; - - bless $class->meta->construct_instance(name => $name, %options) => $class; + $options{init_arg} = $name + if not exists $options{init_arg}; + + # return the new object + $class->meta->new_object(name => $name, %options); +}); + +Class::MOP::Attribute->meta->add_method('clone' => sub { + my $self = shift; + $self->meta->clone_object($self, @_); }); 1; @@ -183,6 +245,49 @@ B drain at all upon your code's performance. In fact, by itself it does nothing to affect your existing code. So you only pay for what you actually use. +=head2 About Metaclass compatibility + +This module makes sure that all metaclasses created are both upwards +and downwards compatible. The topic of metaclass compatibility is +highly esoteric and is something only encountered when doing deep and +involved metaclass hacking. There are two basic kinds of metaclass +incompatibility; upwards and downwards. + +Upwards metaclass compatibility means that the metaclass of a +given class is either the same as (or a subclass of) all of the +class's ancestors. + +Downward metaclass compatibility means that the metaclasses of a +given class's anscestors are all either the same as (or a subclass +of) that metaclass. + +Here is a diagram showing a set of two classes (C and C) and +two metaclasses (C and C) which have correct +metaclass compatibility both upwards and downwards. + + +---------+ +---------+ + | Meta::A |<----| Meta::B | <....... (instance of ) + +---------+ +---------+ <------- (inherits from) + ^ ^ + : : + +---------+ +---------+ + | A |<----| B | + +---------+ +---------+ + +As I said this is a highly esoteric topic and one you will only run +into if you do a lot of subclassing of B. If you +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: @@ -239,6 +344,29 @@ email me and let me know, I would love to hear about them. =back +=head2 Papers + +=over 4 + +=item Uniform and safe metaclass composition + +An excellent paper by the people who brought us the original Traits paper. +This paper is on how Traits can be used to do safe metaclass composition, +and offers an excellent introduction section which delves into the topic of +metaclass compatibility. + +L + +=item Safe Metaclass Programming + +This paper seems to precede the above paper, and propose a mix-in based +approach as opposed to the Traits based approach. Both papers have similar +information on the metaclass compatibility problem space. + +L + +=back + =head2 Prior Art =over 4 @@ -261,30 +389,8 @@ As I have said above, this module is a class-builder-builder, so it is not the same thing as modules like L and L. That being said there are very few modules on CPAN with similar goals to this module. The one I have found which is most -like this module is L, although it's philosophy is very -different from this module. - -To start with, it provides wrappers around common Perl data types, and even -extends those types with more specific subtypes. This module does not -go into that area at all. - -L also seems to create it's own custom meta-object protocol, -which is both more restrictive and more featureful than the vanilla -Perl 5 one. This module attempts to model the existing Perl 5 MOP as it is. - -It's introspection capabilities also seem to be heavily rooted in this -custom MOP, so that you can only introspect classes which are already -created with L. This module does not make such restictions. - -Now, all this said, L is much more featureful than B -would ever try to be. But B has some features which L -could not easily implement. It would be very possible to completely re-implement -L using B and bring some of these features to -L though. - -But in the end, this module's admitedly ambitious goals have no direct equal -on CPAN since surely no one has been crazy enough to try something as silly -as this ;) until now. +like this module is L, although it's philosophy and the MOP it +creates are very different from this modules. =head1 BUGS @@ -292,6 +398,23 @@ 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 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 + ---------------------------- ------ ------ ------ ------ ------ ------ ------ + Total 100.0 100.0 92.2 100.0 100.0 100.0 99.0 + ---------------------------- ------ ------ ------ ------ ------ ------ ------ + =head1 ACKNOWLEDGEMENTS =over 4