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