X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FClass%2FMOP.pm;h=c7e68635cf888357dcab024b1a3d00950b132199;hb=b4bd10ecd2eabe1a2c1bc3addad22b207f6592ee;hp=388faef49cfced058f6bc821089e8cca39f6506a;hpb=682655a3e06e41d219d01af74b05e922db316b85;p=gitmo%2FClass-MOP.git diff --git a/lib/Class/MOP.pm b/lib/Class/MOP.pm index 388faef..c7e6863 100644 --- a/lib/Class/MOP.pm +++ b/lib/Class/MOP.pm @@ -4,30 +4,12 @@ package Class::MOP; use strict; use warnings; +use 5.008; + use MRO::Compat; use Carp 'confess'; -use Scalar::Util 'weaken'; - -use Sub::Identify 'get_code_info'; - -BEGIN { - local $@; - eval { - require Sub::Name; - Sub::Name->import(qw(subname)); - 1 - } or eval 'sub subname { $_[1] }'; - - # this is either part of core or set up appropriately by MRO::Compat - *check_package_cache_flag = \&mro::get_pkg_gen; - - eval { - require Devel::GlobalDestruction; - Devel::GlobalDestruction->import("in_global_destruction"); - 1; - } or *in_global_destruction = sub () { '' }; -} +use Scalar::Util 'weaken', 'reftype'; use Class::MOP::Class; @@ -44,26 +26,57 @@ BEGIN { *HAVE_ISAREV = defined(&mro::get_isarev) ? sub () { 1 } : sub () { 1 }; + + # this is either part of core or set up appropriately by MRO::Compat + *check_package_cache_flag = \&mro::get_pkg_gen; } -our $VERSION = '0.65'; +our $VERSION = '0.77'; +our $XS_VERSION = $VERSION; +$VERSION = eval $VERSION; our $AUTHORITY = 'cpan:STEVAN'; - -# after that everything is loaded, if we're allowed try to load faster XS -# versions of various things -unless ($ENV{CLASS_MOP_NO_XS}) { + +_try_load_xs() or _load_pure_perl(); + +sub _try_load_xs { + return if $ENV{CLASS_MOP_NO_XS}; + my $e = do { local $@; eval { require XSLoader; - __PACKAGE__->XSLoader::load($VERSION); + # just doing this - no warnings 'redefine' - doesn't work + # for some reason + local $^W = 0; + __PACKAGE__->XSLoader::load($XS_VERSION); + + require Sub::Name; + Sub::Name->import(qw(subname)); + + require Devel::GlobalDestruction; + Devel::GlobalDestruction->import("in_global_destruction"); + + *USING_XS = sub () { 1 }; }; $@; }; die $e if $e && $e !~ /object version|loadable object/; + + return $e ? 0 : 1; +} + +sub _load_pure_perl { + require Sub::Identify; + Sub::Identify->import('get_code_info'); + + *subname = sub { $_[1] }; + *in_global_destruction = sub () { !1 }; + + *USING_XS = sub () { 0 }; } + { # Metaclasses are singletons, so we cache them here. # there is no need to worry about destruction though @@ -89,36 +102,80 @@ unless ($ENV{CLASS_MOP_NO_XS}) { # because I don't yet see a good reason to do so. } -sub load_class { - my $class = shift; +sub load_first_existing_class { + my @classes = @_ + or return; - if (ref($class) || !defined($class) || !length($class)) { - my $display = defined($class) ? $class : 'undef'; - confess "Invalid class name ($display)"; + foreach my $class (@classes) { + unless ( _is_valid_class_name($class) ) { + my $display = defined($class) ? $class : 'undef'; + confess "Invalid class name ($display)"; + } } - # if the class is not already loaded in the symbol table.. - unless (is_class_loaded($class)) { - # require it - my $file = $class . '.pm'; - $file =~ s{::}{/}g; - my $e = do { local $@; eval { require($file) }; $@ }; - confess "Could not load class ($class) because : $e" if $e; - } + my $found; + my %exceptions; + for my $class (@classes) { + my $e = _try_load_one_class($class); - # initialize a metaclass if necessary - unless (does_metaclass_exist($class)) { - my $e = do { local $@; eval { Class::MOP::Class->initialize($class) }; $@ }; - confess "Could not initialize class ($class) because : $e" if $e; + if ($e) { + $exceptions{$class} = $e; + } + else { + $found = $class; + last; + } } - return get_metaclass_by_name($class) if defined wantarray; + return $found if $found; + + confess join( + "\n", + map { + sprintf( + "Could not load class (%s) because : %s", $_, + $exceptions{$_} + ) + } @classes + ); +} + +sub _try_load_one_class { + my $class = shift; + + return if is_class_loaded($class); + + my $file = $class . '.pm'; + $file =~ s{::}{/}g; + + return do { + local $@; + eval { require($file) }; + $@; + }; +} + +sub load_class { + my $class = load_first_existing_class($_[0]); + return get_metaclass_by_name($class) || $class; +} + +sub _is_valid_class_name { + my $class = shift; + + return 0 if ref($class); + return 0 unless defined($class); + return 0 unless length($class); + + return 1 if $class =~ /^\w+(?:::\w+)*$/; + + return 0; } sub is_class_loaded { my $class = shift; - return 0 if ref($class) || !defined($class) || !length($class); + return 0 unless _is_valid_class_name($class); # walk the symbol table tree to avoid autovififying # \*{${main::}{"Foo::"}} == \*main::Foo:: @@ -129,9 +186,19 @@ sub is_class_loaded { $pack = \*{${$$pack}{"${part}::"}}; } - # check for $VERSION or @ISA - return 1 if exists ${$$pack}{VERSION} - && defined *{${$$pack}{VERSION}}{SCALAR}; + # We used to check in the package stash, but it turns out that + # *{${$$package}{VERSION}{SCALAR}} can end up pointing to a + # reference to undef. It looks + + my $version = do { + no strict 'refs'; + ${$class . '::VERSION'}; + }; + + return 1 if ! ref $version && defined $version; + # Sometimes $VERSION ends up as a reference to undef (weird) + return 1 if ref $version && reftype $version eq 'SCALAR' && defined ${$version}; + return 1 if exists ${$$pack}{ISA} && defined *{${$$pack}{ISA}}{ARRAY}; @@ -321,6 +388,18 @@ Class::MOP::Class->meta->add_attribute( ); Class::MOP::Class->meta->add_attribute( + Class::MOP::Attribute->new('wrapped_method_metaclass' => ( + reader => { + # NOTE: + # we just alias the original method + # rather than re-produce it here + 'wrapped_method_metaclass' => \&Class::MOP::Class::wrapped_method_metaclass + }, + default => 'Class::MOP::Method::Wrapped', + )) +); + +Class::MOP::Class->meta->add_attribute( Class::MOP::Attribute->new('instance_metaclass' => ( reader => { # NOTE: we need to do this in order @@ -394,6 +473,12 @@ Class::MOP::Attribute->meta->add_attribute( ); Class::MOP::Attribute->meta->add_attribute( + Class::MOP::Attribute->new('definition_context' => ( + reader => { 'definition_context' => \&Class::MOP::Attribute::definition_context }, + )) +); + +Class::MOP::Attribute->meta->add_attribute( Class::MOP::Attribute->new('writer' => ( reader => { 'writer' => \&Class::MOP::Attribute::writer }, predicate => { 'has_writer' => \&Class::MOP::Attribute::has_writer }, @@ -473,9 +558,18 @@ Class::MOP::Method->meta->add_attribute( )) ); +Class::MOP::Method->meta->add_attribute( + Class::MOP::Attribute->new('original_method' => ( + reader => { 'original_method' => \&Class::MOP::Method::original_method }, + writer => { '_set_original_method' => \&Class::MOP::Method::_set_original_method }, + )) +); + Class::MOP::Method->meta->add_method('clone' => sub { my $self = shift; - $self->meta->clone_object($self, @_); + my $clone = $self->meta->clone_object($self, @_); + $clone->_set_original_method($self); + return $clone; }); ## -------------------------------------------------------- @@ -500,14 +594,11 @@ Class::MOP::Method::Generated->meta->add_attribute( )) ); -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; -}); +Class::MOP::Method::Generated->meta->add_attribute( + Class::MOP::Attribute->new('definition_context' => ( + reader => { 'definition_context' => \&Class::MOP::Method::Generated::definition_context }, + )) +); ## -------------------------------------------------------- ## Class::MOP::Method::Accessor @@ -526,36 +617,6 @@ Class::MOP::Method::Accessor->meta->add_attribute( )) ); -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; -}); - - ## -------------------------------------------------------- ## Class::MOP::Method::Constructor @@ -577,30 +638,6 @@ Class::MOP::Method::Constructor->meta->add_attribute( )) ); -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; -}); - ## -------------------------------------------------------- ## Class::MOP::Instance @@ -625,7 +662,7 @@ Class::MOP::Instance->meta->add_attribute( Class::MOP::Instance->meta->add_attribute( Class::MOP::Attribute->new('attributes', - reader => { attributes => \&Class::MOP::Instance::attributes }, + reader => { attributes => \&Class::MOP::Instance::get_all_attributes }, ), ); @@ -646,29 +683,14 @@ Class::MOP::Instance->meta->add_attribute( # for the constructor to be able to use it Class::MOP::Instance->meta->get_meta_instance; -Class::MOP::Instance->meta->add_method('new' => sub { - my $class = shift; - my $options = $class->BUILDARGS(@_); - - my $self = $class->meta->new_object(%$options); - - Scalar::Util::weaken($self->{'associated_metaclass'}); - - $self; -}); - # pretend the add_method never happenned. it hasn't yet affected anything undef Class::MOP::Instance->meta->{_package_cache_flag}; ## -------------------------------------------------------- ## 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 -# no actual benefits. +# NOTE: we don't need to inline the the accessors this only lengthens +# the compile time of the MOP, and gives us no actual benefits. $_->meta->make_immutable( inline_constructor => 1, @@ -893,10 +915,16 @@ compat. Whether or not C provides C, a much faster way to get all the subclasses of a certain class. +=item I + +Whether or not the running C is using its XS version. + =back =head2 Utility functions +Note that these are all called as B. + =over 4 =item B @@ -917,6 +945,8 @@ is probably correct about 99% of the time. =item B +B + This will return an integer that is managed by C to determine if a module's symbol table has been altered. @@ -926,6 +956,8 @@ which is not package specific. =item B +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. @@ -940,41 +972,53 @@ argument. =item B +B + If L is available, this returns true under global destruction. Otherwise it's a constant returning false. +=item B + +B + +Given a list of class names, this function will attempt to load each +one in turn. + +If it finds a class it can load, it will return that class' name. +If none of the classes can be loaded, it will throw an exception. + =back =head2 Metaclass cache functions -Class::MOP holds a cache of metaclasses, the following are 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. +recommended that you mess with these. 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 a 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 a list 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 a list 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>. +This will return a cached B instance, or nothing +if no metaclass exists with that C<$name>. =item B @@ -982,18 +1026,19 @@ 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>. +In rare cases (e.g. anonymous metaclasses) it is desirable 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. +C<$name> key, and return false otherwise. =item B -This will remove a the metaclass stored in the C<$name> key. +This will remove the metaclass stored in the C<$name> key. =back @@ -1100,6 +1145,8 @@ B Brandon (blblack) Black +Florian (rafl) Ragwitz + Guillermo (groditi) Roditi Matt (mst) Trout