t/020_attributes/011_more_attr_delegation.t

   1 #!/usr/bin/perl
   2
   3 use strict;
   4 use warnings;
   5
   6 use Test::More tests => 39;
   7 use Test::Exception;
   8
   9 =pod
  10
  11 This tests the more complex
  12 delegation cases and that they
  13 do not fail at compile time.
  14
  15 =cut
  16
  17 {
  18
  19     package ChildASuper;
  20     use Mouse;
  21
  22     sub child_a_super_method { "as" }
  23
  24     package ChildA;
  25     use Mouse;
  26
  27     extends "ChildASuper";
  28
  29     sub child_a_method_1 { "a1" }
  30     sub child_a_method_2 { Scalar::Util::blessed($_[0]) . " a2" }
  31
  32     package ChildASub;
  33     use Mouse;
  34
  35     extends "ChildA";
  36
  37     sub child_a_method_3 { "a3" }
  38
  39     package ChildB;
  40     use Mouse;
  41
  42     sub child_b_method_1 { "b1" }
  43     sub child_b_method_2 { "b2" }
  44     sub child_b_method_3 { "b3" }
  45
  46     package ChildC;
  47     use Mouse;
  48
  49     sub child_c_method_1 { "c1" }
  50     sub child_c_method_2 { "c2" }
  51     sub child_c_method_3_la { "c3" }
  52     sub child_c_method_4_la { "c4" }
  53
  54     package ChildD;
  55     use Mouse;
  56
  57     sub child_d_method_1 { "d1" }
  58     sub child_d_method_2 { "d2" }
  59
  60     package ChildE;
  61     # no Mouse
  62
  63     sub new { bless {}, shift }
  64     sub child_e_method_1 { "e1" }
  65     sub child_e_method_2 { "e2" }
  66
  67     package ChildF;
  68     # no Mouse
  69
  70     sub new { bless {}, shift }
  71     sub child_f_method_1 { "f1" }
  72     sub child_f_method_2 { "f2" }
  73
  74     package ChildG;
  75     use Mouse;
  76
  77     sub child_g_method_1 { "g1" }
  78
  79     package Parent;
  80     use Mouse;
  81
  82     ::dies_ok {
  83         has child_a => (
  84             is      => "ro",
  85             default => sub { ChildA->new },
  86             handles => qr/.*/,
  87         );
  88     } "all_methods requires explicit isa";
  89
  90     ::lives_ok {
  91         has child_a => (
  92             isa     => "ChildA",
  93             is      => "ro",
  94             default => sub { ChildA->new },
  95             handles => qr/.*/,
  96         );
  97     } "allow all_methods with explicit isa";
  98
  99     ::lives_ok {
 100         has child_b => (
 101             is      => 'ro',
 102             default => sub { ChildB->new },
 103             handles => [qw/child_b_method_1/],
 104         );
 105     } "don't need to declare isa if method list is predefined";
 106
 107     ::lives_ok {
 108         has child_c => (
 109             isa     => "ChildC",
 110             is      => "ro",
 111             default => sub { ChildC->new },
 112             handles => qr/_la$/,
 113         );
 114     } "can declare regex collector";
 115
 116     ::dies_ok {
 117         has child_d => (
 118             is      => "ro",
 119             default => sub { ChildD->new },
 120             handles => sub {
 121                 my ( $class, $delegate_class ) = @_;
 122             }
 123         );
 124     } "can't create attr with generative handles parameter and no isa";
 125
 126     our $TODO;
 127 {
 128     local $TODO = 'handles => CODE is not supported';
 129     ::lives_ok {
 130         has child_d => (
 131             isa     => "ChildD",
 132             is      => "ro",
 133             default => sub { ChildD->new },
 134             handles => sub {
 135                 my ( $class, $delegate_class ) = @_;
 136                 return;
 137             }
 138         );
 139     } "can't create attr with generative handles parameter and no isa";
 140 }
 141
 142     ::lives_ok {
 143         has child_e => (
 144             isa     => "ChildE",
 145             is      => "ro",
 146             default => sub { ChildE->new },
 147             handles => ["child_e_method_2"],
 148         );
 149     } "can delegate to non moose class using explicit method list";
 150
 151 {
 152     local $TODO = 'handles => CODE is not supported';
 153     my $delegate_class;
 154     ::lives_ok {
 155         has child_f => (
 156             isa     => "ChildF",
 157             is      => "ro",
 158             default => sub { ChildF->new },
 159             handles => sub {
 160                 $delegate_class = $_[1]->name;
 161                 return;
 162             },
 163         );
 164     } "subrefs on non moose class give no meta";
 165
 166     ::is( $delegate_class, "ChildF", "plain classes are handed down to subs" );
 167 }
 168
 169     ::lives_ok {
 170         has child_g => (
 171             isa     => "ChildG",
 172             default => sub { ChildG->new },
 173             handles => ["child_g_method_1"],
 174         );
 175     } "can delegate to object even without explicit reader";
 176
 177     sub parent_method { "p" }
 178 }
 179
 180 # sanity
 181
 182 isa_ok( my $p = Parent->new, "Parent" );
 183 isa_ok( $p->child_a, "ChildA" );
 184 isa_ok( $p->child_b, "ChildB" );
 185 isa_ok( $p->child_c, "ChildC" );
 186 isa_ok( $p->child_d, "ChildD" );
 187 isa_ok( $p->child_e, "ChildE" );
 188 isa_ok( $p->child_f, "ChildF" );
 189
 190 ok(!$p->can('child_g'), '... no child_g accessor defined');
 191
 192
 193 is( $p->parent_method, "p", "parent method" );
 194 is( $p->child_a->child_a_super_method, "as", "child supermethod" );
 195 is( $p->child_a->child_a_method_1, "a1", "child method" );
 196
 197 can_ok( $p, "child_a_super_method" );
 198 can_ok( $p, "child_a_method_1" );
 199 can_ok( $p, "child_a_method_2" );
 200 ok( !$p->can( "child_a_method_3" ), "but not subclass of delegate class" );
 201
 202 is( $p->child_a_method_1, $p->child_a->child_a_method_1, "delegate behaves the same" );
 203 is( $p->child_a_method_2, "ChildA a2", "delegates are their own invocants" );
 204
 205
 206 can_ok( $p, "child_b_method_1" );
 207 ok( !$p->can("child_b_method_2"), "but not ChildB's unspecified siblings" );
 208
 209
 210 ok( !$p->can($_), "none of ChildD's methods ($_)" )
 211     for grep { /^child/ } map { $_->name } ChildD->meta->get_all_methods();
 212
 213 can_ok( $p, "child_c_method_3_la" );
 214 can_ok( $p, "child_c_method_4_la" );
 215
 216 is( $p->child_c_method_3_la, "c3", "ChildC method delegated OK" );
 217
 218 can_ok( $p, "child_e_method_2" );
 219 ok( !$p->can("child_e_method_1"), "but not child_e_method_1");
 220
 221 is( $p->child_e_method_2, "e2", "delegate to non moose class (child_e_method_2)" );
 222
 223 can_ok( $p, "child_g_method_1" );
 224 is( $p->child_g_method_1, "g1", "delegate to moose class without reader (child_g_method_1)" );