X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FClass%2FMOP.pm;h=43e51925891bb7ffe6659df88e16c9e3e03d6397;hb=88b8ac17305b1bf7f1795337d7d443aec0bd3057;hp=74ac220ddda996b4217e7786208459b372b5d6a7;hpb=b3b7a216ebf4397fcea34f3deabc671d27fa1d01;p=gitmo%2FClass-MOP.git diff --git a/lib/Class/MOP.pm b/lib/Class/MOP.pm index 74ac220..43e5192 100644 --- a/lib/Class/MOP.pm +++ b/lib/Class/MOP.pm @@ -11,26 +11,6 @@ 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 () { !1 }; -} - use Class::MOP::Class; use Class::MOP::Attribute; @@ -46,28 +26,55 @@ 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.64_06'; +our $VERSION = '0.70_01'; 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; + # 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"); }; $@; }; 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 } +} + + { # Metaclasses are singletons, so we cache them here. # there is no need to worry about destruction though @@ -93,31 +100,74 @@ 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) - || $class !~ /^\w+(?::\w+)*$/ ) { - 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 $e = do { local $@; eval "require $class"; $@ }; - 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 { @@ -478,9 +528,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; }); ## -------------------------------------------------------- @@ -828,6 +887,8 @@ subclasses of a certain class. =head2 Utility functions +Note that these are all called as B. + =over 4 =item B @@ -848,6 +909,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. @@ -857,6 +920,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. @@ -871,11 +936,23 @@ 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 @@ -1031,6 +1108,8 @@ B Brandon (blblack) Black +Florian (rafl) Ragwitz + Guillermo (groditi) Roditi Matt (mst) Trout