t/cmop/custom_instance.t

   1 #!/usr/bin/env perl
   2 use strict;
   3 use warnings;
   4 use Test::More;
   5 use Test::Fatal;
   6
   7 use Class::MOP;
   8
   9 my $instance;
  10 {
  11     package Foo;
  12
  13     sub new {
  14         my $class = shift;
  15         $instance = bless {@_}, $class;
  16         return $instance;
  17     }
  18
  19     sub foo { shift->{foo} }
  20 }
  21
  22 {
  23     package Foo::Sub;
  24     use base 'Foo';
  25     use metaclass;
  26
  27     sub new {
  28         my $class = shift;
  29         $class->meta->new_object(
  30             __INSTANCE__ => $class->SUPER::new(@_),
  31             @_,
  32         );
  33     }
  34
  35     __PACKAGE__->meta->add_attribute(
  36         bar => (
  37             reader      => 'bar',
  38             initializer => sub {
  39                 my $self = shift;
  40                 my ($value, $writer, $attr) = @_;
  41                 $writer->(uc $value);
  42             },
  43         ),
  44     );
  45 }
  46
  47 undef $instance;
  48 is( exception {
  49     my $foo = Foo::Sub->new;
  50     isa_ok($foo, 'Foo');
  51     isa_ok($foo, 'Foo::Sub');
  52     is($foo, $instance, "used the passed-in instance");
  53 }, undef );
  54
  55 undef $instance;
  56 is( exception {
  57     my $foo = Foo::Sub->new(foo => 'FOO');
  58     isa_ok($foo, 'Foo');
  59     isa_ok($foo, 'Foo::Sub');
  60     is($foo, $instance, "used the passed-in instance");
  61     is($foo->foo, 'FOO', "set non-CMOP constructor args");
  62 }, undef );
  63
  64 undef $instance;
  65 is( exception {
  66     my $foo = Foo::Sub->new(bar => 'bar');
  67     isa_ok($foo, 'Foo');
  68     isa_ok($foo, 'Foo::Sub');
  69     is($foo, $instance, "used the passed-in instance");
  70     is($foo->bar, 'BAR', "set CMOP attributes");
  71 }, undef );
  72
  73 undef $instance;
  74 is( exception {
  75     my $foo = Foo::Sub->new(foo => 'FOO', bar => 'bar');
  76     isa_ok($foo, 'Foo');
  77     isa_ok($foo, 'Foo::Sub');
  78     is($foo, $instance, "used the passed-in instance");
  79     is($foo->foo, 'FOO', "set non-CMOP constructor arg");
  80     is($foo->bar, 'BAR', "set correct CMOP attribute");
  81 }, undef );
  82
  83 {
  84     package BadFoo;
  85
  86     sub new {
  87         my $class = shift;
  88         $instance = bless {@_};
  89         return $instance;
  90     }
  91
  92     sub foo { shift->{foo} }
  93 }
  94
  95 {
  96     package BadFoo::Sub;
  97     use base 'BadFoo';
  98     use metaclass;
  99
 100     sub new {
 101         my $class = shift;
 102         $class->meta->new_object(
 103             __INSTANCE__ => $class->SUPER::new(@_),
 104             @_,
 105         );
 106     }
 107
 108     __PACKAGE__->meta->add_attribute(
 109         bar => (
 110             reader      => 'bar',
 111             initializer => sub {
 112                 my $self = shift;
 113                 my ($value, $writer, $attr) = @_;
 114                 $writer->(uc $value);
 115             },
 116         ),
 117     );
 118 }
 119
 120 like( exception { BadFoo::Sub->new }, qr/BadFoo=HASH.*is not a BadFoo::Sub/, "error with incorrect constructors" );
 121
 122 {
 123     my $meta = Class::MOP::Class->create('Really::Bad::Foo');
 124     like( exception {
 125         $meta->new_object(__INSTANCE__ => (bless {}, 'Some::Other::Class'))
 126     }, qr/Some::Other::Class=HASH.*is not a Really::Bad::Foo/, "error with completely invalid class" );
 127 }
 128
 129 {
 130     my $meta = Class::MOP::Class->create('Really::Bad::Foo::2');
 131     for my $invalid ('foo', 1, 0, '') {
 132         like( exception {
 133             $meta->new_object(__INSTANCE__ => $invalid)
 134         }, qr/The __INSTANCE__ parameter must be a blessed reference, not $invalid/, "error with unblessed thing" );
 135     }
 136 }
 137
 138 done_testing;