#!/usr/bin/perl
use warnings;
use strict;
##</code><code>##

package Constrained;
use Errno qw/EINVAL/;
##</code><code>##

sub _invalidate {
    $! = shift;
    die sprintf('Constraint violation: %s by %s::%s in %s line %s.',
                $!,
                map { qq($_) } (caller 1)[0,3,1,2] ),
        "\n";
}
##</code><code>##

sub TIESCALAR {
    my $class = shift;
    if (defined $_[1]) {
        $_[0]($_[1]) or _invalidate EINVAL;
    }
    bless { code => $_[0], val => $_[1]}, $class;
}
##</code><code>##

sub STORE {
    my ($self, $val) = @_;
    $self->{code}($val) or _invalidate EINVAL;
    $self->{val} = $val;
}
##</code><code>##

sub FETCH {
    defined $_[0]{val} or _invalidate EINVAL;
    $_[0]->{val};
}

sub DESTROY {
   # nothing to do
}

1;
##</code><code>##

package main;
my ($v, $c) = (qr/[aeiouy]/i, qr/[bcdfghjklmnpqrstvwxyz]/i);

{
    tie my $foo, 'Constrained', sub {shift=~/^$c$v$v$c$c$/};
    sub foo () :lvalue { $foo }
}
##</code><code>##

print q(Testing FETCH error for undefined value,), $/; 
defined( eval { print 'foo is ', foo, $/ }) or print $@, $/;

print q(Testing STORE error for invalid value, 'quasi',), $/;
print defined( eval { foo = 'quasi'}) ?
      ('foo is ', foo, $/, $/) :
      ($@, $/);

print q(Testing STORE error valid value, 'quash',), $/;
print defined( eval { foo = 'quash'}) ?
      ('foo is ', foo, $/, $/) :
      ($@, $/);

print q(Testing modification, 'foo =~ s/h/e/',), $/;
print defined( eval { foo =~ s/h/e/}) ?
      ('foo is ', foo, ' - ERROR', $/, $/) :
      ($@, $/);

print q(Testing TIESCALAR error invalid value, 'suite',), $/;
print defined( eval {
          tie my $bar, 'Constrained',
              sub {shift=~/^$c$v$v$c$c$/}, 'suite';
          sub bar () :lvalue { $bar }
      }) ?
      ('bar is ', bar, $/, $/) :
      ($@, $/);

print q(Testing TIESCALAR error valid value, 'suits',), $/;
print defined( eval {
          tie my $baz, 'Constrained',
              sub {shift=~/^$c$v$v$c$c$/}, 'suits';
          sub baz () :lvalue { $baz }
      }) ?
      ('baz is ', baz, $/, $/) :
      ($@, $/);
##</code><code>##

__END__
Testing FETCH error for undefined value,
Constraint violation: Invalid argument by main::Constrained::FETCH in lvval.pl line 50.

Testing STORE error for invalid value, 'quasi',
Constraint violation: Invalid argument by main::Constrained::STORE in lvval.pl line 53.

Testing STORE error valid value, 'quash',
foo is quash

Testing modification, 'foo =~ s/h/e/',
Constraint violation: Invalid argument by main::Constrained::STORE in lvval.pl line 63.

Testing TIESCALAR error invalid value, 'suite',
Constraint violation: Invalid argument by main::Constrained::TIESCALAR in lvval.pl line 70.

Testing TIESCALAR error valid value, 'suits',
baz is suits