t/100_bugs/011_DEMOLISH_eats_exceptions.t

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