t/070_delegation.t

   1 #!/usr/bin/perl
   2
   3 use strict;
   4 use warnings;
   5
   6 use Test::More tests => 36;
   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 Parent;
  67     use Moose;
  68
  69     ::dies_ok {
  70         has child_a => (
  71             is      => "ro",
  72             default => sub { ChildA->new },
  73             handles => all_methods,
  74         );
  75     } "all_methods requires explicit isa";
  76
  77     ::lives_ok {
  78         has child_a => (
  79             isa     => "ChildA",
  80             is      => "ro",
  81             default => sub { ChildA->new },
  82             handles => all_methods,
  83         );
  84     } "allow all_methods with explicit isa";
  85
  86     ::lives_ok {
  87         has child_b => (
  88             default => sub { ChildB->new },
  89             handles => [qw/child_b_method_1/],
  90         );
  91     } "don't need to declare isa if method list is predefined";
  92
  93     ::lives_ok {
  94         has child_c => (
  95             isa     => "ChildC",
  96             is      => "ro",
  97             default => sub { ChildC->new },
  98             handles => qr/_la$/,
  99         );
 100     } "can declare regex collector";
 101
 102     ::dies_ok {
 103         has child_d => (
 104             is      => "ro",
 105             default => sub { ChildD->new },
 106             handles => sub {
 107                 my ( $class, $delegate_class ) = @_;
 108             }
 109         );
 110     } "can't create attr with generative handles parameter and no isa";
 111
 112     ::lives_ok {
 113         has child_d => (
 114             isa     => "ChildD",
 115             is      => "ro",
 116             default => sub { ChildD->new },
 117             handles => sub {
 118                 my ( $class, $delegate_class ) = @_;
 119                 return;
 120             }
 121         );
 122     } "can't create attr with generative handles parameter and no isa";
 123
 124     ::lives_ok {
 125         has child_e => (
 126             isa     => "ChildE",
 127             is      => "ro",
 128             default => sub { ChildE->new },
 129             handles => "child_e_method_2",
 130         );
 131     } "can delegate to non moose class using explicit method list";
 132
 133     ::dies_ok {
 134         has child_f => (
 135             isa     => "ChildF",
 136             is      => "ro",
 137             default => sub { ChildF->new },
 138             handles => qr/.*/,
 139         );
 140     } "can't use regexes on foreign classes";
 141
 142     my $delegate_class;
 143     ::lives_ok {
 144         has child_f => (
 145             isa     => "ChildF",
 146             is      => "ro",
 147             default => sub { ChildF->new },
 148             handles => sub {
 149                 $delegate_class = $_[1];
 150             },
 151         );
 152     } "subrefs on non moose class give no meta";
 153
 154     ::is( $delegate_class, "ChildF", "plain classes are handed down to subs" );
 155
 156     sub parent_method { "p" }
 157 }
 158
 159 # sanity
 160
 161 isa_ok( my $p = Parent->new, "Parent" );
 162 isa_ok( $p->child_a, "ChildA" );
 163 ok( !$p->can("child_b"), "no child b accessor" );
 164 isa_ok( $p->child_c, "ChildC" );
 165 isa_ok( $p->child_d, "ChildD" );
 166 isa_ok( $p->child_e, "ChildE" );
 167 isa_ok( $p->child_f, "ChildF" );
 168
 169
 170 is( $p->parent_method, "p", "parent method" );
 171 is( $p->child_a->child_a_super_method, "as", "child supermethod" );
 172 is( $p->child_a->child_a_method_1, "a1", "child method" );
 173
 174 can_ok( $p, "child_a_super_method" );
 175 can_ok( $p, "child_a_method_1" );
 176 can_ok( $p, "child_a_method_2" );
 177 ok( !$p->can( "child_a_method_3" ), "but not subclass of delegate class" );
 178
 179 is( $p->child_a_method_1, $p->child_a->child_a_method_1, "delegate behaves the same" );
 180 is( $p->child_a_method_2, "ChildA a2", "delegates are their own invocants" );
 181
 182
 183 can_ok( $p, "child_b_method_1" );
 184 ok( !$p->can("child_b_method_2"), "but not ChildB's unspecified siblings" );
 185
 186
 187 ok( !$p->can($_), "none of ChildD's methods ($_)" )
 188     for grep { /^child/ } map { $_->{name} } ChildD->meta->compute_all_applicable_methods();
 189
 190 can_ok( $p, "child_c_method_3_la" );
 191 can_ok( $p, "child_c_method_4_la" );
 192
 193 is( $p->child_c_method_3_la, "c3", "ChildC method delegated OK" );
 194
 195 can_ok( $p, "child_e_method_2" );
 196 ok( !$p->can("child_e_method_1"), "but not child_e_method_1");
 197
 198 is( $p->child_e_method_2, "e2", "delegate to non moose class (child_e_method_2)" );