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