X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FClass%2FMOP.pm;h=f72efcbeb6dee5729138786ca1c2f37b5a7b3187;hb=b817e2484ef4612e60c8a7ce34b58b4d359aa3d6;hp=ef130fc5083cfd9a712b3ed59ae3799219dcc714;hpb=c4260b45e76ce008e4c51987b243f2b0ae4313bb;p=gitmo%2FClass-MOP.git diff --git a/lib/Class/MOP.pm b/lib/Class/MOP.pm index ef130fc..f72efcb 100644 --- a/lib/Class/MOP.pm +++ b/lib/Class/MOP.pm @@ -11,9 +11,9 @@ use Class::MOP::Class; use Class::MOP::Attribute; use Class::MOP::Method; -use Class::MOP::Class::Immutable; +use Class::MOP::Immutable; -our $VERSION = '0.34'; +our $VERSION = '0.39'; our $AUTHORITY = 'cpan:STEVAN'; { @@ -41,6 +41,35 @@ our $AUTHORITY = 'cpan:STEVAN'; # because I don't yet see a good reason to do so. } +sub load_class { + my $class = shift; + # see if this is already + # loaded in the symbol table + return 1 if is_class_loaded($class); + # otherwise require it ... + my $file = $class . '.pm'; + $file =~ s{::}{/}g; + eval { CORE::require($file) }; + confess "Could not load class ($class) because : $@" if $@; + unless (does_metaclass_exist($class)) { + eval { Class::MOP::Class->initialize($class) }; + confess "Could not initialize class ($class) because : $@" if $@; + } + 1; # return true if it worked +} + +sub is_class_loaded { + my $class = shift; + no strict 'refs'; + return 1 if defined ${"${class}::VERSION"} || defined @{"${class}::ISA"}; + foreach (keys %{"${class}::"}) { + next if substr($_, -2, 2) eq '::'; + return 1 if defined &{"${class}::$_"}; + } + return 0; +} + + ## ---------------------------------------------------------------------------- ## Setting up our environment ... ## ---------------------------------------------------------------------------- @@ -69,31 +98,27 @@ our $AUTHORITY = 'cpan:STEVAN'; ## Class::MOP::Package Class::MOP::Package->meta->add_attribute( - Class::MOP::Attribute->new('$:package' => ( + Class::MOP::Attribute->new('$!package' => ( 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'} } + # + # we just alias the original method + # rather than re-produce it here + 'name' => \&Class::MOP::Package::name }, - init_arg => ':package', + init_arg => 'package', )) ); Class::MOP::Package->meta->add_attribute( - Class::MOP::Attribute->new('%:namespace' => ( + 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 . '::'} - } + # we just alias the original method + # rather than re-produce it here + 'namespace' => \&Class::MOP::Package::namespace }, # NOTE: # protect this from silliness @@ -108,7 +133,7 @@ Class::MOP::Package->meta->add_attribute( Class::MOP::Package->meta->add_method('initialize' => sub { my $class = shift; my $package_name = shift; - $class->meta->new_object(':package' => $package_name, @_); + $class->meta->new_object('package' => $package_name, @_); }); ## -------------------------------------------------------- @@ -125,12 +150,12 @@ Class::MOP::Package->meta->add_method('initialize' => sub { # the metaclass, isn't abstraction great :) Class::MOP::Module->meta->add_attribute( - Class::MOP::Attribute->new('$:version' => ( + Class::MOP::Attribute->new('$!version' => ( reader => { - 'version' => sub { - my $self = shift; - ${$self->get_package_symbol('$VERSION')}; - } + # NOTE: + # we just alias the original method + # rather than re-produce it here + 'version' => \&Class::MOP::Module::version }, # NOTE: # protect this from silliness @@ -146,12 +171,12 @@ Class::MOP::Module->meta->add_attribute( # well. Class::MOP::Module->meta->add_attribute( - Class::MOP::Attribute->new('$:authority' => ( + Class::MOP::Attribute->new('$!authority' => ( reader => { - 'authority' => sub { - my $self = shift; - ${$self->get_package_symbol('$AUTHORITY')}; - } + # NOTE: + # we just alias the original method + # rather than re-produce it here + 'authority' => \&Class::MOP::Module::authority }, # NOTE: # protect this from silliness @@ -164,70 +189,87 @@ Class::MOP::Module->meta->add_attribute( ## Class::MOP::Class Class::MOP::Class->meta->add_attribute( - Class::MOP::Attribute->new('%:attributes' => ( + Class::MOP::Attribute->new('%!attributes' => ( 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'} } + # not fall into meta-circular death + # + # we just alias the original method + # rather than re-produce it here + 'get_attribute_map' => \&Class::MOP::Class::get_attribute_map }, - init_arg => ':attributes', + init_arg => 'attributes', default => sub { {} } )) ); Class::MOP::Class->meta->add_attribute( - Class::MOP::Attribute->new('%:methods' => ( + Class::MOP::Attribute->new('%!methods' => ( + init_arg => 'methods', reader => { # NOTE: - # as with the $VERSION and $AUTHORITY above - # sometimes we don't/can't store directly - # inside the instance, so we need the accessor - # to just DWIM - 'get_method_map' => sub { - my $self = shift; - # FIXME: - # there is a faster/better way - # to do this, I am sure :) - return +{ - map { - $_ => $self->get_method($_) - } grep { - $self->has_method($_) - } $self->list_all_package_symbols - }; - } + # we just alias the original method + # rather than re-produce it here + 'get_method_map' => \&Class::MOP::Class::get_method_map }, + default => sub { {} } + )) +); + +Class::MOP::Class->meta->add_attribute( + Class::MOP::Attribute->new('@!superclasses' => ( + accessor => { + # NOTE: + # we just alias the original method + # rather than re-produce it here + 'superclasses' => \&Class::MOP::Class::superclasses + }, + # NOTE: + # protect this from silliness init_arg => '!............( DO NOT DO THIS )............!', default => sub { \undef } )) ); Class::MOP::Class->meta->add_attribute( - Class::MOP::Attribute->new('$:attribute_metaclass' => ( - reader => 'attribute_metaclass', - init_arg => ':attribute_metaclass', + Class::MOP::Attribute->new('$!attribute_metaclass' => ( + reader => { + # NOTE: + # we just alias the original method + # rather than re-produce it here + 'attribute_metaclass' => \&Class::MOP::Class::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', + Class::MOP::Attribute->new('$!method_metaclass' => ( + reader => { + # NOTE: + # we just alias the original method + # rather than re-produce it here + 'method_metaclass' => \&Class::MOP::Class::method_metaclass + }, + init_arg => 'method_metaclass', default => 'Class::MOP::Method', )) ); Class::MOP::Class->meta->add_attribute( - Class::MOP::Attribute->new('$:instance_metaclass' => ( + 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'} } + # not fall into meta-circular death + # + # we just alias the original method + # rather than re-produce it here + 'instance_metaclass' => \&Class::MOP::Class::instance_metaclass }, - init_arg => ':instance_metaclass', + init_arg => 'instance_metaclass', default => 'Class::MOP::Instance', )) ); @@ -242,76 +284,98 @@ Class::MOP::Class->meta->add_attribute( ## Class::MOP::Attribute Class::MOP::Attribute->meta->add_attribute( - Class::MOP::Attribute->new('name' => ( - reader => { + Class::MOP::Attribute->new('$!name' => ( + init_arg => '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} } + # not fall into meta-circular death + # + # we just alias the original method + # rather than re-produce it here + 'name' => \&Class::MOP::Attribute::name } )) ); Class::MOP::Attribute->meta->add_attribute( - Class::MOP::Attribute->new('associated_class' => ( - reader => { + Class::MOP::Attribute->new('$!associated_class' => ( + init_arg => '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} } + # not fall into meta-circular death + # + # we just alias the original method + # rather than re-produce it here + 'associated_class' => \&Class::MOP::Attribute::associated_class } )) ); Class::MOP::Attribute->meta->add_attribute( - Class::MOP::Attribute->new('accessor' => ( - reader => 'accessor', - predicate => 'has_accessor', + Class::MOP::Attribute->new('$!accessor' => ( + init_arg => 'accessor', + reader => { 'accessor' => \&Class::MOP::Attribute::accessor }, + predicate => { 'has_accessor' => \&Class::MOP::Attribute::has_accessor }, )) ); Class::MOP::Attribute->meta->add_attribute( - Class::MOP::Attribute->new('reader' => ( - reader => 'reader', - predicate => 'has_reader', + Class::MOP::Attribute->new('$!reader' => ( + init_arg => 'reader', + reader => { 'reader' => \&Class::MOP::Attribute::reader }, + predicate => { 'has_reader' => \&Class::MOP::Attribute::has_reader }, )) ); Class::MOP::Attribute->meta->add_attribute( - Class::MOP::Attribute->new('writer' => ( - reader => 'writer', - predicate => 'has_writer', + Class::MOP::Attribute->new('$!writer' => ( + init_arg => 'writer', + reader => { 'writer' => \&Class::MOP::Attribute::writer }, + predicate => { 'has_writer' => \&Class::MOP::Attribute::has_writer }, )) ); Class::MOP::Attribute->meta->add_attribute( - Class::MOP::Attribute->new('predicate' => ( - reader => 'predicate', - predicate => 'has_predicate', + Class::MOP::Attribute->new('$!predicate' => ( + init_arg => 'predicate', + reader => { 'predicate' => \&Class::MOP::Attribute::predicate }, + predicate => { 'has_predicate' => \&Class::MOP::Attribute::has_predicate }, )) ); Class::MOP::Attribute->meta->add_attribute( - Class::MOP::Attribute->new('clearer' => ( - reader => 'clearer', - predicate => 'has_clearer', + Class::MOP::Attribute->new('$!clearer' => ( + init_arg => 'clearer', + reader => { 'clearer' => \&Class::MOP::Attribute::clearer }, + predicate => { 'has_clearer' => \&Class::MOP::Attribute::has_clearer }, )) ); Class::MOP::Attribute->meta->add_attribute( - Class::MOP::Attribute->new('init_arg' => ( - reader => 'init_arg', - predicate => 'has_init_arg', + Class::MOP::Attribute->new('$!init_arg' => ( + init_arg => 'init_arg', + reader => { 'init_arg' => \&Class::MOP::Attribute::init_arg }, + predicate => { 'has_init_arg' => \&Class::MOP::Attribute::has_init_arg }, )) ); Class::MOP::Attribute->meta->add_attribute( - Class::MOP::Attribute->new('default' => ( + Class::MOP::Attribute->new('$!default' => ( + init_arg => 'default', # default has a custom 'reader' method ... - predicate => 'has_default', + predicate => { 'has_default' => \&Class::MOP::Attribute::has_default }, )) ); +Class::MOP::Attribute->meta->add_attribute( + Class::MOP::Attribute->new('@!associated_methods' => ( + init_arg => 'associated_methods', + reader => { 'associated_methods' => \&Class::MOP::Attribute::associated_methods }, + default => sub { [] } + )) +); # NOTE: (meta-circularity) # This should be one of the last things done @@ -343,15 +407,117 @@ Class::MOP::Attribute->meta->add_method('clone' => sub { }); ## -------------------------------------------------------- +## Class::MOP::Method + +Class::MOP::Method->meta->add_attribute( + Class::MOP::Attribute->new('&!body' => ( + init_arg => 'body', + reader => { 'body' => \&Class::MOP::Method::body }, + )) +); + +## -------------------------------------------------------- +## Class::MOP::Method::Wrapped + +# NOTE: +# the way this item is initialized, this +# really does not follow the standard +# practices of attributes, but we put +# it here for completeness +Class::MOP::Method::Wrapped->meta->add_attribute( + Class::MOP::Attribute->new('%!modifier_table') +); + +## -------------------------------------------------------- +## Class::MOP::Method::Accessor + +Class::MOP::Method::Accessor->meta->add_attribute( + Class::MOP::Attribute->new('$!attribute' => ( + init_arg => 'attribute', + reader => { + 'associated_attribute' => \&Class::MOP::Method::Accessor::associated_attribute + }, + )) +); + +Class::MOP::Method::Accessor->meta->add_attribute( + Class::MOP::Attribute->new('$!accessor_type' => ( + init_arg => 'accessor_type', + reader => { 'accessor_type' => \&Class::MOP::Method::Accessor::accessor_type }, + )) +); + +Class::MOP::Method::Accessor->meta->add_attribute( + Class::MOP::Attribute->new('$!is_inline' => ( + init_arg => 'is_inline', + reader => { 'is_inline' => \&Class::MOP::Method::Accessor::is_inline }, + )) +); + +## -------------------------------------------------------- +## Class::MOP::Method::Constructor + +Class::MOP::Method::Constructor->meta->add_attribute( + Class::MOP::Attribute->new('%!options' => ( + init_arg => 'options', + reader => { + 'options' => \&Class::MOP::Method::Constructor::options + }, + )) +); + +Class::MOP::Method::Constructor->meta->add_attribute( + Class::MOP::Attribute->new('$!associated_metaclass' => ( + init_arg => 'metaclass', + reader => { + 'associated_metaclass' => \&Class::MOP::Method::Constructor::associated_metaclass + }, + )) +); + +## -------------------------------------------------------- +## Class::MOP::Instance + +# NOTE: +# these don't yet do much of anything, but are just +# included for completeness + +Class::MOP::Instance->meta->add_attribute( + Class::MOP::Attribute->new('$!meta') +); + +Class::MOP::Instance->meta->add_attribute( + Class::MOP::Attribute->new('@!slots') +); + +## -------------------------------------------------------- ## 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); +# NOTE: +# we don't need to inline the +# constructors or the accessors +# this only lengthens the compile +# time of the MOP, and gives us +# no actual benefits. + +$_->meta->make_immutable( + inline_constructor => 0, + inline_accessors => 0, +) for qw/ + Class::MOP::Package + Class::MOP::Module + Class::MOP::Class + + Class::MOP::Attribute + Class::MOP::Method + Class::MOP::Instance + + Class::MOP::Object + + Class::MOP::Method::Accessor + Class::MOP::Method::Constructor + Class::MOP::Method::Wrapped +/; 1; @@ -363,11 +529,6 @@ __END__ Class::MOP - A Meta Object Protocol for Perl 5 -=head1 SYNOPSIS - - # ... This will come later, for now see - # the other SYNOPSIS for more information - =head1 DESCRIPTON This module is an attempt to create a meta object protocol for the @@ -533,6 +694,28 @@ See L for more details. =head1 FUNCTIONS +=head2 Utility functions + +=over 4 + +=item B + +This will load a given C<$class_name> and if it does not have an +already initialized metaclass, then it will intialize one for it. + +=item B + +This will return a boolean depending on if the C<$class_name> has +been loaded. + +NOTE: This does a basic check of the symbol table to try and +determine as best it can if the C<$class_name> is loaded, it +is probably correct about 99% of the time. + +=back + +=head2 Metaclass cache 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 @@ -627,6 +810,16 @@ L =back +=head2 Articles + +=over 4 + +=item CPAN Module Review of Class::MOP + +L + +=back + =head1 SIMILAR MODULES As I have said above, this module is a class-builder-builder, so it is @@ -642,28 +835,6 @@ 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 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 91.5 72.1 48.8 90.7 100.0 100.0 84.2 - ---------------------------- ------ ------ ------ ------ ------ ------ ------ - =head1 ACKNOWLEDGEMENTS =over 4 @@ -678,11 +849,19 @@ Thanks to Rob for actually getting the development of this module kick-started. Stevan Little Estevan@iinteractive.comE -Yuval Kogman Enothingmuch@woobling.comE +B + +Brandon (blblack) Black + +Guillermo (groditi) Roditi + +Rob (robkinyon) Kinyon + +Yuval (nothingmuch) Kogman =head1 COPYRIGHT AND LICENSE -Copyright 2006 by Infinity Interactive, Inc. +Copyright 2006, 2007 by Infinity Interactive, Inc. L