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