sub create_instance {
my $self = shift;
- my $instance = $self->bless_instance_structure([]);
+ my $instance = bless [], $self->_class_name;
$self->initialize_all_slots($instance);
return $instance;
}
# generate the methods
-sub generate_history_accessor_method {
+sub _generate_history_accessor_method {
my $attr_name = (shift)->associated_attribute->name;
eval qq{sub {
unless (ref \$_[0]->meta->get_attribute('$attr_name')->_history()->\{\$_[0]\}) \{
}};
}
-sub generate_accessor_method {
+sub _generate_accessor_method {
my $attr_name = (shift)->associated_attribute->name;
eval qq{sub {
if (scalar(\@_) == 2) {
}};
}
-sub generate_writer_method {
+sub _generate_writer_method {
my $attr_name = (shift)->associated_attribute->name;
eval qq{sub {
unless (ref \$_[0]->meta->get_attribute('$attr_name')->_history()->\{\$_[0]\}) \{
## Method generation helpers
-sub generate_accessor_method {
+sub _generate_accessor_method {
my $attr = (shift)->associated_attribute;
my $meta_class = $attr->associated_class;
my $attr_name = $attr->name;
};
}
-sub generate_reader_method {
+sub _generate_reader_method {
my $attr = (shift)->associated_attribute;
my $meta_class = $attr->associated_class;
my $attr_name = $attr->name;
};
}
-sub generate_writer_method {
+sub _generate_writer_method {
my $attr = (shift)->associated_attribute;
my $meta_class = $attr->associated_class;
my $attr_name = $attr->name;
};
}
-sub generate_predicate_method {
+sub _generate_predicate_method {
my $attr = (shift)->associated_attribute;
my $meta_class = $attr->associated_class;
my $attr_name = $attr->name;
sub create_instance {
my ($self, $class) = @_;
- $self->bless_instance_structure(\(my $instance));
+ bless \(my $instance), $self->_class_name;
}
sub get_slot_value {
use base 'Class::MOP::Method::Accessor';
-sub generate_accessor_method {
+sub _generate_accessor_method {
my $attr = (shift)->associated_attribute;
my $attr_name = $attr->name;
};
}
-sub generate_reader_method {
+sub _generate_reader_method {
my $attr = (shift)->associated_attribute;
my $attr_name = $attr->name;
sub process_accessors {
warn 'The process_accessors method has been made private.'
. " The public version is deprecated and will be removed in a future release.\n";
- goto &_process_accessors;
+ shift->_process_accessors;
}
sub _process_accessors {
|| 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 {
+ warn '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)
# 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};
}
# 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 {
+ warn '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 ...
|| 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(@_);
}
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 {
+ warn '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(
# 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 {
+ warn '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";
# 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 alias_method {
- my $self = shift;
+ warn "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 {
+ warn 'The compute_all_applicable_methods method is deprecated.'
+ . " Use get_all_methods instead.\n";
+
return map {
{
name => $_->name,
# for compatibility
sub bless_instance_structure {
+ warn 'The bless_instance_structure method is deprecated.'
+ . " It will be removed in a future release.\n";
+
my ($self, $instance_structure) = @_;
bless $instance_structure, $self->_class_name;
}
# needed
weaken($self->{'attribute'});
- $self->initialize_body;
+ $self->_initialize_body;
return $self;
}
## factory
sub initialize_body {
+ warn 'The initialize_body method has been made private.'
+ . " The public version is deprecated and will be removed in a future release.\n";
+ shift->_initialize_body;
+}
+
+sub _initialize_body {
my $self = shift;
my $method_name = join "_" => (
- 'generate',
+ '_generate',
$self->accessor_type,
'method',
($self->is_inline ? 'inline' : ())
## generators
sub generate_accessor_method {
+ warn 'The generate_accessor_method method has been made private.'
+ . " The public version is deprecated and will be removed in a future release.\n";
+ shift->_generate_accessor_method;
+}
+
+sub _generate_accessor_method {
my $attr = (shift)->associated_attribute;
return sub {
$attr->set_value($_[0], $_[1]) if scalar(@_) == 2;
}
sub generate_reader_method {
+ warn 'The generate_reader_method method has been made private.'
+ . " The public version is deprecated and will be removed in a future release.\n";
+ shift->_generate_reader_method;
+}
+
+sub _generate_reader_method {
my $attr = (shift)->associated_attribute;
return sub {
confess "Cannot assign a value to a read-only accessor" if @_ > 1;
}
sub generate_writer_method {
+ warn 'The generate_writer_method method has been made private.'
+ . " The public version is deprecated and will be removed in a future release.\n";
+ shift->_generate_writer_method;
+}
+
+sub _generate_writer_method {
my $attr = (shift)->associated_attribute;
return sub {
$attr->set_value($_[0], $_[1]);
}
sub generate_predicate_method {
+ warn 'The generate_predicate_method method has been made private.'
+ . " The public version is deprecated and will be removed in a future release.\n";
+ shift->_generate_predicate_method;
+}
+
+sub _generate_predicate_method {
my $attr = (shift)->associated_attribute;
return sub {
$attr->has_value($_[0])
}
sub generate_clearer_method {
+ warn 'The generate_clearer_method method has been made private.'
+ . " The public version is deprecated and will be removed in a future release.\n";
+ shift->_generate_clearer_method;
+}
+
+sub _generate_clearer_method {
my $attr = (shift)->associated_attribute;
return sub {
$attr->clear_value($_[0])
## Inline methods
-
sub generate_accessor_method_inline {
+ warn 'The generate_accessor_method_inline method has been made private.'
+ . " The public version is deprecated and will be removed in a future release.\n";
+ shift->_generate_accessor_method_inline;
+}
+
+sub _generate_accessor_method_inline {
my $self = shift;
my $attr = $self->associated_attribute;
my $attr_name = $attr->name;
}
sub generate_reader_method_inline {
+ warn 'The generate_reader_method_inline method has been made private.'
+ . " The public version is deprecated and will be removed in a future release.\n";
+ shift->_generate_reader_method_inline;
+}
+
+sub _generate_reader_method_inline {
my $self = shift;
my $attr = $self->associated_attribute;
my $attr_name = $attr->name;
}
sub generate_writer_method_inline {
+ warn 'The generate_writer_method_inline method has been made private.'
+ . " The public version is deprecated and will be removed in a future release.\n";
+ shift->_generate_writer_method_inline;
+}
+
+sub _generate_writer_method_inline {
my $self = shift;
my $attr = $self->associated_attribute;
my $attr_name = $attr->name;
return $code;
}
-
sub generate_predicate_method_inline {
+ warn 'The generate_predicate_method_inline method has been made private.'
+ . " The public version is deprecated and will be removed in a future release.\n";
+ shift->_generate_predicate_method_inline;
+}
+
+sub _generate_predicate_method_inline {
my $self = shift;
my $attr = $self->associated_attribute;
my $attr_name = $attr->name;
}
sub generate_clearer_method_inline {
+ warn 'The generate_clearer_method_inline method has been made private.'
+ . " The public version is deprecated and will be removed in a future release.\n";
+ shift->_generate_clearer_method_inline;
+}
+
+sub _generate_clearer_method_inline {
my $self = shift;
my $attr = $self->associated_attribute;
my $attr_name = $attr->name;
# needed
weaken($self->{'associated_metaclass'});
- $self->initialize_body;
+ $self->_initialize_body;
return $self;
}
## cached values ...
sub meta_instance {
+ warn 'The meta_instance method has been made private.'
+ . " The public version is deprecated and will be removed in a future release.\n";
+ shift->_meta_instance;
+}
+
+sub _meta_instance {
my $self = shift;
$self->{'meta_instance'} ||= $self->associated_metaclass->get_meta_instance;
}
sub attributes {
+ warn 'The attributes method is deprecated.'
+ . " Use ->associated_metaclass->compute_all_applicable_attributes instead.\n";
+
my $self = shift;
$self->{'attributes'} ||= [ $self->associated_metaclass->compute_all_applicable_attributes ]
}
## method
sub initialize_body {
+ warn 'The initialize_body method has been made private.'
+ . " The public version is deprecated and will be removed in a future release.\n";
+ shift->_initialize_body;
+}
+
+sub _initialize_body {
my $self = shift;
- my $method_name = 'generate_constructor_method';
+ my $method_name = '_generate_constructor_method';
$method_name .= '_inline' if $self->is_inline;
}
sub generate_constructor_method {
+ warn 'The generate_constructor_method method has been made private.'
+ . " The public version is deprecated and will be removed in a future release.\n";
+ shift->_generate_constructor_method;
+}
+
+sub _generate_constructor_method {
return sub { Class::MOP::Class->initialize(shift)->new_object(@_) }
}
sub generate_constructor_method_inline {
+ warn 'The generate_constructor_method_inline method has been made private.'
+ . " The public version is deprecated and will be removed in a future release.\n";
+ shift->_generate_constructor_method_inline;
+}
+
+sub _generate_constructor_method_inline {
my $self = shift;
my $close_over = {};
$source .= "\n" . 'my $params = @_ == 1 ? $_[0] : {@_};';
- $source .= "\n" . 'my $instance = ' . $self->meta_instance->inline_create_instance('$class');
+ $source .= "\n" . 'my $instance = ' . $self->_meta_instance->inline_create_instance('$class');
$source .= ";\n" . (join ";\n" => map {
$self->_generate_slot_initializer($_, $close_over)
- } @{$self->attributes});
+ } $self->associated_metaclass->compute_all_applicable_attributes);
$source .= ";\n" . 'return $instance';
$source .= ";\n" . '}';
warn $source if $self->options->{debug};
if ( defined $attr->init_arg ) {
return (
'if(exists $params->{\'' . $attr->init_arg . '\'}){' . "\n" .
- $self->meta_instance->inline_set_slot_value(
+ $self->_meta_instance->inline_set_slot_value(
'$instance',
$attr->name,
'$params->{\'' . $attr->init_arg . '\'}' ) . "\n" .
'} ' . (!defined $default ? '' : 'else {' . "\n" .
- $self->meta_instance->inline_set_slot_value(
+ $self->_meta_instance->inline_set_slot_value(
'$instance',
$attr->name,
$default ) . "\n" .
);
} elsif ( defined $default ) {
return (
- $self->meta_instance->inline_set_slot_value(
+ $self->_meta_instance->inline_set_slot_value(
'$instance',
$attr->name,
$default ) . "\n"
}
sub create {
- my ( $class, %options ) = @_;
+ confess "The Class::MOP::Module->create method has been made a private object method.\n";
+}
- my $package_name = $options{package};
+sub _instantiate_module {
+ my $self = shift;
+ my $version = shift;
+ my $authority = shift;
- (defined $package_name && $package_name)
- || confess "You must pass a package name";
+ my $package_name = $self->name;
my $code = "package $package_name;";
- $code .= "\$$package_name\:\:VERSION = '" . $options{version} . "';"
- if exists $options{version};
- $code .= "\$$package_name\:\:AUTHORITY = '" . $options{authority} . "';"
- if exists $options{authority};
+
+ $code .= "\$$package_name\:\:VERSION = '" . $version . "';"
+ if defined $version;
+ $code .= "\$$package_name\:\:AUTHORITY = '" . $authority . "';"
+ if defined $authority;
eval $code;
confess "creation of $package_name failed : $@" if $@;
-
- return; # XXX: should this return some kind of meta object? ~sartak
}
1;
use strict;
use warnings;
-use Test::More tests => 67;
+use Test::More tests => 65;
use Test::Exception;
use Scalar::Util qw/reftype/;
}
}
-{
- package Foo::Aliasing;
- use metaclass;
- sub alias_me { '...' }
-}
-
-$Foo->alias_method('alias_me' => Foo::Aliasing->meta->get_method('alias_me'));
-
-ok($Foo->has_method('alias_me'), '... Foo->has_method(alias_me) (aliased from Foo::Aliasing)');
-ok(defined &Foo::alias_me, '... Foo does have a symbol table slow for alias_me though');
-
ok(!$Foo->has_method('blessed'), '... !Foo->has_method(blessed) (imported into Foo)');
ok(!$Foo->has_method('boom'), '... !Foo->has_method(boom) (defined in main:: using symbol tables and Sub::Name w/out package name)');
is_deeply(
[ sort $Foo->get_method_list ],
- [ qw(FOO_CONSTANT alias_me baaz bang bar baz blah cake evaled_foo floob foo pie) ],
+ [ qw(FOO_CONSTANT baaz bang bar baz blah cake evaled_foo floob foo pie) ],
'... got the right method list for Foo');
is_deeply(
[
map { $Foo->get_method($_) } qw(
FOO_CONSTANT
- alias_me
baaz
bang
bar
is_deeply(
[ sort $Foo->get_method_list ],
- [ qw(FOO_CONSTANT alias_me baaz bang bar baz blah cake evaled_foo floob pie) ],
+ [ qw(FOO_CONSTANT baaz bang bar baz blah cake evaled_foo floob pie) ],
'... got the right method list for Foo');
[ sort { $a->name cmp $b->name } $Bar->get_all_methods() ],
[
$Foo->get_method('FOO_CONSTANT'),
- $Foo->get_method('alias_me'),
$Foo->get_method('baaz'),
$Foo->get_method('bang'),
$Bar->get_method('bar'),
use strict;
use warnings;
-use Test::More tests => 12;
+use Test::More tests => 11;
use Test::Exception;
use Class::MOP;
],
'... got the right list of applicable methods for Foo::Bar');
-# test compute_all_applicable_methods once for compat
-is_deeply(
- [ sort { $a->{name} cmp $b->{name} } Class::MOP::Class->initialize('Foo::Bar::Baz')->compute_all_applicable_methods() ],
- [
- {
- name => 'BUILD',
- class => 'Foo::Bar::Baz',
- code => Class::MOP::Class->initialize('Foo::Bar::Baz')->get_method('BUILD')
- },
- {
- name => 'bar',
- class => 'Foo::Bar::Baz',
- code => Class::MOP::Class->initialize('Foo::Bar::Baz')->get_method('bar')
- },
- {
- name => 'baz',
- class => 'Baz',
- code => Class::MOP::Class->initialize('Baz')->get_method('baz')
- },
- {
- name => 'foo',
- class => 'Foo',
- code => Class::MOP::Class->initialize('Foo')->get_method('foo')
- },
- {
- name => 'foobarbaz',
- class => 'Foo::Bar::Baz',
- code => Class::MOP::Class->initialize('Foo::Bar::Baz')->get_method('foobarbaz')
- },
- ],
- '... got the right list of applicable methods for Foo::Bar::Baz');
-
## find_all_methods_by_name
is_deeply(
use strict;
use warnings;
-use Test::More tests => 250;
+use Test::More tests => 260;
use Test::Exception;
use Class::MOP;
my @class_mop_module_methods = qw(
_new
+ _instantiate_module
+
version authority identifier create
);
create_anon_class is_anon_class
- instance_metaclass get_meta_instance create_meta_instance
+ instance_metaclass get_meta_instance
+ create_meta_instance _create_meta_instance
new_object clone_object
- construct_instance construct_class_instance clone_instance
+ construct_instance
+ construct_class_instance _construct_class_instance
+ clone_instance _clone_instance
rebless_instance rebless_instance_away
- check_metaclass_compatibility
+ check_metaclass_compatibility _check_metaclass_compatibility
add_meta_instance_dependencies remove_meta_instance_dependencies update_meta_instance_dependencies
add_dependent_meta_instance remove_dependent_meta_instance
use strict;
use warnings;
-use Test::More tests => 48;
+use Test::More tests => 43;
use Test::Exception;
use Class::MOP;
{
dies_ok {
- Class::MOP::Class->construct_class_instance();
- } '... construct_class_instance requires an :package parameter';
+ Class::MOP::Class->_construct_class_instance();
+ } '... _construct_class_instance requires an :package parameter';
dies_ok {
- Class::MOP::Class->construct_class_instance(':package' => undef);
- } '... construct_class_instance requires a defined :package parameter';
+ Class::MOP::Class->_construct_class_instance(':package' => undef);
+ } '... _construct_class_instance requires a defined :package parameter';
dies_ok {
- Class::MOP::Class->construct_class_instance(':package' => '');
- } '... construct_class_instance requires a valid :package parameter';
+ Class::MOP::Class->_construct_class_instance(':package' => '');
+ } '... _construct_class_instance requires a valid :package parameter';
}
dies_ok {
Class::MOP::Class->clone_object(1);
} '... can only clone instances';
-
- dies_ok {
- Class::MOP::Class->clone_instance(1);
- } '... can only clone instances';
}
{
{
dies_ok {
- Class::MOP::Class->alias_method();
- } '... alias_method dies as expected';
-
- dies_ok {
- Class::MOP::Class->alias_method('');
- } '... alias_method dies as expected';
-
- dies_ok {
- Class::MOP::Class->alias_method('foo' => 'foo');
- } '... alias_method dies as expected';
-
- dies_ok {
- Class::MOP::Class->alias_method('foo' => []);
- } '... alias_method dies as expected';
-}
-
-{
- dies_ok {
Class::MOP::Class->has_method();
} '... has_method dies as expected';
# add all the methods in ....
foreach my $method_name (keys %methods) {
- $metaclass->alias_method($method_name => $methods{$method_name})
+ $metaclass->add_method($method_name => $methods{$method_name})
unless $metaclass->has_method($method_name);
}
}
use strict;
use warnings;
-use Test::More tests => 114;
+use Test::More tests => 101;
use Test::Exception;
use Scalar::Util;
ok( $meta->add_method('xyz', sub{'xxx'}), '... added method');
is( Baz->xyz, 'xxx', '... method xyz works');
- ok(! $meta->has_method('zxy') ,'... we dont have the aliased method yet');
- ok( $meta->alias_method('zxy',sub{'xxx'}),'... aliased method');
- ok( $meta->has_method('zxy') ,'... the aliased method does register');
- is( Baz->zxy, 'xxx', '... method zxy works');
- ok( $meta->remove_method('xyz'), '... removed method');
- ok( $meta->remove_method('zxy'), '... removed aliased method');
-
ok($meta->add_attribute('fickle', accessor => 'fickle'), '... added attribute');
ok(Baz->can('fickle'), '... Baz can fickle');
ok($meta->remove_attribute('fickle'), '... removed attribute');
lives_ok { $meta->make_immutable() } '... changed Baz to be immutable';
dies_ok{ $meta->add_method('xyz', sub{'xxx'}) } '... exception thrown as expected';
- dies_ok{ $meta->alias_method('zxy',sub{'xxx'}) } '... exception thrown as expected';
- dies_ok{ $meta->remove_method('zxy') } '... exception thrown as expected';
dies_ok {
$meta->add_attribute('fickle', accessor => 'fickle')
my $meta = Baz->meta->create_anon_class(superclasses => ['Baz']);
my %orig_keys = map { $_ => 1 } grep { !/^_/ } keys %$meta;
$orig_keys{immutable_transformer} = 1;
- my @orig_meths = sort { $a->{name} cmp $b->{name} }
- $meta->compute_all_applicable_methods;
+ my @orig_meths = sort { $a->name cmp $b->name }
+ $meta->get_all_methods;
ok($meta->is_anon_class, 'We have an anon metaclass');
ok($meta->is_mutable, '... our anon class is mutable');
ok(!$meta->is_immutable, '... our anon class is not immutable');
my $instance = $meta->new_object;
my %new_keys = map { $_ => 1 } grep { !/^_/ } keys %$meta;
- my @new_meths = sort { $a->{name} cmp $b->{name} }
- $meta->compute_all_applicable_methods;
+ my @new_meths = sort { $a->name cmp $b->name }
+ $meta->get_all_methods;
is_deeply(\%orig_keys, \%new_keys, '... no extraneous hashkeys');
- is_deeply(\@orig_meths, \@new_meths, '... no extraneous methods');
+ is_deeply(\@orig_meths, \@new_meths, '... no straneous methods');
isa_ok($meta, 'Class::MOP::Class', '... Anon class isa Class::MOP::Class');
ok( $meta->add_method('xyz', sub{'xxx'}), '... added method');
is( $instance->xyz , 'xxx', '... method xyz works');
- ok( $meta->alias_method('zxy',sub{'xxx'}),'... aliased method');
- is( $instance->zxy, 'xxx', '... method zxy works');
ok( $meta->remove_method('xyz'), '... removed method');
- ok( $meta->remove_method('zxy'), '... removed aliased method');
ok($meta->add_attribute('fickle', accessor => 'fickle'), '... added attribute');
ok($instance->can('fickle'), '... instance can fickle');
lives_ok {$meta->make_immutable } '... changed class to be immutable';
dies_ok{ $meta->add_method('xyz', sub{'xxx'}) } '... exception thrown as expected';
- dies_ok{ $meta->alias_method('zxy',sub{'xxx'}) } '... exception thrown as expected';
- dies_ok{ $meta->remove_method('zxy') } '... exception thrown as expected';
dies_ok {
$meta->add_attribute('fickle', accessor => 'fickle')
projects / gitmo/Class-MOP.git / commitdiff