t/05-pod-examples.t

   1 use strict;
   2 use warnings;
   3
   4 use Test::More;
   5
   6 {
   7     package Test::MooseX::Types::Parameterizable::Synopsis;
   8
   9     use Moose;
  10     use MooseX::Types::Parameterizable qw(Parameterizable);
  11     use MooseX::Types::Moose qw(Str Int ArrayRef);
  12     use MooseX::Types -declare=>[qw(Varchar)];
  13
  14     ## Create a type constraint that is a string but parameterizes an integer
  15     ## that is used as a maximum length constraint on that string, similar to
  16     ## an SQL Varchar type.
  17
  18     subtype Varchar,
  19       as Parameterizable[Str,Int],
  20       where {
  21         my($string, $int) = @_;
  22         $int >= length($string) ? 1:0;
  23       },
  24       message { "'$_' is too long"  };
  25
  26     coerce Varchar,
  27       from ArrayRef,
  28       via {
  29         my ($arrayref, $int) = @_;
  30         join('', @$arrayref);
  31       };
  32
  33     my $varchar_five = Varchar[5];
  34
  35     Test::More::ok $varchar_five->check('four');
  36     Test::More::ok ! $varchar_five->check('verylongstrong');
  37
  38     my $varchar_ten = Varchar[10];
  39
  40     Test::More::ok $varchar_ten->check( 'X' x 9 );
  41     Test::More::ok ! $varchar_ten->check( 'X' x 12 );
  42
  43     has varchar_five => (isa=>Varchar[5], is=>'ro', coerce=>1);
  44     has varchar_ten => (isa=>Varchar[10], is=>'ro');
  45
  46     my $object1 = __PACKAGE__->new(
  47         varchar_five => '1234',
  48         varchar_ten => '123456789',
  49     );
  50
  51     eval {
  52         my $object2 = __PACKAGE__->new(
  53             varchar_five => '12345678',
  54             varchar_ten => '123456789',
  55         );
  56     };
  57
  58     Test::More::ok $@, 'There was an error';
  59     Test::More::like $@, qr('12345678' is too long), 'Correct custom error';
  60
  61     my $object3 = __PACKAGE__->new(
  62         varchar_five => [qw/aa bb/],
  63         varchar_ten => '123456789',
  64     );
  65
  66     Test::More::is $object3->varchar_five, 'aabb',
  67       'coercion as expected';
  68 }
  69
  70 done_testing;
  71
  72
  73 __END__
  74
  75 use MooseX::Types -declare=>[qw(Set UniqueInt PositiveSet PositiveUniqueInt )];
  76
  77 subtype Set,
  78   as class_type("Set::Scalar");
  79
  80 subtype UniqueInt,
  81   as Parameterizable[Int, Set],
  82   where {
  83     my ($int, $set) = @_;
  84     !$set->has($int);
  85   };
  86
  87 subtype PositiveSet,
  88   as Set,
  89   where {
  90     my ($set) = @_;
  91     ! grep { $_ < 0 } $set->members;
  92   };
  93
  94 subtype PositiveUniqueInt,
  95   as UniqueInt[PositiveSet];
  96
  97 my $set = Set::Scalar->new(-1,-2,1,2,3);
  98 my $positive_set = Set::Scalar->new(1,2,3);
  99 my $negative_set = Set::Scalar->new(-1,-2,-3);
 100
 101 ok Set->check($set),
 102  'Is a Set';
 103
 104 ok Set->check($positive_set),
 105  'Is a Set';
 106
 107 ok Set->check($negative_set),
 108  'Is a Set';
 109
 110 ok !PositiveSet->check($set),
 111  'Is Not a Positive Set';
 112
 113 ok PositiveSet->check($positive_set),
 114  'Is a Positive Set';
 115
 116 ok !PositiveSet->check($negative_set),
 117  'Is Not a Positive Set';
 118
 119 ok UniqueInt([$set])->check(100),
 120  '100 not in Set';
 121
 122 ok UniqueInt([$positive_set])->check(100),
 123  '100 not in Set';
 124
 125 ok UniqueInt([$negative_set])->check(100),
 126  '100 not in Set';
 127
 128 ok UniqueInt([$set])->check(-99),
 129  '-99 not in Set';
 130
 131 ok UniqueInt([$positive_set])->check(-99),
 132  '-99 not in Set';
 133
 134 ok UniqueInt([$negative_set])->check(-99),
 135   '-99 not in Set';
 136
 137 ok !UniqueInt([$set])->check(2),
 138  '2 in Set';
 139
 140 ok !UniqueInt([$positive_set])->check(2),
 141  '2 in Set';
 142
 143 ok UniqueInt([$negative_set])->check(2),
 144   '2 not in Set';
 145
 146
 147 __END__
 148
 149 ok UniqueInt([$set])->check(100);  ## Okay, 100 isn't in (1,2,3)
 150 ok UniqueInt([$set])->check(-99);  ## Okay, -99 isn't in (1,2,3)
 151 ok !UniqueInt([$set])->check(2);  ## Not OK, 2 is in (1,2,3)
 152
 153 ok PositiveUniqueInt([$set])->check(100);  ## Okay, 100 isn't in (1,2,3)
 154 ok !PositiveUniqueInt([$set])->check(-99);  ## Not OK, -99 not Positive Int
 155 ok !PositiveUniqueInt([$set])->check(2);  ## Not OK, 2 is in (1,2,3)
 156
 157 my $negative_set = Set::Scalar->new(-1,-2,-3);
 158
 159 ok UniqueInt([$negative_set])->check(100);  ## Throws exception
 160