One rap against the implementation of OO Perl by lvalue closures is that no hook is available for checking the validity of input. Code before the last line of an lvalue sub is ignored in lvalue assignment.
It struck me that all that is needed is some user sub that can subvert assignment. I realized that if the closure were on a tied variable, the STORE method could do that. Time for an experiment...
For this demo, I define a tied scalar package, Constrained, which takes a coderef in its constructor. The sub takes one argument and returns true if the argument is valid, false otherwise. I'll fill in the details in the listing.
After preliminaries,
#!/usr/bin/perl
use warnings;
use strict;
I define the
Constrained namespace, which is to implement a tied scalar checked against a user-supplied validation routine before storing a value. Errors will throw POSIX EINVAL.
package Constrained;
use Errno qw/EINVAL/;
The _invalidate sub is called with an Errno as argument. This technique is likely to be used with numeric constraints, where EDOM and ERANGE might be more natural. I don't make any use of that here.
sub _invalidate {
$! = shift;
die sprintf('Constraint violation: %s by %s::%s in %s line %s.',
$!,
map { qq($_) } (caller 1)[0,3,1,2] ),
"\n";
}
As an exception to the constraint regime, I permit a newly tied variable to be
undef if no initializer is supplied. That will make it necessary to rule that definedness is required in the FETCH method below.
sub TIESCALAR {
my $class = shift;
if (defined $_[1]) {
$_[0]($_[1]) or _invalidate EINVAL;
}
bless { code => $_[0], val => $_[1]}, $class;
}
STORE() is called in assignment and modification, so we highjack it to throw if fed bad data.
sub STORE {
my ($self, $val) = @_;
$self->{code}($val) or _invalidate EINVAL;
$self->{val} = $val;
}
FETCH() is called when anything reads the value. We require definedness so that we get tested data back.
sub FETCH {
defined $_[0]{val} or _invalidate EINVAL;
$_[0]->{val};
}
sub DESTROY {
# nothing to do
}
1;
To try the idea, let's produce a tied scalar which can only be assigned strings of the form 'cvvcc' (English vowels and consonants). We get back into
main::, cook up some shorthand for vowel and consonant character classes, and fire up the closure on the tied variable.
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 }
}
Finally, we run a series of tests to show what's working.
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, $/, $/) :
($@, $/);
Here are the results:
__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
... and that's that. It was very satisfying to see the s/// modification test pass. It was an afterthought which I feared would break the idea.
Destructive comments will be treasured.
After Compline,
Zaxo
