t/070_delegation.t

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