This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
e0f2f13b628a022d237c0c073d529248bc8c3861
[perl5.git] / cpan / Object-Accessor / t / 00_Object-Accessor.t
1  BEGIN { chdir 't' if -d 't' };
2
3 use strict;
4 use lib '../lib';
5 use Test::More 'no_plan';
6 use Data::Dumper;
7
8 my $Class = 'Object::Accessor';
9
10 use_ok($Class);
11
12 my $Object  = $Class->new;
13 my $Acc     = 'foo';
14 my $Err_re  = qr/No such accessor '$Acc'/;
15
16 ### stupid warnings
17 ### XXX this will break warning tests though if enabled
18 $Object::Accessor::DEBUG = $Object::Accessor::DEBUG = 1 if @ARGV;
19
20
21 ### check the object
22 {   ok( $Object,                "Object of '$Class' created" );
23     isa_ok( $Object,            $Class );
24 }
25
26 ### check non existant accessor
27 {   my $warning;
28     local $SIG{__WARN__} = sub { $warning .= "@_" };
29
30     ok(!$Object->can($Acc),     "Cannot '$Acc'" );
31     ok(!$Object->$Acc(),        "   Method '$Acc' returns false" );
32     like( $warning, $Err_re,    "   Warning logged" );
33
34     ### check fatal error
35     {   local $Object::Accessor::FATAL = 1;
36         local $Object::Accessor::FATAL = 1; # stupid warnings
37
38         my $rv = eval { $Object->$Acc() };
39
40         ok( $@,                 "Cannot '$Acc' -- dies" );
41         ok(!$rv,                "   Method '$Acc' returns false" );
42         like( $@, $Err_re,      "   Fatal error logged" );
43     }
44 }
45
46 ### create an accessor;
47 {   my $warning;
48     local $SIG{__WARN__} = sub { $warning .= "@_" };
49
50     ok( $Object->mk_accessors( $Acc ),
51                                 "Accessor '$Acc' created" );
52
53     ok( $Object->can( $Acc ),   "   Can '$Acc'" );
54     ok(!$warning,               "   No warnings logged" );
55 }
56
57 ### try to use the accessor
58 {   for my $var ($0, $$) {
59
60         ok( $Object->$Acc( $var ),  "'$Acc' set to '$var'" );
61         is( $Object->$Acc(), $var,  "   '$Acc' still holds '$var'" );
62
63         my $sub = $Object->can( $Acc );
64         ok( $sub,                   "Retrieved '$Acc' coderef" );
65         isa_ok( $sub,               "CODE" );
66         is( $sub->(), $var,         "   '$Acc' via coderef holds '$var'" );
67
68         ok( $sub->(1),              "   '$Acc' set via coderef to '1'" );
69         is( $Object->$Acc(), 1,     "   '$Acc' still holds '1'" );
70     }
71 }
72
73 ### get a list of accessors
74 {   my @list = $Object->ls_accessors;
75     ok( scalar(@list),              "Accessors retrieved" );
76
77     for my $acc ( @list ) {
78         ok( $Object->can( $acc ),   "   Accessor '$acc' is valid" );
79     }
80
81     is_deeply( \@list, [$Acc],      "   Only expected accessors found" );
82 }
83
84 ### clone the original
85 {   my $clone = $Object->mk_clone;
86     my @list  = $clone->ls_accessors;
87
88     ok( $clone,                     "Clone created" );
89     isa_ok( $clone,                 $Class );
90     ok( scalar(@list),              "   Clone has accessors" );
91     is_deeply( \@list, [$Object->ls_accessors],
92                                     "   Only expected accessors found" );
93
94     for my $acc ( @list ) {
95         ok( !defined( $clone->$acc() ),
96                                     "   Accessor '$acc' is empty" );
97     }
98 }
99
100 ### flush the original values
101 {   my $val = $Object->$Acc();
102     ok( $val,                       "Objects '$Acc' has a value" );
103
104     ok( $Object->mk_flush,          "   Object flushed" );
105     ok( !$Object->$Acc(),           "   Objects '$Acc' is now empty" );
106 }
107
108 ### check that only our original object can do '$Acc'
109 {   my $warning;
110     local $SIG{__WARN__} = sub { $warning .= "@_" };
111
112     my $other = $Class->new;
113
114
115     ok(!$other->can($Acc),          "Cannot '$Acc' via other object" );
116     ok(!$other->$Acc(),             "   Method '$Acc' returns false" );
117     like( $warning, $Err_re,        "   Warning logged" );
118 }
119
120 ### check if new() passes it's args correctly
121 {   my $obj = $Class->new( $Acc );
122     ok( $obj,                       "Object created with accessors" );
123     isa_ok( $obj,                   $Class );
124     can_ok( $obj,                   $Acc );
125 }
126
127 1;