t/001_mouse/028-subclass-attr.t

   1 #!/usr/bin/env perl
   2 use strict;
   3 use warnings;
   4 use Test::More tests => 11;
   5
   6 do {
   7     package Class;
   8     use Mouse;
   9
  10     has class => (
  11         is  => 'rw',
  12         isa => 'Bool',
  13     );
  14
  15     package Child;
  16     use Mouse;
  17     extends 'Class';
  18
  19     has child => (
  20         is  => 'rw',
  21         isa => 'Bool',
  22     );
  23 };
  24
  25 my $obj = Child->new(class => 1, child => 1);
  26 ok($obj->child, "local attribute set in constructor");
  27 ok($obj->class, "inherited attribute set in constructor");
  28
  29 is_deeply([sort(Child->meta->get_all_attributes)], [sort(
  30     Child->meta->get_attribute('child'),
  31     Class->meta->get_attribute('class'),
  32 )], "correct get_all_attributes");
  33
  34 do {
  35     package Foo;
  36     use Mouse;
  37
  38     has attr => (
  39         is      => 'ro',
  40         default => 'Foo',
  41     );
  42
  43     package Bar;
  44     use Mouse;
  45     extends 'Foo';
  46
  47     has attr => (
  48         is => 'rw',
  49     );
  50 };
  51
  52 my $foo = Foo->new;
  53 is($foo->attr, 'Foo', 'subclass does not affect parent attr');
  54
  55 my $bar = Bar->new;
  56 is($bar->attr, undef, 'new attribute does not have the new default');
  57
  58 is(Foo->meta->get_attribute('attr')->default, 'Foo');
  59 is(Foo->meta->get_attribute('attr')->_is_metadata, 'ro');
  60
  61 is(Bar->meta->get_attribute('attr')->default, undef);
  62 is(Bar->meta->get_attribute('attr')->_is_metadata, 'rw');
  63
  64 is_deeply([Foo->meta->get_all_attributes], [
  65     Foo->meta->get_attribute('attr'),
  66 ], "correct get_all_attributes");
  67
  68 is_deeply([Bar->meta->get_all_attributes], [
  69     Bar->meta->get_attribute('attr'),
  70 ], "correct get_all_attributes");
  71