X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FClass%2FMOP.pm;h=74ac220ddda996b4217e7786208459b372b5d6a7;hb=b3b7a216ebf4397fcea34f3deabc671d27fa1d01;hp=50db76c72c143f01ecd9efaf084e7703c0203766;hpb=32bfc8109f26b0852d44bd36c08c305720bebaa1;p=gitmo%2FClass-MOP.git diff --git a/lib/Class/MOP.pm b/lib/Class/MOP.pm index 50db76c..74ac220 100644 --- a/lib/Class/MOP.pm +++ b/lib/Class/MOP.pm @@ -4,11 +4,34 @@ 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 () { !1 }; +} + + use Class::MOP::Class; use Class::MOP::Attribute; use Class::MOP::Method; @@ -16,86 +39,33 @@ use Class::MOP::Method; use Class::MOP::Immutable; BEGIN { - - our $VERSION = '0.65'; - 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::Identify::get_code_info; + *HAVE_ISAREV = defined(&mro::get_isarev) + ? sub () { 1 } + : sub () { 1 }; +} + +our $VERSION = '0.64_06'; +our $XS_VERSION = $VERSION; +$VERSION = eval $VERSION; +our $AUTHORITY = 'cpan:STEVAN'; - 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; - } - } +# after that everything is loaded, if we're allowed try to load faster XS +# versions of various things +unless ($ENV{CLASS_MOP_NO_XS}) { + my $e = do { + local $@; + eval { + require XSLoader; + __PACKAGE__->XSLoader::load($XS_VERSION); + }; + $@; + }; + + die $e if $e && $e !~ /object version|loadable object/; } { @@ -126,7 +96,10 @@ BEGIN { sub load_class { my $class = shift; - if (ref($class) || !defined($class) || !length($class)) { + if ( ref($class) + || !defined($class) + || !length($class) + || $class !~ /^\w+(?::\w+)*$/ ) { my $display = defined($class) ? $class : 'undef'; confess "Invalid class name ($display)"; } @@ -134,19 +107,17 @@ sub load_class { # 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; - eval { CORE::require($file) }; - confess "Could not load class ($class) because : $@" if $@; + my $e = do { local $@; eval "require $class"; $@ }; + confess "Could not load class ($class) because : $e" if $e; } # initialize a metaclass if necessary unless (does_metaclass_exist($class)) { - eval { Class::MOP::Class->initialize($class) }; - confess "Could not initialize class ($class) because : $@" if $@; + my $e = do { local $@; eval { Class::MOP::Class->initialize($class) }; $@ }; + confess "Could not initialize class ($class) because : $e" if $e; } - return get_metaclass_by_name($class); + return get_metaclass_by_name($class) if defined wantarray; } sub is_class_loaded { @@ -226,7 +197,6 @@ Class::MOP::Package->meta->add_attribute( # rather than re-produce it here 'name' => \&Class::MOP::Package::name }, - init_arg => 'package', )) ); @@ -243,15 +213,6 @@ Class::MOP::Package->meta->add_attribute( )) ); -# NOTE: -# use the metaclass to construct the meta-package -# which is a superclass of the metaclass itself :P -Class::MOP::Package->meta->add_method('initialize' => sub { - my $class = shift; - my $package_name = shift; - $class->meta->new_object('package' => $package_name, @_); -}); - ## -------------------------------------------------------- ## Class::MOP::Module @@ -311,14 +272,12 @@ Class::MOP::Class->meta->add_attribute( # rather than re-produce it here 'get_attribute_map' => \&Class::MOP::Class::get_attribute_map }, - init_arg => 'attributes', default => sub { {} } )) ); Class::MOP::Class->meta->add_attribute( Class::MOP::Attribute->new('methods' => ( - init_arg => 'methods', reader => { # NOTE: # we just alias the original method @@ -350,7 +309,6 @@ Class::MOP::Class->meta->add_attribute( # rather than re-produce it here 'attribute_metaclass' => \&Class::MOP::Class::attribute_metaclass }, - init_arg => 'attribute_metaclass', default => 'Class::MOP::Attribute', )) ); @@ -363,7 +321,6 @@ Class::MOP::Class->meta->add_attribute( # rather than re-produce it here 'method_metaclass' => \&Class::MOP::Class::method_metaclass }, - init_arg => 'method_metaclass', default => 'Class::MOP::Method', )) ); @@ -379,7 +336,6 @@ Class::MOP::Class->meta->add_attribute( # rather than re-produce it here 'instance_metaclass' => \&Class::MOP::Class::instance_metaclass }, - init_arg => 'instance_metaclass', default => 'Class::MOP::Instance', )) ); @@ -395,7 +351,6 @@ Class::MOP::Class->meta->add_attribute( 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 @@ -410,7 +365,6 @@ Class::MOP::Attribute->meta->add_attribute( 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 @@ -425,7 +379,6 @@ Class::MOP::Attribute->meta->add_attribute( Class::MOP::Attribute->meta->add_attribute( Class::MOP::Attribute->new('accessor' => ( - init_arg => 'accessor', reader => { 'accessor' => \&Class::MOP::Attribute::accessor }, predicate => { 'has_accessor' => \&Class::MOP::Attribute::has_accessor }, )) @@ -433,7 +386,6 @@ Class::MOP::Attribute->meta->add_attribute( Class::MOP::Attribute->meta->add_attribute( Class::MOP::Attribute->new('reader' => ( - init_arg => 'reader', reader => { 'reader' => \&Class::MOP::Attribute::reader }, predicate => { 'has_reader' => \&Class::MOP::Attribute::has_reader }, )) @@ -441,7 +393,6 @@ 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 }, )) @@ -449,7 +400,6 @@ Class::MOP::Attribute->meta->add_attribute( Class::MOP::Attribute->meta->add_attribute( Class::MOP::Attribute->new('writer' => ( - init_arg => 'writer', reader => { 'writer' => \&Class::MOP::Attribute::writer }, predicate => { 'has_writer' => \&Class::MOP::Attribute::has_writer }, )) @@ -457,7 +407,6 @@ Class::MOP::Attribute->meta->add_attribute( Class::MOP::Attribute->meta->add_attribute( Class::MOP::Attribute->new('predicate' => ( - init_arg => 'predicate', reader => { 'predicate' => \&Class::MOP::Attribute::predicate }, predicate => { 'has_predicate' => \&Class::MOP::Attribute::has_predicate }, )) @@ -465,7 +414,6 @@ Class::MOP::Attribute->meta->add_attribute( Class::MOP::Attribute->meta->add_attribute( Class::MOP::Attribute->new('clearer' => ( - init_arg => 'clearer', reader => { 'clearer' => \&Class::MOP::Attribute::clearer }, predicate => { 'has_clearer' => \&Class::MOP::Attribute::has_clearer }, )) @@ -473,7 +421,6 @@ 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 }, )) @@ -481,7 +428,6 @@ Class::MOP::Attribute->meta->add_attribute( Class::MOP::Attribute->meta->add_attribute( 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 }, )) @@ -489,7 +435,6 @@ Class::MOP::Attribute->meta->add_attribute( 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 }, )) @@ -497,46 +442,11 @@ Class::MOP::Attribute->meta->add_attribute( 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 -# it will "tie the knot" with Class::MOP::Attribute -# so that it uses the attributes meta-objects -# to construct itself. -Class::MOP::Attribute->meta->add_method('new' => sub { - my ( $class, @args ) = @_; - - unshift @args, "name" if @args % 2 == 1; - my %options = @args; - - my $name = $options{name}; - - (defined $name && $name) - || confess "You must provide a name for the attribute"; - $options{init_arg} = $name - if not exists $options{init_arg}; - - 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(%options); -}); - Class::MOP::Attribute->meta->add_method('clone' => sub { my $self = shift; $self->meta->clone_object($self, @_); @@ -546,43 +456,28 @@ 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->meta->add_attribute( + Class::MOP::Attribute->new('associated_metaclass' => ( + reader => { 'associated_metaclass' => \&Class::MOP::Method::associated_metaclass }, + )) +); + +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, @args ) = @_; - - unshift @args, 'body' if @args % 2 == 1; - - my %options = @args; - my $code = $options{body}; - - ('CODE' eq ref($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(%options); -}); - Class::MOP::Method->meta->add_method('clone' => sub { my $self = shift; $self->meta->clone_object($self, @_); @@ -605,27 +500,16 @@ Class::MOP::Method::Wrapped->meta->add_attribute( 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; -}); - ## -------------------------------------------------------- ## 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 }, @@ -634,47 +518,15 @@ Class::MOP::Method::Accessor->meta->add_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_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 Class::MOP::Method::Constructor->meta->add_attribute( Class::MOP::Attribute->new('options' => ( - init_arg => 'options', reader => { 'options' => \&Class::MOP::Method::Constructor::options }, @@ -684,37 +536,13 @@ Class::MOP::Method::Constructor->meta->add_attribute( Class::MOP::Method::Constructor->meta->add_attribute( Class::MOP::Attribute->new('associated_metaclass' => ( - init_arg => 'metaclass', + init_arg => "metaclass", # FIXME alias and rename 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; -}); - ## -------------------------------------------------------- ## Class::MOP::Instance @@ -723,19 +551,36 @@ Class::MOP::Method::Constructor->meta->add_method('new' => sub { # included for completeness Class::MOP::Instance->meta->add_attribute( - Class::MOP::Attribute->new('associated_metaclass') + Class::MOP::Attribute->new('associated_metaclass', + reader => { associated_metaclass => \&Class::MOP::Instance::associated_metaclass }, + ), ); Class::MOP::Instance->meta->add_attribute( - Class::MOP::Attribute->new('attributes') + Class::MOP::Attribute->new('_class_name', + init_arg => undef, + reader => { _class_name => \&Class::MOP::Instance::_class_name }, + #lazy => 1, # not yet supported by Class::MOP but out our version does it anyway + #default => sub { $_[0]->associated_metaclass->name }, + ), ); Class::MOP::Instance->meta->add_attribute( - Class::MOP::Attribute->new('slots') + Class::MOP::Attribute->new('attributes', + reader => { attributes => \&Class::MOP::Instance::get_all_attributes }, + ), ); Class::MOP::Instance->meta->add_attribute( - Class::MOP::Attribute->new('slot_hash') + Class::MOP::Attribute->new('slots', + reader => { slots => \&Class::MOP::Instance::slots }, + ), +); + +Class::MOP::Instance->meta->add_attribute( + Class::MOP::Attribute->new('slot_hash', + reader => { slot_hash => \&Class::MOP::Instance::slot_hash }, + ), ); @@ -743,17 +588,6 @@ 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}; @@ -768,8 +602,10 @@ undef Class::MOP::Instance->meta->{_package_cache_flag}; # no actual benefits. $_->meta->make_immutable( - inline_constructor => 0, - inline_accessors => 0, + inline_constructor => 1, + replace_constructor => 1, + constructor_name => "_new", + inline_accessors => 0, ) for qw/ Class::MOP::Package Class::MOP::Module @@ -983,6 +819,11 @@ 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. +=item I + +Whether or not C provides C, a much faster way to get all the +subclasses of a certain class. + =back =head2 Utility functions @@ -1028,6 +869,13 @@ If possible, we will load the L module and this will function as C does, otherwise it will just return the C<$code> argument. +=item B + +If L is available, this returns true under global +destruction. + +Otherwise it's a constant returning false. + =back =head2 Metaclass cache functions