X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=t%2Fbugs%2FDEMOLISH_eats_mini.t;fp=t%2Fbugs%2FDEMOLISH_eats_mini.t;h=3e1caf6d01f8b176fe6ce8a8307fe9713d4ff0aa;hb=829433c47061dd70a608bfcd940113c4172b6950;hp=0000000000000000000000000000000000000000;hpb=51c788414482c813eb48fb417b08ba03134ff1a6;p=gitmo%2FMoose.git

diff --git a/t/bugs/DEMOLISH_eats_mini.t b/t/bugs/DEMOLISH_eats_mini.t
new file mode 100644
index 0000000..3e1caf6
--- /dev/null
+++ b/t/bugs/DEMOLISH_eats_mini.t
@@ -0,0 +1,81 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Fatal;
+
+
+{
+    package Foo;
+    use Moose;
+
+    has 'bar' => (
+        is       => 'ro',
+        required => 1,
+    );
+
+    # Defining this causes the FIRST call to Baz->new w/o param to fail,
+    # if no call to ANY Moose::Object->new was done before.
+    sub DEMOLISH {
+        my ( $self ) = @_;
+        # ... Moose (kinda) eats exceptions in DESTROY/DEMOLISH";
+    }
+}
+
+{
+    my $obj = eval { Foo->new; };
+    like( $@, qr/is required/, "... Foo plain" );
+    is( $obj, undef, "... the object is undef" );
+}
+
+{
+    package Bar;
+
+    sub new { die "Bar died"; }
+
+    sub DESTROY {
+        die "Vanilla Perl eats exceptions in DESTROY too";
+    }
+}
+
+{
+    my $obj = eval { Bar->new; };
+    like( $@, qr/Bar died/, "... Bar plain" );
+    is( $obj, undef, "... the object is undef" );
+}
+
+{
+    package Baz;
+    use Moose;
+
+    sub DEMOLISH {
+        $? = 0;
+    }
+}
+
+{
+    local $@ = 42;
+    local $? = 84;
+
+    {
+        Baz->new;
+    }
+
+    is( $@, 42, '$@ is still 42 after object is demolished without dying' );
+    is( $?, 84, '$? is still 84 after object is demolished without dying' );
+
+    local $@ = 0;
+
+    {
+        Baz->new;
+    }
+
+    is( $@, 0, '$@ is still 0 after object is demolished without dying' );
+
+    Baz->meta->make_immutable, redo
+        if Baz->meta->is_mutable
+}
+
+done_testing;