1 BEGIN { chdir 't' if -d 't' };
5 use Test::More 'no_plan';
8 my $Class = 'Object::Accessor';
9 my $LClass = $Class . '::Lvalue';
14 ### XXX this will break warning tests though if enabled
15 $Object::Accessor::DEBUG = $Object::Accessor::DEBUG = 1 if @ARGV;
17 my $Object = $Class->new;
19 my $Func = 'register_callback';
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" );
38 ? is( $val->[0], $SetVal,
39 " Attempted to set $SetVal" )
40 : ok( ! exists $val->[0],
41 " This was a GET request" );
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" );
55 ### test ___get and ___set
58 my $clone = $Object->mk_clone;
59 ok( $clone, "Object cloned" );
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" );
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");
75 my $clone = $Object->mk_clone;
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" );
84 #diag("Running SET tests on regular objects");
86 ok( $clone->$Acc($SetVal), " Setting $Acc" );
87 ok( $Called, " Callback called" );
90 is( $clone->$Acc, $RetVal, " Returns $RetVal" );
91 ok( $Called, " Callback called" );
94 is( $clone->___get( $Acc ), $RetVal,
95 " Direct get returns $RetVal" );
96 ok( !$Called, " Callback not called" );