t/100_bugs/012_DEMOLISH_eats_mini.t

   1 #!/usr/bin/perl
   2
   3 use strict;
   4 use warnings;
   5
   6 use Test::More tests => 10;
   7 use Test::Exception;
   8
   9
  10 {
  11     package Foo;
  12     use Moose;
  13
  14     has 'bar' => (
  15         is       => 'ro',
  16         required => 1,
  17     );
  18
  19     # Defining this causes the FIRST call to Baz->new w/o param to fail,
  20     # if no call to ANY Moose::Object->new was done before.
  21     sub DEMOLISH {
  22         my ( $self ) = @_;
  23         # ... Moose (kinda) eats exceptions in DESTROY/DEMOLISH";
  24     }
  25 }
  26
  27 {
  28     my $obj = eval { Foo->new; };
  29     like( $@, qr/is required/, "... Foo plain" );
  30     is( $obj, undef, "... the object is undef" );
  31 }
  32
  33 {
  34     package Bar;
  35
  36     sub new { die "Bar died"; }
  37
  38     sub DESTROY {
  39         die "Vanilla Perl eats exceptions in DESTROY too";
  40     }
  41 }
  42
  43 {
  44     my $obj = eval { Bar->new; };
  45     like( $@, qr/Bar died/, "... Bar plain" );
  46     is( $obj, undef, "... the object is undef" );
  47 }
  48
  49 {
  50     package Baz;
  51     use Moose;
  52
  53     sub DEMOLISH {
  54         $@ = 1;
  55         $? = 0;
  56         $! = 0;
  57     }
  58 }
  59
  60 {
  61     local $@ = 0;
  62     local $? = 42;
  63     local $! = 84;
  64
  65     {
  66         Baz->new;
  67     }
  68
  69     is( $@, 0, '$@ is still 0 after object is demolished' );
  70     is( $?, 42, '$? is still 42 after object is demolished' );
  71     is( $! + 0, 84, '$! is still 84 after object is demolished' );
  72
  73     Baz->meta->make_immutable, redo
  74         if Baz->meta->is_mutable
  75 }
  76