t/024-isa.t

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