t/019-handles.t

   1 #!/usr/bin/env perl
   2 use strict;
   3 use warnings;
   4 use Test::More tests => 28;
   5 use Test::Exception;
   6
   7 do {
   8     package Person;
   9
  10     sub new {
  11         my $class = shift;
  12         my %args  = @_;
  13
  14         bless \%args, $class;
  15     }
  16
  17     sub name { $_[0]->{name} = $_[1] if @_ > 1; $_[0]->{name} }
  18     sub age { $_[0]->{age} = $_[1] if @_ > 1; $_[0]->{age} }
  19
  20     package Class;
  21     use Mouse;
  22
  23     has person => (
  24         is        => 'rw',
  25         lazy      => 1,
  26         default   => sub { Person->new(age => 37, name => "Chuck") },
  27         predicate => 'has_person',
  28         handles   => {
  29             person_name => 'name',
  30             person_age  => 'age',
  31         },
  32     );
  33
  34     has me => (
  35         is => 'rw',
  36         default => sub { Person->new(age => 21, name => "Shawn") },
  37         predicate => 'quid',
  38         handles => [qw/name age/],
  39     );
  40
  41     TODO: {
  42         local our $TODO = "Mouse lacks this";
  43         eval {
  44             has error => (
  45                 handles => "string",
  46             );
  47         };
  48         ::ok(!$@, "handles => role");
  49     }
  50
  51     TODO: {
  52         local our $TODO = "Mouse lacks this";
  53         eval {
  54             has error2 => (
  55                 handles => \"ref_to_string",
  56             );
  57         };
  58         ::ok(!$@, "handles => \\str");
  59     }
  60
  61     TODO: {
  62         local our $TODO = "Mouse lacks this";
  63         eval {
  64             has error3 => (
  65                 handles => qr/regex/,
  66             );
  67         };
  68         ::ok(!$@, "handles => qr/re/");
  69     }
  70
  71     TODO: {
  72         local our $TODO = "Mouse lacks this";
  73         eval {
  74             has error4 => (
  75                 handles => sub { "code" },
  76             );
  77         };
  78         ::ok(!$@, "handles => sub { code }");
  79     }
  80 };
  81
  82 can_ok(Class => qw(person has_person person_name person_age name age quid));
  83
  84 my $object = Class->new;
  85 ok(!$object->has_person, "don't have a person yet");
  86 $object->person_name("Todd");
  87 ok($object->has_person, "calling person_name instantiated person");
  88 ok($object->person, "we really do have a person");
  89
  90 is($object->person_name, "Todd", "handles method");
  91 is($object->person->name, "Todd", "traditional lookup");
  92 is($object->person_age, 37, "handles method");
  93 is($object->person->age, 37, "traditional lookup");
  94
  95 my $object2 = Class->new(person => Person->new(name => "Philbert"));
  96 ok($object2->has_person, "we have a person from the constructor");
  97 is($object2->person_name, "Philbert", "handles method");
  98 is($object2->person->name, "Philbert", "traditional lookup");
  99 is($object2->person_age, undef, "no age because we didn't use the default");
 100 is($object2->person->age, undef, "no age because we didn't use the default");
 101
 102
 103 ok($object->quid, "we have a Shawn");
 104 is($object->name, "Shawn", "name handle");
 105 is($object->age, 21, "age handle");
 106 is($object->me->name, "Shawn", "me->name");
 107 is($object->me->age, 21, "me->age");
 108
 109 is_deeply(
 110     $object->meta->get_attribute('me')->handles,
 111     [ 'name', 'age' ],
 112     "correct handles layout for 'me'",
 113 );
 114
 115 is_deeply(
 116     $object->meta->get_attribute('person')->handles,
 117     { person_name => 'name', person_age => 'age' },
 118     "correct handles layout for 'person'",
 119 );
 120
 121
 122 {
 123     local $TODO = "failed on some environment, but I don't know why it happens (gfx)";
 124     throws_ok{
 125         $object->person(undef);
 126         $object->person_name();
 127     } qr/Cannot delegate person_name to name because the value of person is not defined/;
 128
 129     throws_ok{
 130         $object->person([]);
 131         $object->person_age();
 132     } qr/Cannot delegate person_age to age because the value of person is not an object/;
 133 }
 134
 135 eval{
 136     $object->person(undef);
 137     $object->person_name();
 138 };
 139 like $@, qr/Cannot delegate person_name to name because the value of person is not defined/;
 140
 141 eval{
 142     $object->person([]);
 143     $object->person_age();
 144 };
 145 like $@, qr/Cannot delegate person_age to age because the value of person is not an object/;
 146
 147