lib/Object/Accessor/t/02_Object-Accessor-allow.t

   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 }