Shut up "calling new on object" warning
[gitmo/Moose.git] / t / 200_examples / 003_example.t
CommitLineData
db1ab48d 1#!/usr/bin/perl
2
3use strict;
4use warnings;
5
7ff56534 6use Test::More tests => 30;
db1ab48d 7use Test::Exception;
8
db1ab48d 9sub U {
10 my $f = shift;
11 sub { $f->($f, @_) };
12}
13
14sub Y {
15 my $f = shift;
16 U(sub { my $h = shift; sub { $f->(U($h)->())->(@_) } })->();
17}
18
19{
20 package List;
db1ab48d 21 use Moose::Role;
d03bd989 22
db1ab48d 23 has '_list' => (
24 is => 'ro',
d03bd989 25 isa => 'ArrayRef',
db1ab48d 26 init_arg => '::',
27 default => sub { [] }
28 );
d03bd989 29
db1ab48d 30 sub head { (shift)->_list->[0] }
31 sub tail {
32 my $self = shift;
f68fa9b4 33 (ref $self)->new(
d03bd989 34 '::' => [
35 @{$self->_list}[1 .. $#{$self->_list}]
db1ab48d 36 ]
37 );
d03bd989 38 }
39
db1ab48d 40 sub print {
41 join ", " => @{$_[0]->_list};
d03bd989 42 }
43
db1ab48d 44 package List::Immutable;
db1ab48d 45 use Moose::Role;
d03bd989 46
db1ab48d 47 requires 'head';
d03bd989 48 requires 'tail';
49
db1ab48d 50 sub is_empty { not defined ($_[0]->head) }
d03bd989 51
db1ab48d 52 sub length {
53 my $self = shift;
54 (::Y(sub {
55 my $redo = shift;
56 sub {
57 my ($list, $acc) = @_;
58 return $acc if $list->is_empty;
59 $redo->($list->tail, $acc + 1);
60 }
61 }))->($self, 0);
62 }
d03bd989 63
db1ab48d 64 sub apply {
65 my ($self, $function) = @_;
66 (::Y(sub {
67 my $redo = shift;
68 sub {
69 my ($list, $func, $acc) = @_;
f68fa9b4 70 return (ref $list)->new('::' => $acc)
db1ab48d 71 if $list->is_empty;
72 $redo->(
d03bd989 73 $list->tail,
db1ab48d 74 $func,
75 [ @{$acc}, $func->($list->head) ]
76 );
77 }
d03bd989 78 }))->($self, $function, []);
db1ab48d 79 }
d03bd989 80
db1ab48d 81 package My::List1;
db1ab48d 82 use Moose;
d03bd989 83
db1ab48d 84 ::lives_ok {
85 with 'List', 'List::Immutable';
86 } '... successfully composed roles together';
d03bd989 87
db1ab48d 88 package My::List2;
d03bd989 89 use Moose;
90
db1ab48d 91 ::lives_ok {
92 with 'List::Immutable', 'List';
d03bd989 93 } '... successfully composed roles together';
94
db1ab48d 95}
96
97{
98 my $coll = My::List1->new;
99 isa_ok($coll, 'My::List1');
100
101 ok($coll->does('List'), '... $coll does List');
102 ok($coll->does('List::Immutable'), '... $coll does List::Immutable');
103
104 ok($coll->is_empty, '... we have an empty collection');
d03bd989 105 is($coll->length, 0, '... we have a length of 1 for the collection');
db1ab48d 106}
107
108{
109 my $coll = My::List2->new;
110 isa_ok($coll, 'My::List2');
111
112 ok($coll->does('List'), '... $coll does List');
113 ok($coll->does('List::Immutable'), '... $coll does List::Immutable');
114
115 ok($coll->is_empty, '... we have an empty collection');
d03bd989 116 is($coll->length, 0, '... we have a length of 1 for the collection');
db1ab48d 117}
118
119{
120 my $coll = My::List1->new('::' => [ 1 .. 10 ]);
121 isa_ok($coll, 'My::List1');
122
123 ok($coll->does('List'), '... $coll does List');
124 ok($coll->does('List::Immutable'), '... $coll does List::Immutable');
125
126 ok(!$coll->is_empty, '... we do not have an empty collection');
d03bd989 127 is($coll->length, 10, '... we have a length of 10 for the collection');
128
db1ab48d 129 is($coll->print, '1, 2, 3, 4, 5, 6, 7, 8, 9, 10', '... got the right printed value');
130
131 my $coll2 = $coll->apply(sub { $_[0] * $_[0] });
132 isa_ok($coll2, 'My::List1');
d03bd989 133
134 is($coll->print, '1, 2, 3, 4, 5, 6, 7, 8, 9, 10', '... original is still the same');
135 is($coll2->print, '1, 4, 9, 16, 25, 36, 49, 64, 81, 100', '... new collection is changed');
db1ab48d 136}
137
138{
139 my $coll = My::List2->new('::' => [ 1 .. 10 ]);
140 isa_ok($coll, 'My::List2');
141
142 ok($coll->does('List'), '... $coll does List');
143 ok($coll->does('List::Immutable'), '... $coll does List::Immutable');
144
145 ok(!$coll->is_empty, '... we do not have an empty collection');
d03bd989 146 is($coll->length, 10, '... we have a length of 10 for the collection');
147
db1ab48d 148 is($coll->print, '1, 2, 3, 4, 5, 6, 7, 8, 9, 10', '... got the right printed value');
149
150 my $coll2 = $coll->apply(sub { $_[0] * $_[0] });
151 isa_ok($coll2, 'My::List2');
d03bd989 152
153 is($coll->print, '1, 2, 3, 4, 5, 6, 7, 8, 9, 10', '... original is still the same');
154 is($coll2->print, '1, 4, 9, 16, 25, 36, 49, 64, 81, 100', '... new collection is changed');
db1ab48d 155}
156
157
158
159
160
161
162
163