t/cmop/magic.t

   1 # Testing magical scalars (using tied scalar)
   2 # Note that XSUBs do not handle magical scalars automatically.
   3
   4 use strict;
   5 use warnings;
   6
   7 use Test::More;
   8 use Test::Fatal;
   9
  10 use Class::Load qw( is_class_loaded load_class );
  11 use Class::MOP;
  12
  13 use Tie::Scalar;
  14
  15 {
  16     package Foo;
  17     use metaclass;
  18
  19     Foo->meta->add_attribute('bar' =>
  20         reader => 'get_bar',
  21         writer => 'set_bar',
  22     );
  23
  24     Foo->meta->add_attribute('baz' =>
  25         accessor => 'baz',
  26     );
  27
  28     Foo->meta->make_immutable();
  29 }
  30
  31 {
  32     tie my $foo, 'Tie::StdScalar', Foo->new(bar => 100, baz => 200);
  33
  34     is $foo->get_bar, 100, 'reader with tied self';
  35     is $foo->baz,     200, 'accessor/r with tied self';
  36
  37     $foo->set_bar(300);
  38     $foo->baz(400);
  39
  40     is $foo->get_bar, 300, 'writer with tied self';
  41     is $foo->baz,     400, 'accessor/w with tied self';
  42 }
  43
  44 {
  45     my $foo = Foo->new();
  46
  47     tie my $value, 'Tie::StdScalar', 42;
  48
  49     $foo->set_bar($value);
  50     $foo->baz($value);
  51
  52     is $foo->get_bar, 42, 'reader/writer with tied value';
  53     is $foo->baz,     42, 'accessor with tied value';
  54 }
  55
  56 {
  57     my $x = tie my $value, 'Tie::StdScalar', 'Class::MOP';
  58
  59     is( exception { load_class($value) }, undef, 'load_class(tied scalar)' );
  60
  61     $value = undef;
  62     $x->STORE('Class::MOP'); # reset
  63
  64     is( exception {
  65         ok is_class_loaded($value);
  66     }, undef, 'is_class_loaded(tied scalar)' );
  67
  68     $value = undef;
  69     $x->STORE(\&Class::MOP::get_code_info); # reset
  70
  71     is( exception {
  72         is_deeply [Class::MOP::get_code_info($value)], [qw(Class::MOP get_code_info)], 'get_code_info(tied scalar)';
  73     }, undef );
  74 }
  75
  76 done_testing;