ext/Object-Accessor/t/05_Object-Accessor-callback.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 my $LClass  = $Class . '::Lvalue';
  10
  11 use_ok($Class);
  12
  13 ### stupid warnings
  14 ### XXX this will break warning tests though if enabled
  15 $Object::Accessor::DEBUG = $Object::Accessor::DEBUG = 1 if @ARGV;
  16
  17 my $Object      = $Class->new;
  18 my $Acc         = 'foo';
  19 my $Func        = 'register_callback';
  20 my $Called      = 0;
  21 my $RetVal      = $$;
  22 my $SetVal      = 1;
  23
  24 ### 6 tests
  25 my $Sub         = sub {
  26         my $obj     = shift;
  27         my $meth    = shift;
  28         my $val     = shift;
  29
  30         $Called++;
  31
  32         ok( 1,                  "   In callback now" );
  33         ok( $obj,               "       Object received" );
  34         isa_ok( $obj, $Class,   "       Object");
  35         is( $meth, $Acc,        "       Method is '$Acc'" );
  36         isa_ok( $val, "ARRAY",  "       Value" );
  37         scalar @$val
  38             ? is( $val->[0], $SetVal,
  39                                 "       Attempted to set $SetVal" )
  40             : ok( ! exists $val->[0],
  41                                 "       This was a GET request" );
  42
  43         return $RetVal;
  44 };
  45
  46 ### set up the object
  47 {   ok( $Object,                "Object created" );
  48     isa_ok( $Object,            $Class );
  49     ok( $Object->mk_accessors( $Acc ),
  50                                 "   Accessor '$Acc' created" );
  51     can_ok( $Object,            $Func );
  52     ok( $Object->$Func( $Sub ), "   Callback registered" );
  53 }
  54
  55 ### test ___get and ___set
  56 {   $Called = 0;
  57
  58     my $clone = $Object->mk_clone;
  59     ok( $clone,                 "Object cloned" );
  60
  61     my $val = $clone->___get($Acc);
  62     is( $val, undef,            "   Direct get returns <undef>" );
  63     ok( $clone->___set( $Acc => $SetVal ),
  64                                 "   Direct set is able to set the value" );
  65     is( $clone->___get( $Acc ), $SetVal,
  66                                 "   Direct get returns $SetVal" );
  67     ok( !$Called,               "   Callbacks didn't get called" );
  68 }
  69
  70 ### test callbacks on regular objects
  71 ### XXX callbacks DO NOT work on lvalue objects. This is verified
  72 ### in the lvalue test file, so we dont test here
  73 {   #diag("Running GET tests on regular objects");
  74
  75     my $clone   = $Object->mk_clone;
  76
  77     $Called = 0;
  78     is( $clone->$Acc, $RetVal,   "   Method '$Acc' returns '$RetVal' " );
  79     is( $clone->___get($Acc), undef,
  80                                 "   Direct get returns <undef>" );
  81     ok( $Called,                "   Callback called" );
  82
  83
  84     #diag("Running SET tests on regular objects");
  85     $Called = 0;
  86     ok( $clone->$Acc($SetVal),  "   Setting $Acc" );
  87     ok( $Called,                "   Callback called" );
  88
  89     $Called = 0;
  90     is( $clone->$Acc, $RetVal,  "   Returns $RetVal" );
  91     ok( $Called,                "   Callback called" );
  92
  93     $Called = 0;
  94     is( $clone->___get( $Acc ), $RetVal,
  95                                 "   Direct get returns $RetVal" );
  96     ok( !$Called,               "   Callback not called" );
  97 }