t/basics/rebless.t

   1 #!/usr/bin/perl
   2
   3 use strict;
   4 use warnings;
   5
   6 use Test::More;
   7 use Test::Fatal;
   8 use Test::Moose qw(with_immutable);
   9 use Scalar::Util 'blessed';
  10
  11 use Moose::Util::TypeConstraints;
  12
  13 subtype 'Positive'
  14      => as 'Num'
  15      => where { $_ > 0 };
  16
  17 {
  18     package Parent;
  19     use Moose;
  20
  21     has name => (
  22         is       => 'rw',
  23         isa      => 'Str',
  24     );
  25
  26     has lazy_classname => (
  27         is      => 'ro',
  28         lazy    => 1,
  29         default => sub { "Parent" },
  30     );
  31
  32     has type_constrained => (
  33         is      => 'rw',
  34         isa     => 'Num',
  35         default => 5.5,
  36     );
  37
  38     package Child;
  39     use Moose;
  40     extends 'Parent';
  41
  42     has '+name' => (
  43         default => 'Junior',
  44     );
  45
  46     has '+lazy_classname' => (
  47         default => sub { "Child" },
  48     );
  49
  50     has '+type_constrained' => (
  51         isa     => 'Int',
  52         default => 100,
  53     );
  54
  55     our %trigger_calls;
  56     our %initializer_calls;
  57
  58     has new_attr => (
  59         is => 'rw', isa => 'Str',
  60         trigger => sub {
  61             my ($self, $val, $attr) = @_;
  62             $trigger_calls{new_attr}++;
  63         },
  64         initializer => sub {
  65             my ($self, $value, $set, $attr) = @_;
  66             $initializer_calls{new_attr}++;
  67         },
  68     );
  69 }
  70
  71 my @classes = qw(Parent Child);
  72
  73 with_immutable
  74 {
  75     my $foo = Parent->new;
  76     my $bar = Parent->new;
  77
  78     is(blessed($foo), 'Parent', 'Parent->new gives a Parent object');
  79     is($foo->name, undef, 'No name yet');
  80     is($foo->lazy_classname, 'Parent', "lazy attribute initialized");
  81     is( exception { $foo->type_constrained(10.5) }, undef, "Num type constraint for now.." );
  82
  83     # try to rebless, except it will fail due to Child's stricter type constraint
  84     like( exception { Child->meta->rebless_instance($foo) }, qr/^Attribute \(type_constrained\) does not pass the type constraint because\: Validation failed for 'Int' with value 10\.5/, '... this failed because of type check' );
  85     like( exception { Child->meta->rebless_instance($bar) }, qr/^Attribute \(type_constrained\) does not pass the type constraint because\: Validation failed for 'Int' with value 5\.5/, '... this failed because of type check' );
  86
  87     $foo->type_constrained(10);
  88     $bar->type_constrained(5);
  89
  90     Child->meta->rebless_instance($foo);
  91     Child->meta->rebless_instance($bar, new_attr => 'blah');
  92
  93     is(blessed($foo), 'Child', 'successfully reblessed into Child');
  94     is($foo->name, 'Junior', "Child->name's default came through");
  95
  96     is($foo->lazy_classname, 'Parent', "lazy attribute was already initialized");
  97     is($bar->lazy_classname, 'Child', "lazy attribute just now initialized");
  98
  99     like( exception { $foo->type_constrained(10.5) }, qr/^Attribute \(type_constrained\) does not pass the type constraint because\: Validation failed for 'Int' with value 10\.5/, '... this failed because of type check' );
 100
 101
 102     TODO: {
 103         local $TODO = 'Moose::Meta::Class does not yet call triggers for rebless_instance!';
 104     is_deeply(\%Child::trigger_calls, { new_attr => 1 }, 'Trigger fired on rebless_instance');
 105     }
 106     is_deeply(\%Child::initializer_calls, { new_attr => 1 }, 'Initializer fired on rebless_instance');
 107
 108     undef %Child::trigger_calls;
 109     undef %Child::initializer_calls;
 110
 111 }
 112 @classes;
 113
 114 done_testing;