t/100_bugs/011_DEMOLISH_eats_exceptions.t

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