1 BEGIN { chdir 't' if -d 't' };
13 : ( skip_all => "Lvalue objects require perl >= 5.8" )
17 my $Class = 'Object::Accessor';
18 my $LClass = $Class . '::Lvalue';
22 my $Object = $LClass->new;
26 ### XXX this will break warning tests though if enabled
27 $Object::Accessor::DEBUG = $Object::Accessor::DEBUG = 1 if @ARGV;
31 { ok( $Object, "Object of '$LClass' created" );
32 isa_ok( $Object, $LClass );
33 isa_ok( $Object, $Class );
34 ok( $Object->mk_clone, " Object cloned" );
37 ### create an accessor;
38 { ok( $Object->mk_accessors( $Acc ),
39 "Accessor '$Acc' created" );
41 eval { $Object->$Acc = $$ };
42 ok( !$@, "lvalue assign successful $@" );
43 ok( $Object->$Acc, "Accessor '$Acc' set" );
44 is( $Object->$Acc, $$, " Contains proper value" );
47 ### test allow handlers
49 my $clone = $Object->mk_clone;
51 ok( $clone, "Cloned the lvalue object" );
53 ### lets see if this causes a warning
55 local $SIG{__WARN__} = sub { $warnings .= "@_" };
57 ok( $clone->mk_accessors({ $acc => sub { 0 } }),
58 " Created accessor '$acc'" );
59 like( $warnings, qr/not supported/,
60 " Got warning about allow handlers" );
63 ok( eval{ $clone->$acc = $$ },
64 " Allow handler ignored" );
65 ok( ! $@, " No error occurred" );
66 is( $clone->$acc, $$, " Setting '$acc' worked" );
69 ### test registering callbacks
70 { my $clone = $Object->mk_clone;
71 ok( $clone, "Cloned the lvalue object" );
74 local $SIG{__WARN__} = sub { $warnings .= "@_" };
75 ok( ! $clone->register_callback( sub { } ),
76 "Callback not registered" );
78 like( $warnings, qr/not supported/,
79 " Got warning about callbacks" );