File Coverage

blib/lib/MooX/SetOnce.pm

Criterion	Covered	Total	%
statement	29	35	82.8
branch	7	8	87.5
condition	9	16	56.2
subroutine	5	5	100.0
pod			n/a
total	50	64	78.1

package MooX::SetOnce;
use strictures 1;

our $VERSION = '0.001002';
$VERSION = eval $VERSION;

use Carp;
use Class::Method::Modifiers qw(install_modifier);

sub import {
  my ($class) = @_;
  my $target = caller;

  install_modifier $target, 'around', 'has', sub {
    my $orig = shift;
    my ($attr, %opts) = @_;
    return $orig->($attr, %opts)
      unless delete $opts{once};

    my $is = $opts{is};
    my $writer = $opts{writer};
    if ($is eq 'rw') {
      $writer ||= $attr;
    }
    elsif ($is eq 'rwp') {
      $writer ||= "_set_$attr";
    }
    else {
      croak "SetOnce can't be used on read-only accessors";
    }
    my $predicate = $opts{predicate} ||= '_has_' . $attr;

    $opts{moosify} ||= [];
    push @{$opts{moosify}}, sub {
      my ($spec) = @_;
      require # hide from CPANTS
        MooseX::SetOnce;
      $spec->{traits} ||= [];
      push @{$spec->{traits}}, 'SetOnce';
    };

    $orig->($attr, %opts);

    $target->can('before')->($writer, sub {
      my ($self) = @_;
      if (@_ > 1 && $self->$predicate) {
        croak "cannot change value of SetOnce attribute $attr";
      }
    });
  }
}

1;

__END__