Commit | Line | Data |
0bbb0bd4 |
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 | |