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