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