t/bugs/DEMOLISH_eats_exceptions.t

   1 #!/usr/bin/perl
   2
   3 use strict;
   4 use warnings;
   5 use FindBin;
   6
   7 use Test::More;
   8
   9 use Moose::Util::TypeConstraints;
  10
  11 subtype 'FilePath'
  12     => as 'Str'
  13     # This used to try to _really_ check for a valid Unix or Windows
  14     # path, but the regex wasn't quite right, and all we care about
  15     # for the tests is that it rejects '/'
  16     => where { $_ ne '/' };
  17 {
  18     package Baz;
  19     use Moose;
  20     use Moose::Util::TypeConstraints;
  21
  22     has 'path' => (
  23         is       => 'ro',
  24         isa      => 'FilePath',
  25         required => 1,
  26     );
  27
  28     sub BUILD {
  29         my ( $self, $params ) = @_;
  30         confess $params->{path} . " does not exist"
  31             unless -e $params->{path};
  32     }
  33
  34     # Defining this causes the FIRST call to Baz->new w/o param to fail,
  35     # if no call to ANY Moose::Object->new was done before.
  36     sub DEMOLISH {
  37         my ( $self ) = @_;
  38     }
  39 }
  40
  41 {
  42     package Qee;
  43     use Moose;
  44     use Moose::Util::TypeConstraints;
  45
  46     has 'path' => (
  47         is       => 'ro',
  48         isa      => 'FilePath',
  49         required => 1,
  50     );
  51
  52     sub BUILD {
  53         my ( $self, $params ) = @_;
  54         confess $params->{path} . " does not exist"
  55             unless -e $params->{path};
  56     }
  57
  58     # Defining this causes the FIRST call to Qee->new w/o param to fail...
  59     # if no call to ANY Moose::Object->new was done before.
  60     sub DEMOLISH {
  61         my ( $self ) = @_;
  62     }
  63 }
  64
  65 {
  66     package Foo;
  67     use Moose;
  68     use Moose::Util::TypeConstraints;
  69
  70     has 'path' => (
  71         is       => 'ro',
  72         isa      => 'FilePath',
  73         required => 1,
  74     );
  75
  76     sub BUILD {
  77         my ( $self, $params ) = @_;
  78         confess $params->{path} . " does not exist"
  79             unless -e $params->{path};
  80     }
  81
  82     # Having no DEMOLISH, everything works as expected...
  83 }
  84
  85 check_em ( 'Baz' );     #     'Baz plain' will fail, aka NO error
  86 check_em ( 'Qee' );     #     ok
  87 check_em ( 'Foo' );     #     ok
  88
  89 check_em ( 'Qee' );     #     'Qee plain' will fail, aka NO error
  90 check_em ( 'Baz' );     #     ok
  91 check_em ( 'Foo' );     #     ok
  92
  93 check_em ( 'Foo' );     #     ok
  94 check_em ( 'Baz' );     #     ok !
  95 check_em ( 'Qee' );     #     ok
  96
  97
  98 sub check_em {
  99      my ( $pkg ) = @_;
 100      my ( %param, $obj );
 101
 102      # Uncomment to see, that it is really any first call.
 103      # Subsequents calls will not fail, aka giving the correct error.
 104      {
 105          local $@;
 106          my $obj = eval { $pkg->new; };
 107          ::like( $@, qr/is required/, "... $pkg plain" );
 108          ::is( $obj, undef, "... the object is undef" );
 109      }
 110      {
 111          local $@;
 112          my $obj = eval { $pkg->new(); };
 113          ::like( $@, qr/is required/, "... $pkg empty" );
 114          ::is( $obj, undef, "... the object is undef" );
 115      }
 116      {
 117          local $@;
 118          my $obj = eval { $pkg->new ( notanattr => 1 ); };
 119          ::like( $@, qr/is required/, "... $pkg undef" );
 120          ::is( $obj, undef, "... the object is undef" );
 121      }
 122
 123      {
 124          local $@;
 125          my $obj = eval { $pkg->new ( %param ); };
 126          ::like( $@, qr/is required/, "... $pkg undef param" );
 127          ::is( $obj, undef, "... the object is undef" );
 128      }
 129      {
 130          local $@;
 131          my $obj = eval { $pkg->new ( path => '/' ); };
 132          ::like( $@, qr/does not pass the type constraint/, "... $pkg root path forbidden" );
 133          ::is( $obj, undef, "... the object is undef" );
 134      }
 135      {
 136          local $@;
 137          my $obj = eval { $pkg->new ( path => '/this_path/does/not_exist' ); };
 138          ::like( $@, qr/does not exist/, "... $pkg non existing path" );
 139          ::is( $obj, undef, "... the object is undef" );
 140      }
 141      {
 142          local $@;
 143          my $obj = eval { $pkg->new ( path => $FindBin::Bin ); };
 144          ::is( $@, '', "... $pkg no error" );
 145          ::isa_ok( $obj, $pkg );
 146          ::isa_ok( $obj, 'Moose::Object' );
 147          ::is( $obj->path, $FindBin::Bin, "... $pkg got the right value" );
 148      }
 149 }
 150
 151 done_testing;