ext/Object-Accessor/t/04_Object-Accessor-lvalue.t

   1 BEGIN { chdir 't' if -d 't' };
   2
   3 use strict;
   4 use lib '../lib';
   5 use Data::Dumper;
   6
   7 BEGIN {
   8     require Test::More;
   9     Test::More->import(
  10         # silly bbedit [
  11         $] >= 5.008
  12             ? 'no_plan'
  13             : ( skip_all => "Lvalue objects require perl >= 5.8" )
  14     );
  15 }
  16
  17 my $Class   = 'Object::Accessor';
  18 my $LClass  =  $Class . '::Lvalue';
  19
  20 use_ok($Class);
  21
  22 my $Object      = $LClass->new;
  23 my $Acc         = 'foo';
  24
  25 ### stupid warnings
  26 ### XXX this will break warning tests though if enabled
  27 $Object::Accessor::DEBUG = $Object::Accessor::DEBUG = 1 if @ARGV;
  28
  29
  30 ### check the object
  31 {   ok( $Object,                "Object of '$LClass' created" );
  32     isa_ok( $Object,            $LClass );
  33     isa_ok( $Object,            $Class );
  34     ok( $Object->mk_clone,      "   Object cloned" );
  35 }
  36
  37 ### create an accessor;
  38 {   ok( $Object->mk_accessors( $Acc ),
  39                                 "Accessor '$Acc' created" );
  40
  41     eval { $Object->$Acc = $$ };
  42     ok( !$@,                    "lvalue assign successful $@" );
  43     ok( $Object->$Acc,          "Accessor '$Acc' set" );
  44     is( $Object->$Acc, $$,      "   Contains proper value" );
  45 }
  46
  47 ### test allow handlers
  48 {   my $acc   = 'bar';
  49     my $clone = $Object->mk_clone;
  50
  51     ok( $clone,                 "Cloned the lvalue object" );
  52
  53     ### lets see if this causes a warning
  54     {   my $warnings;
  55         local $SIG{__WARN__} = sub { $warnings .= "@_" };
  56
  57         ok( $clone->mk_accessors({ $acc => sub { 0 } }),
  58                                 "   Created accessor '$acc'" );
  59         like( $warnings, qr/not supported/,
  60                                 "       Got warning about allow handlers" );
  61     }
  62
  63     ok( eval{ $clone->$acc = $$ },
  64                                 "   Allow handler ignored" );
  65     ok( ! $@,                   "   No error occurred" );
  66     is( $clone->$acc, $$,       "   Setting '$acc' worked" );
  67 }
  68
  69 ### test registering callbacks
  70 {   my $clone = $Object->mk_clone;
  71     ok( $clone,                 "Cloned the lvalue object" );
  72
  73     {   my $warnings;
  74         local $SIG{__WARN__} = sub { $warnings .= "@_" };
  75         ok( ! $clone->register_callback( sub { } ),
  76                                 "Callback not registered" );
  77
  78         like( $warnings, qr/not supported/,
  79                                 "   Got warning about callbacks" );
  80     }
  81 }
  82