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;
[download]

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();
[download]