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