t/020_attributes/011_more_attr_delegation.t

   1 #!/usr/bin/perl
   2 # This is automatically generated by author/import-moose-test.pl.
   3 # DO NOT EDIT THIS FILE. ANY CHANGES WILL BE LOST!!!
   4 use t::lib::MooseCompat;
   5
   6 use strict;
   7 use warnings;
   8
   9 use Test::More;
  10 use Test::Exception;
  11
  12 =pod
  13
  14 This tests the more complex
  15 delegation cases and that they
  16 do not fail at compile time.
  17
  18 =cut
  19
  20 {
  21
  22     package ChildASuper;
  23     use Mouse;
  24
  25     sub child_a_super_method { "as" }
  26
  27     package ChildA;
  28     use Mouse;
  29
  30     extends "ChildASuper";
  31
  32     sub child_a_method_1 { "a1" }
  33     sub child_a_method_2 { Scalar::Util::blessed($_[0]) . " a2" }
  34
  35     package ChildASub;
  36     use Mouse;
  37
  38     extends "ChildA";
  39
  40     sub child_a_method_3 { "a3" }
  41
  42     package ChildB;
  43     use Mouse;
  44
  45     sub child_b_method_1 { "b1" }
  46     sub child_b_method_2 { "b2" }
  47     sub child_b_method_3 { "b3" }
  48
  49     package ChildC;
  50     use Mouse;
  51
  52     sub child_c_method_1 { "c1" }
  53     sub child_c_method_2 { "c2" }
  54     sub child_c_method_3_la { "c3" }
  55     sub child_c_method_4_la { "c4" }
  56
  57     package ChildD;
  58     use Mouse;
  59
  60     sub child_d_method_1 { "d1" }
  61     sub child_d_method_2 { "d2" }
  62
  63     package ChildE;
  64     # no Mouse
  65
  66     sub new { bless {}, shift }
  67     sub child_e_method_1 { "e1" }
  68     sub child_e_method_2 { "e2" }
  69
  70     package ChildF;
  71     # no Mouse
  72
  73     sub new { bless {}, shift }
  74     sub child_f_method_1 { "f1" }
  75     sub child_f_method_2 { "f2" }
  76
  77     package ChildG;
  78     use Mouse;
  79
  80     sub child_g_method_1 { "g1" }
  81
  82     package ChildH;
  83     use Mouse;
  84
  85     sub child_h_method_1 { "h1" }
  86     sub parent_method_1 { "child_parent_1" }
  87
  88     package ChildI;
  89     use Mouse;
  90
  91     sub child_i_method_1 { "i1" }
  92     sub parent_method_1 { "child_parent_1" }
  93
  94     package Parent;
  95     use Mouse;
  96
  97     sub parent_method_1 { "parent_1" }
  98     ::can_ok('Parent', 'parent_method_1');
  99
 100     ::dies_ok {
 101         has child_a => (
 102             is      => "ro",
 103             default => sub { ChildA->new },
 104             handles => qr/.*/,
 105         );
 106     } "all_methods requires explicit isa";
 107
 108     ::lives_ok {
 109         has child_a => (
 110             isa     => "ChildA",
 111             is      => "ro",
 112             default => sub { ChildA->new },
 113             handles => qr/.*/,
 114         );
 115     } "allow all_methods with explicit isa";
 116
 117     ::lives_ok {
 118         has child_b => (
 119             is      => 'ro',
 120             default => sub { ChildB->new },
 121             handles => [qw/child_b_method_1/],
 122         );
 123     } "don't need to declare isa if method list is predefined";
 124
 125     ::lives_ok {
 126         has child_c => (
 127             isa     => "ChildC",
 128             is      => "ro",
 129             default => sub { ChildC->new },
 130             handles => qr/_la$/,
 131         );
 132     } "can declare regex collector";
 133
 134     ::dies_ok {
 135         has child_d => (
 136             is      => "ro",
 137             default => sub { ChildD->new },
 138             handles => sub {
 139                 my ( $class, $delegate_class ) = @_;
 140             }
 141         );
 142     } "can't create attr with generative handles parameter and no isa";
 143
 144     ::lives_ok {
 145         has child_d => (
 146             isa     => "ChildD",
 147             is      => "ro",
 148             default => sub { ChildD->new },
 149             handles => sub {
 150                 my ( $class, $delegate_class ) = @_;
 151                 return;
 152             }
 153         );
 154     } "can't create attr with generative handles parameter and no isa";
 155
 156     ::lives_ok {
 157         has child_e => (
 158             isa     => "ChildE",
 159             is      => "ro",
 160             default => sub { ChildE->new },
 161             handles => ["child_e_method_2"],
 162         );
 163     } "can delegate to non moose class using explicit method list";
 164
 165     my $delegate_class;
 166     ::lives_ok {
 167         has child_f => (
 168             isa     => "ChildF",
 169             is      => "ro",
 170             default => sub { ChildF->new },
 171             handles => sub {
 172                 $delegate_class = $_[1]->name;
 173                 return;
 174             },
 175         );
 176     } "subrefs on non moose class give no meta";
 177
 178     ::is( $delegate_class, "ChildF", "plain classes are handed down to subs" );
 179
 180     ::lives_ok {
 181         has child_g => (
 182             isa     => "ChildG",
 183             default => sub { ChildG->new },
 184             handles => ["child_g_method_1"],
 185         );
 186     } "can delegate to object even without explicit reader";
 187
 188     ::can_ok('Parent', 'parent_method_1');
 189     ::dies_ok {
 190         has child_h => (
 191             isa     => "ChildH",
 192             is      => "ro",
 193             default => sub { ChildH->new },
 194             handles => sub { map { $_, $_ } $_[1]->get_all_method_names },
 195         );
 196     } "Can't override exisiting class method in delegate";
 197     ::can_ok('Parent', 'parent_method_1');
 198
 199     ::lives_ok {
 200         has child_i => (
 201             isa     => "ChildI",
 202             is      => "ro",
 203             default => sub { ChildI->new },
 204             handles => sub {
 205                 map { $_, $_ } grep { !/^parent_method_1|meta$/ }
 206                     $_[1]->get_all_method_names;
 207             },
 208         );
 209     } "Test handles code ref for skipping predefined methods";
 210
 211
 212     sub parent_method { "p" }
 213 }
 214
 215 # sanity
 216 isa_ok( my $p = Parent->new, "Parent" );
 217 isa_ok( $p->child_a, "ChildA" );
 218 isa_ok( $p->child_b, "ChildB" );
 219 isa_ok( $p->child_c, "ChildC" );
 220 isa_ok( $p->child_d, "ChildD" );
 221 isa_ok( $p->child_e, "ChildE" );
 222 isa_ok( $p->child_f, "ChildF" );
 223 isa_ok( $p->child_i, "ChildI" );
 224
 225 ok(!$p->can('child_g'), '... no child_g accessor defined');
 226 { local $TODO = 'Mouse does not install delegations atomically';
 227 ok(!$p->can('child_h'), '... no child_h accessor defined');
 228 }
 229
 230 is( $p->parent_method, "p", "parent method" );
 231 is( $p->child_a->child_a_super_method, "as", "child supermethod" );
 232 is( $p->child_a->child_a_method_1, "a1", "child method" );
 233
 234 can_ok( $p, "child_a_super_method" );
 235 can_ok( $p, "child_a_method_1" );
 236 can_ok( $p, "child_a_method_2" );
 237 ok( !$p->can( "child_a_method_3" ), "but not subclass of delegate class" );
 238
 239 is( $p->child_a_method_1, $p->child_a->child_a_method_1, "delegate behaves the same" );
 240 is( $p->child_a_method_2, "ChildA a2", "delegates are their own invocants" );
 241
 242
 243 can_ok( $p, "child_b_method_1" );
 244 ok( !$p->can("child_b_method_2"), "but not ChildB's unspecified siblings" );
 245
 246
 247 ok( !$p->can($_), "none of ChildD's methods ($_)" )
 248     for grep { /^child/ } map { $_->name } ChildD->meta->get_all_methods();
 249
 250 can_ok( $p, "child_c_method_3_la" );
 251 can_ok( $p, "child_c_method_4_la" );
 252
 253 is( $p->child_c_method_3_la, "c3", "ChildC method delegated OK" );
 254
 255 can_ok( $p, "child_e_method_2" );
 256 ok( !$p->can("child_e_method_1"), "but not child_e_method_1");
 257
 258 is( $p->child_e_method_2, "e2", "delegate to non moose class (child_e_method_2)" );
 259
 260 can_ok( $p, "child_g_method_1" );
 261 is( $p->child_g_method_1, "g1", "delegate to moose class without reader (child_g_method_1)" );
 262
 263 can_ok( $p, "child_i_method_1" );
 264 is( $p->parent_method_1, "parent_1", "delegate doesn't override existing method" );
 265
 266 done_testing;