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 Mouse;
  44  use Mouse::Util::TypeConstraints qw<
  45   coerce from via
  46   find_type_constraint
  47   register_type_constraint
  48  >;
  49
  50  has 'id' => (
  51   is       => 'ro',
  52   isa      => 'Int',
  53   required => 1,
  54  );
  55
  56  register_type_constraint(
  57   LaTeX::TikZ::Meta::TypeConstraint::Autocoerce->new(
  58    name   => 'LaTeX::TikZ::TestX::Autocoerce',
  59    target => find_type_constraint(__PACKAGE__),
  60    mapper => sub {
  61     shift;
  62     my ($last) = $_[0] =~ /::([^:]+)$/;
  63     join '::', __PACKAGE__, "From$last";
  64    },
  65   ),
  66  );
  67
  68  coerce 'LaTeX::TikZ::TestX::Autocoerce'
  69      => from 'LaTeX::TikZ::TestX'
  70      => via { $_ };
  71
  72  coerce 'LaTeX::TikZ::TestX::Autocoerce'
  73      => from 'Int'
  74      => via { __PACKAGE__->new(id => $_) };
  75
  76  __PACKAGE__->meta->make_immutable;
  77
  78  sub main::X () { __PACKAGE__ }
  79 }
  80
  81 {
  82  package LaTeX::TikZ::TestY;
  83
  84  use Mouse;
  85
  86  has 'num' => (
  87   is       => 'ro',
  88   isa      => 'Num',
  89   required => 1,
  90  );
  91
  92  __PACKAGE__->meta->make_immutable;
  93
  94  sub main::Y () { __PACKAGE__ }
  95 }
  96
  97 {
  98  package LaTeX::TikZ::TestZ;
  99
 100  use Mouse;
 101
 102  has 'x' => (
 103   is       => 'ro',
 104   isa      => 'LaTeX::TikZ::TestX::Autocoerce',
 105   required => 1,
 106   coerce   => 1,
 107  );
 108
 109  __PACKAGE__->meta->make_immutable;
 110
 111  sub main::Z () { __PACKAGE__ }
 112 }
 113
 114 {
 115  package LaTeX::TikZ::TestW;
 116
 117  use Mouse;
 118  use Mouse::Util::TypeConstraints;
 119
 120  has 'x' => (
 121   is       => 'ro',
 122   isa      => 'LaTeX::TikZ::TestX',
 123   required => 1,
 124  );
 125
 126  coerce 'LaTeX::TikZ::TestX::Autocoerce'
 127      => from +(__PACKAGE__)
 128      => via { $_->x };
 129
 130  __PACKAGE__->meta->make_immutable;
 131
 132  sub main::W () { __PACKAGE__ }
 133 }
 134
 135 my $y = Y->new(
 136  num => '3.14159',
 137 );
 138
 139 my $y2 = Y->new(
 140  num => exp(1),
 141 );
 142
 143 my $time = time;
 144 my $x0 = X->new(
 145  id => $time,
 146 );
 147
 148 my $w = W->new(
 149  x => $x0,
 150 );
 151
 152 my @tests = (
 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'   ],
 160 );
 161
 162 for my $test (@tests) {
 163  my ($x, $exp, $desc) = @$test;
 164  my $z = eval {
 165   Z->new(x => $x);
 166  };
 167  my $err = $@;
 168  if (ref $exp eq 'Regexp') {
 169   like $err, $exp, "could not $desc";
 170   fail "$desc placeholder $_" for 1 .. 3;
 171  } else {
 172   is     $err,   '',   "$desc doesn't croak";
 173   isa_ok $z,     Z(),  "$desc returns a Z object";
 174   $x = $z->x;
 175   isa_ok $x,     X(),  "$desc stores an X into the Z object";
 176   is     $x->id, $exp, "$desc correctly";
 177  }
 178 }