t/001_mouse/019-handles.t

   1 #!/usr/bin/env perl
   2 use strict;
   3 use warnings;
   4 use Test::More;
   5 use Test::Exception;
   6
   7 do {
   8     package Person;
   9     use Mouse;
  10
  11     has name => (is => 'rw');
  12     has age  => (is => 'rw');
  13
  14     sub make_string {
  15         my($self, $template) = @_;
  16         return sprintf $template, $self->name;
  17     }
  18
  19     package Class;
  20     use Mouse;
  21
  22     has person => (
  23         is        => 'rw',
  24         lazy      => 1,
  25         default   => sub { Person->new(age => 37, name => "Chuck") },
  26         predicate => 'has_person',
  27         handles   => {
  28             person_name => 'name',
  29             person_age  => 'age',
  30             person_hello => [make_string => 'Hello, %s'],
  31         },
  32     );
  33
  34     has me => (
  35         is  => 'rw',
  36         isa => 'Person',
  37         default => sub { Person->new(age => 21, name => "Shawn") },
  38         predicate => 'quid',
  39         handles => [qw/name age/],
  40     );
  41
  42 };
  43
  44 can_ok(Class => qw(person has_person person_name person_age name age quid));
  45
  46 my $object = Class->new;
  47 ok(!$object->has_person, "don't have a person yet");
  48 $object->person_name("Todd");
  49 ok($object->has_person, "calling person_name instantiated person");
  50 ok($object->person, "we really do have a person");
  51
  52 is($object->person_name, "Todd", "handles method");
  53 is($object->person->name, "Todd", "traditional lookup");
  54 is($object->person_age, 37, "handles method");
  55 is($object->person->age, 37, "traditional lookup");
  56 is($object->person_hello, 'Hello, Todd', 'curring');
  57
  58 my $object2 = Class->new(person => Person->new(name => "Philbert"));
  59 ok($object2->has_person, "we have a person from the constructor");
  60 is($object2->person_name, "Philbert", "handles method");
  61 is($object2->person->name, "Philbert", "traditional lookup");
  62 is($object2->person_age, undef, "no age because we didn't use the default");
  63 is($object2->person->age, undef, "no age because we didn't use the default");
  64 is($object2->person_hello, 'Hello, Philbert', 'currying');
  65
  66 ok($object->quid, "we have a Shawn");
  67 is($object->name, "Shawn", "name handle");
  68 is($object->age, 21, "age handle");
  69 is($object->me->name, "Shawn", "me->name");
  70 is($object->me->age, 21, "me->age");
  71
  72 is_deeply(
  73     $object->meta->get_attribute('me')->handles,
  74     [ 'name', 'age' ],
  75     "correct handles layout for 'me'",
  76 );
  77
  78 is_deeply(
  79     $object->meta->get_attribute('person')->handles,
  80     { person_name => 'name', person_age => 'age', person_hello => [make_string => 'Hello, %s']},
  81     "correct handles layout for 'person'",
  82 );
  83
  84 throws_ok{
  85     $object->person(undef);
  86     $object->person_name();
  87 } qr/Cannot delegate person_name to name because the value of person is not defined/;
  88
  89 throws_ok{
  90     $object->person([]);
  91     $object->person_age();
  92 } qr/Cannot delegate person_age to age because the value of person is not an object/;
  93
  94 throws_ok{
  95     $object->person(undef);
  96     $object->person_name();
  97 } qr/Cannot delegate person_name to name because the value of person is not defined/;
  98
  99 throws_ok{
 100     $object->person([]);
 101     $object->person_age();
 102 } qr/Cannot delegate person_age to age because the value of person is not an object/;
 103
 104
 105 done_testing;
 106