The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
use strict;
use warnings;
use Test::More;
use Test::Fatal;
use Test::Moose;

use lib 'lib';
require MooseX::SetOnce;

{
  package Apple;
  use Moose;

  has color => (
    is     => 'rw',
    traits => [ qw(SetOnce) ],
  );
}

{
  package Orange;
  use Moose;

  has color => (
    reader => 'get_color',
    writer => 'set_color',
    traits => [ qw(SetOnce) ],
  );
}

{
  package Tangerine;
  use Moose;

  extends 'Orange';
}

with_immutable {
for my $set (
  [ Apple     => qw(    color     color) ],
  [ Orange    => qw(get_color set_color) ],
  [ Tangerine => qw(get_color set_color) ],
) {
  my ($class, $getter, $setter) = @$set;
  my $object = $class->new;

  {
    is(
      exception { $object->$setter('green'); },
      undef,
      "can set a SetOnce attr once",
    );

    is($object->$getter, 'green', "it has the first value we set");
  }

  {
    like(
      exception { $object->$setter('blue'); },
      qr{cannot change value.+\bcolor\b},
      "can't set a SetOnce attr twice (via $setter)",
    );
    is($object->$getter, 'green', "it has the first value we set");
  }

  {
    like(
      exception {
        $object->meta->find_attribute_by_name('color')->set_value($object, 'yellow');
      },
      qr{cannot change value.+\bcolor\b},
      "can't set a SetOnce attr twice (via set_value)",
    );
    is($object->$getter, 'green', "it has the first value we set");
  }

  my $object2 = $class->new(color => 'green');

  {
    like(
      exception { $object2->$setter('blue'); },
      qr{cannot change value.+\bcolor\b},
      "can't set a SetOnce attr twice (via $setter)",
    );
    is($object2->$getter, 'green', "it has the first value we set");
  }

  {
    like(
      exception {
        $object2->meta->find_attribute_by_name('color')->set_value($object, 'yellow');
      },
      qr{cannot change value.+\bcolor\b},
      "can't set a SetOnce attr twice (via set_value)",
    );
    is($object2->$getter, 'green', "it has the first value we set");
  }
}
} 'Apple', 'Orange';

done_testing;