X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FClass%2FMOP.pm;h=ca07a0a1957e41378d00ee56f48163295afc9f0c;hb=attic%2Fcache-experiment;hp=e2b11bda6a800b7629e502c4878231df87fec9ba;hpb=8cbbcb06f0947737b7456f2af2ef2f7f98565bec;p=gitmo%2FClass-MOP.git diff --git a/lib/Class/MOP.pm b/lib/Class/MOP.pm index e2b11bd..ca07a0a 100644 --- a/lib/Class/MOP.pm +++ b/lib/Class/MOP.pm @@ -4,8 +4,10 @@ package Class::MOP; use strict; use warnings; -use Carp 'confess'; -use Scalar::Util 'weaken'; +use MRO::Compat; + +use Carp 'confess'; +use Scalar::Util 'weaken'; use Class::MOP::Class; use Class::MOP::Attribute; @@ -13,56 +15,231 @@ use Class::MOP::Method; use Class::MOP::Immutable; -our $VERSION = '0.37_001'; -our $AUTHORITY = 'cpan:STEVAN'; +BEGIN { + our $VERSION = '0.56'; + our $AUTHORITY = 'cpan:STEVAN'; + + *IS_RUNNING_ON_5_10 = ($] < 5.009_005) + ? sub () { 0 } + : sub () { 1 }; + + # NOTE: + # we may not use this yet, but once + # the get_code_info XS gets merged + # upstream to it, we will always use + # it. But for now it is just kinda + # extra overhead. + # - SL + require Sub::Identify; + + # stash these for a sec, and see how things go + my $_PP_subname = sub { $_[1] }; + my $_PP_get_code_info = sub ($) { + return ( + Sub::Identify::stash_name($_[0]), + Sub::Identify::sub_name($_[0]) + ) + }; + + if ($ENV{CLASS_MOP_NO_XS}) { + # NOTE: + # this is if you really want things + # to be slow, then you can force the + # no-XS rule this way, otherwise we + # make an effort to load as much of + # the XS as possible. + # - SL + no warnings 'prototype', 'redefine'; + + unless (IS_RUNNING_ON_5_10()) { + # get this from MRO::Compat ... + *check_package_cache_flag = \&MRO::Compat::__get_pkg_gen_pp; + } + else { + # NOTE: + # but if we are running 5.10 + # there is no need to use the + # Pure Perl version since we + # can use the built in mro + # version instead. + # - SL + *check_package_cache_flag = \&mro::get_pkg_gen; + } + # our own version of Sub::Name + *subname = $_PP_subname; + # and the Sub::Identify version of the get_code_info + *get_code_info = $_PP_get_code_info; + } + else { + # now try our best to get as much + # of the XS loaded as possible + { + local $@; + eval { + require XSLoader; + XSLoader::load( 'Class::MOP', $VERSION ); + }; + die $@ if $@ && $@ !~ /object version|loadable object/; + + # okay, so the XS failed to load, so + # use the pure perl one instead. + *get_code_info = $_PP_get_code_info if $@; + } + + # get it from MRO::Compat + *check_package_cache_flag = \&mro::get_pkg_gen; + + # now try and load the Sub::Name + # module and use that as a means + # for naming our CVs, if not, we + # use the workaround instead. + if ( eval { require Sub::Name } ) { + *subname = \&Sub::Name::subname; + } + else { + *subname = $_PP_subname; + } + } +} { # 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 + 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_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 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 } - + 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 + # 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. + # 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 my $symbol (keys %{"${class}::"}) { + next if substr($symbol, -2, 2) eq '::'; + return 1 if defined &{"${class}::${symbol}"}; + } + return 0; } + ## ---------------------------------------------------------------------------- ## Setting up our environment ... ## ---------------------------------------------------------------------------- -## Class::MOP needs to have a few things in the global perl environment so +## 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 ;) +use Storable; + +my $MOP_CACHE_FILE = 'Class_MOP.cache'; + +#warn ((stat $INC{'Class/MOP.pm'})[9]); +#warn ((stat $MOP_CACHE_FILE)[9]); + +if (-e $MOP_CACHE_FILE && (stat $INC{'Class/MOP.pm'})[9] < (stat $MOP_CACHE_FILE)[9]) { + $Storable::Eval = 1; + my $cache = Storable::retrieve($MOP_CACHE_FILE); + + # now we do 2 things, first is to grab + # the cached metaclass, and second is + # to make sure that we reinstall any + # methods we installed in the bootstrap + # process, this is typically constructors + # and clone methods + + my %methods; + + foreach my $meta_name (keys %{$cache->{metas}}) { + my $metaclass = $cache->{metas}->{$meta_name}; + + # before we do anything to the + # metaclasses, we need to grab the + # methods we added in the bootstrap + # because any calls to get_method_map + # will cause it to grab the ones + # that are on disk, and not in the + # bootstrap. + $methods{$meta_name} = []; + + foreach my $method_to_reinstall (@{$cache->{methods_to_reinstall}->{$meta_name}}) { + #use Data::Dumper; + #$Data::Dumper::Deparse = 1; + #warn Dumper $metaclass->{'%!methods'}->{$method_to_reinstall}; + push @{ $methods{$meta_name} } => { + name => $method_to_reinstall, + method => $metaclass->{'%!methods'}->{$method_to_reinstall}, + }; + } + + store_metaclass_by_name($meta_name, $metaclass); + } + + # now we can start adding methods + # so that we get the properly + # bootstrapped versions of them + foreach my $meta_name (keys %methods) { + my $metaclass = $cache->{metas}->{$meta_name}; + foreach my $method_to_install (@{ $methods{$meta_name} }) { + $metaclass->add_method( + $method_to_install->{name}, + $method_to_install->{method} + ); + } + } +} +else { + +my %methods_to_reinstall; + ## ---------------------------------------------------------------------------- -## Bootstrapping +## Bootstrapping ## ---------------------------------------------------------------------------- -## The code below here is to bootstrap our MOP with itself. This is also +## The code below here is to bootstrap our MOP with itself. This is also ## sometimes called "tying the knot". By doing this, we make it much easier ## to extend the MOP through subclassing and such since now you can use the -## MOP itself to extend itself. -## +## MOP itself to extend itself. +## ## Yes, I know, thats weird and insane, but it's a good thing, trust me :) -## ---------------------------------------------------------------------------- +## ---------------------------------------------------------------------------- -# We need to add in the meta-attributes here so that -# any subclass of Class::MOP::* will be able to +# We need to add in the meta-attributes here so that +# any subclass of Class::MOP::* will be able to # inherit them using &construct_instance ## -------------------------------------------------------- @@ -71,12 +248,12 @@ our $AUTHORITY = 'cpan:STEVAN'; Class::MOP::Package->meta->add_attribute( Class::MOP::Attribute->new('$!package' => ( reader => { - # NOTE: we need to do this in order - # for the instance meta-object to + # NOTE: we need to do this in order + # for the instance meta-object to # not fall into meta-circular death - # + # # we just alias the original method - # rather than re-produce it here + # rather than re-produce it here 'name' => \&Class::MOP::Package::name }, init_arg => 'package', @@ -91,9 +268,7 @@ Class::MOP::Package->meta->add_attribute( # rather than re-produce it here 'namespace' => \&Class::MOP::Package::namespace }, - # NOTE: - # protect this from silliness - init_arg => '!............( DO NOT DO THIS )............!', + init_arg => undef, default => sub { \undef } )) ); @@ -104,19 +279,21 @@ 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, @_); }); +$methods_to_reinstall{'Class::MOP::Package'} = [qw[initialize]]; + ## -------------------------------------------------------- ## Class::MOP::Module # NOTE: -# yeah this is kind of stretching things a bit, +# 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. +# 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 :) @@ -125,33 +302,29 @@ Class::MOP::Module->meta->add_attribute( reader => { # NOTE: # we just alias the original method - # rather than re-produce it here + # rather than re-produce it here 'version' => \&Class::MOP::Module::version }, - # NOTE: - # protect this from silliness - init_arg => '!............( DO NOT DO THIS )............!', + init_arg => undef, 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. +# 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 => { # NOTE: # we just alias the original method - # rather than re-produce it here + # rather than re-produce it here 'authority' => \&Class::MOP::Module::authority - }, - # NOTE: - # protect this from silliness - init_arg => '!............( DO NOT DO THIS )............!', + }, + init_arg => undef, default => sub { \undef } )) ); @@ -162,12 +335,12 @@ Class::MOP::Module->meta->add_attribute( Class::MOP::Class->meta->add_attribute( 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 - # + # NOTE: we need to do this in order + # for the instance meta-object to + # not fall into meta-circular death + # # we just alias the original method - # rather than re-produce it here + # rather than re-produce it here 'get_attribute_map' => \&Class::MOP::Class::get_attribute_map }, init_arg => 'attributes', @@ -178,10 +351,10 @@ Class::MOP::Class->meta->add_attribute( Class::MOP::Class->meta->add_attribute( Class::MOP::Attribute->new('%!methods' => ( init_arg => 'methods', - reader => { + reader => { # NOTE: # we just alias the original method - # rather than re-produce it here + # rather than re-produce it here 'get_method_map' => \&Class::MOP::Class::get_method_map }, default => sub { {} } @@ -193,24 +366,22 @@ Class::MOP::Class->meta->add_attribute( accessor => { # NOTE: # we just alias the original method - # rather than re-produce it here + # rather than re-produce it here 'superclasses' => \&Class::MOP::Class::superclasses }, - # NOTE: - # protect this from silliness - init_arg => '!............( DO NOT DO THIS )............!', + init_arg => undef, default => sub { \undef } )) ); Class::MOP::Class->meta->add_attribute( Class::MOP::Attribute->new('$!attribute_metaclass' => ( - reader => { + reader => { # NOTE: # we just alias the original method - # rather than re-produce it here + # rather than re-produce it here 'attribute_metaclass' => \&Class::MOP::Class::attribute_metaclass - }, + }, init_arg => 'attribute_metaclass', default => 'Class::MOP::Attribute', )) @@ -218,38 +389,38 @@ Class::MOP::Class->meta->add_attribute( Class::MOP::Class->meta->add_attribute( Class::MOP::Attribute->new('$!method_metaclass' => ( - reader => { + reader => { # NOTE: # we just alias the original method - # rather than re-produce it here + # rather than re-produce it here 'method_metaclass' => \&Class::MOP::Class::method_metaclass }, init_arg => 'method_metaclass', - default => 'Class::MOP::Method', + default => 'Class::MOP::Method', )) ); 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 - # + # NOTE: we need to do this in order + # for the instance meta-object to + # not fall into meta-circular death + # # we just alias the original method - # rather than re-produce it here + # rather than re-produce it here 'instance_metaclass' => \&Class::MOP::Class::instance_metaclass }, init_arg => 'instance_metaclass', - default => 'Class::MOP::Instance', + 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. +# 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 @@ -258,12 +429,12 @@ Class::MOP::Attribute->meta->add_attribute( 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 - # + # NOTE: we need to do this in order + # for the instance meta-object to + # not fall into meta-circular death + # # we just alias the original method - # rather than re-produce it here + # rather than re-produce it here 'name' => \&Class::MOP::Attribute::name } )) @@ -273,12 +444,12 @@ Class::MOP::Attribute->meta->add_attribute( 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 - # + # NOTE: we need to do this in order + # for the instance meta-object to + # not fall into meta-circular death + # # we just alias the original method - # rather than re-produce it here + # rather than re-produce it here 'associated_class' => \&Class::MOP::Attribute::associated_class } )) @@ -301,6 +472,14 @@ Class::MOP::Attribute->meta->add_attribute( ); Class::MOP::Attribute->meta->add_attribute( + Class::MOP::Attribute->new('$!initializer' => ( + init_arg => 'initializer', + reader => { 'initializer' => \&Class::MOP::Attribute::initializer }, + predicate => { 'has_initializer' => \&Class::MOP::Attribute::has_initializer }, + )) +); + +Class::MOP::Attribute->meta->add_attribute( Class::MOP::Attribute->new('$!writer' => ( init_arg => 'writer', reader => { 'writer' => \&Class::MOP::Attribute::writer }, @@ -325,6 +504,14 @@ Class::MOP::Attribute->meta->add_attribute( ); Class::MOP::Attribute->meta->add_attribute( + Class::MOP::Attribute->new('$!builder' => ( + init_arg => 'builder', + reader => { 'builder' => \&Class::MOP::Attribute::builder }, + predicate => { 'has_builder' => \&Class::MOP::Attribute::has_builder }, + )) +); + +Class::MOP::Attribute->meta->add_attribute( Class::MOP::Attribute->new('$!init_arg' => ( init_arg => 'init_arg', reader => { 'init_arg' => \&Class::MOP::Attribute::init_arg }, @@ -336,7 +523,7 @@ Class::MOP::Attribute->meta->add_attribute( Class::MOP::Attribute->new('$!default' => ( init_arg => 'default', # default has a custom 'reader' method ... - predicate => { 'has_default' => \&Class::MOP::Attribute::has_default }, + predicate => { 'has_default' => \&Class::MOP::Attribute::has_default }, )) ); @@ -344,39 +531,47 @@ 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 { [] } + default => sub { [] } )) ); # NOTE: (meta-circularity) # This should be one of the last things done # it will "tie the knot" with Class::MOP::Attribute -# so that it uses the attributes meta-objects -# to construct itself. +# so that it uses the attributes meta-objects +# to construct itself. Class::MOP::Attribute->meta->add_method('new' => sub { my $class = shift; my $name = shift; - my %options = @_; - + my %options = @_; + (defined $name && $name) || confess "You must provide a name for the attribute"; - $options{init_arg} = $name + $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}; + if(exists $options{builder}){ + confess("builder must be a defined scalar value which is a method name") + if ref $options{builder} || !(defined $options{builder}); + confess("Setting both default and builder is not allowed.") + if exists $options{default}; + } else { + (Class::MOP::Attribute::is_default_a_coderef(\%options)) + || confess("References are not allowed as default values, you must ". + "wrap the default of '$name' 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); }); Class::MOP::Attribute->meta->add_method('clone' => sub { my $self = shift; - $self->meta->clone_object($self, @_); + $self->meta->clone_object($self, @_); }); +$methods_to_reinstall{'Class::MOP::Attribute'} = [qw[new clone]]; + ## -------------------------------------------------------- ## Class::MOP::Method @@ -387,43 +582,125 @@ Class::MOP::Method->meta->add_attribute( )) ); +Class::MOP::Method->meta->add_attribute( + Class::MOP::Attribute->new('$!package_name' => ( + init_arg => 'package_name', + reader => { 'package_name' => \&Class::MOP::Method::package_name }, + )) +); + +Class::MOP::Method->meta->add_attribute( + Class::MOP::Attribute->new('$!name' => ( + init_arg => 'name', + reader => { 'name' => \&Class::MOP::Method::name }, + )) +); + +Class::MOP::Method->meta->add_method('wrap' => sub { + my $class = shift; + my $code = shift; + my %options = @_; + + ('CODE' eq (Scalar::Util::reftype($code) || '')) + || confess "You must supply a CODE reference to bless, not (" . ($code || 'undef') . ")"; + + ($options{package_name} && $options{name}) + || confess "You must supply the package_name and name parameters"; + + # return the new object + $class->meta->new_object(body => $code, %options); +}); + +Class::MOP::Method->meta->add_method('clone' => sub { + my $self = shift; + $self->meta->clone_object($self, @_); +}); + +$methods_to_reinstall{'Class::MOP::Method'} = [qw[wrap clone]]; + ## -------------------------------------------------------- ## Class::MOP::Method::Wrapped # NOTE: -# the way this item is initialized, this -# really does not follow the standard -# practices of attributes, but we put +# 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::Generated + +Class::MOP::Method::Generated->meta->add_attribute( + Class::MOP::Attribute->new('$!is_inline' => ( + init_arg => 'is_inline', + reader => { 'is_inline' => \&Class::MOP::Method::Generated::is_inline }, + default => 0, + )) +); + +Class::MOP::Method::Generated->meta->add_method('new' => sub { + my ($class, %options) = @_; + ($options{package_name} && $options{name}) + || confess "You must supply the package_name and name parameters"; + my $self = $class->meta->new_object(%options); + $self->initialize_body; + $self; +}); + +$methods_to_reinstall{'Class::MOP::Method::Generated'} = [qw[new]]; + +## -------------------------------------------------------- ## 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 + 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::Accessor->meta->add_method('new' => sub { + my $class = shift; + my %options = @_; + + (exists $options{attribute}) + || confess "You must supply an attribute to construct with"; + + (exists $options{accessor_type}) + || confess "You must supply an accessor_type to construct with"; + + (Scalar::Util::blessed($options{attribute}) && $options{attribute}->isa('Class::MOP::Attribute')) + || confess "You must supply an attribute which is a 'Class::MOP::Attribute' instance"; + + ($options{package_name} && $options{name}) + || confess "You must supply the package_name and name parameters"; + + # return the new object + my $self = $class->meta->new_object(%options); + + # we don't want this creating + # a cycle in the code, if not + # needed + Scalar::Util::weaken($self->{'$!attribute'}); + + $self->initialize_body; + + $self; +}); + +$methods_to_reinstall{'Class::MOP::Method::Accessor'} = [qw[new]]; ## -------------------------------------------------------- ## Class::MOP::Method::Constructor @@ -431,26 +708,53 @@ Class::MOP::Method::Accessor->meta->add_attribute( Class::MOP::Method::Constructor->meta->add_attribute( Class::MOP::Attribute->new('%!options' => ( init_arg => 'options', - reader => { - 'options' => \&Class::MOP::Method::Constructor::options + reader => { + 'options' => \&Class::MOP::Method::Constructor::options }, - )) + default => sub { +{} } + )) ); 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 - }, - )) + reader => { + 'associated_metaclass' => \&Class::MOP::Method::Constructor::associated_metaclass + }, + )) ); +Class::MOP::Method::Constructor->meta->add_method('new' => sub { + my $class = shift; + my %options = @_; + + (Scalar::Util::blessed $options{metaclass} && $options{metaclass}->isa('Class::MOP::Class')) + || confess "You must pass a metaclass instance if you want to inline" + if $options{is_inline}; + + ($options{package_name} && $options{name}) + || confess "You must supply the package_name and name parameters"; + + # return the new object + my $self = $class->meta->new_object(%options); + + # we don't want this creating + # a cycle in the code, if not + # needed + Scalar::Util::weaken($self->{'$!associated_metaclass'}); + + $self->initialize_body; + + $self; +}); + +$methods_to_reinstall{'Class::MOP::Method::Constructor'} = [qw[new]]; + ## -------------------------------------------------------- ## Class::MOP::Instance # NOTE: -# these don't yet do much of anything, but are just +# these don't yet do much of anything, but are just # included for completeness Class::MOP::Instance->meta->add_attribute( @@ -465,29 +769,53 @@ Class::MOP::Instance->meta->add_attribute( ## Now close all the Class::MOP::* classes # NOTE: -# we don't need to inline the -# constructors or the accessors -# this only lengthens the compile -# time of the MOP, and gives us +# 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. +unless ($ENV{CLASS_MOP_NO_CACHE}) { + my %metaclasses_to_store = get_all_metaclasses(); + $Storable::Deparse = 1; + Storable::nstore({ + metas => \%metaclasses_to_store, + methods_to_reinstall => \%methods_to_reinstall + }, $MOP_CACHE_FILE); + + #foreach my $meta_name (keys %metaclasses_to_store) { + # my $metaclass = $metaclasses_to_store{$meta_name}; + # foreach my $method_to_reinstall (@{$methods_to_reinstall{$meta_name}}) { + # warn "CHECKING $method_to_reinstall"; + # + # use Data::Dumper; + # $Data::Dumper::Deparse = 1; + # warn Dumper $metaclass->{'%!methods'}->{$method_to_reinstall}; + # } + #} +} + +} + $_->meta->make_immutable( inline_constructor => 0, inline_accessors => 0, ) for qw/ - Class::MOP::Package - Class::MOP::Module - Class::MOP::Class - + Class::MOP::Package + Class::MOP::Module + Class::MOP::Class + Class::MOP::Attribute - Class::MOP::Method - Class::MOP::Instance - - Class::MOP::Object + Class::MOP::Method + Class::MOP::Instance + + Class::MOP::Object + + Class::MOP::Method::Generated Class::MOP::Method::Accessor - Class::MOP::Method::Constructor - Class::MOP::Method::Wrapped + Class::MOP::Method::Constructor + Class::MOP::Method::Wrapped /; 1; @@ -496,221 +824,299 @@ __END__ =pod -=head1 NAME +=head1 NAME 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 -Perl 5 object system. It makes no attempt to change the behavior or -characteristics of the Perl 5 object system, only to create a +This module is a fully functioning meta object protocol for the +Perl 5 object system. It makes no attempt to change the behavior or +characteristics of the Perl 5 object system, only to create a protocol for its manipulation and introspection. -That said, it does attempt to create the tools for building a rich -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 +That said, it does attempt to create the tools for building a rich +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 +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. +A meta object protocol is an API to an object system. -To be more specific, it is a set of abstractions of the components of -an object system (typically things like; classes, object, methods, -object attributes, etc.). These abstractions can then be used to both +To be more specific, it is a set of abstractions of the components of +an object system (typically things like; classes, object, methods, +object attributes, etc.). These abstractions can then be used to both inspect and manipulate the object system which they describe. -It can be said that there are two MOPs for any object system; the -implicit MOP, and the explicit MOP. The implicit MOP handles things -like method dispatch or inheritance, which happen automatically as -part of how the object system works. The explicit MOP typically -handles the introspection/reflection features of the object system. -All object systems have implicit MOPs, without one, they would not -work. Explict MOPs however as less common, and depending on the -language can vary from restrictive (Reflection in Java or C#) to -wide open (CLOS is a perfect example). +It can be said that there are two MOPs for any object system; the +implicit MOP, and the explicit MOP. The implicit MOP handles things +like method dispatch or inheritance, which happen automatically as +part of how the object system works. The explicit MOP typically +handles the introspection/reflection features of the object system. +All object systems have implicit MOPs, without one, they would not +work. Explict MOPs however as less common, and depending on the +language can vary from restrictive (Reflection in Java or C#) to +wide open (CLOS is a perfect example). =head2 Yet Another Class Builder!! Why? -This is B a class builder so much as it is a I>. My intent is that an end user does not use this module -directly, but instead this module is used by module authors to -build extensions and features onto the Perl 5 object system. +This is B a class builder so much as it is a I>. My intent is that an end user does not use this module +directly, but instead this module is used by module authors to +build extensions and features onto the Perl 5 object system. =head2 Who is this module for? -This module is specifically for anyone who has ever created or -wanted to create a module for the Class:: namespace. The tools which -this module will provide will hopefully make it easier to do more -complex things with Perl 5 classes by removing such barriers as -the need to hack the symbol tables, or understand the fine details -of method dispatch. +This module is specifically for anyone who has ever created or +wanted to create a module for the Class:: namespace. The tools which +this module will provide will hopefully make it easier to do more +complex things with Perl 5 classes by removing such barriers as +the need to hack the symbol tables, or understand the fine details +of method dispatch. =head2 What changes do I have to make to use this module? -This module was designed to be as unintrusive as possible. Many of -its features are accessible without B change to your existsing -code at all. It is meant to be a compliment to your existing code and -not an intrusion on your code base. Unlike many other B -modules, this module B require you subclass it, or even that -you C it in within your module's package. +This module was designed to be as unintrusive as possible. Many of +its features are accessible without B change to your existsing +code at all. It is meant to be a compliment to your existing code and +not an intrusion on your code base. Unlike many other B +modules, this module B require you subclass it, or even that +you C it in within your module's package. -The only features which requires additions to your code are the +The only features which requires additions to your code are the attribute handling and instance construction features, and these are -both completely optional features. The only reason for this is because -Perl 5's object system does not actually have these features built +both completely optional features. The only reason for this is because +Perl 5's object system does not actually have these features built in. More information about this feature can be found below. =head2 A Note about Performance? -It is a common misconception that explict MOPs are performance drains. -But this is not a universal truth at all, it is an side-effect of -specific implementations. For instance, using Java reflection is much -slower because the JVM cannot take advantage of any compiler -optimizations, and the JVM has to deal with much more runtime type -information as well. Reflection in C# is marginally better as it was -designed into the language and runtime (the CLR). In contrast, CLOS -(the Common Lisp Object System) was built to support an explicit MOP, -and so performance is tuned for it. - -This library in particular does it's absolute best to avoid putting -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 +It is a common misconception that explict MOPs are performance drains. +But this is not a universal truth at all, it is an side-effect of +specific implementations. For instance, using Java reflection is much +slower because the JVM cannot take advantage of any compiler +optimizations, and the JVM has to deal with much more runtime type +information as well. Reflection in C# is marginally better as it was +designed into the language and runtime (the CLR). In contrast, CLOS +(the Common Lisp Object System) was built to support an explicit MOP, +and so performance is tuned for it. + +This library in particular does it's absolute best to avoid putting +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. +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 +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 +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 +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) + +---------+ +---------+ <------- (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 +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 +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: +The protocol is divided into 4 main sub-protocols: =over 4 =item The Class protocol -This provides a means of manipulating and introspecting a Perl 5 -class. It handles all of symbol table hacking for you, and provides +This provides a means of manipulating and introspecting a Perl 5 +class. It handles all of symbol table hacking for you, and provides a rich set of methods that go beyond simple package introspection. See L for more details. =item The Attribute protocol -This provides a consistent represenation for an attribute of a -Perl 5 class. Since there are so many ways to create and handle -atttributes in Perl 5 OO, this attempts to provide as much of a -unified approach as possible, while giving the freedom and +This provides a consistent represenation for an attribute of a +Perl 5 class. Since there are so many ways to create and handle +attributes in Perl 5 OO, this attempts to provide as much of a +unified approach as possible, while giving the freedom and flexibility to subclass for specialization. See L for more details. =item The Method protocol -This provides a means of manipulating and introspecting methods in -the Perl 5 object system. As with attributes, there are many ways to -approach this topic, so we try to keep it pretty basic, while still +This provides a means of manipulating and introspecting methods in +the Perl 5 object system. As with attributes, there are many ways to +approach this topic, so we try to keep it pretty basic, while still making it possible to extend the system in many ways. See L for more details. +=item The Instance protocol + +This provides a layer of abstraction for creating object instances. +Since the other layers use this protocol, it is relatively easy to +change the type of your instances from the default HASH ref to other +types of references. Several examples are provided in the F +directory included in this distribution. + +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 +=head2 Constants + +=over 4 + +=item I + +We set this constant depending on what version perl we are on, this +allows us to take advantage of new 5.10 features and stay backwards +compat. + +=back + +=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. +This function can be used in place of tricks like +C or using C. + +=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. + +=item B + +This will return an integer that is managed by C +to determine if a module's symbol table has been altered. + +In Perl 5.10 or greater, this flag is package specific. However in +versions prior to 5.10, this will use the C variable +which is not package specific. + +=item B + +This function returns two values, the name of the package the C<$code> +is from and the name of the C<$code> itself. This is used by several +elements of the MOP to detemine where a given C<$code> reference is from. + +=item B + +B + +If possible, we will load the L module and this will function +as C does, otherwise it will just return the C<$code> +argument. + +=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 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. +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 +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 +This will return an array of all the metaclass names that have been cached by B. =item B +This will return a cached B instance of nothing +if no metaclass exist by that C<$name>. + =item B +This will store a metaclass in the cache at the supplied C<$key>. + =item B +In rare cases it is desireable to store a weakened reference in +the metaclass cache. This function will weaken the reference to +the metaclass stored in C<$name>. + =item B +This will return true of there exists a metaclass stored in the +C<$name> key and return false otherwise. + =item B +This will remove a the metaclass stored in the C<$name> key. + =back =head1 SEE ALSO =head2 Books -There are very few books out on Meta Object Protocols and Metaclasses -because it is such an esoteric topic. The following books are really -the only ones I have found. If you know of any more, B> +There are very few books out on Meta Object Protocols and Metaclasses +because it is such an esoteric topic. The following books are really +the only ones I have found. If you know of any more, B> email me and let me know, I would love to hear about them. =over 4 @@ -731,18 +1137,18 @@ email me and let me know, I would love to hear about them. =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 +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. +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 @@ -764,11 +1170,11 @@ L =back -=head2 Article +=head2 Articles =over 4 -=item CPAN Module Review of Class::MOP +=item CPAN Module Review of Class::MOP L @@ -776,48 +1182,26 @@ 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 and the MOP it -creates are very different from this modules. +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 and the MOP it +creates are very different from this modules. =head1 BUGS -All complex software has bugs lurking in it, and this module is no +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 97.7 100.0 88.9 94.7 100.0 3.2 96.6 - Class/MOP/Attribute.pm 75.5 77.9 82.4 88.3 100.0 4.0 81.5 - Class/MOP/Class.pm 96.9 88.8 72.1 98.2 100.0 35.8 91.4 - Class/MOP/Class/Immutable.pm 88.2 60.0 n/a 95.5 100.0 0.5 84.6 - Class/MOP/Instance.pm 86.4 75.0 33.3 86.2 100.0 1.2 87.5 - Class/MOP/Method.pm 97.5 75.0 61.5 80.6 100.0 12.7 89.7 - Class/MOP/Module.pm 100.0 n/a 55.6 100.0 100.0 0.1 90.7 - Class/MOP/Object.pm 73.3 n/a 20.0 80.0 100.0 0.1 66.7 - Class/MOP/Package.pm 94.6 71.7 33.3 100.0 100.0 42.2 87.0 - metaclass.pm 100.0 100.0 83.3 100.0 n/a 0.2 97.7 - ---------------------------- ------ ------ ------ ------ ------ ------ ------ - Total 91.3 80.4 69.8 91.9 100.0 100.0 88.1 - ---------------------------- ------ ------ ------ ------ ------ ------ ------ - =head1 ACKNOWLEDGEMENTS =over 4 =item Rob Kinyon -Thanks to Rob for actually getting the development of this module kick-started. +Thanks to Rob for actually getting the development of this module kick-started. =back @@ -825,15 +1209,27 @@ 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 + +Matt (mst) Trout + +Rob (robkinyon) Kinyon + +Yuval (nothingmuch) Kogman + +Scott (konobi) McWhirter =head1 COPYRIGHT AND LICENSE -Copyright 2006 by Infinity Interactive, Inc. +Copyright 2006-2008 by Infinity Interactive, Inc. L This library is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. +it under the same terms as Perl itself. =cut