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     ::lives_ok {
 127         has child_d => (
 128             isa     => "ChildD",
 129             is      => "ro",
 130             default => sub { ChildD->new },
 131             handles => sub {
 132                 my ( $class, $delegate_class ) = @_;
 133                 return;
 134             }
 135         );
 136     } "can't create attr with generative handles parameter and no isa";
 137
 138     ::lives_ok {
 139         has child_e => (
 140             isa     => "ChildE",
 141             is      => "ro",
 142             default => sub { ChildE->new },
 143             handles => ["child_e_method_2"],
 144         );
 145     } "can delegate to non moose class using explicit method list";
 146
 147     my $delegate_class;
 148     ::lives_ok {
 149         has child_f => (
 150             isa     => "ChildF",
 151             is      => "ro",
 152             default => sub { ChildF->new },
 153             handles => sub {
 154                 $delegate_class = $_[1]->name;
 155                 return;
 156             },
 157         );
 158     } "subrefs on non moose class give no meta";
 159
 160     ::is( $delegate_class, "ChildF", "plain classes are handed down to subs" );
 161
 162     ::lives_ok {
 163         has child_g => (
 164             isa     => "ChildG",
 165             default => sub { ChildG->new },
 166             handles => ["child_g_method_1"],
 167         );
 168     } "can delegate to object even without explicit reader";
 169
 170     sub parent_method { "p" }
 171 }
 172
 173 # sanity
 174
 175 isa_ok( my $p = Parent->new, "Parent" );
 176 isa_ok( $p->child_a, "ChildA" );
 177 isa_ok( $p->child_b, "ChildB" );
 178 isa_ok( $p->child_c, "ChildC" );
 179 isa_ok( $p->child_d, "ChildD" );
 180 isa_ok( $p->child_e, "ChildE" );
 181 isa_ok( $p->child_f, "ChildF" );
 182
 183 ok(!$p->can('child_g'), '... no child_g accessor defined');
 184
 185
 186 is( $p->parent_method, "p", "parent method" );
 187 is( $p->child_a->child_a_super_method, "as", "child supermethod" );
 188 is( $p->child_a->child_a_method_1, "a1", "child method" );
 189
 190 can_ok( $p, "child_a_super_method" );
 191 can_ok( $p, "child_a_method_1" );
 192 can_ok( $p, "child_a_method_2" );
 193 ok( !$p->can( "child_a_method_3" ), "but not subclass of delegate class" );
 194
 195 is( $p->child_a_method_1, $p->child_a->child_a_method_1, "delegate behaves the same" );
 196 is( $p->child_a_method_2, "ChildA a2", "delegates are their own invocants" );
 197
 198
 199 can_ok( $p, "child_b_method_1" );
 200 ok( !$p->can("child_b_method_2"), "but not ChildB's unspecified siblings" );
 201
 202
 203 ok( !$p->can($_), "none of ChildD's methods ($_)" )
 204     for grep { /^child/ } map { $_->name } ChildD->meta->get_all_methods();
 205
 206 can_ok( $p, "child_c_method_3_la" );
 207 can_ok( $p, "child_c_method_4_la" );
 208
 209 is( $p->child_c_method_3_la, "c3", "ChildC method delegated OK" );
 210
 211 can_ok( $p, "child_e_method_2" );
 212 ok( !$p->can("child_e_method_1"), "but not child_e_method_1");
 213
 214 is( $p->child_e_method_2, "e2", "delegate to non moose class (child_e_method_2)" );
 215
 216 can_ok( $p, "child_g_method_1" );
 217 is( $p->child_g_method_1, "g1", "delegate to moose class without reader (child_g_method_1)" );