t/02-autocoerce.t

   1 #!perl -T
   2
   3 use strict;
   4 use warnings;
   5
   6 use Test::More tests => 3 + 7 * 4;
   7
   8 use lib 't/lib';
   9
  10 use LaTeX::TikZ::Meta::TypeConstraint::Autocoerce;
  11
  12 {
  13  my $tc = eval {
  14   LaTeX::TikZ::Meta::TypeConstraint::Autocoerce->new(
  15    target => undef,
  16   );
  17  };
  18  like $@, qr/^No meta object for undefined target/, 'Undef target';
  19 }
  20
  21 {
  22  my $target = 'LaTeX::TikZ::A::Class::Likely::Not::To::Exist';
  23  my $tc = eval {
  24   LaTeX::TikZ::Meta::TypeConstraint::Autocoerce->new(
  25    target => $target,
  26   );
  27  };
  28  like $@, qr/^No meta object for target \Q$target\E/, 'Nonexistent target';
  29 }
  30
  31 {
  32  my $tc = eval {
  33   LaTeX::TikZ::Meta::TypeConstraint::Autocoerce->new(
  34    target => 'LaTeX::TikZ::Meta::TypeConstraint::Autocoerce',
  35   );
  36  };
  37  is $@, '', 'Valid target';
  38 }
  39
  40 {
  41  package LaTeX::TikZ::TestX;
  42
  43  use Any::Moose;
  44  use Any::Moose 'Util::TypeConstraints' => [ qw<
  45   coerce
  46   from
  47   via
  48   find_type_constraint
  49   register_type_constraint
  50  > ];
  51
  52  has 'id' => (
  53   is       => 'ro',
  54   isa      => 'Int',
  55   required => 1,
  56  );
  57
  58  register_type_constraint(
  59   LaTeX::TikZ::Meta::TypeConstraint::Autocoerce->new(
  60    name   => 'LaTeX::TikZ::TestX::Autocoerce',
  61    target => find_type_constraint(__PACKAGE__),
  62    mapper => sub {
  63     shift;
  64     my ($last) = $_[0] =~ /::([^:]+)$/;
  65     join '::', __PACKAGE__, "From$last";
  66    },
  67   ),
  68  );
  69
  70  coerce 'LaTeX::TikZ::TestX::Autocoerce'
  71      => from 'LaTeX::TikZ::TestX'
  72      => via { $_ };
  73
  74  coerce 'LaTeX::TikZ::TestX::Autocoerce'
  75      => from 'Int'
  76      => via { __PACKAGE__->new(id => $_) };
  77
  78  __PACKAGE__->meta->make_immutable;
  79
  80  sub main::X () { __PACKAGE__ }
  81 }
  82
  83 {
  84  package LaTeX::TikZ::TestY;
  85
  86  use Any::Moose;
  87
  88  has 'num' => (
  89   is       => 'ro',
  90   isa      => 'Num',
  91   required => 1,
  92  );
  93
  94  __PACKAGE__->meta->make_immutable;
  95
  96  sub main::Y () { __PACKAGE__ }
  97 }
  98
  99 {
 100  package LaTeX::TikZ::TestZ;
 101
 102  use Any::Moose;
 103
 104  has 'x' => (
 105   is       => 'ro',
 106   isa      => 'LaTeX::TikZ::TestX::Autocoerce',
 107   required => 1,
 108   coerce   => 1,
 109  );
 110
 111  __PACKAGE__->meta->make_immutable if any_moose() ne 'Moose';
 112
 113  sub main::Z () { __PACKAGE__ }
 114 }
 115
 116 {
 117  package LaTeX::TikZ::TestW;
 118
 119  use Any::Moose;
 120  use Any::Moose 'Util::TypeConstraints';
 121
 122  has 'x' => (
 123   is       => 'ro',
 124   isa      => 'LaTeX::TikZ::TestX',
 125   required => 1,
 126  );
 127
 128  coerce 'LaTeX::TikZ::TestX::Autocoerce'
 129      => from __PACKAGE__
 130      => via { $_->x };
 131
 132  __PACKAGE__->meta->make_immutable;
 133
 134  sub main::W () { __PACKAGE__ }
 135 }
 136
 137 my $y = Y->new(
 138  num => '3.14159',
 139 );
 140
 141 my $y2 = Y->new(
 142  num => exp(1),
 143 );
 144
 145 my $time = time;
 146 my $x0 = X->new(
 147  id => $time,
 148 );
 149
 150 my $w = W->new(
 151  x => $x0,
 152 );
 153
 154 my @tests = (
 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'   ],
 162 );
 163
 164 for my $test (@tests) {
 165  my ($x, $exp, $desc) = @$test;
 166  my $z = eval {
 167   Z->new(x => $x);
 168  };
 169  my $err = $@;
 170  if (ref $exp eq 'Regexp') {
 171   like $err, $exp, "could not $desc";
 172   fail "$desc placeholder $_" for 1 .. 3;
 173  } else {
 174   is     $err,   '',   "$desc doesn't croak";
 175   isa_ok $z,     Z(),  "$desc returns a Z object";
 176   $x = $z->x;
 177   isa_ok $x,     X(),  "$desc stores an X into the Z object";
 178   is     $x->id, $exp, "$desc correctly";
 179  }
 180 }