6 use Test::More tests => 3 + 7 * 4;
10 use LaTeX::TikZ::Meta::TypeConstraint::Autocoerce;
14 LaTeX::TikZ::Meta::TypeConstraint::Autocoerce->new(
18 like $@, qr/^No meta object for undefined target/, 'Undef target';
22 my $target = 'LaTeX::TikZ::A::Class::Likely::Not::To::Exist';
24 LaTeX::TikZ::Meta::TypeConstraint::Autocoerce->new(
28 like $@, qr/^No meta object for target \Q$target\E/, 'Nonexistent target';
33 LaTeX::TikZ::Meta::TypeConstraint::Autocoerce->new(
34 target => 'LaTeX::TikZ::Meta::TypeConstraint::Autocoerce',
37 is $@, '', 'Valid target';
41 package LaTeX::TikZ::TestX;
44 use Mouse::Util::TypeConstraints qw<
47 register_type_constraint
56 register_type_constraint(
57 LaTeX::TikZ::Meta::TypeConstraint::Autocoerce->new(
58 name => 'LaTeX::TikZ::TestX::Autocoerce',
59 target => find_type_constraint(__PACKAGE__),
62 my ($last) = $_[0] =~ /::([^:]+)$/;
63 join '::', __PACKAGE__, "From$last";
68 coerce 'LaTeX::TikZ::TestX::Autocoerce'
69 => from 'LaTeX::TikZ::TestX'
72 coerce 'LaTeX::TikZ::TestX::Autocoerce'
74 => via { __PACKAGE__->new(id => $_) };
76 __PACKAGE__->meta->make_immutable;
78 sub main::X () { __PACKAGE__ }
82 package LaTeX::TikZ::TestY;
92 __PACKAGE__->meta->make_immutable;
94 sub main::Y () { __PACKAGE__ }
98 package LaTeX::TikZ::TestZ;
104 isa => 'LaTeX::TikZ::TestX::Autocoerce',
109 __PACKAGE__->meta->make_immutable;
111 sub main::Z () { __PACKAGE__ }
115 package LaTeX::TikZ::TestW;
118 use Mouse::Util::TypeConstraints;
122 isa => 'LaTeX::TikZ::TestX',
126 coerce 'LaTeX::TikZ::TestX::Autocoerce'
127 => from +(__PACKAGE__)
130 __PACKAGE__->meta->make_immutable;
132 sub main::W () { __PACKAGE__ }
153 [ 123, 123, 'autocoerce X from int' ],
154 [ $x0, $time, 'autocoerce X from X' ],
155 [ $x0, $time, 'autocoerce X from X twice' ],
156 [ $y, 3, 'autocoerce X from Y' ],
157 [ $y2, 2, 'autocoerce X from another Y' ],
158 [ $w, $time, 'autocoerce X from W' ],
159 [ $w, $time, 'autocoerce X from W twice' ],
162 for my $test (@tests) {
163 my ($x, $exp, $desc) = @$test;
168 if (ref $exp eq 'Regexp') {
169 like $err, $exp, "could not $desc";
170 fail "$desc placeholder $_" for 1 .. 3;
172 is $err, '', "$desc doesn't croak";
173 isa_ok $z, Z(), "$desc returns a Z object";
175 isa_ok $x, X(), "$desc stores an X into the Z object";
176 is $x->id, $exp, "$desc correctly";