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