+++ /dev/null
-#!/usr/bin/perl
-# This is automatically generated by author/import-moose-test.pl.
-# DO NOT EDIT THIS FILE. ANY CHANGES WILL BE LOST!!!
-use t::lib::MooseCompat;
-
-use strict;
-use warnings;
-
-use Test::More;
-$TODO = q{Mouse is not yet completed};
-use Test::Exception;
-
-use Mouse::Util::TypeConstraints;
-
-# some simple type dispatching ...
-
-subtype 'Null'
- => as 'ArrayRef'
- => where { scalar @{$_} == 0 };
-
-sub head {
- match_on_type @_ =>
- Null => sub { die "Cannot get the head of Null" },
- ArrayRef => sub { $_->[0] };
-}
-
-sub tail {
- match_on_type @_ =>
- Null => sub { die "Cannot get the tail of Null" },
- ArrayRef => sub { [ @{ $_ }[ 1 .. $#{ $_ } ] ] };
-}
-
-sub len {
- match_on_type @_ =>
- Null => sub { 0 },
- ArrayRef => sub { len( tail( $_ ) ) + 1 };
-}
-
-sub rev {
- match_on_type @_ =>
- Null => sub { [] },
- ArrayRef => sub { [ @{ rev( tail( $_ ) ) }, head( $_ ) ] };
-}
-
-is( len( [] ), 0, '... got the right length');
-is( len( [ 1 ] ), 1, '... got the right length');
-is( len( [ 1 .. 5 ] ), 5, '... got the right length');
-is( len( [ 1 .. 50 ] ), 50, '... got the right length');
-
-is_deeply(
- rev( [ 1 .. 5 ] ),
- [ reverse 1 .. 5 ],
- '... got the right reversed value'
-);
-
-# break down a Maybe Type ...
-
-sub break_it_down {
- match_on_type shift,
- 'Maybe[Str]' => sub {
- match_on_type $_ =>
- 'Undef' => sub { 'undef' },
- 'Str' => sub { $_ }
- },
- sub { 'default' }
-}
-
-
-is( break_it_down( 'FOO' ), 'FOO', '... got the right value');
-is( break_it_down( [] ), 'default', '... got the right value');
-is( break_it_down( undef ), 'undef', '... got the right value');
-is( break_it_down(), 'undef', '... got the right value');
-
-# checking against enum types
-
-enum RGB => qw[ red green blue ];
-enum CMYK => qw[ cyan magenta yellow black ];
-
-sub is_acceptable_color {
- match_on_type shift,
- 'RGB' => sub { 'RGB' },
- 'CMYK' => sub { 'CMYK' },
- sub { die "bad color $_" };
-}
-
-is( is_acceptable_color( 'blue' ), 'RGB', '... got the right value');
-is( is_acceptable_color( 'green' ), 'RGB', '... got the right value');
-is( is_acceptable_color( 'red' ), 'RGB', '... got the right value');
-is( is_acceptable_color( 'cyan' ), 'CMYK', '... got the right value');
-is( is_acceptable_color( 'magenta' ), 'CMYK', '... got the right value');
-is( is_acceptable_color( 'yellow' ), 'CMYK', '... got the right value');
-is( is_acceptable_color( 'black' ), 'CMYK', '... got the right value');
-
-dies_ok {
- is_acceptable_color( 'orange' )
-} '... got the exception';
-
-## using it in an OO context
-
-{
- package LinkedList;
- use Mouse;
- use Mouse::Util::TypeConstraints;
-
- has 'next' => (
- is => 'ro',
- isa => __PACKAGE__,
- lazy => 1,
- default => sub { __PACKAGE__->new },
- predicate => 'has_next'
- );
-
- sub pprint {
- my $list = shift;
- match_on_type $list =>
- subtype(
- as 'LinkedList',
- where { ! $_->has_next }
- ) => sub { '[]' },
- 'LinkedList' => sub { '[' . $_->next->pprint . ']' };
- }
-}
-
-my $l = LinkedList->new;
-is($l->pprint, '[]', '... got the right pprint');
-$l->next;
-is($l->pprint, '[[]]', '... got the right pprint');
-$l->next->next;
-is($l->pprint, '[[[]]]', '... got the right pprint');
-$l->next->next->next;
-is($l->pprint, '[[[[]]]]', '... got the right pprint');
-
-# basic data dumper
-
-{
- package Foo;
- use Mouse;
-
- sub to_string { 'Foo()' }
-}
-
-use B;
-
-sub ppprint {
- my $x = shift;
- match_on_type $x =>
- HashRef => sub {
- my $hash = shift;
- '{ ' . (join ", " => map {
- $_ . ' => ' . ppprint( $hash->{ $_ } )
- } sort keys %$hash ) . ' }' },
- ArrayRef => sub {
- my $array = shift;
- '[ ' . (join ", " => map { ppprint( $_ ) } @$array ) . ' ]' },
- CodeRef => sub { 'sub { ... }' },
- RegexpRef => sub { 'qr/' . $_ . '/' },
- GlobRef => sub { '*' . B::svref_2object($_)->NAME },
- Object => sub { $_->can('to_string') ? $_->to_string : $_ },
- ScalarRef => sub { '\\' . ppprint( ${$_} ) },
- Num => sub { $_ },
- Str => sub { '"'. $_ . '"' },
- Undef => sub { 'undef' },
- => sub { die "I don't know what $_ is" };
-}
-
-is(
- ppprint(
- {
- one => [ 1, 2, "three", 4, "five", \(my $x = "six") ],
- two => undef,
- three => sub { "OH HAI" },
- four => qr/.*?/,
- five => \*ppprint,
- six => Foo->new,
- }
- ),
- '{ five => *ppprint, four => qr/(?-xism:.*?)/, one => [ 1, 2, "three", 4, "five", \"six" ], six => Foo(), three => sub { ... }, two => undef }',
- '... got the right pretty printed values'
-);
-
-# simple JSON serializer
-
-sub to_json {
- my $x = shift;
- match_on_type $x =>
- HashRef => sub {
- my $hash = shift;
- '{ ' . (join ", " => map {
- '"' . $_ . '" : ' . to_json( $hash->{ $_ } )
- } sort keys %$hash ) . ' }' },
- ArrayRef => sub {
- my $array = shift;
- '[ ' . (join ", " => map { to_json( $_ ) } @$array ) . ' ]' },
- Num => sub { $_ },
- Str => sub { '"'. $_ . '"' },
- Undef => sub { 'null' },
- => sub { die "$_ is not acceptable json type" };
-}
-
-is(
- to_json( { one => 1, two => 2 } ),
- '{ "one" : 1, "two" : 2 }',
- '... got our valid JSON'
-);
-
-is(
- to_json( {
- one => [ 1, 2, 3, 4 ],
- two => undef,
- three => "Hello World"
- } ),
- '{ "one" : [ 1, 2, 3, 4 ], "three" : "Hello World", "two" : null }',
- '... got our valid JSON'
-);
-
-
-# some error cases
-
-sub not_enough_matches {
- my $x = shift;
- match_on_type $x =>
- Undef => sub { 'hello undef world' },
- CodeRef => sub { $_->('Hello code ref world') };
-}
-
-throws_ok {
- not_enough_matches( [] )
-} qr/No cases matched for /, '... not enough matches';
-
-done_testing;
projects / gitmo/Mouse.git / blobdiff