t/attributes/more_attr_delegation.t

   1 #!/usr/bin/perl
   2
   3 use strict;
   4 use warnings;
   5
   6 use Test::More;
   7 use Test::Fatal;
   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 Moose;
  21
  22     sub child_a_super_method { "as" }
  23
  24     package ChildA;
  25     use Moose;
  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 Moose;
  34
  35     extends "ChildA";
  36
  37     sub child_a_method_3 { "a3" }
  38
  39     package ChildB;
  40     use Moose;
  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 Moose;
  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 Moose;
  56
  57     sub child_d_method_1 { "d1" }
  58     sub child_d_method_2 { "d2" }
  59
  60     package ChildE;
  61     # no Moose
  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 Moose
  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 Moose;
  76
  77     sub child_g_method_1 { "g1" }
  78
  79     package ChildH;
  80     use Moose;
  81
  82     sub child_h_method_1 { "h1" }
  83     sub parent_method_1 { "child_parent_1" }
  84
  85     package ChildI;
  86     use Moose;
  87
  88     sub child_i_method_1 { "i1" }
  89     sub parent_method_1 { "child_parent_1" }
  90
  91     package Parent;
  92     use Moose;
  93
  94     sub parent_method_1 { "parent_1" }
  95     ::can_ok('Parent', 'parent_method_1');
  96
  97     ::isnt( ::exception {
  98         has child_a => (
  99             is      => "ro",
 100             default => sub { ChildA->new },
 101             handles => qr/.*/,
 102         );
 103     }, undef, "all_methods requires explicit isa" );
 104
 105     ::is( ::exception {
 106         has child_a => (
 107             isa     => "ChildA",
 108             is      => "ro",
 109             default => sub { ChildA->new },
 110             handles => qr/.*/,
 111         );
 112     }, undef, "allow all_methods with explicit isa" );
 113
 114     ::is( ::exception {
 115         has child_b => (
 116             is      => 'ro',
 117             default => sub { ChildB->new },
 118             handles => [qw/child_b_method_1/],
 119         );
 120     }, undef, "don't need to declare isa if method list is predefined" );
 121
 122     ::is( ::exception {
 123         has child_c => (
 124             isa     => "ChildC",
 125             is      => "ro",
 126             default => sub { ChildC->new },
 127             handles => qr/_la$/,
 128         );
 129     }, undef, "can declare regex collector" );
 130
 131     ::isnt( ::exception {
 132         has child_d => (
 133             is      => "ro",
 134             default => sub { ChildD->new },
 135             handles => sub {
 136                 my ( $class, $delegate_class ) = @_;
 137             }
 138         );
 139     }, undef, "can't create attr with generative handles parameter and no isa" );
 140
 141     ::is( ::exception {
 142         has child_d => (
 143             isa     => "ChildD",
 144             is      => "ro",
 145             default => sub { ChildD->new },
 146             handles => sub {
 147                 my ( $class, $delegate_class ) = @_;
 148                 return;
 149             }
 150         );
 151     }, undef, "can't create attr with generative handles parameter and no isa" );
 152
 153     ::is( ::exception {
 154         has child_e => (
 155             isa     => "ChildE",
 156             is      => "ro",
 157             default => sub { ChildE->new },
 158             handles => ["child_e_method_2"],
 159         );
 160     }, undef, "can delegate to non moose class using explicit method list" );
 161
 162     my $delegate_class;
 163     ::is( ::exception {
 164         has child_f => (
 165             isa     => "ChildF",
 166             is      => "ro",
 167             default => sub { ChildF->new },
 168             handles => sub {
 169                 $delegate_class = $_[1]->name;
 170                 return;
 171             },
 172         );
 173     }, undef, "subrefs on non moose class give no meta" );
 174
 175     ::is( $delegate_class, "ChildF", "plain classes are handed down to subs" );
 176
 177     ::is( ::exception {
 178         has child_g => (
 179             isa     => "ChildG",
 180             default => sub { ChildG->new },
 181             handles => ["child_g_method_1"],
 182         );
 183     }, undef, "can delegate to object even without explicit reader" );
 184
 185     ::can_ok('Parent', 'parent_method_1');
 186     ::isnt( ::exception {
 187         has child_h => (
 188             isa     => "ChildH",
 189             is      => "ro",
 190             default => sub { ChildH->new },
 191             handles => sub { map { $_, $_ } $_[1]->get_all_method_names },
 192         );
 193     }, undef, "Can't override exisiting class method in delegate" );
 194     ::can_ok('Parent', 'parent_method_1');
 195
 196     ::is( ::exception {
 197         has child_i => (
 198             isa     => "ChildI",
 199             is      => "ro",
 200             default => sub { ChildI->new },
 201             handles => sub {
 202                 map { $_, $_ } grep { !/^parent_method_1|meta$/ }
 203                     $_[1]->get_all_method_names;
 204             },
 205         );
 206     }, undef, "Test handles code ref for skipping predefined methods" );
 207
 208
 209     sub parent_method { "p" }
 210 }
 211
 212 # sanity
 213
 214 isa_ok( my $p = Parent->new, "Parent" );
 215 isa_ok( $p->child_a, "ChildA" );
 216 isa_ok( $p->child_b, "ChildB" );
 217 isa_ok( $p->child_c, "ChildC" );
 218 isa_ok( $p->child_d, "ChildD" );
 219 isa_ok( $p->child_e, "ChildE" );
 220 isa_ok( $p->child_f, "ChildF" );
 221 isa_ok( $p->child_i, "ChildI" );
 222
 223 ok(!$p->can('child_g'), '... no child_g accessor defined');
 224 ok(!$p->can('child_h'), '... no child_h accessor defined');
 225
 226
 227 is( $p->parent_method, "p", "parent method" );
 228 is( $p->child_a->child_a_super_method, "as", "child supermethod" );
 229 is( $p->child_a->child_a_method_1, "a1", "child method" );
 230
 231 can_ok( $p, "child_a_super_method" );
 232 can_ok( $p, "child_a_method_1" );
 233 can_ok( $p, "child_a_method_2" );
 234 ok( !$p->can( "child_a_method_3" ), "but not subclass of delegate class" );
 235
 236 is( $p->child_a_method_1, $p->child_a->child_a_method_1, "delegate behaves the same" );
 237 is( $p->child_a_method_2, "ChildA a2", "delegates are their own invocants" );
 238
 239
 240 can_ok( $p, "child_b_method_1" );
 241 ok( !$p->can("child_b_method_2"), "but not ChildB's unspecified siblings" );
 242
 243
 244 ok( !$p->can($_), "none of ChildD's methods ($_)" )
 245     for grep { /^child/ } map { $_->name } ChildD->meta->get_all_methods();
 246
 247 can_ok( $p, "child_c_method_3_la" );
 248 can_ok( $p, "child_c_method_4_la" );
 249
 250 is( $p->child_c_method_3_la, "c3", "ChildC method delegated OK" );
 251
 252 can_ok( $p, "child_e_method_2" );
 253 ok( !$p->can("child_e_method_1"), "but not child_e_method_1");
 254
 255 is( $p->child_e_method_2, "e2", "delegate to non moose class (child_e_method_2)" );
 256
 257 can_ok( $p, "child_g_method_1" );
 258 is( $p->child_g_method_1, "g1", "delegate to moose class without reader (child_g_method_1)" );
 259
 260 can_ok( $p, "child_i_method_1" );
 261 is( $p->parent_method_1, "parent_1", "delegate doesn't override existing method" );
 262
 263 done_testing;