class-mop says 'The compute_all_applicable_attributes method has been deprecated.'

[gitmo/Mouse.git] / t / 000-recipes / 002_schwartz_tutorial.t

#!/usr/bin/perl

# This adapted from the tutorial here:
# http://www.stonehenge.com/merlyn/LinuxMag/col94.html
# The Moose is Flying (part 1)'
# Using Mouse, instead

# use feature ':5.10';


use strict;
use warnings;

# functions to capture the output of the tutorial
our $DUMMY_STDOUT = "";
sub dprint { $DUMMY_STDOUT .= join "", @_ };
sub stdout { my $stdout = $DUMMY_STDOUT; $DUMMY_STDOUT = ""; return $stdout }
sub say    { ::dprint $_, "\n" for @_ }

######################################################################
# This is the tutorial, as posted by Heikki Lehvaslaiho in Mouse's RT
# ticket #42992, except with print and say modified to use the above.

package Animal;
use Mouse::Role;
has 'name' => (is => 'rw');
sub speak {
    my $self = shift;
    ::dprint $self->name, " goes ", $self->sound, "\n";
}
requires 'sound';
has 'color' => (is => 'rw', default => sub { shift->default_color });
requires 'default_color';
no Mouse::Role;
1;

## Cow.pm:
package Cow;
use Mouse;
with 'Animal';
sub default_color { 'spotted' }
sub sound { 'moooooo' }
no Mouse;
1;
## Horse.pm:
package Horse;
use Mouse;
with 'Animal';
sub default_color { 'brown' }
sub sound { 'neigh' }
no Mouse;
1;
## Sheep.pm:
package Sheep;
use Mouse;
with 'Animal';
sub default_color { 'black' }
sub sound { 'baaaah' }
no Mouse;
1;

package MouseA;
use Mouse;
with 'Animal';
sub default_color { 'white' }
sub sound { 'squeak' }
after 'speak' => sub {
    ::dprint "[but you can barely hear it!]\n";
};
before 'speak' => sub {
    ::dprint "[Ahem]\n";
};
no Mouse;
1;



package Racer;
use Mouse::Role;
has $_ => (is => 'rw', default => 0)
    foreach qw(wins places shows losses);
sub won { my $self = shift; $self->wins($self->wins + 1) }
sub placed { my $self = shift; $self->places($self->places + 1) }
sub showed { my $self = shift; $self->shows($self->shows + 1) }
sub lost { my $self = shift; $self->losses($self->losses + 1) }
sub standings {
    my $self = shift;
    join ", ", map { $self->$_ . " $_" } qw(wins places shows losses);
}
no Mouse::Role;
1;



# To create the race horse, we just mix a horse with a racer:

package RaceHorse;
use Mouse;
extends 'Horse';
with 'Racer';
no Mouse;
1;


######################################################################
# Now the tests
package main;
use Test::More tests => 5;

#use Horse;
my $talking = Horse->new(name => 'Mr. Ed');
say $talking->name;             # prints Mr. Ed
is stdout, "Mr. Ed\n";
$talking->color("grey");        # sets the color
$talking->speak;                # says "Mr. Ed goes neigh"

TODO: { local $TODO = "this currently fails because of a bug in Class::Method::Modifiers (see RT #42992)";
is stdout, <<EXPECTED;
Mr. Ed goes neigh
EXPECTED


#use Sheep;
my $baab = Sheep->new(color => 'white', name => 'Baab');
$baab->speak;                   # prints "Baab goes baaaah"
is stdout, <<EXPECTED;
Baab goes baaaah
EXPECTED
    }

#use MouseA
my $mickey = MouseA->new(name => 'Mickey');
$mickey->speak;
is stdout, <<EXPECTED;
[Ahem]
Mickey goes squeak
[but you can barely hear it!]
EXPECTED

#use RaceHorse;
my $s = RaceHorse->new(name => 'Seattle Slew');
$s->won; $s->won; $s->won; $s->placed; $s->lost; # run some races
::dprint $s->standings, "\n";      # 3 wins, 1 places, 0 shows, 1 losses
is stdout, <<EXPECTED;
3 wins, 1 places, 0 shows, 1 losses
EXPECTED