I have a database full of subroutines that I import into applications. The code is eval'd and stored into a hash, which is then tied to a scalar. When the user references the scalar, FETCH returns the subref so the user can execute it. One of the nice things about this setup is that I can "call" a subroutine with the tied variable, but have other events occur prior to execution. For example, a user can pause execution of the code by tripping a button on a web form. When FETCH is called, it checks the pid for the routine against a database of active pids to see if the program has been paused. If so, it delays execution of the subref in the hash until the pause is released. Kinda neat! Problem is, when I access one of the tied variables inside a for loop, the FETCH doesn't run. I've included a sample below. Can somebody tell me what's going on? Thanks in advance!
my $r = { subref => sub { return 2 * $_[0] } };
my $tied;
tie $tied, 'TieTest', $r;
# This will perform the pre-action before executing
print $tied->(5);
# These will not
for(0..100){
print $tied->(5), "\n";
}
package TieTest;
sub TIESCALAR{
my $caller = shift;
my $r = shift;
bless $r, $caller;
}
sub FETCH{
my $r = shift;
print "Checking for pause...\n";
return $$r{subref};
}
** UPDATE:
EVEN STRANGER BEHAVIOR...
This code works:
# This will perform the pre-action before executing
print $tied;
# These will not
for(0..10){
print $tied, "\n";
}
This prints the "extra" message plus a "CODE(0x224e2c)". So FETCH only fails when I attempt to dereference the returned subref.
Dragonchild's $r->{subref} = $r->{subref} fix doesn't work, but I need that type of transparency to make this work in my case. Any ideas?
** END UPDATE
update: it gives
Checking for pause... Can't use an undefined value as a subroutine reference at test.pl line 8.For perl 5.00504
for(0..100){
my $x = $tied;
print $x->(5), "\n";
}
As far as I can tell, the issue is the fact that the thing has already been FETCH'ed into an anonymous variable within either that scope or an enclosing scope. You can trip the bug even easier by doing the following:
print $tied->(5), $/;
{
print $tied->(10), $/;
}
But, if you assign it to something, then the fetch is going to a different place, as seen by the workaround.
And, it seems to be a check for the constancy of the thing. The following also "fixes" the bug:
print $tied->(5), $/;
$r->{subref} = sub { return 2 * $_[0] }; # This is a new anonymous subref
{
print $tied->(10), $/;
}
Or, more transparently to the calling code:
sub FETCH {
my $r = shift;
print "Checking for pause ...";
return $r->{subref} = $r->{subref};
}
It's definitely a bug and it looks to be a misplaced optimization.
My criteria for good software:
- Does it work?
- Can someone else come in, make a change, and be reasonably certain no bugs were introduced?
Any additional thoughts?
In 5.6.1, even the first call doesn't work (Can't use an undefined value as a subroutine reference).
Using
my $sub = $tied;
print $sub->(5), "\n";
fixed the problem in both places. It seems that $var->() and &{$var}() doesn't check if $var is tied.
Anyway, you don't have to use tie at all:
sub wrap {
my ($r) = @_;
return sub {
print "Checking for pause...\n";
return $r->{subref}->(@_);
};
}
my $tied = wrap($r);
print call $tied, 5;
sub call(@){
my $tied = shift;
return $tied->(@_);
}
I hate the look of that, though. I really want to be able to tie the scalar, and call the routine via
print $tied->(5), $/;
On the other hand, the pit bull in me has my teeth into tying variables
Tied variables are pretty slow, and they don't always work due to bugs. That's why I suggested the alternative.
Closest I've been able to come so far is this wrapper
The variable you called $tied isn't tied. That's why it works. If you fix the variable name, you get:
sub call {
my $sub = shift;
return $sub->(@_);
}
You basically took the solution I already posted and put it in a function.
I got rid of the misleading/broken/wrong prototype. Don't use prototypes unless you have a good reason and you understand the problems associated with using them.
Goodbye, tie.
Thanks for the comments and suggestions.
The following accomplishes what you want plus has the added benefit of allowing you to cache the values of the function.
package TieTest;
sub TIESCALAR {
my $class = shift @_;
die "Incorrect # of arguments" if @_ % 2;
my $self = bless {}, $class;
$self->_init(@_);
return $self;
}
sub FETCH {
my $self = shift @_;
my $work_around = sub {
my $tgt = shift @_;
if (exists $self->{$tgt}) {
print "Fetching value from cache\n";
return $self->{$tgt};
}
print "Calculating and caching value for $tgt\n";
return $self->{$tgt} = $self->{subref}->($tgt);
};
return $work_around;
}
sub _init {
my $self = shift @_;
my %arg = @_;
for (qw/subref/) { # All valid args
$self->{$_} = delete $arg{$_};
}
if (keys %arg) {
my $bad = join ' ', keys %arg;
die "The following args are invalid: $bad";
}
return;
}
package main;
tie my $tied_func, 'TieTest', subref => sub {$_[0] * 2};
# Calculate the function values for 1 .. 100
print $tied_func->($_), "\n" for 1 .. 10;
# Retrieve cached values
print $tied_func->($_), "\n" for 1 .. 10;
sub FETCH {
my $self = shift @_;
my $work_around = sub {
my $tgt = shift @_;
print "Checking for pause\n";
return $self->{subref}->($tgt);
};
return $work_around;
}
I hope that helps. You should still file a bug report!
Cheers - [Limbic~Region|L~R]
That doesn't work in 5.6.1. I don't know if that's a problem.
I don't have 5.6.1 around to test with but fortunately it worked for rational_icthus's version of Perl. Do you think getting a copy of 5.6.1 to find a work around is warranted or is the filing of a bug report sufficient?
Cheers - L~R
Thanks for the caching as well. A definite plus, although I'll probably adjust the subroutine database, adding a cache flag so that I can enable caching at the subroutine level. I just recently made it through Higher Order Perl, and I seem to recall there are times when caching is not in order.
Problem solved. Thanks!
Next item on the agenda. Filing a bug report. I'm using ActiveState on an XP box. Do I file the bug report with ActiveState, on CPAN, or both? I've never found a bug before, so never filed a bug report. How does one go about doing this?
P.S. Also appreciated some of the argument checking idioms. Haven't seen those before. They're very nice. Always looking for a step forward, and those will help me write better code in the future.
I am glad it worked for you. I don't think it is constructing and returning a new sub each time. I think Perl is over-optimizing. The trick I used was to return a closure over $self which includes the desired subref.
You are correct, caching isn't always a solution. You might want to check out Memoize for future reference. In many cases, cache is the right solution but with limited resources you need to expire unused items from the cache and only keep the most used recent. The CPAN has all kinds of options. Just search for cache.
The argument checking is not perfect. There are much better modules such as Params::Validate. Everyone has their own way of doing things. Figuring out what works for you and those responsible for maintaining your code is what is important.
This problem is not restricted to ActiveState so that's not the proper course of action. If you are not familiar with perlbug then read up on it and send in a minimalistic test case.
Cheers - L~R