Consider the following class:
package Foo;
sub new { bless {todo => 0, done => 0}, shift };
sub add { shift->{todo}++ };
sub remove {
my $self = shift;
$self->{todo}--;
$self->{done}++;
};
sub todo { shift->{todo} };
sub done { shift->{done} };
Nice and simple. Unless of course some bad classes break encapsulation:
package Bar;
use base qw(Foo);
# oops. $self->{done} not updated
sub naughty_remove { shift->{todo}-- };
...
package Ni;
use base qw(Foo);
sub naughty_transfer {
my ($to, $from) = @_;
while ($from->todo) {
$to->{todo}++;
# oops. $from->{done} not updated
$from->{todo}--;
};
};
This kind of bug can be hard to locate in large classes. Wouldn't it be nice if we could ask perl to keep a lookout for where Foo objects are used incorrectly by a subroutine? Maybe something like this:
# Monitor the arguments of subroutines ...
my $monitor = monitor_arg
# ... in the following packages ...
in_package => [ 'Foo', 'Bar', 'Ni' ],
# ... where the argument isa Foo object
matching => sub { ref($_[0]) && UNIVERSAL::isa($_[0], 'Foo') },
# ... and check that we didn't mess with the internals ...
with => sub {
my ($original, $current, $subroutine) = @_;
my $removed = $original->todo - $current->todo;
my $done = $current->done - $original->done;
warn "removed item not added to done list in $subroutine\n"
if $removed > 0 && $removed != $done;
};
With the wonder of Hook::LexWrap we can :-)
use Carp;
use Storable qw(dclone);
use Hook::LexWrap;
use Devel::Symdump;
our $Monitoring;
sub monitor_arg {
my %param = @_;
my ($matching, $in_package, $with) =
map {$param{$_} or croak "need $_"}
qw(matching in_package with);
croak "called in void context" unless defined wantarray;
my @wrappers;
foreach my $subroutine (Devel::Symdump->functions(@$in_package)) {
my ($original, @current);
push @wrappers, wrap $subroutine,
pre => sub {
return if $Monitoring;
local $Monitoring = 1;
@current = grep { $matching->($_) } @_;
$original = dclone(\@current);
},
post => sub {
return if $Monitoring;
local $Monitoring = 1;
foreach my $current (@current) {
my $original = shift @$original;
$with->($original, $current, $subroutine);
}
};
};
return \@wrappers;
};
So running:
my $o = Bar->new;
$o->add;
$o->add;
$o->naughty_remove;
my $from = Foo->new();
$from->add;
my $to = Ni->new;
$to->naughty_transfer($from);
with the previously shown call to monitor_arg will give us
removed item not added to done list in Bar::naughty_remove
removed item not added to done list in Ni::naughty_transfer
I'm sure you get the idea. What interesting things have you done with Hook::LexWrap?