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