ext/Object-Accessor/t/00_Object-Accessor.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 $Err_re  = qr/No such accessor '$Acc'/;
  15
  16 ### stupid warnings
  17 ### XXX this will break warning tests though if enabled
  18 $Object::Accessor::DEBUG = $Object::Accessor::DEBUG = 1 if @ARGV;
  19
  20
  21 ### check the object
  22 {   ok( $Object,                "Object of '$Class' created" );
  23     isa_ok( $Object,            $Class );
  24 }
  25
  26 ### check non existant accessor
  27 {   my $warning;
  28     local $SIG{__WARN__} = sub { $warning .= "@_" };
  29
  30     ok(!$Object->can($Acc),     "Cannot '$Acc'" );
  31     ok(!$Object->$Acc(),        "   Method '$Acc' returns false" );
  32     like( $warning, $Err_re,    "   Warning logged" );
  33
  34     ### check fatal error
  35     {   local $Object::Accessor::FATAL = 1;
  36         local $Object::Accessor::FATAL = 1; # stupid warnings
  37
  38         my $rv = eval { $Object->$Acc() };
  39
  40         ok( $@,                 "Cannot '$Acc' -- dies" );
  41         ok(!$rv,                "   Method '$Acc' returns false" );
  42         like( $@, $Err_re,      "   Fatal error logged" );
  43     }
  44 }
  45
  46 ### create an accessor;
  47 {   my $warning;
  48     local $SIG{__WARN__} = sub { $warning .= "@_" };
  49
  50     ok( $Object->mk_accessors( $Acc ),
  51                                 "Accessor '$Acc' created" );
  52
  53     ok( $Object->can( $Acc ),   "   Can '$Acc'" );
  54     ok(!$warning,               "   No warnings logged" );
  55 }
  56
  57 ### try to use the accessor
  58 {   for my $var ($0, $$) {
  59
  60         ok( $Object->$Acc( $var ),  "'$Acc' set to '$var'" );
  61         is( $Object->$Acc(), $var,  "   '$Acc' still holds '$var'" );
  62
  63         my $sub = $Object->can( $Acc );
  64         ok( $sub,                   "Retrieved '$Acc' coderef" );
  65         isa_ok( $sub,               "CODE" );
  66         is( $sub->(), $var,         "   '$Acc' via coderef holds '$var'" );
  67
  68         ok( $sub->(1),              "   '$Acc' set via coderef to '1'" );
  69         is( $Object->$Acc(), 1,     "   '$Acc' still holds '1'" );
  70     }
  71 }
  72
  73 ### get a list of accessors
  74 {   my @list = $Object->ls_accessors;
  75     ok( scalar(@list),              "Accessors retrieved" );
  76
  77     for my $acc ( @list ) {
  78         ok( $Object->can( $acc ),   "   Accessor '$acc' is valid" );
  79     }
  80
  81     is_deeply( \@list, [$Acc],      "   Only expected accessors found" );
  82 }
  83
  84 ### clone the original
  85 {   my $clone = $Object->mk_clone;
  86     my @list  = $clone->ls_accessors;
  87
  88     ok( $clone,                     "Clone created" );
  89     isa_ok( $clone,                 $Class );
  90     ok( scalar(@list),              "   Clone has accessors" );
  91     is_deeply( \@list, [$Object->ls_accessors],
  92                                     "   Only expected accessors found" );
  93
  94     for my $acc ( @list ) {
  95         ok( !defined( $clone->$acc() ),
  96                                     "   Accessor '$acc' is empty" );
  97     }
  98 }
  99
 100 ### flush the original values
 101 {   my $val = $Object->$Acc();
 102     ok( $val,                       "Objects '$Acc' has a value" );
 103
 104     ok( $Object->mk_flush,          "   Object flushed" );
 105     ok( !$Object->$Acc(),           "   Objects '$Acc' is now empty" );
 106 }
 107
 108 ### check that only our original object can do '$Acc'
 109 {   my $warning;
 110     local $SIG{__WARN__} = sub { $warning .= "@_" };
 111
 112     my $other = $Class->new;
 113
 114
 115     ok(!$other->can($Acc),          "Cannot '$Acc' via other object" );
 116     ok(!$other->$Acc(),             "   Method '$Acc' returns false" );
 117     like( $warning, $Err_re,        "   Warning logged" );
 118 }
 119
 120 ### check if new() passes it's args correctly
 121 {   my $obj = $Class->new( $Acc );
 122     ok( $obj,                       "Object created with accessors" );
 123     isa_ok( $obj,                   $Class );
 124     can_ok( $obj,                   $Acc );
 125 }
 126
 127 1;