t-failing/100_bugs/006_handles_foreign_class_bug.t

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