1#!/usr/bin/env perl
2use strict;
3use warnings;
4use Test::More;
5use Test::Exception;
6use IO::Handle;
7
8my @types = qw/Any Item Bool Undef Defined Value Num Int Str ClassName
9               Ref ScalarRef ArrayRef HashRef CodeRef RegexpRef GlobRef
10               FileHandle Object/;
11
12my @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
41my %values_for_type;
42
43for (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
55do {
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
67can_ok(Class => @types);
68
69for 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
101done_testing;
102