X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FClass%2FMOP%2FImmutable.pm;h=0fce0aa81e947eacf4c7e5c7f57a0e83aee29476;hb=403cfbeccca4e7750da88c52ad7fd81f35a7e9a7;hp=076fbab1c95142b2270840a425f5ab4c5c7aa985;hpb=5f9d7960c4bc46df9da25d5aefaf6610c9cbc20a;p=gitmo%2FClass-MOP.git

diff --git a/lib/Class/MOP/Immutable.pm b/lib/Class/MOP/Immutable.pm
index 076fbab..0fce0aa 100644
--- a/lib/Class/MOP/Immutable.pm
+++ b/lib/Class/MOP/Immutable.pm
@@ -9,7 +9,7 @@ use Class::MOP::Method::Constructor;
 use Carp         'confess';
 use Scalar::Util 'blessed';
 
-our $VERSION   = '0.78_01';
+our $VERSION   = '0.82';
 $VERSION = eval $VERSION;
 our $AUTHORITY = 'cpan:STEVAN';
 
@@ -18,23 +18,21 @@ use base 'Class::MOP::Object';
 sub new {
     my ($class, @args) = @_;
 
-    my ( $metaclass, $options );
+    unshift @args, 'metaclass' if @args % 2 == 1;
 
-    if ( @args == 2 ) {
-        # compatibility args
-        ( $metaclass, $options ) = @args;
-    } else {
-        unshift @args, "metaclass" if @args % 2 == 1;
-
-        # default named args
-        my %options = @args;
-        $options = \%options;
-        $metaclass = $options{metaclass};
-    }
+    my %options = (
+        inline_accessors   => 1,
+        inline_constructor => 1,
+        inline_destructor  => 0,
+        constructor_name   => 'new',
+        constructor_class  => 'Class::MOP::Method::Constructor',
+        debug              => 0,
+        @args,
+    );
 
     my $self = $class->_new(
-        'metaclass'           => $metaclass,
-        'options'             => $options,
+        'metaclass'           => delete $options{metaclass},
+        'options'             => \%options,
         'immutable_metaclass' => undef,
         'inlined_constructor' => undef,
     );
@@ -52,188 +50,172 @@ sub _new {
 sub immutable_metaclass {
     my $self = shift;
 
-    $self->create_immutable_metaclass unless $self->{'immutable_metaclass'};
-
-    return $self->{'immutable_metaclass'};
+    return $self->{'immutable_metaclass'} ||= $self->_create_immutable_metaclass;
 }
 
 sub metaclass           { (shift)->{'metaclass'}           }
 sub options             { (shift)->{'options'}             }
 sub inlined_constructor { (shift)->{'inlined_constructor'} }
 
-sub create_immutable_metaclass {
+sub _create_immutable_metaclass {
     my $self = shift;
 
-    # NOTE:
-    # The immutable version of the
-    # metaclass is just a anon-class
-    # which shadows the methods
-    # appropriately
-    $self->{'immutable_metaclass'} = Class::MOP::Class->create_anon_class(
+    # NOTE: The immutable version of the metaclass is just a
+    # anon-class which shadows the methods appropriately
+    return Class::MOP::Class->create_anon_class(
         superclasses => [ blessed($self->metaclass) ],
-        methods      => $self->create_methods_for_immutable_metaclass,
+        methods      => $self->_create_methods_for_immutable_metaclass,
     );
 }
 
-
-my %DEFAULT_METHODS = (
-    # I don't really understand this, but removing it breaks tests (groditi)
-    meta => sub {
-        my $self = shift;
-        # if it is not blessed, then someone is asking
-        # for the meta of Class::MOP::Immutable
-        return Class::MOP::Class->initialize($self) unless blessed($self);
-        # otherwise, they are asking for the metaclass
-        # which has been made immutable, which is itself
-        # except in the cases where it is a metaclass itself
-        # that has been made immutable and for that we need 
-        # to dig a bit ...
-        if ($self->isa('Class::MOP::Class')) {
-            return $self->{'___original_class'}->meta;
-        }
-        else {
-            return $self;
-        }
-    },
-    is_mutable     => sub { 0  },
-    is_immutable   => sub { 1  },
-    make_immutable => sub { () },
-);
-
-# NOTE:
-# this will actually convert the
-# existing metaclass to an immutable
-# version of itself
 sub make_metaclass_immutable {
-    my ($self, $metaclass, $options) = @_;
-
-    my %options = (
-        inline_accessors   => 1,
-        inline_constructor => 1,
-        inline_destructor  => 0,
-        constructor_name   => 'new',
-        debug              => 0,
-        %$options,
-    );
+    my $self = shift;
 
-    %$options = %options; # FIXME who the hell is relying on this?!? tests fail =(
+    $self->_inline_accessors;
+    $self->_inline_constructor;
+    $self->_inline_destructor;
+    $self->_check_memoized_methods;
 
-    $self->_inline_accessors( $metaclass, \%options );
-    $self->_inline_constructor( $metaclass, \%options );
-    $self->_inline_destructor( $metaclass, \%options );
-    $self->_check_memoized_methods( $metaclass, \%options );
+    my $metaclass = $self->metaclass;
 
     $metaclass->{'___original_class'} = blessed($metaclass);
     bless $metaclass => $self->immutable_metaclass->name;
 }
 
 sub _inline_accessors {
-    my ( $self, $metaclass, $options ) = @_;
+    my $self = shift;
 
-    return unless $options->{inline_accessors};
+    return unless $self->options->{inline_accessors};
 
-    foreach my $attr_name ( $metaclass->get_attribute_list ) {
-        $metaclass->get_attribute($attr_name)->install_accessors(1);
+    foreach my $attr_name ( $self->metaclass->get_attribute_list ) {
+        $self->metaclass->get_attribute($attr_name)->install_accessors(1);
     }
 }
 
 sub _inline_constructor {
-    my ( $self, $metaclass, $options ) = @_;
-
-    return unless $options->{inline_constructor};
+    my $self = shift;
 
-    return
-        unless $options->{replace_constructor}
-            or !$metaclass->has_method( $options->{constructor_name} );
+    return unless $self->options->{inline_constructor};
+
+    unless ($self->options->{replace_constructor}
+         or !$self->metaclass->has_method(
+             $self->options->{constructor_name}
+         )) {
+        my $class = $self->metaclass->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 = $options->{constructor_class}
-        || 'Class::MOP::Method::Constructor';
+    my $constructor_class = $self->options->{constructor_class};
 
     my $constructor = $constructor_class->new(
-        options      => $options,
-        metaclass    => $metaclass,
+        options      => $self->options,
+        metaclass    => $self->metaclass,
         is_inline    => 1,
-        package_name => $metaclass->name,
-        name         => $options->{constructor_name},
+        package_name => $self->metaclass->name,
+        name         => $self->options->{constructor_name},
     );
 
-    if ( $options->{replace_constructor} or $constructor->can_be_inlined ) {
-        $metaclass->add_method( $options->{constructor_name} => $constructor );
+    if (   $self->options->{replace_constructor}
+        or $constructor->can_be_inlined ) {
+        $self->metaclass->add_method(
+            $self->options->{constructor_name} => $constructor );
         $self->{inlined_constructor} = $constructor;
     }
 }
 
 sub _inline_destructor {
-    my ( $self, $metaclass, $options ) = @_;
+    my $self = shift;
 
-    return unless $options->{inline_destructor};
+    return unless $self->options->{inline_destructor};
 
-    ( exists $options->{destructor_class} )
+    ( exists $self->options->{destructor_class} )
         || confess "The 'inline_destructor' option is present, but "
         . "no destructor class was specified";
 
-    my $destructor_class = $options->{destructor_class};
+    my $destructor_class = $self->options->{destructor_class};
 
-    return unless $destructor_class->is_needed($metaclass);
+    return unless $destructor_class->is_needed( $self->metaclass );
 
     my $destructor = $destructor_class->new(
-        options      => $options,
-        metaclass    => $metaclass,
-        package_name => $metaclass->name,
+        options      => $self->options,
+        metaclass    => $self->metaclass,
+        package_name => $self->metaclass->name,
         name         => 'DESTROY'
     );
 
-    return unless $destructor->is_needed;
-
-    $metaclass->add_method( 'DESTROY' => $destructor )
+    $self->metaclass->add_method( 'DESTROY' => $destructor );
 }
 
 sub _check_memoized_methods {
-    my ( $self, $metaclass, $options ) = @_;
+    my $self = shift;
 
     my $memoized_methods = $self->options->{memoize};
     foreach my $method_name ( keys %{$memoized_methods} ) {
         my $type = $memoized_methods->{$method_name};
 
-        ( $metaclass->can($method_name) )
+        ( $self->metaclass->can($method_name) )
             || confess "Could not find the method '$method_name' in "
-            . $metaclass->name;
+            . $self->metaclass->name;
     }
 }
+my %DEFAULT_METHODS = (
+    # I don't really understand this, but removing it breaks tests (groditi)
+    meta => sub {
+        my $self = shift;
+        # if it is not blessed, then someone is asking
+        # for the meta of Class::MOP::Immutable
+        return Class::MOP::Class->initialize($self) unless blessed($self);
+        # otherwise, they are asking for the metaclass
+        # which has been made immutable, which is itself
+        # except in the cases where it is a metaclass itself
+        # that has been made immutable and for that we need 
+        # to dig a bit ...
+        if ($self->isa('Class::MOP::Class')) {
+            return Class::MOP::class_of($self->{'___original_class'});
+        }
+        else {
+            return $self;
+        }
+    },
+    is_mutable     => sub { 0  },
+    is_immutable   => sub { 1  },
+    make_immutable => sub { () },
+);
 
-sub create_methods_for_immutable_metaclass {
+sub _create_methods_for_immutable_metaclass {
     my $self = shift;
 
-    my %methods   = %DEFAULT_METHODS;
     my $metaclass = $self->metaclass;
-    my $meta      = $metaclass->meta;
-
-    $methods{get_mutable_metaclass_name}
-        = sub { (shift)->{'___original_class'} };
-
-    $methods{immutable_transformer} = sub {$self};
+    my $meta      = Class::MOP::class_of($metaclass);
 
     return {
         %DEFAULT_METHODS,
-        $self->_make_read_only_methods( $metaclass, $meta ),
-        $self->_make_uncallable_methods( $metaclass, $meta ),
-        $self->_make_memoized_methods( $metaclass, $meta ),
-        $self->_make_wrapped_methods( $metaclass, $meta ),
+        $self->_make_read_only_methods,
+        $self->_make_uncallable_methods,
+        $self->_make_memoized_methods,
+        $self->_make_wrapped_methods,
         get_mutable_metaclass_name => sub { (shift)->{'___original_class'} },
         immutable_transformer      => sub {$self},
     };
 }
 
 sub _make_read_only_methods {
-    my ( $self, $metaclass, $meta ) = @_;
+    my $self = shift;
+
+    my $metameta = Class::MOP::class_of($self->metaclass);
 
     my %methods;
     foreach my $read_only_method ( @{ $self->options->{read_only} } ) {
-        my $method = $meta->find_method_by_name($read_only_method);
+        my $method = $metameta->find_method_by_name($read_only_method);
 
         ( defined $method )
             || confess "Could not find the method '$read_only_method' in "
-            . $metaclass->name;
+            . $self->metaclass->name;
 
         $methods{$read_only_method} = sub {
             confess "This method is read-only" if scalar @_ > 1;
@@ -245,7 +227,7 @@ sub _make_read_only_methods {
 }
 
 sub _make_uncallable_methods {
-    my ( $self, $metaclass, $meta ) = @_;
+    my $self = shift;
 
     my %methods;
     foreach my $cannot_call_method ( @{ $self->options->{cannot_call} } ) {
@@ -259,15 +241,17 @@ sub _make_uncallable_methods {
 }
 
 sub _make_memoized_methods {
-    my ( $self, $metaclass, $meta ) = @_;
+    my $self = shift;
 
     my %methods;
 
+    my $metameta = Class::MOP::class_of($self->metaclass);
+
     my $memoized_methods = $self->options->{memoize};
     foreach my $method_name ( keys %{$memoized_methods} ) {
         my $type   = $memoized_methods->{$method_name};
         my $key    = '___' . $method_name;
-        my $method = $meta->find_method_by_name($method_name);
+        my $method = $metameta->find_method_by_name($method_name);
 
         if ( $type eq 'ARRAY' ) {
             $methods{$method_name} = sub {
@@ -296,18 +280,20 @@ sub _make_memoized_methods {
 }
 
 sub _make_wrapped_methods {
-    my ( $self, $metaclass, $meta ) = @_;
+    my $self = shift;
 
     my %methods;
 
     my $wrapped_methods = $self->options->{wrapped};
 
+    my $metameta = Class::MOP::class_of($self->metaclass);
+
     foreach my $method_name ( keys %{$wrapped_methods} ) {
-        my $method = $meta->find_method_by_name($method_name);
+        my $method = $metameta->find_method_by_name($method_name);
 
         ( defined $method )
             || confess "Could not find the method '$method_name' in "
-            . $metaclass->name;
+            . $self->metaclass->name;
 
         my $wrapper = $wrapped_methods->{$method_name};
 
@@ -318,28 +304,31 @@ sub _make_wrapped_methods {
 }
 
 sub make_metaclass_mutable {
-    my ($self, $immutable, $options) = @_;
+    my $self = shift;
 
-    my %options = %$options;
+    my $metaclass = $self->metaclass;
 
-    my $original_class = $immutable->get_mutable_metaclass_name;
-    delete $immutable->{'___original_class'} ;
-    bless $immutable => $original_class;
+    my $original_class = $metaclass->get_mutable_metaclass_name;
+    delete $metaclass->{'___original_class'};
+    bless $metaclass => $original_class;
 
     my $memoized_methods = $self->options->{memoize};
-    foreach my $method_name (keys %{$memoized_methods}) {
+    foreach my $method_name ( keys %{$memoized_methods} ) {
         my $type = $memoized_methods->{$method_name};
 
-        ($immutable->can($method_name))
-          || confess "Could not find the method '$method_name' in " . $immutable->name;
-        if ($type eq 'SCALAR' || $type eq 'ARRAY' ||  $type eq 'HASH' ) {
-            delete $immutable->{'___' . $method_name};
+        ( $metaclass->can($method_name) )
+            || confess "Could not find the method '$method_name' in "
+            . $metaclass->name;
+        if ( $type eq 'SCALAR' || $type eq 'ARRAY' || $type eq 'HASH' ) {
+            delete $metaclass->{ '___' . $method_name };
         }
     }
 
-    if ($options{inline_destructor} && $immutable->has_method('DESTROY')) {
-        $immutable->remove_method('DESTROY')
-          if blessed($immutable->get_method('DESTROY')) eq $options{destructor_class};
+    if (   $self->options->{inline_destructor}
+        && $metaclass->has_method('DESTROY') ) {
+        $metaclass->remove_method('DESTROY')
+            if blessed( $metaclass->get_method('DESTROY') ) eq
+                $self->options->{destructor_class};
     }
 
     # NOTE:
@@ -359,11 +348,17 @@ sub make_metaclass_mutable {
     # 14:26 <@stevan> the only user of ::Method::Constructor is immutable
     # 14:27 <@stevan> if someone uses it outside of immutable,.. they are either: mst or groditi
     # 14:27 <@stevan> so I am not worried
-    if ($options{inline_constructor}  && $immutable->has_method($options{constructor_name})) {
-        my $constructor_class = $options{constructor_class} || 'Class::MOP::Method::Constructor';
-
-        if ( blessed($immutable->get_method($options{constructor_name})) eq $constructor_class ) {
-            $immutable->remove_method( $options{constructor_name}  );
+    if (   $self->options->{inline_constructor}
+        && $metaclass->has_method( $self->options->{constructor_name} ) ) {
+        my $constructor_class = $self->options->{constructor_class}
+            || 'Class::MOP::Method::Constructor';
+
+        if (
+            blessed(
+                $metaclass->get_method( $self->options->{constructor_name} )
+            ) eq $constructor_class
+            ) {
+            $metaclass->remove_method( $self->options->{constructor_name} );
             $self->{inlined_constructor} = undef;
         }
     }
@@ -395,14 +390,14 @@ Class::MOP::Immutable - A class to transform Class::MOP::Class metaclasses
             remove_package_symbol
         /],
         memoize     => {
-            class_precedence_list             => 'ARRAY',
-            compute_all_applicable_attributes => 'ARRAY',
-            get_meta_instance                 => 'SCALAR',
-            get_method_map                    => 'SCALAR',
+            class_precedence_list => 'ARRAY',
+            get_all_attributes    => 'ARRAY',
+            get_meta_instance     => 'SCALAR',
+            get_method_map        => 'SCALAR',
         }
     });
 
-    $immutable_metaclass->make_metaclass_immutable(@_)
+    $immutable_metaclass->make_metaclass_immutable;
 
 =head1 DESCRIPTION
 
@@ -512,6 +507,14 @@ transformation process.
 If the constructor was inlined, this returns the constructor method
 object that was created to do this.
 
+=item B<< $transformer->make_metaclass_immutable >>
+
+Makes the transformer's metaclass immutable.
+
+=item B<< $transformer->make_metaclass_mutable >>
+
+Makes the transformer's metaclass mutable.
+
 =back
 
 =head1 AUTHORS