From: Stevan Little <stevan.little@iinteractive.com>
Date: Sat, 5 Apr 2008 21:17:18 +0000 (+0000)
Subject: fixing bug;
X-Git-Tag: 0_55~244
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=7c60f73067531e1823ab461d99009b5d097c2160;p=gitmo%2FMoose.git

fixing bug;
---

diff --git a/Changes b/Changes
index 2459cf1..fbee72c 100644
--- a/Changes
+++ b/Changes
@@ -25,7 +25,11 @@ Revision history for Perl extension Moose
       - when an attribute property is malformed (such as lazy without 
         a default), give the name of the attribute in the error 
         message (Sartak)
-      
+     
+    * Moose::Object 
+      - localize $@ inside DEMOLISHALL to avoid it 
+        eating $@ (found by Ernesto)
+        - added test for this (thanks to Ernesto)
 
 0.40 Fri. March 14, 2008
     - I hate Pod::Coverage
diff --git a/lib/Moose/Object.pm b/lib/Moose/Object.pm
index 90ca089..4b3272e 100644
--- a/lib/Moose/Object.pm
+++ b/lib/Moose/Object.pm
@@ -9,7 +9,7 @@ use if ( not our $__mx_is_compiled ), metaclass => 'Moose::Meta::Class';
 
 use Carp 'confess';
 
-our $VERSION   = '0.11';
+our $VERSION   = '0.12';
 our $AUTHORITY = 'cpan:STEVAN';
 
 sub new {
@@ -47,8 +47,11 @@ sub DEMOLISHALL {
     # extra meta level calls    
     return unless $_[0]->can('DEMOLISH');    
     my $self = shift;    
-    foreach my $method ($self->meta->find_all_methods_by_name('DEMOLISH')) {
-        $method->{code}->($self);
+    {
+        local $@;
+        foreach my $method ($self->meta->find_all_methods_by_name('DEMOLISH')) {
+            $method->{code}->($self);
+        }
     }    
 }
 
diff --git a/t/100_bugs/011_DEMOLISH_eats_exceptions.t b/t/100_bugs/011_DEMOLISH_eats_exceptions.t
new file mode 100644
index 0000000..4083578
--- /dev/null
+++ b/t/100_bugs/011_DEMOLISH_eats_exceptions.t
@@ -0,0 +1,191 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More no_plan => 1;
+use Test::Exception;
+use Test::Deep;
+
+use Data::Dumper;
+
+BEGIN
+{
+	use_ok('Moose');
+}
+
+{
+	use Moose::Util::TypeConstraints;
+
+	subtype 'FilePath'
+		=> as 'Str'
+		=> where { $_ =~ m#^(/[a-zA-Z0-9_.-]+)+$#;		};			#	'/' (root) forbidden!
+}
+
+{
+	package Baz;
+	use Moose;
+	use Moose::Util::TypeConstraints;
+
+	has 'path' =>
+	(
+		is			=> 'ro',
+		isa		=> 'FilePath',
+		required	=> 1,
+	);
+
+	sub BUILD
+	{
+		my ( $self, $params )	= @_;
+
+		confess $params->{path} . " does not exist"		unless -e $params->{path};
+
+		#	open files etc.
+	}
+
+	#	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 )	= @_;
+
+		#	cleanup files etc.
+	}
+}
+
+{
+	package Qee;
+	use Moose;
+	use Moose::Util::TypeConstraints;
+
+	has 'path' =>
+	(
+		is			=> 'ro',
+		isa		=> 'FilePath',
+		required	=> 1,
+	);
+
+	sub BUILD
+	{
+		my ( $self, $params )	= @_;
+
+		confess $params->{path} . " does not exist"		unless -e $params->{path};
+
+		#	open files etc.
+	}
+
+	#	Defining this causes the FIRST call to Qee->new w/o param to fail...
+	#	if no call to ANY Moose::Object->new was done before.
+	#
+	sub DEMOLISH
+	{
+		my ( $self )	= @_;
+
+		#	cleanup files etc.
+	}
+}
+
+{
+	package Foo;
+	use Moose;
+	use Moose::Util::TypeConstraints;
+
+	has 'path' =>
+	(
+		is			=> 'ro',
+		isa		=> 'FilePath',
+		required	=> 1,
+	);
+
+	sub BUILD
+	{
+		my ( $self, $params )	= @_;
+
+		confess $params->{path} . " does not exist"		unless -e $params->{path};
+
+		#	open files etc.
+	}
+
+	#	Having no DEMOLISH, everything works as expected...
+	#
+}
+
+#	Uncomment only one block per test run:
+#
+
+#=pod
+check_em ( 'Baz' );	#	'Baz plain' will fail, aka NO error
+check_em ( 'Qee' );	#	ok
+check_em ( 'Foo' );	#	ok
+#=cut
+
+#=pod
+check_em ( 'Qee' );	#	'Qee plain' will fail, aka NO error
+check_em ( 'Baz' );	#	ok
+check_em ( 'Foo' );	#	ok
+#=cut
+
+#=pod
+check_em ( 'Foo' );	#	ok
+check_em ( 'Baz' );	#	ok !
+check_em ( 'Qee' );	#	ok
+#=cut
+
+
+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.
+    #
+    #=pod
+    {
+        local $@;
+    	my $obj	= eval { $pkg->new; };
+    	::like	( $@,				qr/is required/,		"... $pkg plain" );
+    	::is		( $obj,			undef,					"" );
+    }
+    {
+        local $@;
+    	my $obj	= eval { $pkg->new(); };
+    	::like	( $@,				qr/is required/,		"... $pkg empty" );
+    	::is		( $obj,			undef,					"" );
+    }
+    {
+        local $@;        
+    	my $obj	= eval { $pkg->new ( undef ); };
+    	::like	( $@,				qr/is required/,		"... $pkg undef" );
+    	::is		( $obj,			undef,					"" );
+    }
+    #=cut
+    {
+        local $@;        
+    	my $obj	= eval { $pkg->new ( %param ); };
+    	::like	( $@,				qr/is required/,		"... $pkg undef param" );
+    	::is		( $obj,			undef,					"" );
+    }
+    {
+        local $@;        
+    	my $obj	= eval { $pkg->new ( path => '/' ); };
+    	::like	( $@,				qr/does not pass the type constraint/,	"... $pkg root path forbidden" );
+    	::is		( $obj,			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,					"" );
+    }
+    {
+        local $@;        
+    	my $obj	= eval { $pkg->new ( path => '/tmp' ); };
+    	::is		( $@,				'',						"... $pkg no error" );
+    	::isa_ok	( $obj,			$pkg );
+    	::isa_ok	( $obj,			'Moose::Object' );
+    	::is		( $obj->path,	'/tmp',					"... $pkg got the right value" );
+    }
+}
\ No newline at end of file