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