t-failing/040_type_constraints/036_match_type_operator.t

   1 #!/usr/bin/perl
   2 # This is automatically generated by author/import-moose-test.pl.
   3 # DO NOT EDIT THIS FILE. ANY CHANGES WILL BE LOST!!!
   4 use t::lib::MooseCompat;
   5
   6 use strict;
   7 use warnings;
   8
   9 use Test::More;
  10 $TODO = q{Mouse is not yet completed};
  11 use Test::Exception;
  12
  13 use Mouse::Util::TypeConstraints;
  14
  15 # some simple type dispatching ...
  16
  17 subtype 'Null'
  18     => as 'ArrayRef'
  19     => where { scalar @{$_} == 0 };
  20
  21 sub head {
  22     match_on_type @_ =>
  23         Null => sub { die "Cannot get the head of Null" },
  24     ArrayRef => sub { $_->[0] };
  25 }
  26
  27 sub tail {
  28     match_on_type @_ =>
  29         Null => sub { die "Cannot get the tail of Null" },
  30     ArrayRef => sub { [ @{ $_ }[ 1 .. $#{ $_ } ] ] };
  31 }
  32
  33 sub len {
  34     match_on_type @_ =>
  35         Null => sub { 0 },
  36     ArrayRef => sub { len( tail( $_ ) ) + 1 };
  37 }
  38
  39 sub rev {
  40     match_on_type @_ =>
  41         Null => sub { [] },
  42     ArrayRef => sub { [ @{ rev( tail( $_ ) ) }, head( $_ ) ] };
  43 }
  44
  45 is( len( [] ), 0, '... got the right length');
  46 is( len( [ 1 ] ), 1, '... got the right length');
  47 is( len( [ 1 .. 5 ] ), 5, '... got the right length');
  48 is( len( [ 1 .. 50 ] ), 50, '... got the right length');
  49
  50 is_deeply(
  51     rev( [ 1 .. 5 ] ),
  52     [ reverse 1 .. 5 ],
  53     '... got the right reversed value'
  54 );
  55
  56 # break down a Maybe Type ...
  57
  58 sub break_it_down {
  59     match_on_type shift,
  60         'Maybe[Str]' => sub {
  61             match_on_type $_ =>
  62                 'Undef' => sub { 'undef' },
  63                   'Str' => sub { $_      }
  64         },
  65         sub { 'default' }
  66 }
  67
  68
  69 is( break_it_down( 'FOO' ), 'FOO', '... got the right value');
  70 is( break_it_down( [] ), 'default', '... got the right value');
  71 is( break_it_down( undef ), 'undef', '... got the right value');
  72 is( break_it_down(), 'undef', '... got the right value');
  73
  74 # checking against enum types
  75
  76 enum RGB  => qw[ red green blue ];
  77 enum CMYK => qw[ cyan magenta yellow black ];
  78
  79 sub is_acceptable_color {
  80     match_on_type shift,
  81         'RGB'  => sub { 'RGB'              },
  82         'CMYK' => sub { 'CMYK'             },
  83                   sub { die "bad color $_" };
  84 }
  85
  86 is( is_acceptable_color( 'blue' ), 'RGB', '... got the right value');
  87 is( is_acceptable_color( 'green' ), 'RGB', '... got the right value');
  88 is( is_acceptable_color( 'red' ), 'RGB', '... got the right value');
  89 is( is_acceptable_color( 'cyan' ), 'CMYK', '... got the right value');
  90 is( is_acceptable_color( 'magenta' ), 'CMYK', '... got the right value');
  91 is( is_acceptable_color( 'yellow' ), 'CMYK', '... got the right value');
  92 is( is_acceptable_color( 'black' ), 'CMYK', '... got the right value');
  93
  94 dies_ok {
  95     is_acceptable_color( 'orange' )
  96 } '... got the exception';
  97
  98 ## using it in an OO context
  99
 100 {
 101     package LinkedList;
 102     use Mouse;
 103     use Mouse::Util::TypeConstraints;
 104
 105     has 'next' => (
 106         is        => 'ro',
 107         isa       => __PACKAGE__,
 108         lazy      => 1,
 109         default   => sub { __PACKAGE__->new },
 110         predicate => 'has_next'
 111     );
 112
 113     sub pprint {
 114         my $list = shift;
 115         match_on_type $list =>
 116             subtype(
 117                  as 'LinkedList',
 118               where { ! $_->has_next }
 119                        ) => sub { '[]' },
 120             'LinkedList' => sub { '[' . $_->next->pprint . ']' };
 121     }
 122 }
 123
 124 my $l = LinkedList->new;
 125 is($l->pprint, '[]', '... got the right pprint');
 126 $l->next;
 127 is($l->pprint, '[[]]', '... got the right pprint');
 128 $l->next->next;
 129 is($l->pprint, '[[[]]]', '... got the right pprint');
 130 $l->next->next->next;
 131 is($l->pprint, '[[[[]]]]', '... got the right pprint');
 132
 133 # basic data dumper
 134
 135 {
 136     package Foo;
 137     use Mouse;
 138
 139     sub to_string { 'Foo()' }
 140 }
 141
 142 use B;
 143
 144 sub ppprint {
 145     my $x = shift;
 146     match_on_type $x =>
 147         HashRef   => sub {
 148             my $hash = shift;
 149             '{ ' . (join ", " => map {
 150                         $_ . ' => ' . ppprint( $hash->{ $_ } )
 151                     } sort keys %$hash ) . ' }'                         },
 152         ArrayRef  => sub {
 153             my $array = shift;
 154             '[ ' . (join ", " => map { ppprint( $_ ) } @$array ) . ' ]' },
 155         CodeRef   => sub { 'sub { ... }'                                },
 156         RegexpRef => sub { 'qr/' . $_ . '/'                             },
 157         GlobRef   => sub { '*' . B::svref_2object($_)->NAME             },
 158         Object    => sub { $_->can('to_string') ? $_->to_string : $_    },
 159         ScalarRef => sub { '\\' . ppprint( ${$_} )                      },
 160         Num       => sub { $_                                           },
 161         Str       => sub { '"'. $_ . '"'                                },
 162         Undef     => sub { 'undef'                                      },
 163                   => sub { die "I don't know what $_ is"                };
 164 }
 165
 166 is(
 167     ppprint(
 168         {
 169             one   => [ 1, 2, "three", 4, "five", \(my $x = "six") ],
 170             two   => undef,
 171             three => sub { "OH HAI" },
 172             four  => qr/.*?/,
 173             five  => \*ppprint,
 174             six   => Foo->new,
 175         }
 176     ),
 177     '{ five => *ppprint, four => qr/(?-xism:.*?)/, one => [ 1, 2, "three", 4, "five", \"six" ], six => Foo(), three => sub { ... }, two => undef }',
 178     '... got the right pretty printed values'
 179 );
 180
 181 # simple JSON serializer
 182
 183 sub to_json {
 184     my $x = shift;
 185     match_on_type $x =>
 186         HashRef   => sub {
 187             my $hash = shift;
 188             '{ ' . (join ", " => map {
 189                         '"' . $_ . '" : ' . to_json( $hash->{ $_ } )
 190                     } sort keys %$hash ) . ' }'                         },
 191         ArrayRef  => sub {
 192             my $array = shift;
 193             '[ ' . (join ", " => map { to_json( $_ ) } @$array ) . ' ]' },
 194         Num       => sub { $_                                           },
 195         Str       => sub { '"'. $_ . '"'                                },
 196         Undef     => sub { 'null'                                       },
 197                   => sub { die "$_ is not acceptable json type"         };
 198 }
 199
 200 is(
 201     to_json( { one => 1, two => 2 } ),
 202     '{ "one" : 1, "two" : 2 }',
 203     '... got our valid JSON'
 204 );
 205
 206 is(
 207     to_json( {
 208         one   => [ 1, 2, 3, 4 ],
 209         two   => undef,
 210         three => "Hello World"
 211     } ),
 212     '{ "one" : [ 1, 2, 3, 4 ], "three" : "Hello World", "two" : null }',
 213     '... got our valid JSON'
 214 );
 215
 216
 217 # some error cases
 218
 219 sub not_enough_matches {
 220     my $x = shift;
 221     match_on_type $x =>
 222         Undef => sub { 'hello undef world'          },
 223       CodeRef => sub { $_->('Hello code ref world') };
 224 }
 225
 226 throws_ok {
 227     not_enough_matches( [] )
 228 } qr/No cases matched for /, '... not enough matches';
 229
 230 done_testing;