t/000-recipes/002_schwartz_tutorial.t

   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