t/001_mouse/019-handles.t

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