t/02-autocoerce.t

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