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 | my $LClass = $Class . '::Lvalue'; |
10 | |
11 | use_ok($Class); |
12 | |
13 | ### stupid warnings |
14 | ### XXX this will break warning tests though if enabled |
15 | $Object::Accessor::DEBUG = $Object::Accessor::DEBUG = 1 if @ARGV; |
16 | |
17 | my $Object = $Class->new; |
18 | my $Acc = 'foo'; |
19 | my $Func = 'register_callback'; |
20 | my $Called = 0; |
21 | my $RetVal = $$; |
22 | my $SetVal = 1; |
23 | |
24 | ### 6 tests |
25 | my $Sub = sub { |
26 | my $obj = shift; |
27 | my $meth = shift; |
28 | my $val = shift; |
29 | |
30 | $Called++; |
31 | |
32 | ok( 1, " In callback now" ); |
33 | ok( $obj, " Object received" ); |
34 | isa_ok( $obj, $Class, " Object"); |
35 | is( $meth, $Acc, " Method is '$Acc'" ); |
36 | isa_ok( $val, "ARRAY", " Value" ); |
37 | scalar @$val |
38 | ? is( $val->[0], $SetVal, |
39 | " Attempted to set $SetVal" ) |
40 | : ok( ! exists $val->[0], |
41 | " This was a GET request" ); |
42 | |
43 | return $RetVal; |
44 | }; |
45 | |
46 | ### set up the object |
47 | { ok( $Object, "Object created" ); |
48 | isa_ok( $Object, $Class ); |
49 | ok( $Object->mk_accessors( $Acc ), |
50 | " Accessor '$Acc' created" ); |
51 | can_ok( $Object, $Func ); |
52 | ok( $Object->$Func( $Sub ), " Callback registered" ); |
53 | } |
54 | |
55 | ### test ___get and ___set |
56 | { $Called = 0; |
57 | |
58 | my $clone = $Object->mk_clone; |
59 | ok( $clone, "Object cloned" ); |
60 | |
61 | my $val = $clone->___get($Acc); |
62 | is( $val, undef, " Direct get returns <undef>" ); |
63 | ok( $clone->___set( $Acc => $SetVal ), |
64 | " Direct set is able to set the value" ); |
65 | is( $clone->___get( $Acc ), $SetVal, |
66 | " Direct get returns $SetVal" ); |
67 | ok( !$Called, " Callbacks didn't get called" ); |
68 | } |
69 | |
70 | ### test callbacks on regular objects |
71 | ### XXX callbacks DO NOT work on lvalue objects. This is verified |
72 | ### in the lvalue test file, so we dont test here |
73 | { #diag("Running GET tests on regular objects"); |
74 | |
75 | my $clone = $Object->mk_clone; |
76 | |
77 | $Called = 0; |
78 | is( $clone->$Acc, $RetVal, " Method '$Acc' returns '$RetVal' " ); |
79 | is( $clone->___get($Acc), undef, |
80 | " Direct get returns <undef>" ); |
81 | ok( $Called, " Callback called" ); |
82 | |
83 | |
84 | #diag("Running SET tests on regular objects"); |
85 | $Called = 0; |
86 | ok( $clone->$Acc($SetVal), " Setting $Acc" ); |
87 | ok( $Called, " Callback called" ); |
88 | |
89 | $Called = 0; |
90 | is( $clone->$Acc, $RetVal, " Returns $RetVal" ); |
91 | ok( $Called, " Callback called" ); |
92 | |
93 | $Called = 0; |
94 | is( $clone->___get( $Acc ), $RetVal, |
95 | " Direct get returns $RetVal" ); |
96 | ok( !$Called, " Callback not called" ); |
97 | } |