t/001_mouse/024-isa.t

   1 #!/usr/bin/env perl
   2 use strict;
   3 use warnings;
   4 use Test::More;
   5 use Test::Exception;
   6 use IO::Handle;
   7
   8 my @types = qw/Any Item Bool Undef Defined Value Num Int Str ClassName
   9                Ref ScalarRef ArrayRef HashRef CodeRef RegexpRef GlobRef
  10                FileHandle Object/;
  11
  12 my @type_values = (
  13     undef              ,  [qw/Any Item Undef Bool/],
  14     0                  => [qw/Any Item Defined Bool Value Num Int Str/],
  15     1                  => [qw/Any Item Defined Bool Value Num Int Str/],
  16     42                 => [qw/Any Item Defined      Value Num Int Str/],
  17     1.5                => [qw/Any Item Defined      Value Num     Str/],
  18     ''                 => [qw/Any Item Defined Bool Value         Str/],
  19     '0'                => [qw/Any Item Defined Bool Value Num Int Str/],
  20     '1'                => [qw/Any Item Defined Bool Value Num Int Str/],
  21     '42'               => [qw/Any Item Defined      Value Num Int Str/],
  22     '1.5'              => [qw/Any Item Defined Value Num Str/],
  23     't'                => [qw/Any Item Defined Value Str/],
  24     'f'                => [qw/Any Item Defined Value Str/],
  25     'undef'            => [qw/Any Item Defined Value Str/],
  26     'Test::More'       => [qw/Any Item Defined Value Str ClassName/],
  27     \undef             => [qw/Any Item Defined Ref ScalarRef/],
  28     \1                 => [qw/Any Item Defined Ref ScalarRef/],
  29     \"foo"             => [qw/Any Item Defined Ref ScalarRef/],
  30     [],                => [qw/Any Item Defined Ref ArrayRef/],
  31     [undef, \1]        => [qw/Any Item Defined Ref ArrayRef/],
  32     {}                 => [qw/Any Item Defined Ref HashRef/],
  33     sub { die }        => [qw/Any Item Defined Ref CodeRef/],
  34     qr/.*/             => [qw/Any Item Defined Ref RegexpRef/],
  35     \*main::ok         => [qw/Any Item Defined Ref GlobRef/],
  36     \*STDOUT           => [qw/Any Item Defined Ref GlobRef FileHandle/],
  37     IO::Handle->new    => [qw/Any Item Defined Ref Object FileHandle/],
  38     Test::Builder->new => [qw/Any Item Defined Ref Object/],
  39 );
  40
  41 my %values_for_type;
  42
  43 for (my $i = 1; $i < @type_values; $i += 2) {
  44     my ($value, $valid_types) = @type_values[$i-1, $i];
  45     my %is_invalid = map { $_ => 1 } @types;
  46     delete @is_invalid{@$valid_types};
  47
  48     push @{ $values_for_type{$_}{invalid} }, $value
  49         for grep { $is_invalid{$_} } @types;
  50
  51     push @{ $values_for_type{$_}{valid} }, $value
  52         for grep { !$is_invalid{$_} } @types;
  53 }
  54
  55 do {
  56     package Class;
  57     use Mouse;
  58
  59     for my $type (@types) {
  60         has $type => (
  61             is  => 'rw',
  62             isa => $type,
  63         );
  64     }
  65 };
  66
  67 can_ok(Class => @types);
  68
  69 for my $type (@types) {
  70     note "For $type";
  71     for my $value (@{ $values_for_type{$type}{valid} }) {
  72         lives_ok {
  73             my $via_new = Class->new($type => $value);
  74             is_deeply($via_new->$type, $value, "correctly set a $type in the constructor");
  75         } or die;
  76
  77         lives_ok {
  78             my $via_set = Class->new;
  79             is($via_set->$type, undef, "initially unset");
  80             $via_set->$type($value);
  81             is_deeply($via_set->$type, $value, "correctly set a $type in the setter");
  82         } or die;
  83     }
  84
  85     for my $value (@{ $values_for_type{$type}{invalid} }) {
  86         my $display = defined($value) ? overload::StrVal($value) : 'undef';
  87         my $via_new;
  88         throws_ok {
  89             $via_new = Class->new($type => $value);
  90         } qr/Attribute \($type\) does not pass the type constraint because: Validation failed for '$type' with value \Q$display\E/;
  91         is($via_new, undef, "no object created") or die;
  92
  93         my $via_set = Class->new;
  94         throws_ok {
  95             $via_set->$type($value);
  96         } qr/Attribute \($type\) does not pass the type constraint because: Validation failed for '$type' with value \Q$display\E/;
  97         is($via_set->$type, undef, "value for $type not set") or die;
  98     }
  99 }
 100
 101 done_testing;