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