t/demolish-bugs-eats_exceptions.t

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