#!/usr/bin/perl -l
use warnings;
use strict;


package Checkee;

# A tied object that has a value and a closure.  Any value that the
# caller wants to assign to the object is first run through the
# closure; if the result is false, we die with a backtrace.

use fields qw/Value Closure/;

use Carp;

sub TIESCALAR {
    my ($class, $closure) = @_;
    my Checkee $self = fields::new;
    $$self{Closure} = $closure;
    bless $self;
}

sub FETCH {
    (my Checkee $self) = @_;
    $$self{Value};
}

sub STORE {
    (my Checkee $self, local $_) = @_;
    confess "Illegal assignment: ", defined $_? $_: '[undef]'
        unless $$self{Closure}();
    $$self{Value} = $_;
}


package CheckFactory;

# An object that stores a closure.  It can create tied objects that
# use the closure to check any value assigned to them.

use fields 'Closure';

sub new(&) {
    my ($closure) = @_;
    die "CheckFactory::new must be passed a closure\n"
        unless ref $closure eq 'CODE';

    my CheckFactory $self = fields::new;
    $$self{Closure} = $closure;
    bless $self;
}


# Calling Syntax could be a lot prettier if we found a way to return
# tied objects from a sub.

sub Monitor: lvalue {
    (my CheckFactory $self, my $rvar) = @_;
    tie $$rvar, 'Checkee', $$self{Closure};
    $$rvar;
}


package main;

# Proof o' the pudding...


sub deftest() {
    my $deffactory = CheckFactory::new {defined};
    $deffactory->Monitor(\ my $var);

    print($var = 'Defined');
    # print($var = undef);
}


sub inttest() {
    my $intfactory = CheckFactory::new {!defined or /^ -? \d+ $/x};
    $intfactory->Monitor(\ my $var) = 42;   # assigns 42 to $var
                                            # -- far from obvious.
    print($var /= 2);
    # print($var /= 2);
}


sub main() {
    deftest;
    inttest;
}

main;