use Carp 'confess';
use Scalar::Util 'blessed', 'reftype', 'weaken';
-use Sub::Name 'subname';
+use Sub::Name 'subname';
use Devel::GlobalDestruction 'in_global_destruction';
+use Try::Tiny;
-our $VERSION = '0.89';
+our $VERSION = '0.97';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
|| $class->_construct_class_instance(package => $package_name, @_);
}
-sub construct_class_instance {
- Carp::cluck('The construct_class_instance method has been made private.'
- . " The public version is deprecated and will be removed in a future release.\n");
- shift->_construct_class_instance(@_);
-}
-
# NOTE: (meta-circularity)
# this is a special form of _construct_instance
# (see below), which is used to construct class
# get the name of the class appropriately
$class = (ref($class)
? ($class->is_immutable
- ? $class->get_mutable_metaclass_name()
+ ? $class->_get_mutable_metaclass_name()
: ref($class))
: $class);
# should not actually have a value associated
# with the slot.
'namespace' => \undef,
+ 'methods' => {},
# inherited from Class::MOP::Module
'version' => \undef,
# defined in Class::MOP::Class
'superclasses' => \undef,
- 'methods' => {},
'attributes' => {},
'attribute_metaclass' =>
( $options->{'attribute_metaclass'} || 'Class::MOP::Attribute' ),
$self->{'_package_cache_flag'} = Class::MOP::check_package_cache_flag($self->name);
}
-
-sub check_metaclass_compatibility {
- Carp::cluck('The check_metaclass_compatibility method has been made private.'
- . " The public version is deprecated and will be removed in a future release.\n");
- shift->_check_metaclass_compatibility(@_);
-}
-
sub _check_metaclass_compatibility {
my $self = shift;
# get the name of the class appropriately
my $super_meta_type
= $super_meta->is_immutable
- ? $super_meta->get_mutable_metaclass_name()
+ ? $super_meta->_get_mutable_metaclass_name()
: ref($super_meta);
($self->isa($super_meta_type))
my $current_meta = Class::MOP::get_metaclass_by_name($name);
return if $current_meta ne $self;
-
- @{$self->get_package_symbol({name => 'ISA', type => 'ARRAY', sigil => '$', create => 1 })} = ();
- %{ $self->namespace } = ();
-
my ($serial_id) = ($name =~ /^$ANON_CLASS_PREFIX(\d+)/o);
-
- Class::MOP::remove_metaclass_by_name($name);
-
no strict 'refs';
+ @{$name . '::ISA'} = ();
+ %{$name . '::'} = ();
delete ${$ANON_CLASS_PREFIX}{$serial_id . '::'};
- return;
+
+ Class::MOP::remove_metaclass_by_name($name);
}
}
# all these attribute readers will be bootstrapped
# away in the Class::MOP bootstrap section
-sub get_attribute_map { $_[0]->{'attributes'} }
+sub _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 {
return $class->_construct_instance(@_);
}
-sub construct_instance {
- Carp::cluck('The construct_instance method has been made private.'
- . " The public version is deprecated and will be removed in a future release.\n");
- shift->_construct_instance(@_);
-}
-
sub _construct_instance {
my $class = shift;
my $params = @_ == 1 ? $_[0] : {@_};
$self->{'_meta_instance'} ||= $self->_create_meta_instance();
}
-sub create_meta_instance {
- Carp::cluck('The create_meta_instance method has been made private.'
- . " The public version is deprecated and will be removed in a future release.\n");
- shift->_create_meta_instance(@_);
-}
-
sub _create_meta_instance {
my $self = shift;
$class->_clone_instance($instance, @_);
}
-sub clone_instance {
- Carp::cluck('The clone_instance method has been made private.'
- . " The public version is deprecated and will be removed in a future release.\n");
- shift->_clone_instance(@_);
-}
-
sub _clone_instance {
my ($class, $instance, %params) = @_;
(blessed($instance))
sub superclasses {
my $self = shift;
- my $var_spec = { sigil => '@', type => 'ARRAY', name => 'ISA', create => 1 };
+ my $var_spec = { sigil => '@', type => 'ARRAY', name => 'ISA' };
if (@_) {
my @supers = @_;
@{$self->get_package_symbol($var_spec)} = @supers;
## 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) = @_;
sub add_before_method_modifier {
my ($self, $method_name, $method_modifier) = @_;
- (defined $method_name && $method_name)
+ (defined $method_name && length $method_name)
|| confess "You must pass in a method name";
my $method = $fetch_and_prepare_method->($self, $method_name);
$method->add_before_modifier(
sub add_after_method_modifier {
my ($self, $method_name, $method_modifier) = @_;
- (defined $method_name && $method_name)
+ (defined $method_name && length $method_name)
|| confess "You must pass in a method name";
my $method = $fetch_and_prepare_method->($self, $method_name);
$method->add_after_modifier(
sub add_around_method_modifier {
my ($self, $method_name, $method_modifier) = @_;
- (defined $method_name && $method_name)
+ (defined $method_name && length $method_name)
|| confess "You must pass in a method name";
my $method = $fetch_and_prepare_method->($self, $method_name);
$method->add_around_modifier(
# to, and so don't need the fully qualified name.
}
-sub alias_method {
- Carp::cluck("The alias_method method is deprecated. Use add_method instead.\n");
-
- 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)
+ (defined $method_name && length $method_name)
|| confess "You must define a method name to find";
foreach my $class ($self->linearized_isa) {
my $method = $self->initialize($class)->get_method($method_name);
sub get_all_methods {
my $self = shift;
- my %methods = map { %{ $self->initialize($_)->get_method_map } } reverse $self->linearized_isa;
- return values %methods;
-}
-sub compute_all_applicable_methods {
- Carp::cluck('The compute_all_applicable_methods method is deprecated.'
- . " Use get_all_methods instead.\n");
-
- return map {
- {
- name => $_->name,
- class => $_->package_name,
- code => $_, # sigh, overloading
- },
- } shift->get_all_methods(@_);
+ my %methods;
+ for my $class ( reverse $self->linearized_isa ) {
+ my $meta = $self->initialize($class);
+
+ $methods{$_} = $meta->get_method($_)
+ for $meta->get_method_list;
+ }
+
+ return values %methods;
}
sub get_all_method_names {
sub find_all_methods_by_name {
my ($self, $method_name) = @_;
- (defined $method_name && $method_name)
+ (defined $method_name && length $method_name)
|| confess "You must define a method name to find";
my @methods;
foreach my $class ($self->linearized_isa) {
sub find_next_method_by_name {
my ($self, $method_name) = @_;
- (defined $method_name && $method_name)
+ (defined $method_name && length $method_name)
|| confess "You must define a method name to find";
my @cpl = $self->linearized_isa;
shift @cpl; # discard ourselves
# get our count of previously inserted attributes and
# increment by one so this attribute knows its order
- my $order = (scalar keys %{$self->get_attribute_map});
+ my $order = (scalar keys %{$self->_attribute_map});
$attribute->_set_insertion_order($order);
# then onto installing the new accessors
- $self->get_attribute_map->{$attr_name} = $attribute;
+ $self->_attribute_map->{$attr_name} = $attribute;
# invalidate package flag here
- my $e = do {
- local $@;
+ try {
local $SIG{__DIE__};
- eval { $attribute->install_accessors() };
- $@;
- };
- if ( $e ) {
- $self->remove_attribute($attr_name);
- die $e;
+ $attribute->install_accessors();
}
+ catch {
+ $self->remove_attribute($attr_name);
+ die $_;
+ };
return $attribute;
}
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};
+ exists $self->_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}
+ return $self->_attribute_map->{$attribute_name}
# NOTE:
# this will return undef anyway, so no need ...
# if $self->has_attribute($attribute_name);
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};
+ my $removed_attribute = $self->_attribute_map->{$attribute_name};
return unless defined $removed_attribute;
- delete $self->get_attribute_map->{$attribute_name};
+ delete $self->_attribute_map->{$attribute_name};
$self->invalidate_meta_instances();
$removed_attribute->remove_accessors();
$removed_attribute->detach_from_class();
sub get_attribute_list {
my $self = shift;
- keys %{$self->get_attribute_map};
+ keys %{$self->_attribute_map};
}
sub get_all_attributes {
my $self = shift;
- my %attrs = map { %{ $self->initialize($_)->get_attribute_map } } reverse $self->linearized_isa;
+ my %attrs = map { %{ $self->initialize($_)->_attribute_map } } reverse $self->linearized_isa;
return values %attrs;
}
-sub compute_all_applicable_attributes {
- Carp::cluck('The compute_all_applicable_attributes method has been deprecated.'
- . " Use get_all_attributes instead.\n");
-
- shift->get_all_attributes(@_);
-}
-
sub find_attribute_by_name {
my ($self, $attr_name) = @_;
foreach my $class ($self->linearized_isa) {
return if $self->get_attribute_list;
# or any non-declared methods
- if ( my @methods = values %{ $self->get_method_map } ) {
- my $metaclass = $self->method_metaclass;
- foreach my $method ( @methods ) {
- return if $method->isa("Class::MOP::Method::Generated");
- # FIXME do we need to enforce this too? return unless $method->isa($metaclass);
- }
+ for my $method ( map { $self->get_method($_) } $self->get_method_list ) {
+ return if $method->isa("Class::MOP::Method::Generated");
+ # FIXME do we need to enforce this too? return unless $method->isa( $self->method_metaclass );
}
return 1;
sub is_mutable { 1 }
sub is_immutable { 0 }
+sub immutable_options { %{ $_[0]{__immutable}{options} || {} } }
+
sub _immutable_options {
my ( $self, @args ) = @_;
# example of where this matters).
my $meta_name
= $meta->is_immutable
- ? $meta->get_mutable_metaclass_name
+ ? $meta->_get_mutable_metaclass_name
: ref $meta;
my $immutable_meta = $meta_name->create(
sub _rebless_as_mutable {
my $self = shift;
- bless $self, $self->get_mutable_metaclass_name;
+ bless $self, $self->_get_mutable_metaclass_name;
return $self;
}
The Class Protocol is the largest and most complex part of the
Class::MOP meta-object protocol. It controls the introspection and
manipulation of Perl 5 classes, and it can create them as well. The
-best way to understand what this module can do, is to read the
+best way to understand what this module can do is to read the
documentation for each of its methods.
=head1 INHERITANCE
=head2 Class construction
These methods all create new C<Class::MOP::Class> objects. These
-objects can represent existing classes, or they can be used to create
+objects can represent existing classes or they can be used to create
new classes from scratch.
The metaclass object for a given class is a singleton. If you attempt
=item B<< Class::MOP::Class->create($package_name, %options) >>
This method creates a new C<Class::MOP::Class> object with the given
-package name. It accepts a number of options.
+package name. It accepts a number of options:
=over 8
=item * methods
An optional hash reference of methods for the class. The keys of the
-hash reference are method names, and values are subroutine references.
+hash reference are method names and values are subroutine references.
=item * attributes
metaclass object, which prevents the metaclass from going out of scope
while any instances exist.
-This only works if the instance if based on a hash reference, however.
+This only works if the instance is based on a hash reference, however.
=item B<< Class::MOP::Class->initialize($package_name, %options) >>
instance's attributes. A special C<__INSTANCE__> key can be passed to
provide an already generated instance, rather than having Class::MOP
generate it for you. This is mostly useful for using Class::MOP with
-foreign classes, which generally generate instances using their own
-constructor.
+foreign classes which generate instances using their own constructors.
=item B<< $metaclass->instance_metaclass >>
-Returns the class name of the instance metaclass, see
+Returns the class name of the instance metaclass. See
L<Class::MOP::Instance> for more information on the instance
metaclass.
=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.
+=head2 Method introspection
-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
named attribute. It does not include attributes inherited from parent
classes.
-=item B<< $metaclass->get_attribute_map >>
-
-Returns a hash reference representing the attributes defined in this
-class. The keys are attribute names and the values are
-L<Class::MOP::Attribute> objects.
-
=item B<< $metaclass->get_attribute_list >>
This will return a list of attributes I<names> for all attributes
This will return a L<Class::MOP::Attribute> for the specified
C<$attribute_name>. If the class does not have the specified
-attribute, it returns C<undef>
+attribute, it returns C<undef>.
Unlike C<get_attribute>, this attribute I<will> look for the named
attribute in superclasses.
=item B<< $metaclass->add_attribute(...) >>
This method accepts either an existing L<Class::MOP::Attribute>
-object, or parameters suitable for passing to that class's C<new>
+object or parameters suitable for passing to that class's C<new>
method.
The attribute provided will be added to the class.
=item B<< $metaclass->attribute_metaclass >>
Returns the class name of the attribute metaclass for this class. By
-default, this is L<Class::MOP::Attribute>. for more information on
+default, this is L<Class::MOP::Attribute>.
=back
methods, and also allows us to optimize some methods on the metaclass
object itself.
-After immutabilization, the metaclass object will cache most
-informational methods such as C<get_method_map> and
-C<get_all_attributes>. Methods which would alter the class, such as
-C<add_attribute>, C<add_method>, and so on will throw an error on an
-immutable metaclass object.
+After immutabilization, the metaclass object will cache most informational
+methods that returns information about methods or attributes. Methods which
+would alter the class, such as C<add_attribute> and C<add_method>, will
+throw an error on an immutable metaclass object.
The immutabilization system in L<Moose> takes much greater advantage
of the inlining features than Class::MOP itself does.
=item B<< $metaclass->make_immutable(%options) >>
-This method will create an immutable transformer and uses it to make
+This method will create an immutable transformer and use it to make
the class and its metaclass object immutable.
This method accepts the following options:
=back
+=item B<< $metaclass->immutable_options >>
+
+Returns a hash of the options used when making the class immutable, including
+both defaults and anything supplied by the user in the call to C<<
+$metaclass->make_immutable >>. This is useful if you need to temporarily make
+a class mutable and then restore immutability as it was before.
+
=item B<< $metaclass->make_mutable >>
Calling this method reverse the immutabilization transformation.
Method modifiers are hooks which allow a method to be wrapped with
I<before>, I<after> and I<around> method modifiers. Every time a
-method is called, it's modifiers are also called.
+method is called, its modifiers are also called.
A class can modify its own methods, as well as methods defined in
parent classes.
Of course there is a performance cost associated with method
modifiers, but we have made every effort to make that cost directly
-proportional to the number of modifier features you utilize.
+proportional to the number of modifier features you use.
-The wrapping method does it's best to B<only> do as much work as it
+The wrapping method does its best to B<only> do as much work as it
absolutely needs to. In order to do this we have moved some of the
performance costs to set-up time, where they are easier to amortize.
projects / gitmo/Class-MOP.git / blobdiff