| 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 | } |
projects / p5sagit/p5-mst-13.2.git / blame