Commit | Line | Data |
e1bb45ff |
1 | #!/usr/bin/perl |
2 | |
3 | use strict; |
4 | use warnings; |
5 | |
8d8356bb |
6 | use Test::More tests => 11; |
e1bb45ff |
7 | |
8 | BEGIN { |
9 | use_ok('MooseX::Storage'); |
10 | } |
11 | |
95f31c36 |
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 | |
e1bb45ff |
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 | |
913d96dd |
29 | with Storage; |
e1bb45ff |
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 | { |
ba5bba75 |
73 | __CLASS__ => 'Foo', |
e1bb45ff |
74 | number => 10, |
75 | string => 'foo', |
76 | float => 10.5, |
77 | array => [ 1 .. 10 ], |
78 | hash => { map { $_ => undef } ( 1 .. 10 ) }, |
79 | object => { |
ba5bba75 |
80 | __CLASS__ => 'Foo', |
e1bb45ff |
81 | number => 2 |
82 | }, |
83 | }, |
84 | '... got the right frozen class' |
85 | ); |
86 | } |
87 | |
88 | { |
89 | my $foo = Foo->unpack( |
90 | { |
ba5bba75 |
91 | __CLASS__ => 'Foo', |
e1bb45ff |
92 | number => 10, |
93 | string => 'foo', |
94 | float => 10.5, |
95 | array => [ 1 .. 10 ], |
96 | hash => { map { $_ => undef } ( 1 .. 10 ) }, |
97 | object => { |
ba5bba75 |
98 | __CLASS__ => 'Foo', |
e1bb45ff |
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 | } |