From: Jesse Luehrs <doy@tozt.net>
Date: Sun, 7 Mar 2010 08:10:07 +0000 (-0600)
Subject: fix DEMOLISH methods not being called in some cases
X-Git-Tag: 0.99~2
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=258181213ac82cfd982078558df96f412ed5fb84;p=gitmo%2FMoose.git

fix DEMOLISH methods not being called in some cases

in particular, defining a DEMOLISH method in a mutable subclass of an
immutable class wouldn't work properly, since the inlined DESTROY method
didn't include proper fallbacks
---

diff --git a/Changes b/Changes
index 180b234..abf6319 100644
--- a/Changes
+++ b/Changes
@@ -8,6 +8,11 @@ for, noteworthy changes.
   * New method find_type_for in Moose::Meta::TypeConstraint::Union, for finding
     which member of the union a given value validates for. (Cory Watson)
 
+  [BUG FIXES]
+
+  * DEMOLISH methods in mutable subclasses of immutable classes are now called
+    properly (Chia-liang Kao, Jesse Luehrs)
+
   [NEW DOCUMENTATION]
 
   * Added Moose::Manual::Support that defines the support, compatiblity, and
diff --git a/lib/Moose/Meta/Method/Destructor.pm b/lib/Moose/Meta/Method/Destructor.pm
index 0fdfa17..33a5ffa 100644
--- a/lib/Moose/Meta/Method/Destructor.pm
+++ b/lib/Moose/Meta/Method/Destructor.pm
@@ -81,10 +81,14 @@ sub _initialize_body {
     my @DEMOLISH_methods = $self->associated_metaclass->find_all_methods_by_name('DEMOLISH');
 
     my $source;
-    if ( @DEMOLISH_methods ) {
-        $source = 'sub {';
-        $source .= 'my $self = shift;' . "\n";
+    $source  = 'sub {' . "\n";
+    $source .= 'my $self = shift;' . "\n";
+    $source .= 'return $self->Moose::Object::DESTROY(@_)' . "\n";
+    $source .= '    if Scalar::Util::blessed($self) ne ';
+    $source .= "'" . $self->associated_metaclass->name . "'";
+    $source .= ';' . "\n";
 
+    if ( @DEMOLISH_methods ) {
         $source .= 'local $?;' . "\n";
 
         $source .= 'my $in_global_destruction = Devel::GlobalDestruction::in_global_destruction;' . "\n";
@@ -98,11 +102,10 @@ sub _initialize_body {
         $source .= q[ Try::Tiny::catch { no warnings 'misc'; die $_ };] . "\n";
         $source .= 'return;' . "\n";
 
-        $source .= '}';
-    } else {
-        $source = 'sub { }';
     }
 
+    $source .= '}';
+
     warn $source if $self->options->{debug};
 
     my ( $code, $e ) = $self->_compile_code(
diff --git a/t/300_immutable/016_inline_fallbacks.t b/t/300_immutable/016_inline_fallbacks.t
new file mode 100644
index 0000000..362d60e
--- /dev/null
+++ b/t/300_immutable/016_inline_fallbacks.t
@@ -0,0 +1,70 @@
+use strict;
+use warnings;
+use Test::More;
+
+{
+    package Foo;
+    use Moose;
+    has foo => (is => 'ro');
+}
+
+{
+    package Foo::Sub;
+    use Moose;
+    extends 'Foo';
+    has bar => (is => 'ro');
+}
+
+{
+    my $foo = Foo::Sub->new(foo => 12, bar => 25);
+    is($foo->foo, 12, 'got right value for foo');
+    is($foo->bar, 25, 'got right value for bar');
+}
+
+Foo->meta->make_immutable;
+
+{
+    package Foo::Sub2;
+    use Moose;
+    extends 'Foo';
+    has baz => (is => 'ro');
+    # not making immutable, inheriting Foo's inlined constructor
+}
+
+{
+    my $foo = Foo::Sub2->new(foo => 42, baz => 27);
+    is($foo->foo, 42, 'got right value for foo');
+    is($foo->baz, 27, 'got right value for baz');
+}
+
+my $BAR = 0;
+{
+    package Bar;
+    use Moose;
+}
+
+{
+    package Bar::Sub;
+    use Moose;
+    extends 'Bar';
+    sub DEMOLISH { $BAR++ }
+}
+
+Bar::Sub->new;
+is($BAR, 1, 'DEMOLISH in subclass was called');
+$BAR = 0;
+
+Bar->meta->make_immutable;
+
+{
+    package Bar::Sub2;
+    use Moose;
+    extends 'Bar';
+    sub DEMOLISH { $BAR++ }
+    # not making immutable, inheriting Bar's inlined destructor
+}
+
+Bar::Sub2->new;
+is($BAR, 1, 'DEMOLISH in subclass was called');
+
+done_testing;