X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FClass%2FMOP.pm;h=9a0dab41eee80d4158d709c8a5da2bbdeb8a2c52;hb=7329b9e22f165fcc4b0f688986197ca5f7e109ff;hp=0c0550f34ce61869e8a88f764d50640b0d24ac99;hpb=15273f3c0305b96e49dd34030b995623bcd670c5;p=gitmo%2FClass-MOP.git diff --git a/lib/Class/MOP.pm b/lib/Class/MOP.pm index 0c0550f..9a0dab4 100644 --- a/lib/Class/MOP.pm +++ b/lib/Class/MOP.pm @@ -4,16 +4,21 @@ package Class::MOP; use strict; use warnings; +use 5.008; + use MRO::Compat; use Carp 'confess'; use Scalar::Util 'weaken'; + +use Class::MOP::Class; +use Class::MOP::Attribute; +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 }; @@ -22,79 +27,53 @@ BEGIN { ? sub () { 1 } : 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; + # this is either part of core or set up appropriately by MRO::Compat + *check_package_cache_flag = \&mro::get_pkg_gen; +} + +our $VERSION = '0.70'; +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'; - - # this is either part of core or set up appropriately by MRO::Compat - *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 - { - my $e = do { - local $@; - eval { - require XSLoader; - __PACKAGE__->XSLoader::load($VERSION); - }; - $@; - }; - - die $e if $e && $e !~ /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 $e; - } - - # 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. +# after that everything is loaded, if we're allowed try to load faster XS +# versions of various things +_try_load_xs() or _load_pure_perl(); + +sub _try_load_xs { + return if $ENV{CLASS_MOP_NO_XS}; + + my $e = do { local $@; - if ( eval { require Sub::Name } ) { - *subname = \&Sub::Name::subname; - } - else { - *subname = $_PP_subname; - } - } + 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; } -use Class::MOP::Class; -use Class::MOP::Attribute; -use Class::MOP::Method; +sub _load_pure_perl { + require Sub::Identify; + Sub::Identify->import('get_code_info'); + + *subname = sub { $_[1] }; + *in_global_destruction = sub () { !1 } +} -use Class::MOP::Immutable; { # Metaclasses are singletons, so we cache them here. @@ -121,30 +100,74 @@ use Class::MOP::Immutable; # 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 { @@ -240,15 +263,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 @@ -483,40 +497,6 @@ Class::MOP::Attribute->meta->add_attribute( )) ); -# 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, @_); @@ -548,28 +528,18 @@ Class::MOP::Method->meta->add_attribute( )) ); -# FIMXE prime candidate for immutablization -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_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; }); ## -------------------------------------------------------- @@ -594,15 +564,6 @@ 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::Accessor @@ -620,36 +581,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 @@ -671,30 +602,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 @@ -719,7 +626,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 }, ), ); @@ -740,17 +647,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}; @@ -765,8 +661,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 @@ -989,6 +887,8 @@ subclasses of a certain class. =head2 Utility functions +Note that these are all called as B. + =over 4 =item B @@ -1009,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. @@ -1018,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. @@ -1030,6 +934,25 @@ 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 + +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 @@ -1185,6 +1108,8 @@ B Brandon (blblack) Black +Florian (rafl) Ragwitz + Guillermo (groditi) Roditi Matt (mst) Trout