This is a proposal for a Tutorial. Please post your comments here RFC: Tutorial "Introspecting your Moose code using Test Point Callbacks"
Introspecting your Moose code using Test Point Callbacks
There are times when you want to check the value of something at a specific place in your object code, much like the times when you wind up setting up a debugger's break point and watches. This technique allows you to set-up automated "Test Points" analogous to those found in printed circuit boards. This way, you can test for example: partial results within a sub, monitor some local var or object attribute in a sub, or check the HTTP status of an LWP call to another system (i.e. to SKIP certain tests given the result of this call).
How it works
You set-up a single test_callback attribute in your Moose object which will be initialized with a simple sub that does nothing. Then, whenever you find yourself in the need to debug something instead of using a warn statement that you will throw away, or whenever you have found the need for a DB breakpoint and watches, you can just as easily code a permanent test point, helping you debug this problem in the future using diags and test result messages rather than warns all over the place.
Here is a simple test class and test code that illustrates this technique:
test_class.pm
package test_class;
use Moose;
has 'foo' => (
is => 'rw',
isa => 'Str',
);
has 'bar' => (
is => 'rw',
isa => 'Str',
);
has 'test_callback' => (
is => 'rw',
isa => 'CodeRef',
);
sub BUILD {
my $self = shift;
# initialize the test callback
$self->test_callback(sub {return;});
}
sub asub {
my $self = shift;
my $lvar_foo;
my $lvar_bar;
# some code that sets bar
$self->bar('result');
# you want to test the value of bar at this point
$self->test_callback->('test_point_one');
# some code that sets a local vars
$lvar_foo = 'yuca';
$lvar_bar = 'pelada';
# you want to test the value of lvar at this point
$self->test_callback->('test_point_two', {
lvar_foo => $lvar_foo,
lvar_bar => $lvar_bar,
});
return 1;
}
__PACKAGE__->meta->make_immutable;
1;
test_class.t
#!/usr/bin/perl
use strict;
use warnings;
use Test::More;
BEGIN { use_ok 'test_class' }
my $tc = test_class->new();
# the dispatch table
my %test_points = (
test_point_one => \&test_point_one,
test_point_two => \&test_point_two,
);
# setup the callback dispatch
$tc->test_callback(
sub {
my $tp = shift;
$test_points{$tp}->(@_);
}
);
# regular tests here
cmp_ok($tc->asub(), '==', 1, 'Result of asub');
# callback test subs here (or in pm?)
sub test_point_one {
my $params = shift; #not used in this test point
cmp_ok($tc->bar, 'eq', 'result',
'Value of attr bar at test_point_one');
}
sub test_point_two {
my $params = shift;
cmp_ok($params->{lvar_foo}, 'eq', 'yuca',
'Value of lvar_foo at test_point_two');
cmp_ok($params->{lvar_bar}, 'eq', 'pelada',
'Value of lvar_bar at test_point_two');
}
done_testing();
|