t/040_type_constraints/failing/036_match_type_operator.t

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