From: Alex J. G. Burzyński Date: Fri, 5 Aug 2011 09:50:14 +0000 (+0100) Subject: provide DEMOLISH X-Git-Tag: v0.009011~6 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=c2cc003f41aa57bf01dcde5b6cab28abb064b2bf;p=gitmo%2FRole-Tiny.git provide DEMOLISH --- diff --git a/lib/Moo.pm b/lib/Moo.pm index 16b7db4..d354bcc 100644 --- a/lib/Moo.pm +++ b/lib/Moo.pm @@ -218,6 +218,12 @@ a C method on your class and the constructor will automatically call the C 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 +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 --- 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 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 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 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 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 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;