provide DEMOLISH

diff --git a/lib/Moo.pm b/lib/Moo.pm
index 16b7db4..d354bcc 100644 (file)
--- a/lib/Moo.pm
+++ b/lib/Moo.pm
@@ -218,6 +218,12 @@ a C<BUILD> method on your class and the constructor will automatically call the
 C<BUILD> method from parent down to child after the object has been
 instantiated.  Typically this is used for object validation or possibly logging.
 
+=head2 DESTROY
+
+A default destructor is provided, which calls
+C<< $instance->DEMOLISH($in_global_destruction) >> for each C<DEMOLISH>
+method in the inheritance hierarchy.
+
 =head2 does
 
  if ($foo->does('Some::Role1')) {

diff --git a/lib/Moo/Object.pm b/lib/Moo/Object.pm
index cc7fc06..1b26821 100644 (file)
--- a/lib/Moo/Object.pm
+++ b/lib/Moo/Object.pm
@@ -45,6 +45,39 @@ sub BUILDALL {
   })->generate_method(ref($self)))}(@_);
 }
 
+sub DESTROY {
+    my $self = shift;
+
+    return unless $self->can('DEMOLISH'); # short circuit
+
+    require Moo::_Utils;
+
+    my $e = do {
+        local $?;
+        local $@;
+        eval {
+            # DEMOLISHALL
+
+            # We cannot count on being able to retrieve a previously made
+            # metaclass, _or_ being able to make a new one during global
+            # destruction. However, we should still be able to use mro at
+            # that time (at least tests suggest so ;)
+
+            foreach my $class (@{ Moo::_Utils::_get_linear_isa(ref $self) }) {
+                my $demolish = $class->can('DEMOLISH') || next;
+
+                $self->$demolish($Moo::_Utils::_in_global_destruction);
+            }
+        };
+        $@;
+    };
+
+    no warnings 'misc';
+    die $e if $e; # rethrow
+}
+
+
+
 sub does {
   require Role::Tiny;
   { no warnings 'redefine'; *does = \&Role::Tiny::does_role }

diff --git a/t/demolish-basics.t b/t/demolish-basics.t
new file mode 100644 (file)
index 0000000..b5a83da
--- /dev/null
+++ b/t/demolish-basics.t
@@ -0,0 +1,51 @@
+
+use strictures 1;
+use Test::More;
+use Test::Fatal;
+
+our @demolished;
+package Foo;
+use Moo;
+
+sub DEMOLISH {
+    my $self = shift;
+    push @::demolished, __PACKAGE__;
+}
+
+package Foo::Sub;
+use Moo;
+extends 'Foo';
+
+sub DEMOLISH {
+    my $self = shift;
+    push @::demolished, __PACKAGE__;
+}
+
+package Foo::Sub::Sub;
+use Moo;
+extends 'Foo::Sub';
+
+sub DEMOLISH {
+    my $self = shift;
+    push @::demolished, __PACKAGE__;
+}
+
+package main;
+{
+    my $foo = Foo->new;
+}
+is_deeply(\@demolished, ['Foo'], "Foo demolished properly");
+@demolished = ();
+{
+    my $foo_sub = Foo::Sub->new;
+}
+is_deeply(\@demolished, ['Foo::Sub', 'Foo'], "Foo::Sub demolished properly");
+@demolished = ();
+{
+    my $foo_sub_sub = Foo::Sub::Sub->new;
+}
+is_deeply(\@demolished, ['Foo::Sub::Sub', 'Foo::Sub', 'Foo'],
+          "Foo::Sub::Sub demolished properly");
+@demolished = ();
+
+done_testing;

diff --git a/t/demolish-bugs-eats_exceptions.t b/t/demolish-bugs-eats_exceptions.t
new file mode 100644 (file)
index 0000000..7170b7a
--- /dev/null
+++ b/t/demolish-bugs-eats_exceptions.t
@@ -0,0 +1,141 @@
+
+use strictures 1;
+use Test::More;
+use Test::Fatal;
+use FindBin;
+
+
+my $FilePath = sub { die "does not pass the type constraint" if $_[0] eq '/' };
+
+{
+    package Baz;
+    use Moo;
+
+    has 'path' => (
+        is       => 'ro',
+        isa      => $FilePath,
+        required => 1,
+    );
+
+    sub BUILD {
+        my ( $self, $params ) = @_;
+        die $params->{path} . " does not exist"
+            unless -e $params->{path};
+    }
+
+    # Defining this causes the FIRST call to Baz->new w/o param to fail,
+    # if no call to ANY Moo::Object->new was done before.
+    sub DEMOLISH {
+        my ( $self ) = @_;
+    }
+}
+
+{
+    package Qee;
+    use Moo;
+
+    has 'path' => (
+        is       => 'ro',
+        isa      => $FilePath,
+        required => 1,
+    );
+
+    sub BUILD {
+        my ( $self, $params ) = @_;
+        die $params->{path} . " does not exist"
+            unless -e $params->{path};
+    }
+
+    # Defining this causes the FIRST call to Qee->new w/o param to fail...
+    # if no call to ANY Moo::Object->new was done before.
+    sub DEMOLISH {
+        my ( $self ) = @_;
+    }
+}
+
+{
+    package Foo;
+    use Moo;
+
+    has 'path' => (
+        is       => 'ro',
+        isa      => $FilePath,
+        required => 1,
+    );
+
+    sub BUILD {
+        my ( $self, $params ) = @_;
+        die $params->{path} . " does not exist"
+            unless -e $params->{path};
+    }
+
+    # Having no DEMOLISH, everything works as expected...
+}
+
+check_em ( 'Baz' );     #     'Baz plain' will fail, aka NO error
+check_em ( 'Qee' );     #     ok
+check_em ( 'Foo' );     #     ok
+
+check_em ( 'Qee' );     #     'Qee plain' will fail, aka NO error
+check_em ( 'Baz' );     #     ok
+check_em ( 'Foo' );     #     ok
+
+check_em ( 'Foo' );     #     ok
+check_em ( 'Baz' );     #     ok !
+check_em ( 'Qee' );     #     ok
+
+
+sub check_em {
+     my ( $pkg ) = @_;
+     my ( %param, $obj );
+
+     # Uncomment to see, that it is really any first call.
+     # Subsequents calls will not fail, aka giving the correct error.
+     {
+         local $@;
+         my $obj = eval { $pkg->new; };
+         ::like( $@, qr/Missing required argument/, "... $pkg plain" );
+         ::is( $obj, undef, "... the object is undef" );
+     }
+     {
+         local $@;
+         my $obj = eval { $pkg->new(); };
+         ::like( $@, qr/Missing required argument/, "... $pkg empty" );
+         ::is( $obj, undef, "... the object is undef" );
+     }
+     {
+         local $@;
+         my $obj = eval { $pkg->new ( notanattr => 1 ); };
+         ::like( $@, qr/Missing required argument/, "... $pkg undef" );
+         ::is( $obj, undef, "... the object is undef" );
+     }
+
+     {
+         local $@;
+         my $obj = eval { $pkg->new ( %param ); };
+         ::like( $@, qr/Missing required argument/, "... $pkg undef param" );
+         ::is( $obj, undef, "... the object is undef" );
+     }
+     {
+         local $@;
+         my $obj = eval { $pkg->new ( path => '/' ); };
+         ::like( $@, qr/does not pass the type constraint/, "... $pkg root path forbidden" );
+         ::is( $obj, undef, "... the object is undef" );
+     }
+     {
+         local $@;
+         my $obj = eval { $pkg->new ( path => '/this_path/does/not_exist' ); };
+         ::like( $@, qr/does not exist/, "... $pkg non existing path" );
+         ::is( $obj, undef, "... the object is undef" );
+     }
+     {
+         local $@;
+         my $obj = eval { $pkg->new ( path => $FindBin::Bin ); };
+         ::is( $@, '', "... $pkg no error" );
+         ::isa_ok( $obj, $pkg );
+         ::isa_ok( $obj, 'Moo::Object' );
+         ::is( $obj->path, $FindBin::Bin, "... $pkg got the right value" );
+     }
+}
+
+done_testing;

diff --git a/t/demolish-bugs-eats_mini.t b/t/demolish-bugs-eats_mini.t
new file mode 100644 (file)
index 0000000..43af629
--- /dev/null
+++ b/t/demolish-bugs-eats_mini.t
@@ -0,0 +1,75 @@
+
+use strictures 1;
+use Test::More;
+use Test::Fatal;
+
+{
+    package Foo;
+    use Moo;
+
+    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 Moo::Object->new was done before.
+    sub DEMOLISH {
+        my ( $self ) = @_;
+        # ... Moo (kinda) eats exceptions in DESTROY/DEMOLISH";
+    }
+}
+
+{
+    my $obj = eval { Foo->new; };
+    like( $@, qr/Missing required arguments/, "... 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 Moo;
+
+    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' );
+
+}
+
+done_testing;

diff --git a/t/demolish-global_destruction.t b/t/demolish-global_destruction.t
new file mode 100644 (file)
index 0000000..c9da471
--- /dev/null
+++ b/t/demolish-global_destruction.t
@@ -0,0 +1,29 @@
+
+use strictures 1;
+use Test::More;
+use Test::Fatal;
+
+{
+    package Foo;
+    use Moo;
+
+    sub DEMOLISH {
+        my $self = shift;
+        my ($igd) = @_;
+        ::ok(
+            !$igd,
+            'in_global_destruction state is passed to DEMOLISH properly (false)'
+        );
+    }
+}
+
+{
+    my $foo = Foo->new;
+}
+
+ok(
+    $_,
+    'in_global_destruction state is passed to DEMOLISH properly (true)'
+) for split //, `$^X t/global-destruction-helper.pl`;
+
+done_testing;

diff --git a/t/global-destruction-helper.pl b/t/global-destruction-helper.pl
new file mode 100644 (file)
index 0000000..13d794c
--- /dev/null
+++ b/t/global-destruction-helper.pl
@@ -0,0 +1,19 @@
+#!/usr/bin/env perl
+
+use strict;
+use warnings;
+no warnings 'once'; # work around 5.6.2
+
+{
+    package Foo;
+    use Moo;
+
+    sub DEMOLISH {
+        my $self = shift;
+        my ($igd) = @_;
+
+        print $igd || 0, "\n";
+    }
+}
+
+our $foo = Foo->new;