X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FClass%2FMOP.pm;h=91a65f6699485690ccd813ff1340307a6f532884;hb=ec52b37ad0cba41a9770c8971ee16f54bbfdfc89;hp=e99cc24077593002b33882a328471e4a41c28888;hpb=b1a46f91382e5b1d9a69a401162dcf13ca6b6ba9;p=gitmo%2FClass-MOP.git diff --git a/lib/Class/MOP.pm b/lib/Class/MOP.pm index e99cc24..91a65f6 100644 --- a/lib/Class/MOP.pm +++ b/lib/Class/MOP.pm @@ -9,33 +9,26 @@ use 5.008; use MRO::Compat; use Carp 'confess'; -use Devel::GlobalDestruction qw( in_global_destruction ); use Scalar::Util 'weaken', 'reftype', 'blessed'; -use Sub::Name qw( subname ); +use Try::Tiny; use Class::MOP::Class; use Class::MOP::Attribute; use Class::MOP::Method; -use Class::MOP::Immutable; - BEGIN { - *IS_RUNNING_ON_5_10 = ($] < 5.009_005) + *IS_RUNNING_ON_5_10 = ($] < 5.009_005) ? sub () { 0 } - : sub () { 1 }; - - *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.79'; +our $VERSION = '0.97'; our $XS_VERSION = $VERSION; $VERSION = eval $VERSION; -our $AUTHORITY = 'cpan:STEVAN'; +our $AUTHORITY = 'cpan:STEVAN'; require XSLoader; XSLoader::load( __PACKAGE__, $XS_VERSION ); @@ -46,10 +39,9 @@ XSLoader::load( __PACKAGE__, $XS_VERSION ); # 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? + # Anonymous classes manage their own destruction. 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 } @@ -57,7 +49,14 @@ XSLoader::load( __PACKAGE__, $XS_VERSION ); 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 { delete $METAS{$_[0]}; return } + + # This handles instances as well as class names + sub class_of { + return unless defined $_[0]; + my $class = blessed($_[0]) || $_[0]; + return $METAS{$class}; + } # NOTE: # We only cache metaclasses, meaning instances of @@ -66,9 +65,18 @@ XSLoader::load( __PACKAGE__, $XS_VERSION ); # because I don't yet see a good reason to do so. } +sub _class_to_pmfile { + my $class = shift; + + my $file = $class . '.pm'; + $file =~ s{::}{/}g; + + return $file; +} + sub load_first_existing_class { my @classes = @_ - or return; + or return; foreach my $class (@classes) { unless ( _is_valid_class_name($class) ) { @@ -79,49 +87,40 @@ sub load_first_existing_class { my $found; my %exceptions; - for my $class (@classes) { - my $e = _try_load_one_class($class); - - if ($e) { - $exceptions{$class} = $e; - } - else { - $found = $class; - last; - } - } - return $found if $found; - - confess join( - "\n", - map { - sprintf( - "Could not load class (%s) because : %s", $_, - $exceptions{$_} - ) - } @classes - ); -} + for my $class (@classes) { + my $file = _class_to_pmfile($class); -sub _try_load_one_class { - my $class = shift; + return $class if is_class_loaded($class);; - return if is_class_loaded($class); + return $class if try { + local $SIG{__DIE__}; + require $file; + return 1; + } + catch { + unless (/^Can't locate \Q$file\E in \@INC/) { + confess "Couldn't load class ($class) because: $_"; + } - my $file = $class . '.pm'; - $file =~ s{::}{/}g; + return; + }; + } - return do { - local $@; - eval { require($file) }; - $@; - }; + if ( @classes > 1 ) { + confess "Can't locate any of @classes in \@INC (\@INC contains: @INC)."; + } else { + confess "Can't locate " . _class_to_pmfile($classes[0]) . " in \@INC (\@INC contains: @INC)."; + } } sub load_class { - my $class = load_first_existing_class($_[0]); - return get_metaclass_by_name($class) || $class; + load_first_existing_class($_[0]); + + # This is done to avoid breaking code which checked the return value. Said + # code is dumb. The return value was _always_ true, since it dies on + # failure! + return 1; } sub _is_valid_class_name { @@ -136,17 +135,6 @@ sub _is_valid_class_name { return 0; } -sub class_of { - my $self = shift; - my $class = shift; - - return undef if !defined($class); - - $class = blessed($class) || $class; - - return get_metaclass_by_name($class); -} - ## ---------------------------------------------------------------------------- ## Setting up our environment ... ## ---------------------------------------------------------------------------- @@ -169,7 +157,7 @@ sub class_of { # 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 +# inherit them using _construct_instance ## -------------------------------------------------------- ## Class::MOP::Package @@ -201,6 +189,42 @@ Class::MOP::Package->meta->add_attribute( )) ); +Class::MOP::Package->meta->add_attribute( + Class::MOP::Attribute->new('_methods' => ( + reader => { + # NOTE: + # we just alias the original method + # rather than re-produce it here + '_full_method_map' => \&Class::MOP::Package::_full_method_map + }, + default => sub { {} } + )) +); + +Class::MOP::Package->meta->add_attribute( + Class::MOP::Attribute->new('method_metaclass' => ( + reader => { + # NOTE: + # we just alias the original method + # rather than re-produce it here + 'method_metaclass' => \&Class::MOP::Package::method_metaclass + }, + default => 'Class::MOP::Method', + )) +); + +Class::MOP::Package->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::Package::wrapped_method_metaclass + }, + default => 'Class::MOP::Method::Wrapped', + )) +); + ## -------------------------------------------------------- ## Class::MOP::Module @@ -258,25 +282,13 @@ Class::MOP::Class->meta->add_attribute( # # we just alias the original method # rather than re-produce it here - 'get_attribute_map' => \&Class::MOP::Class::get_attribute_map + '_attribute_map' => \&Class::MOP::Class::_attribute_map }, default => sub { {} } )) ); Class::MOP::Class->meta->add_attribute( - Class::MOP::Attribute->new('methods' => ( - reader => { - # NOTE: - # 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: @@ -302,51 +314,52 @@ Class::MOP::Class->meta->add_attribute( ); Class::MOP::Class->meta->add_attribute( - Class::MOP::Attribute->new('method_metaclass' => ( + Class::MOP::Attribute->new('instance_metaclass' => ( reader => { - # NOTE: + # 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 - 'method_metaclass' => \&Class::MOP::Class::method_metaclass + 'instance_metaclass' => \&Class::MOP::Class::instance_metaclass }, - default => 'Class::MOP::Method', + default => 'Class::MOP::Instance', )) ); Class::MOP::Class->meta->add_attribute( - Class::MOP::Attribute->new('wrapped_method_metaclass' => ( + Class::MOP::Attribute->new('immutable_trait' => ( reader => { - # NOTE: - # we just alias the original method - # rather than re-produce it here - 'wrapped_method_metaclass' => \&Class::MOP::Class::wrapped_method_metaclass + 'immutable_trait' => \&Class::MOP::Class::immutable_trait }, - default => 'Class::MOP::Method::Wrapped', + default => "Class::MOP::Class::Immutable::Trait", )) ); Class::MOP::Class->meta->add_attribute( - Class::MOP::Attribute->new('instance_metaclass' => ( + Class::MOP::Attribute->new('constructor_name' => ( reader => { - # 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 - 'instance_metaclass' => \&Class::MOP::Class::instance_metaclass + 'constructor_name' => \&Class::MOP::Class::constructor_name, }, - default => 'Class::MOP::Instance', + default => "new", )) ); Class::MOP::Class->meta->add_attribute( - Class::MOP::Attribute->new('immutable_transformer' => ( + Class::MOP::Attribute->new('constructor_class' => ( reader => { - 'immutable_transformer' => \&Class::MOP::Class::immutable_transformer + 'constructor_class' => \&Class::MOP::Class::constructor_class, }, - writer => { - '_set_immutable_transformer' => \&Class::MOP::Class::_set_immutable_transformer + default => "Class::MOP::Method::Constructor", + )) +); + + +Class::MOP::Class->meta->add_attribute( + Class::MOP::Attribute->new('destructor_class' => ( + reader => { + 'destructor_class' => \&Class::MOP::Class::destructor_class, }, )) ); @@ -355,7 +368,7 @@ Class::MOP::Class->meta->add_attribute( # 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. +# _construct_class_instance method. ## -------------------------------------------------------- ## Class::MOP::Attribute @@ -464,6 +477,14 @@ Class::MOP::Attribute->meta->add_attribute( )) ); +Class::MOP::Attribute->meta->add_attribute( + Class::MOP::Attribute->new('insertion_order' => ( + reader => { 'insertion_order' => \&Class::MOP::Attribute::insertion_order }, + writer => { '_set_insertion_order' => \&Class::MOP::Attribute::_set_insertion_order }, + predicate => { 'has_insertion_order' => \&Class::MOP::Attribute::has_insertion_order }, + )) +); + Class::MOP::Attribute->meta->add_method('clone' => sub { my $self = shift; $self->meta->clone_object($self, @_); @@ -537,6 +558,16 @@ Class::MOP::Method::Generated->meta->add_attribute( )) ); + +## -------------------------------------------------------- +## Class::MOP::Method::Inlined + +Class::MOP::Method::Inlined->meta->add_attribute( + Class::MOP::Attribute->new('_expected_method_class' => ( + reader => { '_expected_method_class' => \&Class::MOP::Method::Inlined::_expected_method_class }, + )) +); + ## -------------------------------------------------------- ## Class::MOP::Method::Accessor @@ -615,6 +646,7 @@ Class::MOP::Instance->meta->add_attribute( ), ); +require Class::MOP::Deprecated unless our $no_deprecated; # we need the meta instance of the meta instance to be created now, in order # for the constructor to be able to use it @@ -630,8 +662,7 @@ undef Class::MOP::Instance->meta->{_package_cache_flag}; # the compile time of the MOP, and gives us no actual benefits. $_->meta->make_immutable( - inline_constructor => 1, - replace_constructor => 1, + inline_constructor => 0, constructor_name => "_new", inline_accessors => 0, ) for qw/ @@ -646,6 +677,7 @@ $_->meta->make_immutable( Class::MOP::Object Class::MOP::Method::Generated + Class::MOP::Method::Inlined Class::MOP::Method::Accessor Class::MOP::Method::Constructor @@ -853,11 +885,6 @@ 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 compatible. -=item I - -Whether or not the L pragma provides C, a much faster -way to get all the subclasses of a certain class. - =back =head2 Utility functions @@ -868,10 +895,15 @@ Note that these are all called as B. =item B -This will load the specified C<$class_name>. This function can be used +This will load the specified C<$class_name>, if it is not already +loaded (as reported by C). This function can be used in place of tricks like C or using C unconditionally. +If the module cannot be loaded, an exception is thrown. + +For historical reasons, this function explicitly returns a true value. + =item B Returns a boolean indicating whether or not C<$class_name> has been @@ -880,7 +912,9 @@ loaded. 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, but it can be fooled into reporting false -positives. +positives. In particular, loading any of the core L modules will +cause most of the rest of the core L modules to falsely report +having been loaded, due to the way the base L module works. =item B @@ -891,9 +925,9 @@ from. =item B -This will return the metaclass of the given instance or class name. -Even if the class lacks a metaclass, no metaclass will be initialized -and C will be returned. +This will return the metaclass of the given instance or class name. If the +class lacks a metaclass, no metaclass will be initialized, and C will be +returned. =item B @@ -1021,7 +1055,7 @@ L =over 4 -=item L +=item L =item L @@ -1051,8 +1085,14 @@ creates are very different from this modules. =head1 BUGS 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. +exception. + +Please report any bugs to C, or through the +web interface at L. + +You can also discuss feature requests or possible bugs on the Moose +mailing list (moose@perl.org) or on IRC at +L. =head1 ACKNOWLEDGEMENTS @@ -1076,6 +1116,8 @@ Florian (rafl) Ragwitz Guillermo (groditi) Roditi +Dave (autarch) Rolsky + Matt (mst) Trout Rob (robkinyon) Kinyon @@ -1084,6 +1126,8 @@ Yuval (nothingmuch) Kogman Scott (konobi) McWhirter +Dylan Hardison + =head1 COPYRIGHT AND LICENSE Copyright 2006-2009 by Infinity Interactive, Inc.