Commit | Line | Data |
7e68124f |
1 | #!/usr/bin/env perl |
2 | use strict; |
3 | use warnings; |
9f15f9eb |
4 | use Test::More; |
eab81545 |
5 | use Test::Exception; |
e2962c13 |
6 | use IO::Handle; |
7e68124f |
7 | |
dfaf3196 |
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/], |
27a22464 |
14 | 0 => [qw/Any Item Defined Bool Value Num Int Str/], |
15 | 1 => [qw/Any Item Defined Bool Value Num Int Str/], |
e2962c13 |
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/], |
dfaf3196 |
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/], |
d2e2ac48 |
35 | \*main::ok => [qw/Any Item Defined Ref GlobRef/], |
dfaf3196 |
36 | \*STDOUT => [qw/Any Item Defined Ref GlobRef FileHandle/], |
d2e2ac48 |
37 | IO::Handle->new => [qw/Any Item Defined Ref Object FileHandle/], |
dfaf3196 |
38 | Test::Builder->new => [qw/Any Item Defined Ref Object/], |
39 | ); |
7e68124f |
40 | |
dfaf3196 |
41 | my %values_for_type; |
7e68124f |
42 | |
dfaf3196 |
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}; |
7e68124f |
47 | |
dfaf3196 |
48 | push @{ $values_for_type{$_}{invalid} }, $value |
49 | for grep { $is_invalid{$_} } @types; |
7e68124f |
50 | |
dfaf3196 |
51 | push @{ $values_for_type{$_}{valid} }, $value |
52 | for grep { !$is_invalid{$_} } @types; |
53 | } |
9f15f9eb |
54 | |
7e68124f |
55 | do { |
56 | package Class; |
57 | use Mouse; |
58 | |
dfaf3196 |
59 | for my $type (@types) { |
7e68124f |
60 | has $type => ( |
61 | is => 'rw', |
62 | isa => $type, |
63 | ); |
64 | } |
65 | }; |
66 | |
dfaf3196 |
67 | can_ok(Class => @types); |
7e68124f |
68 | |
dfaf3196 |
69 | for my $type (@types) { |
e2962c13 |
70 | note "For $type"; |
7e68124f |
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"); |
e2962c13 |
75 | } or die; |
7e68124f |
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"); |
e2962c13 |
82 | } or die; |
7e68124f |
83 | } |
84 | |
85 | for my $value (@{ $values_for_type{$type}{invalid} }) { |
e8b3db47 |
86 | my $display = defined($value) ? overload::StrVal($value) : 'undef'; |
7e68124f |
87 | my $via_new; |
88 | throws_ok { |
89 | $via_new = Class->new($type => $value); |
537873b0 |
90 | } qr/Attribute \($type\) does not pass the type constraint because: Validation failed for '$type' with value \Q$display\E/; |
e2962c13 |
91 | is($via_new, undef, "no object created") or die; |
7e68124f |
92 | |
93 | my $via_set = Class->new; |
94 | throws_ok { |
95 | $via_set->$type($value); |
537873b0 |
96 | } qr/Attribute \($type\) does not pass the type constraint because: Validation failed for '$type' with value \Q$display\E/; |
e2962c13 |
97 | is($via_set->$type, undef, "value for $type not set") or die; |
7e68124f |
98 | } |
99 | } |
100 | |
e2962c13 |
101 | done_testing; |