Revision history for Perl extension Class-MOP.
-0.90
- Japan Perl Association has sponsored Goro Fuji to improve
- startup performance of Class::MOP and Moose. These enhancements
- may break backwards compatibility if you're doing (or using)
- complex metaprogramming, so, as always, test your code!
+0.92 Thu Aug 13, 2009
+ * Class::MOP::Class
+ * Class::MOP::Package
+ - Move get_method_map and its various scaffolding into Package. (hdp)
+
+ * Class::MOP::Method
+ - Allow Class::MOP::Method->wrap to take a Class::MOP::Method object as
+ the first argument, rather than just a coderef. (doy)
+
+ * Class::MOP::Attribute
+ * Class::MOP::Class
+ - Allow attribute names to be false (while still requiring them to be
+ defined). (rafl)
+
+0.91 Wed Jul 29, 2009
+ * Class::MOP::Method::Wrapped
+ - Fixing variable usage issues with the patch from previous
+ version, not properly using lexicals in the for
+ loops. (stevan)
+
+0.90 Tue Jul 21, 2009
+ Japan Perl Association has sponsored Goro Fuji to improve startup
+ performance of Class::MOP and Moose. These enhancements may break
+ backwards compatibility if you're doing (or using) complex
+ metaprogramming, so, as always, test your code!
http://blog.perlassociation.org/2009/07/jpa-sponsors-moose-class-mop-work.html
* Class::MOP::Class
* XS
- - Anonymous classes were not destroyed properly when they went
- out of scope, leading to a memory leak. RT #47480 (Goro Fuji).
+ - Anonymous classes were not completely destroyed when they went
+ out of scope, leading to a memory leak. RT #47480. (Goro
+ Fuji).
* Class::MOP::Class
- - get_method, has_method, and add_method no longer use get_method_map.
- Methods are more lazily instantiated to improve performance pretty
- significantly (Goro Fuji)
+ - The get_method, has_method, and add_method methods no longer
+ use get_method_map. Method objects are instantiated
+ lazily. This significantly improves Class::MOP's load
+ time. (Goro Fuji)
* All classes
- - Inline fewer metaclass-level constructors since the ones we have are
- perfectly fine. This reduces the number of string evals (Goro Fuji)
+ - Inline fewer metaclass-level constructors since the ones we
+ have are perfectly fine. This reduces the number of string
+ evals. (Goro Fuji)
+
+ * Class::MOP::Method::Wrapped
+ - If a method modifier set $_, this caused the modifier to blow
+ up, because of some weird internals. (Jeremy Stashewsky)
0.89 Fri Jul 3, 2009
* Class::MOP::Class
the symbol table as methods (these are optimized constant subs)
0.61 Fri. June 13, 2008
- - Okay, lets give this another try and see if PAUSE
+ - Okay, lets give this another try and see if PAUSE
recognizes it correct this time.
0.60 Thurs. Jun 12, 2008
!! Several fixes resulting in yet another 25-30% speedup !!
* Class::MOP::Class
- - now stores the instance of the instance
+ - now stores the instance of the instance
metaclass to avoid needless recomputation
and deletes it when the cache is blown
- - introduce methods to query Class::MOP::Class for
+ - introduce methods to query Class::MOP::Class for
the options used to make it immutable as well as
- the proper immutable transformer. (groditi)
+ the proper immutable transformer. (groditi)
* Class::MOP::Package
- - {add, has, get, remove}_package_symbol all
+ - {add, has, get, remove}_package_symbol all
now accept a HASH ref argument as well as the
string. All internal usages now use the HASH
ref version.
* Class::MOP
- - MOP.xs does sanity checks on the coderef
+ - MOP.xs does sanity checks on the coderef
to avoid a segfault
- is_class_loaded check now uses code that
was improved in Moose's ClassName type
load_class (Sartak)
- tests for this and other aspects of
load_class (Sartak)
-
+
* Class::MOP
- Class::MOP::Class
+ Class::MOP::Class
Class::MOP::Method
Class::MOP::Method::Wrapped
Class::MOP::Attribute
- - switched usage of reftype to ref because
+ - switched usage of reftype to ref because
it is much faster
0.58 Thurs. May 29, 2008
(late night release engineering)--
-
- - fixing the version is META.yml, no functional
+
+ - fixing the version is META.yml, no functional
changes in this release
0.57 Wed. May 28, 2008
instead of manually grabbing each symbol
- streamlining &initialize somewhat, since it gets
called so much
-
+
* Class::MOP::Package
- - made {get, has}_package_symbol not call
- &namespace so much
- - inlining a few calls to &name with
+ - made {get, has}_package_symbol not call
+ &namespace so much
+ - inlining a few calls to &name with
direct HASH access key access
- - added get_all_package_symbols to fetch
+ - added get_all_package_symbols to fetch
a HASH of items based on a type filter
similar to list_all_package_symbols
- added tests for this
Class::MOP::Method::Constructor
Class::MOP::Method::Generated
Class::MOP::Method::Accessor
- - added more descriptive error message to help
+ - added more descriptive error message to help
keep people from wasting time tracking an error
that is easily fixed by upgrading.
* Class::MOP
- we now get the &check_package_cache_flag
function from MRO::Compat
- - All XS based functionality now has a
+ - All XS based functionality now has a
Pure Perl alternative
- the CLASS_MOP_NO_XS environment variable
can now be used to force non-XS versions
Class::MOP::Method::Generated
Class::MOP::Method::Accessor
Class::MOP::Method::Consructor
- - the &wrap constructor method now requires that a
- 'package_name' and 'name' attribute are passed. This
- is to help support the no-XS version, and will
- throw an error if these are not supplied.
+ - the &wrap constructor method now requires that a
+ 'package_name' and 'name' attribute are passed. This
+ is to help support the no-XS version, and will
+ throw an error if these are not supplied.
- all these classes are now bootstrapped properly
and now store the package_name and name attributes
- correctly as well
+ correctly as well
- ~ Build.PL has been removed since the
+ ~ Build.PL has been removed since the
Module::Install support has been removed
0.55 Mon. April 28, 2008
requires 'Task::Weaken';
test_requires 'File::Spec';
-test_requires 'Test::More' => '0.77';
+test_requires 'Test::More' => '0.88';
test_requires 'Test::Exception' => '0.27';
extra_tests();
-Class::MOP version 0.89
+Class::MOP version 0.92
===========================
See the individual module documentation for more information
DEPENDENCIES
This module requires these other modules and libraries:
-
+
+ Devel::GlobalDestruction
+ MRO::Compat
Scalar::Util
Sub::Name
- Carp
- B
+ Task::Weaken
COPYRIGHT AND LICENCE
$count ||= 10;
$module ||= 'Moose';
+my @blib = qw(-Iblib/lib -Iblib/arch -I../Moose/blib/lib -I../Moose/blib/arch -I../Moose/lib);
+
+$| = 1; # autoflush
+
+print 'Installed: ';
+system $^X, '-le', 'require Moose; print $INC{q{Moose.pm}}';
+
+print 'Blead: ';
+system $^X, @blib, '-le', 'require Moose; print $INC{q{Moose.pm}}';
+
cmpthese timethese $count => {
released => sub {
- system( $^X, '-e', "require $module" ) == 0 or die;
+ system( $^X, '-e', "require $module") == 0 or die;
},
blead => sub {
- system( $^X, '-Iblib/lib', '-Iblib/arch', '-e', "require $module" )
- == 0
- or die;
+ system( $^X, @blib, '-e', "require $module") == 0 or die;
},
};
*check_package_cache_flag = \&mro::get_pkg_gen;
}
-our $VERSION = '0.89';
+our $VERSION = '0.92';
our $XS_VERSION = $VERSION;
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
))
);
+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
+ 'get_method_map' => \&Class::MOP::Package::get_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
);
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:
);
Class::MOP::Class->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::Class::method_metaclass
- },
- default => 'Class::MOP::Method',
- ))
-);
-
-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
use Carp 'confess';
use Scalar::Util 'blessed', 'weaken';
-our $VERSION = '0.89';
+our $VERSION = '0.92';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
my $name = $options{name};
- (defined $name && $name)
+ (defined $name)
|| confess "You must provide a name for the attribute";
$options{init_arg} = $name
use Carp 'confess';
use Scalar::Util 'blessed', 'reftype', 'weaken';
-use Sub::Name 'subname';
+use Sub::Name 'subname';
use Devel::GlobalDestruction 'in_global_destruction';
-our $VERSION = '0.89';
+our $VERSION = '0.92';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
sub get_attribute_map { $_[0]->{'attributes'} }
sub attribute_metaclass { $_[0]->{'attribute_metaclass'} }
-sub method_metaclass { $_[0]->{'method_metaclass'} }
-sub wrapped_method_metaclass { $_[0]->{'wrapped_method_metaclass'} }
sub instance_metaclass { $_[0]->{'instance_metaclass'} }
sub immutable_trait { $_[0]->{'immutable_trait'} }
sub constructor_class { $_[0]->{'constructor_class'} }
sub constructor_name { $_[0]->{'constructor_name'} }
sub destructor_class { $_[0]->{'destructor_class'} }
-sub _method_map { $_[0]->{'methods'} }
-
# Instance Construction & Cloning
sub new_object {
## Methods
-sub wrap_method_body {
- my ( $self, %args ) = @_;
-
- ('CODE' eq ref $args{body})
- || confess "Your code block must be a CODE reference";
-
- $self->method_metaclass->wrap(
- package_name => $self->name,
- %args,
- );
-}
-
-sub add_method {
- my ($self, $method_name, $method) = @_;
- (defined $method_name && $method_name)
- || confess "You must define a method name";
-
- my $body;
- if (blessed($method)) {
- $body = $method->body;
- if ($method->package_name ne $self->name) {
- $method = $method->clone(
- package_name => $self->name,
- name => $method_name
- ) if $method->can('clone');
- }
-
- $method->attach_to_class($self);
- $self->_method_map->{$method_name} = $method;
- }
- else {
- # If a raw code reference is supplied, its method object is not created.
- # The method object won't be created until required.
- $body = $method;
- }
-
- $self->add_package_symbol(
- { sigil => '&', type => 'CODE', name => $method_name },
- $body,
- );
-}
-
{
my $fetch_and_prepare_method = sub {
my ($self, $method_name) = @_;
shift->add_method(@_);
}
-sub _code_is_mine {
- my ( $self, $code ) = @_;
-
- my ( $code_package, $code_name ) = Class::MOP::get_code_info($code);
-
- return $code_package && $code_package eq $self->name
- || ( $code_package eq 'constant' && $code_name eq '__ANON__' );
-}
-
-sub has_method {
- my ($self, $method_name) = @_;
- (defined $method_name && $method_name)
- || confess "You must define a method name";
-
- return defined($self->get_method($method_name));
-}
-
-sub get_method {
- my ($self, $method_name) = @_;
- (defined $method_name && $method_name)
- || confess "You must define a method name";
-
- my $method_map = $self->_method_map;
- my $method_object = $method_map->{$method_name};
- my $code = $self->get_package_symbol({
- name => $method_name,
- sigil => '&',
- type => 'CODE',
- });
-
- unless ( $method_object && $method_object->body == ( $code || 0 ) ) {
- if ( $code && $self->_code_is_mine($code) ) {
- $method_object = $method_map->{$method_name}
- = $self->wrap_method_body(
- body => $code,
- name => $method_name,
- associated_metaclass => $self,
- );
- }
- else {
- delete $method_map->{$method_name};
- return undef;
- }
- }
-
- return $method_object;
-}
-
-sub remove_method {
- my ($self, $method_name) = @_;
- (defined $method_name && $method_name)
- || confess "You must define a method name";
-
- my $removed_method = delete $self->get_method_map->{$method_name};
-
- $self->remove_package_symbol(
- { sigil => '&', type => 'CODE', name => $method_name }
- );
-
- $removed_method->detach_from_class if $removed_method;
-
- $self->update_package_cache_flag; # still valid, since we just removed the method from the map
-
- return $removed_method;
-}
-
-sub get_method_list {
- my $self = shift;
- return grep { $self->has_method($_) } keys %{ $self->namespace };
-}
-
sub find_method_by_name {
my ($self, $method_name) = @_;
(defined $method_name && $method_name)
sub has_attribute {
my ($self, $attribute_name) = @_;
- (defined $attribute_name && $attribute_name)
+ (defined $attribute_name)
|| confess "You must define an attribute name";
exists $self->get_attribute_map->{$attribute_name};
}
sub get_attribute {
my ($self, $attribute_name) = @_;
- (defined $attribute_name && $attribute_name)
+ (defined $attribute_name)
|| confess "You must define an attribute name";
return $self->get_attribute_map->{$attribute_name}
# NOTE:
sub remove_attribute {
my ($self, $attribute_name) = @_;
- (defined $attribute_name && $attribute_name)
+ (defined $attribute_name)
|| confess "You must define an attribute name";
my $removed_attribute = $self->get_attribute_map->{$attribute_name};
return unless defined $removed_attribute;
=back
-=head2 Method introspection and creation
-
-These methods allow you to introspect a class's methods, as well as
-add, remove, or change methods.
-
-Determining what is truly a method in a Perl 5 class requires some
-heuristics (aka guessing).
+=head2 Method introspection
-Methods defined outside the package with a fully qualified name (C<sub
-Package::name { ... }>) will be included. Similarly, methods named
-with a fully qualified name using L<Sub::Name> are also included.
-
-However, we attempt to ignore imported functions.
-
-Ultimately, we are using heuristics to determine what truly is a
-method in a class, and these heuristics may get the wrong answer in
-some edge cases. However, for most "normal" cases the heuristics work
-correctly.
+See L<Class::MOP::Package/Method introspection and creation> for
+methods that operate only on the current class. Class::MOP::Class adds
+introspection capabilities that take inheritance into account.
=over 4
-=item B<< $metaclass->get_method($method_name) >>
-
-This will return a L<Class::MOP::Method> for the specified
-C<$method_name>. If the class does not have the specified method, it
-returns C<undef>
-
-=item B<< $metaclass->has_method($method_name) >>
-
-Returns a boolean indicating whether or not the class defines the
-named method. It does not include methods inherited from parent
-classes.
-
-=item B<< $metaclass->get_method_map >>
-
-Returns a hash reference representing the methods defined in this
-class. The keys are method names and the values are
-L<Class::MOP::Method> objects.
-
-=item B<< $metaclass->get_method_list >>
-
-This will return a list of method I<names> for all methods defined in
-this class.
-
=item B<< $metaclass->get_all_methods >>
This will traverse the inheritance hierarchy and return a list of all
given name. It is effectively the method that C<SUPER::$method_name>
would dispatch to.
-=item B<< $metaclass->add_method($method_name, $method) >>
-
-This method takes a method name and a subroutine reference, and adds
-the method to the class.
-
-The subroutine reference can be a L<Class::MOP::Method>, and you are
-strongly encouraged to pass a meta method object instead of a code
-reference. If you do so, that object gets stored as part of the
-class's method map directly. If not, the meta information will have to
-be recreated later, and may be incorrect.
-
-If you provide a method object, this method will clone that object if
-the object's package name does not match the class name. This lets us
-track the original source of any methods added from other classes
-(notably Moose roles).
-
-=item B<< $metaclass->remove_method($method_name) >>
-
-Remove the named method from the class. This method returns the
-L<Class::MOP::Method> object for the method.
-
-=item B<< $metaclass->method_metaclass >>
-
-Returns the class name of the method metaclass, see
-L<Class::MOP::Method> for more information on the method metaclass.
-
-=item B<< $metaclass->wrapped_method_metaclass >>
-
-Returns the class name of the wrapped method metaclass, see
-L<Class::MOP::Method::Wrapped> for more information on the wrapped
-method metaclass.
-
=back
=head2 Attribute introspection and creation
use Carp 'confess';
use Scalar::Util 'blessed', 'weaken';
-our $VERSION = '0.89';
+our $VERSION = '0.92';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
use Scalar::Util 'weaken', 'blessed';
-our $VERSION = '0.89';
+our $VERSION = '0.92';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
sub inline_slot_access {
my ($self, $instance, $slot_name) = @_;
- sprintf q[%s->{'%s'}], $instance, quotemeta($slot_name);
+ sprintf q[%s->{"%s"}], $instance, quotemeta($slot_name);
}
sub inline_get_slot_value {
use warnings;
use Carp 'confess';
-use Scalar::Util 'weaken', 'reftype';
+use Scalar::Util 'weaken', 'reftype', 'blessed';
-our $VERSION = '0.89';
+our $VERSION = '0.92';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
my %params = @args;
my $code = $params{body};
- (ref $code && 'CODE' eq reftype($code))
- || confess "You must supply a CODE reference to bless, not (" . ($code || 'undef') . ")";
+ if (blessed($code) && $code->isa(__PACKAGE__)) {
+ my $method = $code->clone;
+ delete $params{body};
+ Class::MOP::class_of($class)->rebless_instance($method, %params);
+ return $method;
+ }
+ elsif (!ref $code || 'CODE' ne reftype($code)) {
+ confess "You must supply a CODE reference to bless, not (" . ($code || 'undef') . ")";
+ }
($params{package_name} && $params{name})
|| confess "You must supply the package_name and name parameters";
=item B<< Class::MOP::Method->wrap($code, %options) >>
-This is the constructor. It accepts a subroutine reference and a hash
-of options.
+This is the constructor. It accepts a method body in the form of
+either a code reference or a L<Class::MOP::Method> instance, followed
+by a hash of options.
The options are:
=item * name
-The method name (without a package name). This is required.
+The method name (without a package name). This is required if C<$code>
+is a coderef.
=item * package_name
-The package name for the method. This is required.
+The package name for the method. This is required if C<$code> is a
+coderef.
=item * associated_metaclass
use Carp 'confess';
use Scalar::Util 'blessed', 'weaken';
-our $VERSION = '0.89';
+our $VERSION = '0.92';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
use Carp 'confess';
use Scalar::Util 'blessed', 'weaken', 'looks_like_number';
-our $VERSION = '0.89';
+our $VERSION = '0.92';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
use Carp 'confess';
-our $VERSION = '0.89';
+our $VERSION = '0.92';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
use base 'Class::MOP::Method';
+use constant _PRINT_SOURCE => $ENV{MOP_PRINT_SOURCE} ? 1 : 0;
+
## accessors
sub new {
my $e = do {
local $@;
local $SIG{__DIE__};
- $code = eval join
+ my $source = join
"\n", (
map {
/^([\@\%\$])/
} keys %$__captures
),
$_[2];
+ print STDERR $_[0]->name, ' ', $source, "\n" if _PRINT_SOURCE;
+ $code = eval $source;
$@;
};
use Carp 'confess';
use Scalar::Util 'blessed', 'weaken', 'looks_like_number', 'refaddr';
-our $VERSION = '0.89';
+our $VERSION = '0.92';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
use Carp 'confess';
use Scalar::Util 'blessed';
-our $VERSION = '0.89';
+our $VERSION = '0.92';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
);
if (@$before && @$after) {
$modifier_table->{cache} = sub {
- $_->(@_) for @{$before};
+ for my $c (@$before) { $c->(@_) };
my @rval;
((defined wantarray) ?
((wantarray) ?
($rval[0] = $around->{cache}->(@_)))
:
$around->{cache}->(@_));
- $_->(@_) for @{$after};
+ for my $c (@$after) { $c->(@_) };
return unless defined wantarray;
return wantarray ? @rval : $rval[0];
}
}
elsif (@$before && !@$after) {
$modifier_table->{cache} = sub {
- $_->(@_) for @{$before};
+ for my $c (@$before) { $c->(@_) };
return $around->{cache}->(@_);
}
}
($rval[0] = $around->{cache}->(@_)))
:
$around->{cache}->(@_));
- $_->(@_) for @{$after};
+ for my $c (@$after) { $c->(@_) };
return unless defined wantarray;
return wantarray ? @rval : $rval[0];
}
sub wrap {
my ( $class, $code, %params ) = @_;
-
+
(blessed($code) && $code->isa('Class::MOP::Method'))
|| confess "Can only wrap blessed CODE";
-
+
my $modifier_table = {
cache => undef,
orig => $code,
$_build_wrapped_method->($modifier_table);
return $class->SUPER::wrap(
sub { $modifier_table->{cache}->(@_) },
- # get these from the original
+ # get these from the original
# unless explicitly overriden
package_name => $params{package_name} || $code->package_name,
name => $params{name} || $code->name,
use Carp 'confess';
use Scalar::Util 'blessed';
-our $VERSION = '0.89';
+our $VERSION = '0.92';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
use Scalar::Util 'blessed';
-our $VERSION = '0.89';
+our $VERSION = '0.92';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
use Scalar::Util 'blessed', 'reftype';
use Carp 'confess';
+use Sub::Name 'subname';
-our $VERSION = '0.89';
+our $VERSION = '0.92';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
my %options = @args;
my $package_name = delete $options{package};
- (defined $package_name && $package_name && !blessed($package_name))
- || confess "You must pass a package name and it cannot be blessed";
+ (defined $package_name && $package_name
+ && (!blessed $package_name || $package_name->isa('Class::MOP::Package')))
+ || confess "You must pass a package name or an existing Class::MOP::Package instance";
+
+ $package_name = $package_name->name
+ if blessed $package_name;
Class::MOP::remove_metaclass_by_name($package_name);
\%{$_[0]->{'package'} . '::'}
}
+sub method_metaclass { $_[0]->{'method_metaclass'} }
+sub wrapped_method_metaclass { $_[0]->{'wrapped_method_metaclass'} }
+
+sub _method_map { $_[0]->{'methods'} }
+
# utility methods
{
}
}
+## Methods
+
+sub wrap_method_body {
+ my ( $self, %args ) = @_;
+
+ ('CODE' eq ref $args{body})
+ || confess "Your code block must be a CODE reference";
+
+ $self->method_metaclass->wrap(
+ package_name => $self->name,
+ %args,
+ );
+}
+
+sub add_method {
+ my ($self, $method_name, $method) = @_;
+ (defined $method_name && $method_name)
+ || confess "You must define a method name";
+
+ my $body;
+ if (blessed($method)) {
+ $body = $method->body;
+ if ($method->package_name ne $self->name) {
+ $method = $method->clone(
+ package_name => $self->name,
+ name => $method_name
+ ) if $method->can('clone');
+ }
+
+ $method->attach_to_class($self);
+ $self->_method_map->{$method_name} = $method;
+ }
+ else {
+ # If a raw code reference is supplied, its method object is not created.
+ # The method object won't be created until required.
+ $body = $method;
+ }
+
+
+ my ( $current_package, $current_name ) = Class::MOP::get_code_info($body);
+
+ if ( !defined $current_name || $current_name eq '__ANON__' ) {
+ my $full_method_name = ($self->name . '::' . $method_name);
+ subname($full_method_name => $body);
+ }
+
+ $self->add_package_symbol(
+ { sigil => '&', type => 'CODE', name => $method_name },
+ $body,
+ );
+}
+
+sub _code_is_mine {
+ my ( $self, $code ) = @_;
+
+ my ( $code_package, $code_name ) = Class::MOP::get_code_info($code);
+
+ return $code_package && $code_package eq $self->name
+ || ( $code_package eq 'constant' && $code_name eq '__ANON__' );
+}
+
+sub has_method {
+ my ($self, $method_name) = @_;
+ (defined $method_name && $method_name)
+ || confess "You must define a method name";
+
+ return defined($self->get_method($method_name));
+}
+
+sub get_method {
+ my ($self, $method_name) = @_;
+ (defined $method_name && $method_name)
+ || confess "You must define a method name";
+
+ my $method_map = $self->_method_map;
+ my $method_object = $method_map->{$method_name};
+ my $code = $self->get_package_symbol({
+ name => $method_name,
+ sigil => '&',
+ type => 'CODE',
+ });
+
+ unless ( $method_object && $method_object->body == ( $code || 0 ) ) {
+ if ( $code && $self->_code_is_mine($code) ) {
+ $method_object = $method_map->{$method_name}
+ = $self->wrap_method_body(
+ body => $code,
+ name => $method_name,
+ associated_metaclass => $self,
+ );
+ }
+ else {
+ delete $method_map->{$method_name};
+ return undef;
+ }
+ }
+
+ return $method_object;
+}
+
+sub remove_method {
+ my ($self, $method_name) = @_;
+ (defined $method_name && $method_name)
+ || confess "You must define a method name";
+
+ my $removed_method = delete $self->get_method_map->{$method_name};
+
+ $self->remove_package_symbol(
+ { sigil => '&', type => 'CODE', name => $method_name }
+ );
+
+ $removed_method->detach_from_class if $removed_method;
+
+ $self->update_package_cache_flag; # still valid, since we just removed the method from the map
+
+ return $removed_method;
+}
+
+sub get_method_list {
+ my $self = shift;
+ return grep { $self->has_method($_) } keys %{ $self->namespace };
+}
+
1;
__END__
represents specified package. If an existing metaclass object exists
for the package, that will be returned instead.
-=item B<< Class::MOP::Package->reinitialize($package_name) >>
+=item B<< Class::MOP::Package->reinitialize($package) >>
This method forcibly removes any existing metaclass for the package
-before calling C<initialize>
+before calling C<initialize>. In contrast to C<initialize>, you may
+also pass an existing C<Class::MOP::Package> instance instead of just
+a package name as C<$package>.
Do not call this unless you know what you are doing.
hash reference. The keys are glob names and the values are references
to the value for that name.
+=back
+
+=head2 Method introspection and creation
+
+These methods allow you to introspect a class's methods, as well as
+add, remove, or change methods.
+
+Determining what is truly a method in a Perl 5 class requires some
+heuristics (aka guessing).
+
+Methods defined outside the package with a fully qualified name (C<sub
+Package::name { ... }>) will be included. Similarly, methods named
+with a fully qualified name using L<Sub::Name> are also included.
+
+However, we attempt to ignore imported functions.
+
+Ultimately, we are using heuristics to determine what truly is a
+method in a class, and these heuristics may get the wrong answer in
+some edge cases. However, for most "normal" cases the heuristics work
+correctly.
+
+=over 4
+
+=item B<< $metapackage->get_method($method_name) >>
+
+This will return a L<Class::MOP::Method> for the specified
+C<$method_name>. If the class does not have the specified method, it
+returns C<undef>
+
+=item B<< $metapackage->has_method($method_name) >>
+
+Returns a boolean indicating whether or not the class defines the
+named method. It does not include methods inherited from parent
+classes.
+
+=item B<< $metapackage->get_method_map >>
+
+Returns a hash reference representing the methods defined in this
+class. The keys are method names and the values are
+L<Class::MOP::Method> objects.
+
+=item B<< $metapackage->get_method_list >>
+
+This will return a list of method I<names> for all methods defined in
+this class.
+
+=item B<< $metapackage->add_method($method_name, $method) >>
+
+This method takes a method name and a subroutine reference, and adds
+the method to the class.
+
+The subroutine reference can be a L<Class::MOP::Method>, and you are
+strongly encouraged to pass a meta method object instead of a code
+reference. If you do so, that object gets stored as part of the
+class's method map directly. If not, the meta information will have to
+be recreated later, and may be incorrect.
+
+If you provide a method object, this method will clone that object if
+the object's package name does not match the class name. This lets us
+track the original source of any methods added from other classes
+(notably Moose roles).
+
+=item B<< $metapackage->remove_method($method_name) >>
+
+Remove the named method from the class. This method returns the
+L<Class::MOP::Method> object for the method.
+
+=item B<< $metapackage->method_metaclass >>
+
+Returns the class name of the method metaclass, see
+L<Class::MOP::Method> for more information on the method metaclass.
+
+=item B<< $metapackage->wrapped_method_metaclass >>
+
+Returns the class name of the wrapped method metaclass, see
+L<Class::MOP::Method::Wrapped> for more information on the wrapped
+method metaclass.
+
=item B<< Class::MOP::Package->meta >>
This will return a L<Class::MOP::Class> instance for this class.
use Carp 'confess';
use Scalar::Util 'blessed';
-our $VERSION = '0.89';
+our $VERSION = '0.92';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
we hit it without the guard, we segfault. The slightly odd return
value strikes me as an improvement (mst)
*/
-#ifdef isGV_with_GP
+
if ( isGV_with_GP(CvGV(coderef)) ) {
-#endif
GV *gv = CvGV(coderef);
*pkg = HvNAME( GvSTASH(gv) ? GvSTASH(gv) : CvSTASH(coderef) );
*name = GvNAME( CvGV(coderef) );
-#ifdef isGV_with_GP
} else {
*pkg = "__UNKNOWN__";
*name = "__ANON__";
}
-#endif
return 1;
}
/*
----------------------------------------------------------------------
- ppport.h -- Perl/Pollution/Portability Version 3.17
+ ppport.h -- Perl/Pollution/Portability Version 3.19
Automatically created by Devel::PPPort running under perl 5.010000.
=head1 NAME
-ppport.h - Perl/Pollution/Portability version 3.17
+ppport.h - Perl/Pollution/Portability version 3.19
=head1 SYNOPSIS
my_strlcpy() NEED_my_strlcpy NEED_my_strlcpy_GLOBAL
newCONSTSUB() NEED_newCONSTSUB NEED_newCONSTSUB_GLOBAL
newRV_noinc() NEED_newRV_noinc NEED_newRV_noinc_GLOBAL
+ newSV_type() NEED_newSV_type NEED_newSV_type_GLOBAL
newSVpvn_flags() NEED_newSVpvn_flags NEED_newSVpvn_flags_GLOBAL
newSVpvn_share() NEED_newSVpvn_share NEED_newSVpvn_share_GLOBAL
pv_display() NEED_pv_display NEED_pv_display_GLOBAL
# Disable broken TRIE-optimization
BEGIN { eval '${^RE_TRIE_MAXBUF} = -1' if $] >= 5.009004 && $] <= 5.009005 }
-my $VERSION = 3.17;
+my $VERSION = 3.19;
my %opt = (
quiet => 0,
G_SCALAR|||
G_VOID||5.004000|
GetVars|||
+GvSVn|5.009003||p
GvSV|||
Gv_AMupdate|||
HEf_SVKEY||5.004000|
HeSVKEY||5.004000|
HeUTF8||5.011000|
HeVAL||5.004000|
+HvNAMELEN_get|5.009003||p
+HvNAME_get|5.009003||p
HvNAME|||
INT2PTR|5.006000||p
IN_LOCALE_COMPILETIME|5.007002||p
PERL_SHORT_MIN|5.004000||p
PERL_SIGNALS_UNSAFE_FLAG|5.008001||p
PERL_SUBVERSION|5.006000||p
+PERL_SYS_INIT3||5.006000|
+PERL_SYS_INIT|||
+PERL_SYS_TERM||5.011000|
PERL_UCHAR_MAX|5.004000||p
PERL_UCHAR_MIN|5.004000||p
PERL_UINT_MAX|5.004000||p
PL_dirty|5.004050||p
PL_dowarn|||pn
PL_errgv|5.004050||p
+PL_error_count|5.011000||p
PL_expect|5.011000||p
PL_hexdigit|5.005000||p
PL_hints|5.005000||p
+PL_in_my_stash|5.011000||p
+PL_in_my|5.011000||p
PL_last_in_gv|||n
PL_laststatval|5.005000||p
PL_lex_state|5.011000||p
SV_NOSTEAL|5.009002||p
SV_SMAGIC|5.009003||p
SV_UTF8_NO_ENCODING|5.008001||p
+SVfARG|5.009005||p
SVf_UTF8|5.006000||p
SVf|5.006000||p
SVt_IV|||
XPUSHp|||
XPUSHs|||
XPUSHu|5.004000||p
+XSPROTO|5.010000||p
XSRETURN_EMPTY|||
XSRETURN_IV|||
XSRETURN_NO|||
boot_core_PerlIO|||
boot_core_UNIVERSAL|||
boot_core_mro|||
-boot_core_xsutils|||
bytes_from_utf8||5.007001|
bytes_to_uni|||n
bytes_to_utf8||5.006001|
getcwd_sv||5.007002|
getenv_len|||
glob_2number|||
-glob_2pv|||
glob_assign_glob|||
glob_assign_ref|||
gp_dup|||
gv_fetchmethod_flags||5.011000|
gv_fetchmethod|||
gv_fetchmeth|||
-gv_fetchpvn_flags||5.009002|
+gv_fetchpvn_flags|5.009002||p
+gv_fetchpvs|5.009004||p
gv_fetchpv|||
gv_fetchsv||5.009002|
gv_fullname3||5.004000|
gv_init|||
gv_name_set||5.009004|
gv_stashpvn|5.004000||p
-gv_stashpvs||5.009003|
+gv_stashpvs|5.009003||p
gv_stashpv|||
gv_stashsv|||
he_dup|||
isCNTRL|5.006000||p
isDIGIT|||
isGRAPH|5.006000||p
+isGV_with_GP|5.009004||p
isLOWER|||
isPRINT|5.004000||p
isPSXSPC|5.006001||p
newSUB|||
newSVOP|||
newSVREF|||
-newSV_type||5.009005|
+newSV_type|5.009005||p
newSVhek||5.009003|
newSViv|||
newSVnv|||
sv_destroyable||5.010000|
sv_does||5.009004|
sv_dump|||
+sv_dup_inc_multiple|||
sv_dup|||
sv_eq|||
sv_exp_grow|||
return; \
} STMT_END
#endif
+#ifndef XSPROTO
+# define XSPROTO(name) void name(pTHX_ CV* cv)
+#endif
+
+#ifndef SVfARG
+# define SVfARG(p) ((void*)(p))
+#endif
#ifndef PERL_ABS
# define PERL_ABS(x) ((x) < 0 ? -(x) : (x))
#endif
# define PL_dirty dirty
# define PL_dowarn dowarn
# define PL_errgv errgv
+# define PL_error_count error_count
# define PL_expect expect
# define PL_hexdigit hexdigit
# define PL_hints hints
+# define PL_in_my in_my
# define PL_laststatval laststatval
# define PL_lex_state lex_state
# define PL_lex_stuff lex_stuff
# define PL_lex_state D_PPP_my_PL_parser_var(lex_state)
# define PL_lex_stuff D_PPP_my_PL_parser_var(lex_stuff)
# define PL_tokenbuf D_PPP_my_PL_parser_var(tokenbuf)
+# define PL_in_my D_PPP_my_PL_parser_var(in_my)
+# define PL_in_my_stash D_PPP_my_PL_parser_var(in_my_stash)
+# define PL_error_count D_PPP_my_PL_parser_var(error_count)
+
#else
# define SvREFCNT_inc_simple_void_NN(sv) (void)(++SvREFCNT((SV*)(sv)))
#endif
+#ifndef newSV_type
+
+#if defined(NEED_newSV_type)
+static SV* DPPP_(my_newSV_type)(pTHX_ svtype const t);
+static
+#else
+extern SV* DPPP_(my_newSV_type)(pTHX_ svtype const t);
+#endif
+
+#ifdef newSV_type
+# undef newSV_type
+#endif
+#define newSV_type(a) DPPP_(my_newSV_type)(aTHX_ a)
+#define Perl_newSV_type DPPP_(my_newSV_type)
+
+#if defined(NEED_newSV_type) || defined(NEED_newSV_type_GLOBAL)
+
+SV*
+DPPP_(my_newSV_type)(pTHX_ svtype const t)
+{
+ SV* const sv = newSV(0);
+ sv_upgrade(sv, t);
+ return sv;
+}
+
+#endif
+
+#endif
+
#if (PERL_BCDVERSION < 0x5006000)
# define D_PPP_CONSTPV_ARG(x) ((char *) (x))
#else
#ifndef SvSHARED_HASH
# define SvSHARED_HASH(sv) (0 + SvUVX(sv))
#endif
+#ifndef HvNAME_get
+# define HvNAME_get(hv) HvNAME(hv)
+#endif
+#ifndef HvNAMELEN_get
+# define HvNAMELEN_get(hv) (HvNAME_get(hv) ? (I32)strlen(HvNAME_get(hv)) : 0)
+#endif
+#ifndef GvSVn
+# define GvSVn(gv) GvSV(gv)
+#endif
+
+#ifndef isGV_with_GP
+# define isGV_with_GP(gv) isGV(gv)
+#endif
#ifndef WARN_ALL
# define WARN_ALL 0
#endif
#ifndef hv_stores
# define hv_stores(hv, key, val) hv_store(hv, key "", sizeof(key) - 1, val, 0)
#endif
+#ifndef gv_fetchpvn_flags
+# define gv_fetchpvn_flags(name, len, flags, svt) gv_fetchpv(name, flags, svt)
+#endif
+
+#ifndef gv_fetchpvs
+# define gv_fetchpvs(name, flags, svt) gv_fetchpvn_flags(name "", sizeof(name) - 1, flags, svt)
+#endif
+
+#ifndef gv_stashpvs
+# define gv_stashpvs(name, flags) gv_stashpvn(name "", sizeof(name) - 1, flags)
+#endif
#ifndef SvGETMAGIC
# define SvGETMAGIC(x) STMT_START { if (SvGMAGICAL(x)) mg_get(x); } STMT_END
#endif
use strict;
use warnings;
-use Test::More tests => 73;
+use Test::More tests => 90;
use Test::Exception;
use Class::MOP;
} '... we added a method to Buzz successfully';
}
-{
+
+
+for(1 .. 2){
my $buzz;
::lives_ok { $buzz = Buzz->meta->new_object } '...Buzz instantiated successfully';
::is($buzz->foo, 'Buzz', '...foo builder works as expected');
::ok($buzz2->has_bar, '...bar is set');
::is($buzz2->bar, undef, '...bar is undef');
-}
+ my $buzz3;
+ ::lives_ok { $buzz3 = Buzz->meta->new_object } '...Buzz instantiated successfully';
+ ::ok($buzz3->has_bah, '...bah is set');
+ ::is($buzz3->bah, 'BAH', '...bah returns "BAH" ');
-{
- my $buzz;
- ::lives_ok { $buzz = Buzz->meta->new_object } '...Buzz instantiated successfully';
- ::ok($buzz->has_bah, '...bah is set');
- ::is($buzz->bah, 'BAH', '...bah returns "BAH" ');
-
- my $buzz2;
- ::lives_ok { $buzz2 = Buzz->meta->new_object('$bah' => undef) } '...Buzz instantiated successfully';
- ::ok($buzz2->has_bah, '...bah is set');
- ::is($buzz2->bah, undef, '...bah is undef');
+ my $buzz4;
+ ::lives_ok { $buzz4 = Buzz->meta->new_object('$bah' => undef) } '...Buzz instantiated successfully';
+ ::ok($buzz4->has_bah, '...bah is set');
+ ::is($buzz4->bah, undef, '...bah is undef');
+ Buzz->meta->make_immutable();
}
add_package_symbol get_package_symbol has_package_symbol remove_package_symbol
list_all_package_symbols get_all_package_symbols remove_package_glob
+ method_metaclass wrapped_method_metaclass
+
+ _method_map
+ _code_is_mine
+ has_method get_method add_method remove_method wrap_method_body
+ get_method_list get_method_map
+
_deconstruct_variable_name
);
add_dependent_meta_instance remove_dependent_meta_instance
invalidate_meta_instances invalidate_meta_instance
- attribute_metaclass method_metaclass wrapped_method_metaclass
+ attribute_metaclass
superclasses subclasses direct_subclasses class_precedence_list
linearized_isa _superclasses_updated
- _method_map
- _code_is_mine
- has_method get_method add_method remove_method alias_method wrap_method_body
- get_method_list get_method_map get_all_method_names get_all_methods compute_all_applicable_methods
+ alias_method get_all_method_names get_all_methods compute_all_applicable_methods
find_method_by_name find_all_methods_by_name find_next_method_by_name
add_before_method_modifier add_after_method_modifier add_around_method_modifier
my @class_mop_package_attributes = (
'package',
'namespace',
+ 'methods',
+ 'method_metaclass',
+ 'wrapped_method_metaclass',
);
my @class_mop_module_attributes = (
my @class_mop_class_attributes = (
'superclasses',
- 'methods',
'attributes',
'attribute_metaclass',
- 'method_metaclass',
- 'wrapped_method_metaclass',
'instance_metaclass',
'immutable_trait',
'constructor_name',
ok($class_mop_package_meta->get_attribute('package')->has_init_arg, '... Class::MOP::Class package has a init_arg');
is($class_mop_package_meta->get_attribute('package')->init_arg, 'package', '... Class::MOP::Class package\'s a init_arg is package');
+ok($class_mop_package_meta->get_attribute('method_metaclass')->has_reader, '... Class::MOP::Package method_metaclass has a reader');
+is_deeply($class_mop_package_meta->get_attribute('method_metaclass')->reader,
+ { 'method_metaclass' => \&Class::MOP::Package::method_metaclass },
+ '... Class::MOP::Package method_metaclass\'s a reader is &method_metaclass');
+
+ok($class_mop_package_meta->get_attribute('method_metaclass')->has_init_arg, '... Class::MOP::Package method_metaclass has a init_arg');
+is($class_mop_package_meta->get_attribute('method_metaclass')->init_arg,
+ 'method_metaclass',
+ '... Class::MOP::Package method_metaclass\'s init_arg is method_metaclass');
+
+ok($class_mop_package_meta->get_attribute('method_metaclass')->has_default, '... Class::MOP::Package method_metaclass has a default');
+is($class_mop_package_meta->get_attribute('method_metaclass')->default,
+ 'Class::MOP::Method',
+ '... Class::MOP::Package method_metaclass\'s a default is Class::MOP:::Method');
+
+ok($class_mop_package_meta->get_attribute('wrapped_method_metaclass')->has_reader, '... Class::MOP::Package wrapped_method_metaclass has a reader');
+is_deeply($class_mop_package_meta->get_attribute('wrapped_method_metaclass')->reader,
+ { 'wrapped_method_metaclass' => \&Class::MOP::Package::wrapped_method_metaclass },
+ '... Class::MOP::Package wrapped_method_metaclass\'s a reader is &wrapped_method_metaclass');
+
+ok($class_mop_package_meta->get_attribute('wrapped_method_metaclass')->has_init_arg, '... Class::MOP::Package wrapped_method_metaclass has a init_arg');
+is($class_mop_package_meta->get_attribute('wrapped_method_metaclass')->init_arg,
+ 'wrapped_method_metaclass',
+ '... Class::MOP::Package wrapped_method_metaclass\'s init_arg is wrapped_method_metaclass');
+
+ok($class_mop_package_meta->get_attribute('method_metaclass')->has_default, '... Class::MOP::Package method_metaclass has a default');
+is($class_mop_package_meta->get_attribute('method_metaclass')->default,
+ 'Class::MOP::Method',
+ '... Class::MOP::Package method_metaclass\'s a default is Class::MOP:::Method');
+
+
# ... class
ok($class_mop_class_meta->get_attribute('attributes')->has_reader, '... Class::MOP::Class attributes has a reader');
'Class::MOP::Attribute',
'... Class::MOP::Class attribute_metaclass\'s a default is Class::MOP:::Attribute');
-ok($class_mop_class_meta->get_attribute('method_metaclass')->has_reader, '... Class::MOP::Class method_metaclass has a reader');
-is_deeply($class_mop_class_meta->get_attribute('method_metaclass')->reader,
- { 'method_metaclass' => \&Class::MOP::Class::method_metaclass },
- '... Class::MOP::Class method_metaclass\'s a reader is &method_metaclass');
-
-ok($class_mop_class_meta->get_attribute('method_metaclass')->has_init_arg, '... Class::MOP::Class method_metaclass has a init_arg');
-is($class_mop_class_meta->get_attribute('method_metaclass')->init_arg,
- 'method_metaclass',
- '... Class::MOP::Class method_metaclass\'s init_arg is method_metaclass');
-
-ok($class_mop_class_meta->get_attribute('method_metaclass')->has_default, '... Class::MOP::Class method_metaclass has a default');
-is($class_mop_class_meta->get_attribute('method_metaclass')->default,
- 'Class::MOP::Method',
- '... Class::MOP::Class method_metaclass\'s a default is Class::MOP:::Method');
-
-ok($class_mop_class_meta->get_attribute('wrapped_method_metaclass')->has_reader, '... Class::MOP::Class wrapped_method_metaclass has a reader');
-is_deeply($class_mop_class_meta->get_attribute('wrapped_method_metaclass')->reader,
- { 'wrapped_method_metaclass' => \&Class::MOP::Class::wrapped_method_metaclass },
- '... Class::MOP::Class wrapped_method_metaclass\'s a reader is &wrapped_method_metaclass');
-
-ok($class_mop_class_meta->get_attribute('wrapped_method_metaclass')->has_init_arg, '... Class::MOP::Class wrapped_method_metaclass has a init_arg');
-is($class_mop_class_meta->get_attribute('wrapped_method_metaclass')->init_arg,
- 'wrapped_method_metaclass',
- '... Class::MOP::Class wrapped_method_metaclass\'s init_arg is wrapped_method_metaclass');
-
-ok($class_mop_class_meta->get_attribute('method_metaclass')->has_default, '... Class::MOP::Class method_metaclass has a default');
-is($class_mop_class_meta->get_attribute('method_metaclass')->default,
- 'Class::MOP::Method',
- '... Class::MOP::Class method_metaclass\'s a default is Class::MOP:::Method');
-
# check the values of some of the methods
is($class_mop_class_meta->name, 'Class::MOP::Class', '... Class::MOP::Class->name');
Class::MOP::Attribute->new();
} '... no name argument';
- dies_ok {
+ # These are no longer errors
+ lives_ok {
Class::MOP::Attribute->new('');
} '... bad name argument';
- dies_ok {
+ lives_ok {
Class::MOP::Attribute->new(0);
} '... bad name argument';
}
use strict;
use warnings;
-use Test::More tests => 47;
+use Test::More tests => 53;
use Test::Exception;
use Class::MOP;
'... original_name follows clone chain' );
is( $clone2->original_fully_qualified_name, 'main::__ANON__',
'... original_fully_qualified_name follows clone chain' );
+
+Class::MOP::Class->create(
+ 'Method::Subclass',
+ superclasses => ['Class::MOP::Method'],
+ attributes => [
+ Class::MOP::Attribute->new(
+ foo => (
+ accessor => 'foo',
+ )
+ ),
+ ],
+);
+
+my $wrapped = Method::Subclass->wrap($method, foo => 'bar');
+isa_ok($wrapped, 'Method::Subclass');
+isa_ok($wrapped, 'Class::MOP::Method');
+is($wrapped->foo, 'bar', 'attribute set properly');
+is($wrapped->package_name, 'main', 'package_name copied properly');
+is($wrapped->name, '__ANON__', 'method name copied properly');
+
+my $wrapped2 = Method::Subclass->wrap($method, foo => 'baz', name => 'FOO');
+is($wrapped2->name, 'FOO', 'got a new method name');
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Exception;
+
+{
+ package Foo;
+ use metaclass;
+ sub foo {}
+}
+
+sub check_meta_sanity {
+ my ($meta) = @_;
+ isa_ok($meta, 'Class::MOP::Class');
+ is($meta->name, 'Foo');
+ ok($meta->has_method('foo'));
+}
+
+can_ok('Foo', 'meta');
+
+my $meta = Foo->meta;
+check_meta_sanity($meta);
+
+lives_ok {
+ $meta = $meta->reinitialize($meta->name);
+};
+check_meta_sanity($meta);
+
+lives_ok {
+ $meta = $meta->reinitialize($meta);
+};
+check_meta_sanity($meta);
+
+throws_ok {
+ $meta->reinitialize('');
+} qr/You must pass a package name or an existing Class::MOP::Package instance/;
+
+throws_ok {
+ $meta->reinitialize($meta->new_object);
+} qr/You must pass a package name or an existing Class::MOP::Package instance/;
+
+done_testing;
'bless {} => $class',
'... got the right code for create_instance');
is($C->inline_get_slot_value($instance, $slot_name),
- "\$self->{'foo'}",
+ q[$self->{"foo"}],
'... got the right code for get_slot_value');
is($C->inline_set_slot_value($instance, $slot_name, $value),
- "\$self->{'foo'} = \$value",
+ q[$self->{"foo"} = $value],
'... got the right code for set_slot_value');
is($C->inline_initialize_slot($instance, $slot_name),
'... got the right code for initialize_slot');
is($C->inline_is_slot_initialized($instance, $slot_name),
- "exists \$self->{'foo'}",
+ q[exists $self->{"foo"}],
'... got the right code for get_slot_value');
is($C->inline_weaken_slot_value($instance, $slot_name),
- "Scalar::Util::weaken( \$self->{'foo'} )",
+ q[Scalar::Util::weaken( $self->{"foo"} )],
'... got the right code for weaken_slot_value');
is($C->inline_strengthen_slot_value($instance, $slot_name),
- "\$self->{'foo'} = \$self->{'foo'}",
+ q[$self->{"foo"} = $self->{"foo"}],
'... got the right code for strengthen_slot_value');
is($C->inline_rebless_instance_structure($instance, $class),
- "bless \$self => \$class",
+ q[bless $self => $class],
'... got the right code for rebless_instance_structure');
}
--- /dev/null
+use strict;
+use warnings;
+
+use Class::MOP;
+use Class::MOP::Class;
+use Test::More qw/no_plan/;
+use Test::Exception;
+
+my %results;
+
+{
+ package Base;
+ use metaclass;
+ sub hey { $results{base}++ }
+}
+
+for my $wrap (qw(before after)) {
+ my $meta = Class::MOP::Class->create_anon_class(
+ superclasses => ['Base', 'Class::MOP::Object']
+ );
+ my $alter = "add_${wrap}_method_modifier";
+ $meta->$alter('hey' => sub {
+ $results{wrapped}++;
+ $_ = 'barf'; # 'barf' would replace the cached wrapper subref
+ });
+
+ %results = ();
+ my $o = $meta->get_meta_instance->create_instance;
+ isa_ok($o, 'Base');
+ lives_ok {
+ $o->hey;
+ $o->hey; # this would die with 'Can't use string ("barf") as a subroutine ref while "strict refs" in use'
+ } 'wrapped doesn\'t die when $_ gets changed';
+ is_deeply(\%results, {base=>2,wrapped=>2});
+}
+
+{
+ my $meta = Class::MOP::Class->create_anon_class(
+ superclasses => ['Base', 'Class::MOP::Object']
+ );
+ for my $wrap (qw(before after)) {
+ my $alter = "add_${wrap}_method_modifier";
+ $meta->$alter('hey' => sub {
+ $results{wrapped}++;
+ $_ = 'barf'; # 'barf' would replace the cached wrapper subref
+ });
+ }
+
+ %results = ();
+ my $o = $meta->get_meta_instance->create_instance;
+ isa_ok($o, 'Base');
+ lives_ok {
+ $o->hey;
+ $o->hey; # this would die with 'Can't use string ("barf") as a subroutine ref while "strict refs" in use'
+ } 'double-wrapped doesn\'t die when $_ gets changed';
+ is_deeply(\%results, {base=>2,wrapped=>4});
+}
+++ /dev/null
-#include "mop.h"
-
-static void
-mop_update_method_map(pTHX_ SV *const self, SV *const class_name, HV *const stash, HV *const map)
-{
- const char *const class_name_pv = HvNAME(stash); /* must be HvNAME(stash), not SvPV_nolen_const(class_name) */
- SV *method_metaclass_name;
- char *method_name;
- I32 method_name_len;
- SV *coderef;
- HV *symbols;
- dSP;
-
- symbols = mop_get_all_package_symbols(stash, TYPE_FILTER_CODE);
- sv_2mortal((SV*)symbols);
- (void)hv_iterinit(symbols);
- while ( (coderef = hv_iternextsv(symbols, &method_name, &method_name_len)) ) {
- CV *cv = (CV *)SvRV(coderef);
- char *cvpkg_name;
- char *cv_name;
- SV *method_slot;
- SV *method_object;
-
- if (!mop_get_code_info(coderef, &cvpkg_name, &cv_name)) {
- continue;
- }
-
- /* this checks to see that the subroutine is actually from our package */
- if ( !(strEQ(cvpkg_name, "constant") && strEQ(cv_name, "__ANON__")) ) {
- if ( strNE(cvpkg_name, class_name_pv) ) {
- continue;
- }
- }
-
- method_slot = *hv_fetch(map, method_name, method_name_len, TRUE);
- if ( SvOK(method_slot) ) {
- SV *const body = mop_call0(aTHX_ method_slot, KEY_FOR(body)); /* $method_object->body() */
- if ( SvROK(body) && ((CV *) SvRV(body)) == cv ) {
- continue;
- }
- }
-
- method_metaclass_name = mop_call0(aTHX_ self, mop_method_metaclass); /* $self->method_metaclass() */
-
- /*
- $method_object = $method_metaclass->wrap(
- $cv,
- associated_metaclass => $self,
- package_name => $class_name,
- name => $method_name
- );
- */
- ENTER;
- SAVETMPS;
-
- PUSHMARK(SP);
- EXTEND(SP, 8);
- PUSHs(method_metaclass_name); /* invocant */
- mPUSHs(newRV_inc((SV *)cv));
- PUSHs(mop_associated_metaclass);
- PUSHs(self);
- PUSHs(KEY_FOR(package_name));
- PUSHs(class_name);
- PUSHs(KEY_FOR(name));
- mPUSHs(newSVpv(method_name, method_name_len));
- PUTBACK;
-
- call_sv(mop_wrap, G_SCALAR | G_METHOD);
- SPAGAIN;
- method_object = POPs;
- PUTBACK;
- /* $map->{$method_name} = $method_object */
- sv_setsv(method_slot, method_object);
-
- FREETMPS;
- LEAVE;
- }
-}
-
-MODULE = Class::MOP::Class PACKAGE = Class::MOP::Class
-
-PROTOTYPES: DISABLE
-
-void
-get_method_map(self)
- SV *self
- PREINIT:
- HV *const obj = (HV *)SvRV(self);
- SV *const class_name = HeVAL( hv_fetch_ent(obj, KEY_FOR(package), 0, HASH_FOR(package)) );
- HV *const stash = gv_stashsv(class_name, 0);
- UV current;
- SV *cache_flag;
- SV *map_ref;
- PPCODE:
- if (!stash) {
- mXPUSHs(newRV_noinc((SV *)newHV()));
- return;
- }
-
- current = mop_check_package_cache_flag(aTHX_ stash);
- cache_flag = HeVAL( hv_fetch_ent(obj, KEY_FOR(package_cache_flag), TRUE, HASH_FOR(package_cache_flag)));
- map_ref = HeVAL( hv_fetch_ent(obj, KEY_FOR(methods), TRUE, HASH_FOR(methods)));
-
- /* $self->{methods} does not yet exist (or got deleted) */
- if ( !SvROK(map_ref) || SvTYPE(SvRV(map_ref)) != SVt_PVHV ) {
- SV *new_map_ref = newRV_noinc((SV *)newHV());
- sv_2mortal(new_map_ref);
- sv_setsv(map_ref, new_map_ref);
- }
-
- if ( !SvOK(cache_flag) || SvUV(cache_flag) != current ) {
- mop_update_method_map(aTHX_ self, class_name, stash, (HV *)SvRV(map_ref));
- sv_setuv(cache_flag, mop_check_package_cache_flag(aTHX_ stash)); /* update_cache_flag() */
- }
-
- XPUSHs(map_ref);
}
EXTERN_C XS(boot_Class__MOP__Package);
-EXTERN_C XS(boot_Class__MOP__Class);
EXTERN_C XS(boot_Class__MOP__Attribute);
EXTERN_C XS(boot_Class__MOP__Method);
mop_namespace = newSVpvs("namespace");
MOP_CALL_BOOT (boot_Class__MOP__Package);
- MOP_CALL_BOOT (boot_Class__MOP__Class);
MOP_CALL_BOOT (boot_Class__MOP__Attribute);
MOP_CALL_BOOT (boot_Class__MOP__Method);
#include "mop.h"
-
static void
mop_deconstruct_variable_name(pTHX_ SV* const variable,
const char** const var_name, STRLEN* const var_name_len,
}
+static void
+mop_update_method_map(pTHX_ SV *const self, SV *const class_name, HV *const stash, HV *const map)
+{
+ const char *const class_name_pv = HvNAME(stash); /* must be HvNAME(stash), not SvPV_nolen_const(class_name) */
+ SV *method_metaclass_name;
+ char *method_name;
+ I32 method_name_len;
+ SV *coderef;
+ HV *symbols;
+ dSP;
+
+ symbols = mop_get_all_package_symbols(stash, TYPE_FILTER_CODE);
+ sv_2mortal((SV*)symbols);
+ (void)hv_iterinit(symbols);
+ while ( (coderef = hv_iternextsv(symbols, &method_name, &method_name_len)) ) {
+ CV *cv = (CV *)SvRV(coderef);
+ char *cvpkg_name;
+ char *cv_name;
+ SV *method_slot;
+ SV *method_object;
+
+ if (!mop_get_code_info(coderef, &cvpkg_name, &cv_name)) {
+ continue;
+ }
+
+ /* this checks to see that the subroutine is actually from our package */
+ if ( !(strEQ(cvpkg_name, "constant") && strEQ(cv_name, "__ANON__")) ) {
+ if ( strNE(cvpkg_name, class_name_pv) ) {
+ continue;
+ }
+ }
+
+ method_slot = *hv_fetch(map, method_name, method_name_len, TRUE);
+ if ( SvOK(method_slot) ) {
+ SV *const body = mop_call0(aTHX_ method_slot, KEY_FOR(body)); /* $method_object->body() */
+ if ( SvROK(body) && ((CV *) SvRV(body)) == cv ) {
+ continue;
+ }
+ }
+
+ method_metaclass_name = mop_call0(aTHX_ self, mop_method_metaclass); /* $self->method_metaclass() */
+
+ /*
+ $method_object = $method_metaclass->wrap(
+ $cv,
+ associated_metaclass => $self,
+ package_name => $class_name,
+ name => $method_name
+ );
+ */
+ ENTER;
+ SAVETMPS;
+
+ PUSHMARK(SP);
+ EXTEND(SP, 8);
+ PUSHs(method_metaclass_name); /* invocant */
+ mPUSHs(newRV_inc((SV *)cv));
+ PUSHs(mop_associated_metaclass);
+ PUSHs(self);
+ PUSHs(KEY_FOR(package_name));
+ PUSHs(class_name);
+ PUSHs(KEY_FOR(name));
+ mPUSHs(newSVpv(method_name, method_name_len));
+ PUTBACK;
+
+ call_sv(mop_wrap, G_SCALAR | G_METHOD);
+ SPAGAIN;
+ method_object = POPs;
+ PUTBACK;
+ /* $map->{$method_name} = $method_object */
+ sv_setsv(method_slot, method_object);
+
+ FREETMPS;
+ LEAVE;
+ }
+}
+
MODULE = Class::MOP::Package PACKAGE = Class::MOP::Package
PROTOTYPES: DISABLE
symbols = mop_get_all_package_symbols(stash, filter);
PUSHs(sv_2mortal(newRV_noinc((SV *)symbols)));
+void
+get_method_map(self)
+ SV *self
+ PREINIT:
+ HV *const obj = (HV *)SvRV(self);
+ SV *const class_name = HeVAL( hv_fetch_ent(obj, KEY_FOR(package), 0, HASH_FOR(package)) );
+ HV *const stash = gv_stashsv(class_name, 0);
+ UV current;
+ SV *cache_flag;
+ SV *map_ref;
+ PPCODE:
+ if (!stash) {
+ mXPUSHs(newRV_noinc((SV *)newHV()));
+ return;
+ }
+
+ current = mop_check_package_cache_flag(aTHX_ stash);
+ cache_flag = HeVAL( hv_fetch_ent(obj, KEY_FOR(package_cache_flag), TRUE, HASH_FOR(package_cache_flag)));
+ map_ref = HeVAL( hv_fetch_ent(obj, KEY_FOR(methods), TRUE, HASH_FOR(methods)));
+
+ /* $self->{methods} does not yet exist (or got deleted) */
+ if ( !SvROK(map_ref) || SvTYPE(SvRV(map_ref)) != SVt_PVHV ) {
+ SV *new_map_ref = newRV_noinc((SV *)newHV());
+ sv_2mortal(new_map_ref);
+ sv_setsv(map_ref, new_map_ref);
+ }
+
+ if ( !SvOK(cache_flag) || SvUV(cache_flag) != current ) {
+ mop_update_method_map(aTHX_ self, class_name, stash, (HV *)SvRV(map_ref));
+ sv_setuv(cache_flag, mop_check_package_cache_flag(aTHX_ stash)); /* update_cache_flag() */
+ }
+
+ XPUSHs(map_ref);
+
BOOT:
INSTALL_SIMPLE_READER_WITH_KEY(Package, name, package);
'get_immutable_options',
'reset_package_cache_flag',
'update_package_cache_flag',
- 'wrap_method_body',
# doc'd with rebless_instance
'rebless_instance_away',
)
],
'Class::MOP::Module' => ['create'],
+ 'Class::MOP::Package' => ['wrap_method_body'],
);
for my $module ( sort @modules ) {
projects / gitmo/Class-MOP.git / commitdiff