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