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