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 parent/, 'Undef parent';
22 my $parent = 'LaTeX::TikZ::A::Class::Likely::Not::To::Exist';
24 LaTeX::TikZ::Meta::TypeConstraint::Autocoerce->new(
28 like $@, qr/^No meta object for parent \Q$parent\E/, 'Nonexistent parent';
33 LaTeX::TikZ::Meta::TypeConstraint::Autocoerce->new(
34 parent => 'LaTeX::TikZ::Meta::TypeConstraint::Autocoerce',
37 is $@, '', 'Valid parent';
41 package LaTeX::TikZ::TestX;
44 use Any::Moose 'Util::TypeConstraints' => [ qw<
49 register_type_constraint
58 register_type_constraint(
59 LaTeX::TikZ::Meta::TypeConstraint::Autocoerce->new(
60 name => 'LaTeX::TikZ::TestX::Autocoerce',
61 parent => find_type_constraint(__PACKAGE__),
64 my ($last) = $_[0] =~ /::([^:]+)$/;
65 join '::', __PACKAGE__, "From$last";
70 coerce 'LaTeX::TikZ::TestX::Autocoerce'
71 => from 'LaTeX::TikZ::TestX'
74 coerce 'LaTeX::TikZ::TestX::Autocoerce'
76 => via { __PACKAGE__->new(id => $_) };
78 __PACKAGE__->meta->make_immutable;
80 sub main::X () { __PACKAGE__ }
84 package LaTeX::TikZ::TestY;
94 __PACKAGE__->meta->make_immutable;
96 sub main::Y () { __PACKAGE__ }
100 package LaTeX::TikZ::TestZ;
106 isa => 'LaTeX::TikZ::TestX::Autocoerce',
111 __PACKAGE__->meta->make_immutable;
113 sub main::Z () { __PACKAGE__ }
117 package LaTeX::TikZ::TestW;
120 use Any::Moose 'Util::TypeConstraints';
124 isa => 'LaTeX::TikZ::TestX',
128 coerce 'LaTeX::TikZ::TestX::Autocoerce'
132 __PACKAGE__->meta->make_immutable;
134 sub main::W () { __PACKAGE__ }
155 [ 123, 123, 'autocoerce X from int' ],
156 [ $x0, $time, 'autocoerce X from X' ],
157 [ $x0, $time, 'autocoerce X from X twice' ],
158 [ $y, 3, 'autocoerce X from Y' ],
159 [ $y2, 2, 'autocoerce X from another Y' ],
160 [ $w, $time, 'autocoerce X from W' ],
161 [ $w, $time, 'autocoerce X from W twice' ],
164 for my $test (@tests) {
165 my ($x, $exp, $desc) = @$test;
170 if (ref $exp eq 'Regexp') {
171 like $err, $exp, "could not $desc";
172 fail "$desc placeholder $_" for 1 .. 3;
174 is $err, '', "$desc doesn't croak";
175 isa_ok $z, Z(), "$desc returns a Z object";
177 isa_ok $x, X(), "$desc stores an X into the Z object";
178 is $x->id, $exp, "$desc correctly";