File Coverage

blib/lib/Method/Generate/Accessor/Role/LvalueAttribute.pm

Criterion	Covered	Total	%
statement	27	27	100.0
branch	4	4	100.0
condition			n/a
subroutine	8	8	100.0
pod			n/a
total	39	39	100.0

#
# This file is part of MooX-LvalueAttribute
#
# This software is copyright (c) 2013 by Damien "dams" Krotkine.
#
# This is free software; you can redistribute it and/or modify it under
# the same terms as the Perl 5 programming language system itself.
#
package Method::Generate::Accessor::Role::LvalueAttribute;
{
  $Method::Generate::Accessor::Role::LvalueAttribute::VERSION = '0.16';
}
use strictures 1;

# ABSTRACT: Provides Lvalue accessors to Moo class attributes

use Moo::Role;
use Variable::Magic qw(wizard cast);

use Hash::Util::FieldHash::Compat;

Hash::Util::FieldHash::Compat::fieldhash my %LVALUES;

require MooX::LvalueAttribute;

around generate_method => sub {
    my $orig = shift;
    my $self = shift;
    # would like a better way to disable XS

    my ($into, $name, $spec, $quote_opts) = @_;

    $MooX::LvalueAttribute::INJECTED_IN_ROLE{$into}
      || $MooX::LvalueAttribute::INJECTED_IN_CLASS{$into}
      or return $self->$orig(@_);

    if ($spec->{lvalue}) {

        my $is = $spec->{is};
        if ($is eq 'rw') {
            $spec->{accessor} = $name unless exists $spec->{accessor}
              or ( $spec->{reader} and $spec->{writer} );
        } elsif ($is eq 'rwp') {
            $spec->{writer} = "_set_${name}" unless exists $spec->{writer};
        }

        exists $spec->{writer} || exists $spec->{accessor}
          or die "lvalue was set but no accessor nor reader, and attribute is not rw";
        foreach( qw(writer accessor) ) {
            my $t = $spec->{$_}
              or next;
            $spec->{'lv_' . $_} = $t;
            $spec->{$_} = '_lv_' . $t;
        }
    }

    my $methods = $self->$orig(@_);

    foreach ( qw(writer accessor) ) {
        my $lv_name = $spec->{'lv_' . $_}
          or next;
        my $name = $spec->{$_};
        no strict 'refs';
        my $sub = sub : lvalue {
            my $self = shift;
            if (! exists $LVALUES{$self}{$lv_name}) {
                my $wiz = wizard(
                 set  => sub {
                     $self->$name(${$_[0]});
                     return 1;
                 },
                 get => sub {
                     ${$_[0]} = $self->$name();
                     return 1;
                 },
                );
                cast $LVALUES{$self}{$lv_name}, $wiz;
            }
            @_ and $self->$name(@_);
            $LVALUES{$self}{$lv_name};
        };
        $methods->{$lv_name} = $sub;
        *{"${into}::${lv_name}"} = $sub;
    }
};

1;

__END__