Commit | Line | Data |
0bbb0bd4 |
1 | BEGIN { chdir 't' if -d 't' }; |
2 | |
3 | use strict; |
4 | use lib '../lib'; |
5 | use Test::More 'no_plan'; |
6 | use Data::Dumper; |
7 | |
8 | my $Class = 'Object::Accessor'; |
9 | |
10 | use_ok($Class); |
11 | |
12 | my $Object = $Class->new; |
13 | my $Acc = 'foo'; |
14 | my $Allow = qr/^\d+$/; |
15 | my $Err_re = qr/is an invalid value for '$Acc'/; |
16 | my ($Ver_re) = map { qr/$_/ } quotemeta qq['$Acc' (<undef>) is invalid]; |
17 | |
18 | ### stupid warnings |
19 | ### XXX this will break warning tests though if enabled |
20 | $Object::Accessor::DEBUG = $Object::Accessor::DEBUG = 1 if @ARGV; |
21 | |
22 | |
23 | ### check the object |
24 | { ok( $Object, "Object of '$Class' created" ); |
25 | isa_ok( $Object, $Class ); |
26 | } |
27 | |
28 | ### create an accessor; |
29 | { my $warning; |
30 | local $SIG{__WARN__} = sub { $warning .= "@_" }; |
31 | |
32 | ok( $Object->mk_accessors( { $Acc => $Allow } ), |
33 | "Accessor '$Acc' created" ); |
34 | |
35 | ok( $Object->can( $Acc ), " Can '$Acc'" ); |
36 | ok(!$warning, " No warnings logged" ); |
37 | is( $Object->ls_allow( $Acc ), $Allow, |
38 | " Proper allow handler stored" ); |
39 | |
40 | |
41 | } |
42 | |
43 | ### try to use the accessor |
44 | { ### bad |
45 | { my $warning; |
46 | local $SIG{__WARN__} = sub { $warning .= "@_" }; |
47 | |
48 | ok( !$Object->$Acc( $0 ), "'$Acc' NOT set to '$0'" ); |
49 | is( $Object->$Acc(), undef, " '$Acc' still holds '<undef>'" ); |
50 | like( $warning, $Err_re, " Warnings logged" ); |
51 | |
52 | ### reset warnings; |
53 | undef $warning; |
54 | |
55 | |
56 | my $ok = $Object->mk_verify; |
57 | ok( !$ok, " Internal verify fails" ); |
58 | like( $warning, $Ver_re, " Warning logged" ); |
59 | } |
60 | |
61 | $Object->mk_flush; |
62 | |
63 | ### good |
64 | { my $warning; |
65 | local $SIG{__WARN__} = sub { $warning .= "@_" }; |
66 | |
67 | ok( $Object->$Acc( $$ ), "'$Acc' set to '$$'" ); |
68 | is( $Object->$Acc(), $$, " '$Acc' still holds '$$'" ); |
69 | ok(!$warning, " No warnings logged" ); |
70 | |
71 | ### reset warnings; |
72 | undef $warning; |
73 | |
74 | my $ok = $Object->mk_verify; |
75 | ok( $ok, " Internal verify succeeds" ); |
76 | ok( !$warning, " No warnings" ); |
77 | |
78 | } |
79 | |
80 | $Object->mk_flush; |
81 | |
82 | } |