t/100_bugs/011_DEMOLISH_eats_exceptions.t

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