Commit | Line | Data |
51212d90 |
1 | #!/usr/bin/perl |
2 | |
3 | # This adapted from the tutorial here: |
4 | # http://www.stonehenge.com/merlyn/LinuxMag/col94.html |
5 | # The Moose is Flying (part 1)' |
6 | # Using Mouse, instead |
7 | |
8 | # use feature ':5.10'; |
9 | |
10 | |
11 | use strict; |
12 | use warnings; |
49a56bba |
13 | use Test::More; |
14 | |
51212d90 |
15 | # functions to capture the output of the tutorial |
16 | our $DUMMY_STDOUT = ""; |
17 | sub dprint { $DUMMY_STDOUT .= join "", @_ }; |
18 | sub stdout { my $stdout = $DUMMY_STDOUT; $DUMMY_STDOUT = ""; return $stdout } |
19 | sub say { ::dprint $_, "\n" for @_ } |
20 | |
21 | ###################################################################### |
22 | # This is the tutorial, as posted by Heikki Lehvaslaiho in Mouse's RT |
23 | # ticket #42992, except with print and say modified to use the above. |
24 | |
25 | package Animal; |
26 | use Mouse::Role; |
27 | has 'name' => (is => 'rw'); |
28 | sub speak { |
29 | my $self = shift; |
30 | ::dprint $self->name, " goes ", $self->sound, "\n"; |
31 | } |
32 | requires 'sound'; |
33 | has 'color' => (is => 'rw', default => sub { shift->default_color }); |
34 | requires 'default_color'; |
35 | no Mouse::Role; |
36 | 1; |
37 | |
38 | ## Cow.pm: |
39 | package Cow; |
40 | use Mouse; |
41 | with 'Animal'; |
42 | sub default_color { 'spotted' } |
43 | sub sound { 'moooooo' } |
44 | no Mouse; |
45 | 1; |
46 | ## Horse.pm: |
47 | package Horse; |
48 | use Mouse; |
49 | with 'Animal'; |
50 | sub default_color { 'brown' } |
51 | sub sound { 'neigh' } |
52 | no Mouse; |
53 | 1; |
54 | ## Sheep.pm: |
55 | package Sheep; |
56 | use Mouse; |
57 | with 'Animal'; |
58 | sub default_color { 'black' } |
59 | sub sound { 'baaaah' } |
60 | no Mouse; |
61 | 1; |
62 | |
63 | package MouseA; |
64 | use Mouse; |
65 | with 'Animal'; |
66 | sub default_color { 'white' } |
67 | sub sound { 'squeak' } |
68 | after 'speak' => sub { |
69 | ::dprint "[but you can barely hear it!]\n"; |
70 | }; |
71 | before 'speak' => sub { |
72 | ::dprint "[Ahem]\n"; |
73 | }; |
74 | no Mouse; |
75 | 1; |
76 | |
77 | |
78 | |
79 | package Racer; |
80 | use Mouse::Role; |
81 | has $_ => (is => 'rw', default => 0) |
82 | foreach qw(wins places shows losses); |
83 | sub won { my $self = shift; $self->wins($self->wins + 1) } |
84 | sub placed { my $self = shift; $self->places($self->places + 1) } |
85 | sub showed { my $self = shift; $self->shows($self->shows + 1) } |
86 | sub lost { my $self = shift; $self->losses($self->losses + 1) } |
87 | sub standings { |
88 | my $self = shift; |
89 | join ", ", map { $self->$_ . " $_" } qw(wins places shows losses); |
90 | } |
91 | no Mouse::Role; |
92 | 1; |
93 | |
94 | |
95 | |
96 | # To create the race horse, we just mix a horse with a racer: |
97 | |
98 | package RaceHorse; |
99 | use Mouse; |
100 | extends 'Horse'; |
101 | with 'Racer'; |
102 | no Mouse; |
103 | 1; |
104 | |
105 | |
106 | ###################################################################### |
107 | # Now the tests |
108 | package main; |
49a56bba |
109 | plan tests => 5; |
51212d90 |
110 | |
111 | #use Horse; |
112 | my $talking = Horse->new(name => 'Mr. Ed'); |
113 | say $talking->name; # prints Mr. Ed |
114 | is stdout, "Mr. Ed\n"; |
115 | $talking->color("grey"); # sets the color |
116 | $talking->speak; # says "Mr. Ed goes neigh" |
117 | |
51212d90 |
118 | is stdout, <<EXPECTED; |
119 | Mr. Ed goes neigh |
120 | EXPECTED |
121 | |
122 | |
123 | #use Sheep; |
124 | my $baab = Sheep->new(color => 'white', name => 'Baab'); |
125 | $baab->speak; # prints "Baab goes baaaah" |
126 | is stdout, <<EXPECTED; |
127 | Baab goes baaaah |
128 | EXPECTED |
51212d90 |
129 | |
130 | #use MouseA |
131 | my $mickey = MouseA->new(name => 'Mickey'); |
132 | $mickey->speak; |
133 | is stdout, <<EXPECTED; |
134 | [Ahem] |
135 | Mickey goes squeak |
136 | [but you can barely hear it!] |
137 | EXPECTED |
138 | |
139 | #use RaceHorse; |
140 | my $s = RaceHorse->new(name => 'Seattle Slew'); |
141 | $s->won; $s->won; $s->won; $s->placed; $s->lost; # run some races |
142 | ::dprint $s->standings, "\n"; # 3 wins, 1 places, 0 shows, 1 losses |
143 | is stdout, <<EXPECTED; |
144 | 3 wins, 1 places, 0 shows, 1 losses |
145 | EXPECTED |
146 | |