t/100_bugs/failing/006_handles_foreign_class_bug.t

   1 #!/usr/bin/perl
   2
   3 use strict;
   4 use warnings;
   5
   6 use Test::More tests => 15;
   7 use Test::Exception;
   8
   9 {
  10     package Foo;
  11
  12     sub new {
  13         bless({}, 'Foo')
  14     }
  15
  16     sub a { 'Foo::a' }
  17 }
  18
  19 {
  20     package Bar;
  21     use Mouse;
  22
  23     ::lives_ok {
  24         has 'baz' => (
  25             is      => 'ro',
  26             isa     => 'Foo',
  27             lazy    => 1,
  28             default => sub { Foo->new() },
  29             handles => qr/^a$/,
  30         );
  31     } '... can create the attribute with delegations';
  32
  33 }
  34
  35 my $bar;
  36 lives_ok {
  37     $bar = Bar->new;
  38 } '... created the object ok';
  39 isa_ok($bar, 'Bar');
  40
  41 is($bar->a, 'Foo::a', '... got the right delgated value');
  42
  43 my @w;
  44 $SIG{__WARN__} = sub { push @w, "@_" };
  45 {
  46     package Baz;
  47     use Mouse;
  48
  49     ::lives_ok {
  50         has 'bar' => (
  51             is      => 'ro',
  52             isa     => 'Foo',
  53             lazy    => 1,
  54             default => sub { Foo->new() },
  55             handles => qr/.*/,
  56         );
  57     } '... can create the attribute with delegations';
  58
  59 }
  60
  61 is(@w, 0, "no warnings");
  62
  63
  64 my $baz;
  65 lives_ok {
  66     $baz = Baz->new;
  67 } '... created the object ok';
  68 isa_ok($baz, 'Baz');
  69
  70 is($baz->a, 'Foo::a', '... got the right delgated value');
  71
  72
  73
  74
  75
  76 @w = ();
  77
  78 {
  79     package Blart;
  80     use Mouse;
  81
  82     ::lives_ok {
  83         has 'bar' => (
  84             is      => 'ro',
  85             isa     => 'Foo',
  86             lazy    => 1,
  87             default => sub { Foo->new() },
  88             handles => [qw(a new)],
  89         );
  90     } '... can create the attribute with delegations';
  91
  92 }
  93
  94 {
  95     local $TODO = "warning not yet implemented";
  96
  97     is(@w, 1, "one warning");
  98     like($w[0], qr/not delegating.*new/i, "warned");
  99 }
 100
 101
 102
 103 my $blart;
 104 lives_ok {
 105     $blart = Blart->new;
 106 } '... created the object ok';
 107 isa_ok($blart, 'Blart');
 108
 109 is($blart->a, 'Foo::a', '... got the right delgated value');
 110
 111