X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FClass%2FMOP%2FClass.pm;h=82ca2b2ab188bee90f9a5015033e8864903a14e0;hb=bbdaea42d9c753913a13892ab705e622efd045bf;hp=0155c7068a95cb0d53d582dc45be73e5b3f16246;hpb=403cfbeccca4e7750da88c52ad7fd81f35a7e9a7;p=gitmo%2FClass-MOP.git diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm index 0155c70..82ca2b2 100644 --- a/lib/Class/MOP/Class.pm +++ b/lib/Class/MOP/Class.pm @@ -4,14 +4,18 @@ package Class::MOP::Class; 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.82'; +our $VERSION = '0.83'; $VERSION = eval $VERSION; our $AUTHORITY = 'cpan:STEVAN'; @@ -127,16 +131,27 @@ sub _new { # 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; } @@ -233,7 +248,7 @@ 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/; @@ -326,6 +341,10 @@ 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'} } # Instance Construction & Cloning @@ -593,7 +612,7 @@ sub add_method { 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) ); } @@ -630,7 +649,7 @@ sub add_method { || 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) ); } @@ -640,7 +659,7 @@ sub add_method { || 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) ); } @@ -650,7 +669,7 @@ sub add_method { || 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) ); } @@ -966,88 +985,215 @@ sub is_pristine { 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; + } - sub _default_immutable_transformer_options { - return %Default_Immutable_Options; + 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"); + + 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; @@ -1070,12 +1216,12 @@ Class::MOP::Class - Class Meta Object # 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 ... @@ -1084,8 +1230,8 @@ Class::MOP::Class - Class Meta Object 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 {...},