[libclass-tiny-perl] 13/22: add support for DEMOLISH

[gregor herrmann]

This is an automated email from the git hooks/post-receive script.

gregoa pushed a commit to annotated tag release-0.001
in repository libclass-tiny-perl.

commit 3bbb1e84844630a9a792978791c148ec906a9280
Author: David Golden <dagolden at cpan.org>
Date:   Fri Aug 16 09:17:52 2013 -0400

    add support for DEMOLISH
---
 lib/Class/Tiny.pm | 18 ++++++++++++++++++
 t/delta.t         |  7 +++++++
 t/echo.t          |  9 +++++++++
 t/lib/Delta.pm    | 10 ++++++++++
 t/lib/Echo.pm     |  5 +++++
 5 files changed, 49 insertions(+)

diff --git a/lib/Class/Tiny.pm b/lib/Class/Tiny.pm
index 9fd19ba..fe62245 100644
--- a/lib/Class/Tiny.pm
+++ b/lib/Class/Tiny.pm
@@ -69,6 +69,24 @@ sub new {
     return $self;
 }
 
+# Adapted from Moo
+sub DESTROY {
+    my $self = shift;
+
+    for my $s ( @{ mro::get_linear_isa( ref $self ) } ) {
+        no strict 'refs';
+        my $demolisher = *{ $s . "::DEMOLISH" }{CODE};
+        my $e          = do {
+            local $?;
+            local $@;
+            eval { $self->$demolisher if defined $demolisher };
+            $@;
+        };
+        no warnings 'misc'; # avoid (in cleanup) warnings
+        die $e if $e;       # rethrow
+    }
+}
+
 1;
 
 =for Pod::Coverage method_names_here
diff --git a/t/delta.t b/t/delta.t
index 26c75d8..fc05cc9 100644
--- a/t/delta.t
+++ b/t/delta.t
@@ -16,6 +16,13 @@ subtest "attribute set as list" => sub {
     is( $obj->bar, 23, "bar is set" );
 };
 
+subtest "destructor" => sub {
+    my @objs = map { new_ok( "Delta", [ foo => 42, bar => 23 ] ) } 1 .. 3;
+    is ($Delta::counter, 3, "BUILD incremented counter");
+    @objs = ();
+    is ($Delta::counter, 0, "DEMOLISH decremented counter");
+};
+
 subtest "exceptions" => sub {
     like(
         exception { Delta->new( foo => 0 ) },
diff --git a/t/echo.t b/t/echo.t
index d95169e..f6a903e 100644
--- a/t/echo.t
+++ b/t/echo.t
@@ -17,6 +17,15 @@ subtest "attribute set as list" => sub {
     is( $obj->baz, 24, "baz is set" );
 };
 
+subtest "destructor" => sub {
+    no warnings 'once';
+    my @objs = map { new_ok( "Echo", [ foo => 42, bar => 23 ] ) } 1 .. 3;
+    is ($Delta::counter, 3, "BUILD incremented counter");
+    @objs = ();
+    is ($Delta::counter, 0, "DEMOLISH decremented counter");
+    is ($Delta::exception, 0, "cleanup worked in correct order");
+};
+
 subtest "exceptions" => sub {
     like(
         exception { Echo->new( foo => 0, bar => 23 ) },
diff --git a/t/lib/Delta.pm b/t/lib/Delta.pm
index 670c308..bde1cd5 100644
--- a/t/lib/Delta.pm
+++ b/t/lib/Delta.pm
@@ -4,6 +4,9 @@ use warnings;
 
 package Delta;
 
+our $counter = 0;
+our $exception = 0;
+
 use Carp ();
 
 use Class::Tiny qw/foo bar/;
@@ -14,6 +17,13 @@ sub BUILD {
       unless defined $self->foo && $self->foo > 0;
 
     $self->bar(42) unless defined $self->bar;
+    $counter++;
+}
+
+sub DEMOLISH {
+    my $self = shift;
+    $counter--;
+    $exception++ if keys %$self > 2; # Echo will delete first
 }
 
 1;
diff --git a/t/lib/Echo.pm b/t/lib/Echo.pm
index 36d6727..5b3c793 100644
--- a/t/lib/Echo.pm
+++ b/t/lib/Echo.pm
@@ -12,4 +12,9 @@ sub BUILD {
     $self->baz( $self->bar + 1 );
 }
 
+sub DEMOLISH {
+    my $self = shift;
+    delete $self->{baz}; # or else Delta::DEMOLISH dies
+}
+
 1;

-- 
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/pkg-perl/packages/libclass-tiny-perl.git