Commit | Line | Data |
0bbb0bd4 |
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; |