092c74169a732cfa732b86b637a1aaa5ed06d53e
[perl.git] / ext / Object-Accessor / t / 04_Object-Accessor-lvalue.t
1 BEGIN { chdir 't' if -d 't' };
2
3 use strict;
4 use lib '../lib';
5 use Data::Dumper;
6
7 BEGIN {
8     require Test::More;
9     Test::More->import( 
10         # silly bbedit [
11         $] >= 5.008         
12             ? 'no_plan' 
13             : ( skip_all => "Lvalue objects require perl >= 5.8" )
14     );
15 }
16
17 my $Class   = 'Object::Accessor';
18 my $LClass  =  $Class . '::Lvalue';
19
20 use_ok($Class);
21
22 my $Object      = $LClass->new;
23 my $Acc         = 'foo';
24
25 ### stupid warnings
26 ### XXX this will break warning tests though if enabled
27 $Object::Accessor::DEBUG = $Object::Accessor::DEBUG = 1 if @ARGV;
28
29
30 ### check the object
31 {   ok( $Object,                "Object of '$LClass' created" );
32     isa_ok( $Object,            $LClass );
33     isa_ok( $Object,            $Class );
34     ok( $Object->mk_clone,      "   Object cloned" );
35 }
36
37 ### create an accessor;
38 {   ok( $Object->mk_accessors( $Acc ),
39                                 "Accessor '$Acc' created" );
40     
41     eval { $Object->$Acc = $$ };
42     ok( !$@,                    "lvalue assign successful $@" );
43     ok( $Object->$Acc,          "Accessor '$Acc' set" );
44     is( $Object->$Acc, $$,      "   Contains proper value" );
45 }
46
47 ### test allow handlers
48 {   my $acc   = 'bar';
49     my $clone = $Object->mk_clone;
50
51     ok( $clone,                 "Cloned the lvalue object" );
52
53     ### lets see if this causes a warning
54     {   my $warnings;
55         local $SIG{__WARN__} = sub { $warnings .= "@_" };
56
57         ok( $clone->mk_accessors({ $acc => sub { 0 } }),
58                                 "   Created accessor '$acc'" );
59         like( $warnings, qr/not supported/,
60                                 "       Got warning about allow handlers" );
61     }
62
63     ok( eval{ $clone->$acc = $$ },      
64                                 "   Allow handler ignored" );       
65     ok( ! $@,                   "   No error occurred" );
66     is( $clone->$acc, $$,       "   Setting '$acc' worked" );
67 }
68
69 ### test registering callbacks
70 {   my $clone = $Object->mk_clone;
71     ok( $clone,                 "Cloned the lvalue object" );
72     
73     {   my $warnings;
74         local $SIG{__WARN__} = sub { $warnings .= "@_" };
75         ok( ! $clone->register_callback( sub { } ),
76                                 "Callback not registered" );
77
78         like( $warnings, qr/not supported/,
79                                 "   Got warning about callbacks" );
80     }                                
81 }
82