t/001_mouse/027-modifiers.t

   1 #!perl -T
   2 use strict;
   3 use warnings;
   4
   5 use Test::More tests => 25;
   6
   7 my @seen;
   8 my @expected = ("before 4",
   9                   "before 3",
  10                     "around 4 before",
  11                       "around 3 before",
  12                         "before 2",
  13                           "before 1",
  14                             "around 2 before",
  15                               "around 1 before",
  16                                 "orig",
  17                               "around 1 after",
  18                             "around 2 after",
  19                           "after 1",
  20                         "after 2",
  21                       "around 3 after",
  22                     "around 4 after",
  23                   "after 3",
  24                 "after 4",
  25                );
  26
  27 my $child = Grandchild->new; $child->orig;
  28
  29 is_deeply(\@seen, \@expected, "multiple afters called in the right order");
  30
  31 BEGIN {
  32     package Parent;
  33     use Mouse;
  34
  35     sub orig {
  36         push @seen, "orig";
  37     }
  38 }
  39
  40 BEGIN {
  41     package Child;
  42     use Mouse;
  43     extends 'Parent';
  44
  45     before orig => sub {
  46         push @seen, "before 1";
  47     };
  48
  49     before orig => sub {
  50         push @seen, "before 2";
  51     };
  52
  53     around orig => sub {
  54         my $orig = shift;
  55         push @seen, "around 1 before";
  56         $orig->();
  57         push @seen, "around 1 after";
  58     };
  59
  60     around orig => sub {
  61         my $orig = shift;
  62         push @seen, "around 2 before";
  63         $orig->();
  64         push @seen, "around 2 after";
  65     };
  66
  67     after orig => sub {
  68         push @seen, "after 1";
  69     };
  70
  71     after orig => sub {
  72         push @seen, "after 2";
  73     };
  74 }
  75
  76 BEGIN {
  77     package Grandchild;
  78     use Mouse;
  79     extends 'Child';
  80
  81     before orig => sub {
  82         push @seen, "before 3";
  83     };
  84
  85     before orig => sub {
  86         push @seen, "before 4";
  87     };
  88
  89     around orig => sub {
  90         my $orig = shift;
  91         push @seen, "around 3 before";
  92         $orig->();
  93         push @seen, "around 3 after";
  94     };
  95
  96     around orig => sub {
  97         my $orig = shift;
  98         push @seen, "around 4 before";
  99         $orig->();
 100         push @seen, "around 4 after";
 101     };
 102
 103     after orig => sub {
 104         push @seen, "after 3";
 105     };
 106
 107     after orig => sub {
 108         push @seen, "after 4";
 109     };
 110 }
 111
 112 # from Class::Method::Modifers' t/020-multiple-inheritance.t
 113
 114 # inheritance tree looks like:
 115 #
 116 #    SuperL        SuperR
 117 #      \             /
 118 #      MiddleL  MiddleR
 119 #         \       /
 120 #          -Child-
 121
 122 # the Child and MiddleR modules use modifiers
 123 # Child will modify a method in SuperL (sl_c)
 124 # Child will modify a method in SuperR (sr_c)
 125 # Child will modify a method in SuperR already modified by MiddleR (sr_m_c)
 126 # SuperL and MiddleR will both have a method of the same name, doing different
 127 #     things (called 'conflict' and 'cnf_mod')
 128
 129 # every method and modifier will just return <Class:Method:STUFF>
 130
 131 BEGIN
 132 {
 133     {
 134         package SuperL;
 135         use Mouse;
 136
 137         sub superl { "<SuperL:superl>" }
 138         sub conflict { "<SuperL:conflict>" }
 139         sub cnf_mod { "<SuperL:cnf_mod>" }
 140         sub sl_c { "<SuperL:sl_c>" }
 141     }
 142
 143     {
 144         package SuperR;
 145         use Mouse;
 146
 147         sub superr { "<SuperR:superr>" }
 148         sub sr_c { "<SuperR:sr_c>" }
 149         sub sr_m_c { "<SuperR:sr_m_c>" }
 150     }
 151
 152     {
 153         package MiddleL;
 154         use Mouse;
 155         extends 'SuperL';
 156
 157         sub middlel { "<MiddleL:middlel>" }
 158     }
 159
 160     {
 161         package MiddleR;
 162         use Mouse;
 163         extends 'SuperR';
 164
 165         sub middler { "<MiddleR:middler>" }
 166         sub conflict { "<MiddleR:conflict>" }
 167         sub cnf_mod { "<MiddleR:cnf_mod>" }
 168         around sr_m_c => sub {
 169             my $orig = shift;
 170             return "<MiddleR:sr_m_c:".$orig->(@_).">"
 171         };
 172     }
 173
 174     {
 175         package Child;
 176         use Mouse;
 177         extends qw(MiddleL MiddleR);
 178
 179         sub child { "<Child:child>" }
 180         around cnf_mod => sub { "<Child:cnf_mod:".shift->(@_).">" };
 181         around sl_c => sub { "<Child:sl_c:".shift->(@_).">" };
 182         around sr_c => sub { "<Child:sr_c:".shift->(@_).">" };
 183         around sr_m_c => sub {
 184             my $orig = shift;
 185             return "<Child:sr_m_c:".$orig->(@_).">"
 186         };
 187     }
 188 }
 189
 190
 191 my $SuperL = SuperL->new();
 192 my $SuperR = SuperR->new();
 193 my $MiddleL = MiddleL->new();
 194 my $MiddleR = MiddleR->new();
 195 my $Child = Child->new();
 196
 197 is($SuperL->superl, "<SuperL:superl>", "SuperL loaded correctly");
 198 is($SuperR->superr, "<SuperR:superr>", "SuperR loaded correctly");
 199 is($MiddleL->middlel, "<MiddleL:middlel>", "MiddleL loaded correctly");
 200 is($MiddleR->middler, "<MiddleR:middler>", "MiddleR loaded correctly");
 201 is($Child->child, "<Child:child>", "Child loaded correctly");
 202
 203 is($SuperL->sl_c, "<SuperL:sl_c>", "SuperL->sl_c on SuperL");
 204 is($Child->sl_c, "<Child:sl_c:<SuperL:sl_c>>", "SuperL->sl_c wrapped by Child's around");
 205
 206 is($SuperR->sr_c, "<SuperR:sr_c>", "SuperR->sr_c on SuperR");
 207 is($Child->sr_c, "<Child:sr_c:<SuperR:sr_c>>", "SuperR->sr_c wrapped by Child's around");
 208
 209 is($SuperR->sr_m_c, "<SuperR:sr_m_c>", "SuperR->sr_m_c on SuperR");
 210 is($MiddleR->sr_m_c, "<MiddleR:sr_m_c:<SuperR:sr_m_c>>", "SuperR->sr_m_c wrapped by MiddleR's around");
 211 is($Child->sr_m_c, "<Child:sr_m_c:<MiddleR:sr_m_c:<SuperR:sr_m_c>>>", "MiddleR->sr_m_c's wrapping wrapped by Child's around");
 212
 213 is($SuperL->conflict, "<SuperL:conflict>", "SuperL->conflict on SuperL");
 214 is($MiddleR->conflict, "<MiddleR:conflict>", "MiddleR->conflict on MiddleR");
 215 is($Child->conflict, "<SuperL:conflict>", "SuperL->conflict on Child");
 216
 217 is($SuperL->cnf_mod, "<SuperL:cnf_mod>", "SuperL->cnf_mod on SuperL");
 218 is($MiddleR->cnf_mod, "<MiddleR:cnf_mod>", "MiddleR->cnf_mod on MiddleR");
 219 is($Child->cnf_mod, "<Child:cnf_mod:<SuperL:cnf_mod>>", "SuperL->cnf_mod wrapped by Child's around");
 220
 221 # taken from Class::Method::Modifiers' t/051-undef-list-ctxt.t
 222 my($orig_called, $after_called);
 223 BEGIN
 224 {
 225     package ParentX;
 226     use Mouse;
 227
 228     sub orig
 229     {
 230         my $self = shift;
 231         $orig_called = 1;
 232         return;
 233     }
 234
 235     package ChildX;
 236     use Mouse;
 237     extends 'ParentX';
 238
 239     after 'orig' => sub
 240     {
 241         $after_called = 1;
 242     };
 243 }
 244
 245 {
 246     ($after_called, $orig_called) = (0, 0);
 247     my $child = ChildX->new();
 248     my @results = $child->orig();
 249
 250     ok($orig_called, "original method called");
 251     ok($after_called, "after-modifier called");
 252     is(@results, 0, "list context with after doesn't screw up 'return'");
 253
 254     ($after_called, $orig_called) = (0, 0);
 255     my $result = $child->orig();
 256
 257     ok($orig_called, "original method called");
 258     ok($after_called, "after-modifier called");
 259     is($result, undef, "scalar context with after doesn't screw up 'return'");
 260 }