t/bugs/DEMOLISH_eats_mini.t

   1 #!/usr/bin/perl
   2
   3 use strict;
   4 use warnings;
   5
   6 use Test::More;
   7 use Test::Fatal;
   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         $? = 0;
  55     }
  56 }
  57
  58 {
  59     local $@ = 42;
  60     local $? = 84;
  61
  62     {
  63         Baz->new;
  64     }
  65
  66     is( $@, 42, '$@ is still 42 after object is demolished without dying' );
  67     is( $?, 84, '$? is still 84 after object is demolished without dying' );
  68
  69     local $@ = 0;
  70
  71     {
  72         Baz->new;
  73     }
  74
  75     is( $@, 0, '$@ is still 0 after object is demolished without dying' );
  76
  77     Baz->meta->make_immutable, redo
  78         if Baz->meta->is_mutable
  79 }
  80
  81 done_testing;