t/002_basic_w_subtypes.t

   1 #!/usr/bin/perl
   2
   3 use strict;
   4 use warnings;
   5
   6 use Test::More tests => 11;
   7
   8 BEGIN {
   9     use_ok('MooseX::Storage');
  10 }
  11
  12 =pod
  13
  14 This extends the 001_basic test to
  15 show that subtypes will DWIM in most
  16 cases.
  17
  18 =cut
  19
  20 {
  21
  22     package Foo;
  23     use Moose;
  24     use Moose::Util::TypeConstraints;
  25     use MooseX::Storage;
  26
  27     use Scalar::Util 'looks_like_number';
  28
  29     with Storage;
  30
  31     subtype 'Natural'
  32         => as 'Int'
  33         => where { $_ > 0 };
  34
  35     subtype 'HalfNum'
  36         => as 'Num'
  37         => where { "$_" =~ /\.5$/ };
  38
  39     subtype 'FooString'
  40         => as 'Str'
  41         => where { lc($_) eq 'foo' };
  42
  43     subtype 'IntArray'
  44         => as 'ArrayRef'
  45         => where { scalar grep { looks_like_number($_) } @{$_} };
  46
  47     subtype 'UndefHash'
  48         => as 'HashRef'
  49         => where { scalar grep { !defined($_) } values %{$_} };
  50
  51     has 'number' => ( is => 'ro', isa => 'Natural' );
  52     has 'string' => ( is => 'ro', isa => 'FooString' );
  53     has 'float'  => ( is => 'ro', isa => 'HalfNum' );
  54     has 'array'  => ( is => 'ro', isa => 'IntArray' );
  55     has 'hash'   => ( is => 'ro', isa => 'UndefHash' );
  56     has 'object' => ( is => 'ro', isa => 'Foo' );
  57 }
  58
  59 {
  60     my $foo = Foo->new(
  61         number => 10,
  62         string => 'foo',
  63         float  => 10.5,
  64         array  => [ 1 .. 10 ],
  65         hash   => { map { $_ => undef } ( 1 .. 10 ) },
  66         object => Foo->new( number => 2 ),
  67     );
  68     isa_ok( $foo, 'Foo' );
  69
  70     is_deeply(
  71         $foo->pack,
  72         {
  73             __CLASS__ => 'Foo',
  74             number    => 10,
  75             string    => 'foo',
  76             float     => 10.5,
  77             array     => [ 1 .. 10 ],
  78             hash      => { map { $_ => undef } ( 1 .. 10 ) },
  79             object    => {
  80                             __CLASS__ => 'Foo',
  81                             number    => 2
  82                          },
  83         },
  84         '... got the right frozen class'
  85     );
  86 }
  87
  88 {
  89     my $foo = Foo->unpack(
  90         {
  91             __CLASS__ => 'Foo',
  92             number    => 10,
  93             string    => 'foo',
  94             float     => 10.5,
  95             array     => [ 1 .. 10 ],
  96             hash      => { map { $_ => undef } ( 1 .. 10 ) },
  97             object    => {
  98                             __CLASS__ => 'Foo',
  99                             number    => 2
 100                          },
 101         }
 102     );
 103     isa_ok( $foo, 'Foo' );
 104
 105     is( $foo->number, 10,    '... got the right number' );
 106     is( $foo->string, 'foo', '... got the right string' );
 107     is( $foo->float,  10.5,  '... got the right float' );
 108     is_deeply( $foo->array, [ 1 .. 10 ], '... got the right array' );
 109     is_deeply(
 110         $foo->hash,
 111         { map { $_ => undef } ( 1 .. 10 ) },
 112         '... got the right hash'
 113     );
 114
 115     isa_ok( $foo->object, 'Foo' );
 116     is( $foo->object->number, 2,
 117         '... got the right number (in the embedded object)' );
 118 }