1 BEGIN { chdir 't' if -d 't' };
5 use Test::More 'no_plan';
8 my $Class = 'Object::Accessor';
12 my $Object = $Class->new;
14 my $Err_re = qr/No such accessor '$Acc'/;
17 ### XXX this will break warning tests though if enabled
18 $Object::Accessor::DEBUG = $Object::Accessor::DEBUG = 1 if @ARGV;
22 { ok( $Object, "Object of '$Class' created" );
23 isa_ok( $Object, $Class );
26 ### check non existant accessor
28 local $SIG{__WARN__} = sub { $warning .= "@_" };
30 ok(!$Object->can($Acc), "Cannot '$Acc'" );
31 ok(!$Object->$Acc(), " Method '$Acc' returns false" );
32 like( $warning, $Err_re, " Warning logged" );
35 { local $Object::Accessor::FATAL = 1;
36 local $Object::Accessor::FATAL = 1; # stupid warnings
38 my $rv = eval { $Object->$Acc() };
40 ok( $@, "Cannot '$Acc' -- dies" );
41 ok(!$rv, " Method '$Acc' returns false" );
42 like( $@, $Err_re, " Fatal error logged" );
46 ### create an accessor;
48 local $SIG{__WARN__} = sub { $warning .= "@_" };
50 ok( $Object->mk_accessors( $Acc ),
51 "Accessor '$Acc' created" );
53 ok( $Object->can( $Acc ), " Can '$Acc'" );
54 ok(!$warning, " No warnings logged" );
57 ### try to use the accessor
58 { for my $var ($0, $$) {
60 ok( $Object->$Acc( $var ), "'$Acc' set to '$var'" );
61 is( $Object->$Acc(), $var, " '$Acc' still holds '$var'" );
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'" );
68 ok( $sub->(1), " '$Acc' set via coderef to '1'" );
69 is( $Object->$Acc(), 1, " '$Acc' still holds '1'" );
73 ### get a list of accessors
74 { my @list = $Object->ls_accessors;
75 ok( scalar(@list), "Accessors retrieved" );
77 for my $acc ( @list ) {
78 ok( $Object->can( $acc ), " Accessor '$acc' is valid" );
81 is_deeply( \@list, [$Acc], " Only expected accessors found" );
84 ### clone the original
85 { my $clone = $Object->mk_clone;
86 my @list = $clone->ls_accessors;
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" );
94 for my $acc ( @list ) {
95 ok( !defined( $clone->$acc() ),
96 " Accessor '$acc' is empty" );
100 ### flush the original values
101 { my $val = $Object->$Acc();
102 ok( $val, "Objects '$Acc' has a value" );
104 ok( $Object->mk_flush, " Object flushed" );
105 ok( !$Object->$Acc(), " Objects '$Acc' is now empty" );
108 ### check that only our original object can do '$Acc'
110 local $SIG{__WARN__} = sub { $warning .= "@_" };
112 my $other = $Class->new;
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" );
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 );