use strict;
use warnings;
-use Class::MOP::Immutable;
use Class::MOP::Instance;
use Class::MOP::Method::Wrapped;
+use Class::MOP::Method::Accessor;
+use Class::MOP::Method::Constructor;
+use Class::MOP::Class::Immutable::Class::MOP::Class;
use Carp 'confess';
use Scalar::Util 'blessed', 'weaken';
+use Sub::Name 'subname';
+use Devel::GlobalDestruction 'in_global_destruction';
-our $VERSION = '0.80';
+our $VERSION = '0.84';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
}
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;
+ 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)
# defined in Class::MOP::Class
'superclasses' => \undef,
- 'methods' => {},
- 'attributes' => {},
- 'attribute_metaclass' => $options->{'attribute_metaclass'}
- || 'Class::MOP::Attribute',
- 'method_metaclass' => $options->{'method_metaclass'}
- || 'Class::MOP::Method',
- 'wrapped_method_metaclass' => $options->{'wrapped_method_metaclass'}
- || 'Class::MOP::Method::Wrapped',
- 'instance_metaclass' => $options->{'instance_metaclass'}
- || 'Class::MOP::Instance',
+ 'methods' => {},
+ 'attributes' => {},
+ 'attribute_metaclass' =>
+ ( $options->{'attribute_metaclass'} || 'Class::MOP::Attribute' ),
+ 'method_metaclass' =>
+ ( $options->{'method_metaclass'} || 'Class::MOP::Method' ),
+ 'wrapped_method_metaclass' => (
+ $options->{'wrapped_method_metaclass'}
+ || 'Class::MOP::Method::Wrapped'
+ ),
+ 'instance_metaclass' =>
+ ( $options->{'instance_metaclass'} || 'Class::MOP::Instance' ),
+ 'immutable_trait' => (
+ $options->{'immutable_trait'}
+ || 'Class::MOP::Class::Immutable::Trait'
+ ),
+ 'constructor_name' => ( $options->{constructor_name} || 'new' ),
+ 'constructor_class' => (
+ $options->{constructor_class} || 'Class::MOP::Method::Constructor'
+ ),
+ 'destructor_class' => $options->{destructor_class},
}, $class;
}
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;
+ 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 {
sub DESTROY {
my $self = shift;
- return if Class::MOP::in_global_destruction(); # it'll happen soon anyway and this just makes things more complicated
+ return if in_global_destruction(); # it'll happen soon anyway and this just makes things more complicated
no warnings 'uninitialized';
return unless $self->name =~ /^$ANON_CLASS_PREFIX/;
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'} }
# Instance Construction & Cloning
}
sub construct_instance {
- warn '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;
+ 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 {
}
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;
+ 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 {
}
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;
+ 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 $full_method_name = ($self->name . '::' . $method_name);
$self->add_package_symbol(
{ sigil => '&', type => 'CODE', name => $method_name },
- Class::MOP::subname($full_method_name => $body)
+ subname($full_method_name => $body)
);
}
|| confess "You must pass in a method name";
my $method = $fetch_and_prepare_method->($self, $method_name);
$method->add_before_modifier(
- Class::MOP::subname(':before' => $method_modifier)
+ subname(':before' => $method_modifier)
);
}
|| confess "You must pass in a method name";
my $method = $fetch_and_prepare_method->($self, $method_name);
$method->add_after_modifier(
- Class::MOP::subname(':after' => $method_modifier)
+ subname(':after' => $method_modifier)
);
}
|| confess "You must pass in a method name";
my $method = $fetch_and_prepare_method->($self, $method_name);
$method->add_around_modifier(
- Class::MOP::subname(':around' => $method_modifier)
+ subname(':around' => $method_modifier)
);
}
}
sub alias_method {
- warn "The alias_method method is deprecated. Use add_method instead.\n";
+ Carp::cluck("The alias_method method is deprecated. Use add_method instead.\n");
- shift->add_method;
+ shift->add_method(@_);
}
sub has_method {
}
sub compute_all_applicable_methods {
- warn 'The compute_all_applicable_methods method is deprecated.'
- . " Use get_all_methods instead.\n";
+ Carp::cluck('The compute_all_applicable_methods method is deprecated.'
+ . " Use get_all_methods instead.\n");
return map {
{
} else {
$self->invalidate_meta_instances();
}
+
+ # 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}) - 1;
+ $attribute->_set_insertion_order($order + 1);
# then onto installing the new accessors
$self->get_attribute_map->{$attribute->name} = $attribute;
}
sub compute_all_applicable_attributes {
- warn 'The construct_class_instance method has been deprecated.'
- . " Use get_all_attributes instead.\n";
+ Carp::cluck('The compute_all_applicable_attributes method has been deprecated.'
+ . " Use get_all_attributes instead.\n");
- shift->get_all_attributes;
+ shift->get_all_attributes(@_);
}
sub find_attribute_by_name {
sub is_mutable { 1 }
sub is_immutable { 0 }
-
-sub immutable_transformer { $_[0]->{immutable_transformer} }
-sub _set_immutable_transformer { $_[0]->{immutable_transformer} = $_[1] }
+sub immutable_transformer { return }
+
+sub _immutable_options {
+ my ( $self, @args ) = @_;
+
+ return (
+ inline_accessors => 1,
+ inline_constructor => 1,
+ inline_destructor => 0,
+ debug => 0,
+ immutable_trait => $self->immutable_trait,
+ constructor_name => $self->constructor_name,
+ constructor_class => $self->constructor_class,
+ destructor_class => $self->destructor_class,
+ @args,
+ );
+}
sub make_immutable {
+ my ( $self, @args ) = @_;
+
+ if ( $self->is_mutable ) {
+ $self->_initialize_immutable( $self->_immutable_options(@args) );
+ $self->_rebless_as_immutable(@args);
+ return $self;
+ }
+ else {
+ return;
+ }
+}
+
+sub make_mutable {
my $self = shift;
- return if $self->is_immutable;
+ if ( $self->is_immutable ) {
+ my @args = $self->immutable_options;
+ $self->_rebless_as_mutable();
+ $self->_remove_inlined_code(@args);
+ delete $self->{__immutable};
+ return $self;
+ }
+ else {
+ return;
+ }
+}
- my $transformer = $self->immutable_transformer
- || $self->_make_immutable_transformer(@_);
+sub _rebless_as_immutable {
+ my ( $self, @args ) = @_;
- $self->_set_immutable_transformer($transformer);
+ $self->{__immutable}{original_class} = ref $self;
- $transformer->make_metaclass_immutable;
+ bless $self => $self->_immutable_metaclass(@args);
}
-{
- my %Default_Immutable_Options = (
- read_only => [qw/superclasses/],
- cannot_call => [
- qw(
- add_method
- alias_method
- remove_method
- add_attribute
- remove_attribute
- remove_package_symbol
- )
- ],
- 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',
- get_all_attributes => 'ARRAY',
- get_meta_instance => 'SCALAR',
- get_method_map => 'SCALAR',
- },
+sub _immutable_metaclass {
+ my ( $self, %args ) = @_;
- # NOTE:
- # this is ugly, but so are typeglobs,
- # so whattayahgonnadoboutit
- # - SL
- wrapped => {
- add_package_symbol => sub {
- my $original = shift;
- confess "Cannot add package symbols to an immutable metaclass"
- unless ( caller(2) )[3] eq
- 'Class::MOP::Package::get_package_symbol';
-
- # This is a workaround for a bug in 5.8.1 which thinks that
- # goto $original->body
- # is trying to go to a label
- my $body = $original->body;
- goto $body;
- },
- },
- );
+ if ( my $class = $args{immutable_metaclass} ) {
+ return $class;
+ }
+
+ my $trait = $args{immutable_trait} = $self->immutable_trait
+ || confess "no immutable trait specified for $self";
+
+ my $meta_attr = $self->meta->find_attribute_by_name("immutable_trait");
- sub _default_immutable_transformer_options {
- return %Default_Immutable_Options;
+ my $class_name;
+
+ if ( $meta_attr and $trait eq $meta_attr->default ) {
+
+ # if the trait is the same as the default we try and pick a predictable
+ # name for the immutable metaclass
+ $class_name = "Class::MOP::Class::Immutable::" . ref($self);
+ }
+ else {
+ $class_name
+ = join( "::", "Class::MOP::Class::Immutable::CustomTrait", $trait,
+ "ForMetaClass", ref($self) );
+ }
+
+ if ( Class::MOP::is_class_loaded($class_name) ) {
+ if ( $class_name->isa($trait) ) {
+ return $class_name;
+ }
+ else {
+ confess
+ "$class_name is already defined but does not inherit $trait";
+ }
+ }
+ else {
+ my @super = ( $trait, ref($self) );
+
+ my $meta = Class::MOP::Class->initialize($class_name);
+ $meta->superclasses(@super);
+
+ $meta->make_immutable;
+
+ return $class_name;
}
}
-sub _make_immutable_transformer {
+sub _remove_inlined_code {
my $self = shift;
- Class::MOP::Immutable->new(
- $self,
- $self->_default_immutable_transformer_options,
- @_
- );
+ $self->remove_method( $_->name ) for $self->_inlined_methods;
+
+ delete $self->{__immutable}{inlined_methods};
}
-sub make_mutable {
+sub _inlined_methods { @{ $_[0]{__immutable}{inlined_methods} || [] } }
+
+sub _add_inlined_method {
+ my ( $self, $method ) = @_;
+
+ push @{ $self->{__immutable}{inlined_methods} ||= [] }, $method;
+}
+
+sub _initialize_immutable {
+ my ( $self, %args ) = @_;
+
+ $self->{__immutable}{options} = \%args;
+ $self->_install_inlined_code(%args);
+}
+
+sub _install_inlined_code {
+ my ( $self, %args ) = @_;
+
+ # FIXME
+ $self->_inline_accessors(%args) if $args{inline_accessors};
+ $self->_inline_constructor(%args) if $args{inline_constructor};
+ $self->_inline_destructor(%args) if $args{inline_destructor};
+}
+
+sub _rebless_as_mutable {
my $self = shift;
- return if $self->is_mutable;
+ bless $self, $self->get_mutable_metaclass_name;
+
+ return $self;
+}
+
+sub _inline_accessors {
+ my $self = shift;
+
+ foreach my $attr_name ( $self->get_attribute_list ) {
+ $self->get_attribute($attr_name)->install_accessors(1);
+ }
+}
+
+sub _inline_constructor {
+ my ( $self, %args ) = @_;
+
+ my $name = $args{constructor_name};
+
+ #if ( my $existing = $self->name->can($args{constructor_name}) ) {
+ # if ( refaddr($existing) == refaddr(\&Moose::Object::new) ) {
+
+ unless ( $args{replace_constructor}
+ or !$self->has_method($name) ) {
+ my $class = $self->name;
+ warn "Not inlining a constructor for $class since it defines"
+ . " its own constructor.\n"
+ . "If you are certain you don't need to inline your"
+ . " constructor, specify inline_constructor => 0 in your"
+ . " call to $class->meta->make_immutable\n";
+ return;
+ }
+
+ my $constructor_class = $args{constructor_class};
+
+ Class::MOP::load_class($constructor_class);
+
+ my $constructor = $constructor_class->new(
+ options => \%args,
+ metaclass => $self,
+ is_inline => 1,
+ package_name => $self->name,
+ name => $name,
+ );
+
+ if ( $args{replace_constructor} or $constructor->can_be_inlined ) {
+ $self->add_method( $name => $constructor );
+ $self->_add_inlined_method($constructor);
+ }
+}
+
+sub _inline_destructor {
+ my ( $self, %args ) = @_;
+
+ ( exists $args{destructor_class} )
+ || confess "The 'inline_destructor' option is present, but "
+ . "no destructor class was specified";
+
+ my $destructor_class = $args{destructor_class};
+
+ Class::MOP::load_class($destructor_class);
+
+ return unless $destructor_class->is_needed($self);
+
+ my $destructor = $destructor_class->new(
+ options => \%args,
+ metaclass => $self,
+ package_name => $self->name,
+ name => 'DESTROY'
+ );
+
+ $self->add_method( 'DESTROY' => $destructor );
- $self->immutable_transformer->make_metaclass_mutable;
+ $self->_add_inlined_method($destructor);
}
1;
# add a method to Foo ...
Foo->meta->add_method( 'bar' => sub {...} )
- # get a list of all the classes searched
- # the method dispatcher in the correct order
- Foo->meta->class_precedence_list()
+ # get a list of all the classes searched
+ # the method dispatcher in the correct order
+ Foo->meta->class_precedence_list()
- # remove a method from Foo
- Foo->meta->remove_method('bar');
+ # remove a method from Foo
+ Foo->meta->remove_method('bar');
# or use this to actually create classes ...
version => '0.01',
superclasses => ['Foo'],
attributes => [
- Class::MOP:: : Attribute->new('$bar'),
- Class::MOP:: : Attribute->new('$baz'),
+ Class::MOP::Attribute->new('$bar'),
+ Class::MOP::Attribute->new('$baz'),
],
methods => {
calculate_bar => sub {...},
projects / gitmo/Class-MOP.git / blobdiff