lvalue-after.pl

use strict;
use warnings;
use Test::More;

# lvalue method
{
  package Foo;
  sub new { bless {}, shift }
  sub attr :lvalue { $_[0]->{bar} }
}

{
  my $f = Foo->new;
  $f->attr = 5;
  is $f->attr, 5;
}

# wrapping an lvalue method, adding an after
#
# We can take a reference to the inner sub return value, call our afters, then
# return a dereference of the the stored reference (reftype LVALUE).  This will
# propogate changes to the wrapped sub's return.
{
  package Foo;
  sub after { $_[0]->{after} }
  sub attr_wrap :lvalue {
    my $self = shift;
    my $ret = \($self->attr);
    $self->{after}++;
    $$ret;
  }
}

{
  my $f = Foo->new;
  $f->attr_wrap = 5;
  is $f->attr, 5;
  is $f->after, 1;
}

# array lvalue method
{
  package Bar;
  sub new { bless {}, shift }
  sub attr :lvalue {
    my $self = shift;
    @{$self->{attr} ||= []};
  }
  sub attr_as_list :lvalue {
    my $self = shift;
    $self->{attr} ||= [];
    ($self->{attr}[0], $self->{attr}[1]);
  }
}

{
  my $f = Bar->new;
  ($f->attr) = (1, 2);
  is_deeply [$f->attr], [1, 2];
  ($f->attr_as_list) = (3, 4);
  is_deeply [$f->attr], [3, 4];
}

# wrapping an array lvalue method, adding an after
{
  package Bar;
  sub after { $_[0]->{after} }
  sub attr_wrap :lvalue {
    my $self = shift;

    # no answer that works consistently for any inner method
    #my $ret = \($self->attr);          # ref to last entry
    #my $ret = \($self->attr_as_list);  # ref to last entry
    #my @ret = \($self->attr);          # nothing
    my @ret = \($self->attr_as_list);  # ref to each working

    $self->{after}++;

    # have to hard code number of elements.  not generalizable.
    (${$ret[0]}, ${$ret[1]});
  }
}

{
  my $f = Bar->new;
  ($f->attr_wrap) = (1, 2);
  is_deeply [$f->attr], [1, 2];
  is $f->after, 1;
}

# wrapping an array lvalue method using a tie hack, adding an after
#
# taking a reference to an array lvalue method doesn't work.  this is what
# necessitates this implementation, but also means we don't need most of what
# would be needed for most ties.  Also, the array will be destroyed immediately
# after the assignment or read.
#
# When a read operation is being performed, we can run the wrapped sub directly,
# storing its result in the tied hash.  Then the afters can be run, and the
# appropriate result returned for the operation.
#
# When a lvalue write is being performed, it calls CLEAR, then EXTEND, then does
# multiple STOREs.  If an empty list is assigned, no EXTEND or STOREs are
# performed.  Because of this, the only reliable opportunity we will have to run
# the wrapped sub is by being DESTROYed.  Assignment of the full array is the
# only operation supported by perl for lvalue subs, so we don't need to
# implement PUSH, POP, UNSHIFT, SHIFT, SPLICE, EXISTS, or DELETE.
{
  package LvalueArray;
  sub TIEARRAY {
    my ($class, $sub, $params, $afters) = @_;
    my $self = bless [ $sub, $params, $afters ], $class;
  }

  sub STORE {
    $_[0]->[4][$_[1]] = $_[2];
  }
  sub CLEAR {
    $_[0]->[4] = [];
  }
  sub EXTEND {
    $#{$_[0]->[4]} = $_[1]-1;
  }

  sub FETCH {
    $_[0]->run;
    $_[0]->[3][$_[1]];
  }
  sub FETCHSIZE {
    $_[0]->run;
    scalar @{$_[0]->[3]};
  }

  sub run {
    my ($sub, $params, $afters, $result, $store) = @{$_[0]};
    return if $result;
    if ($store) {
      $_[0]->[3] = [($sub->(@$params)) = @$store];
    }
    else {
      $_[0]->[3] = [($sub->(@$params))];
    }
    for my $after (@$afters) {
      $after->(@$params);
    }
  }

  sub DESTROY {
    $_[0]->run;
  }
}

{
  package Bar;
  sub attr_wrap_tie :lvalue {
    tie my @array, 'LvalueArray', \&attr, \@_, [sub { $_[0]->{after}++ }];
    @array;
  }
  sub attr_as_list_wrap_tie :lvalue {
    tie my @array, 'LvalueArray', \&attr_as_list, \@_, [sub { $_[0]->{after}++ }];
    @array;
  }
}

{
  my $f = Bar->new;
  ($f->attr_wrap_tie) = (1, 2);
  is_deeply [$f->attr], [1, 2];
  is $f->after, 1;

  my $out = [($f->attr_as_list_wrap_tie) = (3, 4)];
  is_deeply [$f->attr], [3, 4];
  is $f->after, 2;
  is_deeply $out, [3, 4];

  $out = [$f->attr_wrap_tie];
  is_deeply $out, [3, 4];
  is $f->after, 3;

  $out = [($f->attr_wrap_tie) = ()];
  is_deeply [$f->attr], [];
  is $f->after, 4;
  is_deeply $out, [];
}

done_testing;