use Carp 'confess';
use Scalar::Util 'blessed', 'weaken';
-our $VERSION = '0.78';
+our $VERSION = '0.82';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
|| confess "You must pass a package name and it cannot be blessed";
return Class::MOP::get_metaclass_by_name($package_name)
- || $class->construct_class_instance(package => $package_name, @_);
+ || $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
+# this is a special form of _construct_instance
# (see below), which is used to construct class
# meta-object instances for any Class::MOP::*
# class. All other classes will use the more
# normal &construct_instance.
-sub construct_class_instance {
+sub _construct_class_instance {
my $class = shift;
my $options = @_ == 1 ? $_[0] : {@_};
my $package_name = $options->{package};
# it is safe to use meta here because
# class will always be a subclass of
# Class::MOP::Class, which defines meta
- $meta = $class->meta->construct_instance($options)
+ $meta = $class->meta->_construct_instance($options)
}
# and check the metaclass compatibility
- $meta->check_metaclass_compatibility();
+ $meta->_check_metaclass_compatibility();
Class::MOP::store_metaclass_by_name($package_name, $meta);
$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;
# this is always okay ...
: ref($super_meta);
($self->isa($super_meta_type))
- || confess $self->name . "->meta => (" . (ref($self)) . ")" .
- " is not compatible with the " .
- $superclass_name . "->meta => (" . ($super_meta_type) . ")";
+ || confess "Class::MOP::class_of(" . $self->name . ") => ("
+ . (ref($self)) . ")" . " is not compatible with the " .
+ "Class::MOP::class_of(".$superclass_name . ") => ("
+ . ($super_meta_type) . ")";
# NOTE:
# we also need to check that instance metaclasses
# are compatibile in the same the class.
($self->instance_metaclass->isa($super_meta->instance_metaclass))
- || confess $self->name . "->meta->instance_metaclass => (" . ($self->instance_metaclass) . ")" .
+ || confess "Class::MOP::class_of(" . $self->name . ")->instance_metaclass => (" . ($self->instance_metaclass) . ")" .
" is not compatible with the " .
- $superclass_name . "->meta->instance_metaclass => (" . ($super_meta->instance_metaclass) . ")";
+ "Class::MOP::class_of(" . $superclass_name . ")->instance_metaclass => (" . ($super_meta->instance_metaclass) . ")";
}
}
|| confess "You must pass a HASH ref of methods"
if exists $options{methods};
- $class->SUPER::create(%options);
-
my (%initialize_options) = @args;
delete @initialize_options{qw(
package
)};
my $meta = $class->initialize( $package_name => %initialize_options );
+ $meta->_instantiate_module( $options{version}, $options{authority} );
+
# FIXME totally lame
$meta->add_method('meta' => sub {
$class->initialize(ref($_[0]) || $_[0]);
# Class::MOP::Class singletons here, so we
# delegate this to &construct_class_instance
# which will deal with the singletons
- return $class->construct_class_instance(@_)
+ return $class->_construct_class_instance(@_)
if $class->name->isa('Class::MOP::Class');
- return $class->construct_instance(@_);
+ 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] : {@_};
my $meta_instance = $class->get_meta_instance();
my $instance = $meta_instance->create_instance();
- foreach my $attr ($class->compute_all_applicable_attributes()) {
+ foreach my $attr ($class->get_all_attributes()) {
$attr->initialize_instance_slot($meta_instance, $instance, $params);
}
# NOTE:
sub get_meta_instance {
my $self = shift;
- $self->{'_meta_instance'} ||= $self->create_meta_instance();
+ $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;
my $instance = $self->instance_metaclass->new(
associated_metaclass => $self,
- attributes => [ $self->compute_all_applicable_attributes() ],
+ attributes => [ $self->get_all_attributes() ],
);
$self->add_meta_instance_dependencies()
# Class::MOP::Class singletons here, they
# should not be cloned.
return $instance if $instance->isa('Class::MOP::Class');
- $class->clone_instance($instance, @_);
+ $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))
|| confess "You can only clone instances, ($instance) is not a blessed instance";
my $meta_instance = $class->get_meta_instance();
my $clone = $meta_instance->clone_instance($instance);
- foreach my $attr ($class->compute_all_applicable_attributes()) {
+ foreach my $attr ($class->get_all_attributes()) {
if ( defined( my $init_arg = $attr->init_arg ) ) {
if (exists $params{$init_arg}) {
$attr->set_value($clone, $params{$init_arg});
sub rebless_instance {
my ($self, $instance, %params) = @_;
- my $old_metaclass;
- if ($instance->can('meta')) {
- ($instance->meta->isa('Class::MOP::Class'))
- || confess 'Cannot rebless instance if ->meta is not an instance of Class::MOP::Class';
- $old_metaclass = $instance->meta;
- }
- else {
- $old_metaclass = $self->initialize(ref($instance));
- }
+ my $old_metaclass = Class::MOP::class_of($instance);
- my $meta_instance = $self->get_meta_instance();
+ my $old_class = $old_metaclass ? $old_metaclass->name : blessed($instance);
+ $self->name->isa($old_class)
+ || confess "You may rebless only into a subclass of ($old_class), of which (". $self->name .") isn't.";
- $self->name->isa($old_metaclass->name)
- || confess "You may rebless only into a subclass of (". $old_metaclass->name ."), of which (". $self->name .") isn't.";
+ $old_metaclass->rebless_instance_away($instance, $self, %params)
+ if $old_metaclass;
+
+ my $meta_instance = $self->get_meta_instance();
# rebless!
# we use $_[1] here because of t/306_rebless_overload.t regressions on 5.8.8
$meta_instance->rebless_instance_structure($_[1], $self);
- foreach my $attr ( $self->compute_all_applicable_attributes ) {
+ foreach my $attr ( $self->get_all_attributes ) {
if ( $attr->has_value($instance) ) {
if ( defined( my $init_arg = $attr->init_arg ) ) {
$params{$init_arg} = $attr->get_value($instance)
}
}
- foreach my $attr ($self->compute_all_applicable_attributes) {
+ foreach my $attr ($self->get_all_attributes) {
$attr->initialize_instance_slot($meta_instance, $instance, \%params);
}
$instance;
}
+sub rebless_instance_away {
+ # this intentionally does nothing, it is just a hook
+}
+
# Inheritance
sub superclasses {
# not potentially creating an issues
# we don't know about
- $self->check_metaclass_compatibility();
+ $self->_check_metaclass_compatibility();
$self->update_meta_instance_dependencies();
}
@{$self->get_package_symbol($var_spec)};
sub subclasses {
my $self = shift;
-
my $super_class = $self->name;
- if ( Class::MOP::HAVE_ISAREV() ) {
- return @{ $super_class->mro::get_isarev() };
- } else {
- my @derived_classes;
-
- my $find_derived_classes;
- $find_derived_classes = sub {
- my ($outer_class) = @_;
-
- my $symbol_table_hashref = do { no strict 'refs'; \%{"${outer_class}::"} };
-
- SYMBOL:
- for my $symbol ( keys %$symbol_table_hashref ) {
- next SYMBOL if $symbol !~ /\A (\w+):: \z/x;
- my $inner_class = $1;
-
- next SYMBOL if $inner_class eq 'SUPER'; # skip '*::SUPER'
-
- my $class =
- $outer_class
- ? "${outer_class}::$inner_class"
- : $inner_class;
-
- if ( $class->isa($super_class) and $class ne $super_class ) {
- push @derived_classes, $class;
- }
-
- next SYMBOL if $class eq 'main'; # skip 'main::*'
-
- $find_derived_classes->($class);
- }
- };
-
- my $root_class = q{};
- $find_derived_classes->($root_class);
-
- undef $find_derived_classes;
-
- @derived_classes = sort { $a->isa($b) ? 1 : $b->isa($a) ? -1 : 0 } @derived_classes;
-
- return @derived_classes;
- }
+ return @{ $super_class->mro::get_isarev() };
}
}
sub alias_method {
- my $self = shift;
+ Carp::cluck("The alias_method method is deprecated. Use add_method instead.\n");
- $self->add_method(@_);
+ shift->add_method(@_);
}
sub has_method {
return values %methods;
}
-# compatibility
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,
$self->remove_meta_instance_dependencies;
- my @attrs = $self->compute_all_applicable_attributes();
+ my @attrs = $self->get_all_attributes();
my %seen;
my @classes = grep { not $seen{$_->name}++ } map { $_->associated_class } @attrs;
}
sub get_all_attributes {
- shift->compute_all_applicable_attributes(@_);
-}
-
-sub compute_all_applicable_attributes {
my $self = shift;
my %attrs = map { %{ $self->initialize($_)->get_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) {
memoize => {
class_precedence_list => 'ARRAY',
# FIXME perl 5.10 memoizes this on its own, no need?
- linearized_isa => 'ARRAY',
- get_all_methods => 'ARRAY',
- get_all_method_names => 'ARRAY',
- compute_all_applicable_attributes => 'ARRAY',
- get_meta_instance => 'SCALAR',
- get_method_map => 'SCALAR',
+ linearized_isa => 'ARRAY',
+ get_all_methods => 'ARRAY',
+ get_all_method_names => 'ARRAY',
+ get_all_attributes => 'ARRAY',
+ get_meta_instance => 'SCALAR',
+ get_method_map => 'SCALAR',
},
# NOTE:
attributes. Any existing attributes that are already set will be
overwritten.
+Before reblessing the instance, this method will call
+C<rebless_instance_away> on the instance's current metaclass. This method
+will be passed the instance, the new metaclass, and any parameters
+specified to C<rebless_instance>. By default, C<rebless_instance_away>
+does nothing; it is merely a hook.
+
=item B<< $metaclass->new_object(%params) >>
This method is used to create a new object of the metaclass's
This will traverse the inheritance hierarchy and return a list of all
the L<Class::MOP::Attribute> objects for this class and its parents.
-This method can also be called as C<compute_all_applicable_attributes>.
-
=item B<< $metaclass->find_attribute_by_name($attribute_name) >>
This will return a L<Class::MOP::Attribute> for the specified
projects / gitmo/Class-MOP.git / blobdiff