package test_class;
use Moose;
has 'foo' => (
is => 'rw',
isa => 'Str',
);
has 'bar' => (
is => 'rw',
isa => 'Str',
);
has 'tp_callback' => (
is => 'rw',
isa => 'CodeRef',
);
sub BUILD {
my $self = shift;
# initialize the test callback
$self->tp_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->tp_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->tp_callback->('test_point_two', {
lvar_foo => $lvar_foo,
lvar_bar => $lvar_bar,
});
return 1;
}
__PACKAGE__->meta->make_immutable;
1;
####
#!/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->tp_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();
##
##
aimass@yclt2:~/languages/perl/MooseTest$ prove -v test_class.t
test_class.t ..
ok 1 - use test_class;
ok 2 - Value of attr bar at test_point_one
ok 3 - Value of lvar_foo at test_point_two
ok 4 - Value of lvar_bar at test_point_two
ok 5 - Result of asub
1..5
ok
All tests successful.
Files=1, Tests=5, 0 wallclock secs ( 0.05 usr 0.00 sys + 0.37 cusr 0.02 csys = 0.44 CPU)
Result: PASS
##
##
package cond_tp;
use Moose;
use namespace::autoclean;
has 'foo' => (
is => 'rw',
isa => 'Str',
);
has 'bar' => (
is => 'rw',
isa => 'Str',
);
# set-up Test-Point depending on debug level
{
my $debug_level = $ENV{'MYDEBUG_LEVEL'} || 0;
my $meta = Class::MOP::get_metaclass_by_name(__PACKAGE__);
# enable TPs at debug level 5 and higher
if($debug_level > 4){
$meta->add_attribute(
tp_enabled => (
accessor => 'tp_enabled',
init_arg => undef, # prevent override via new()
predicate => 'has_tp_enabled'
default => 1, # test-points are enabled
writer => undef, # always read-only
)
);
$meta->add_attribute(
tp_callback => (
accessor => 'tp_callback', # default is rw
predicate => 'has_tp_callback',
default => sub {return;},
)
);
}
else{
$meta->add_attribute(
tp_enabled => (
accessor => 'tp_enabled',
init_arg => undef,
predicate => 'has_tp_enabled',
default => 0, # test points are disabled
writer => undef,
)
);
$meta->add_attribute(
tp_callback => (
accessor => 'tp_callback',
predicate => 'has_tp_callback',
default => sub {return;},
writer => undef, # cb is now read-only
)
);
}
}
sub asub {
my $self = shift;
my $lvar_foo;
my $lvar_bar;
# some code that sets bar
$self->bar('result');
# TP conditioned
$self->tp_callback->('test_point_one')
if $self->tp_enabled;
# some code that sets a local vars
$lvar_foo = 'yuca';
$lvar_bar = 'pelada';
# TP conditioned
$self->tp_callback->('test_point_two', {
lvar_foo => $lvar_foo,
lvar_bar => $lvar_bar,
}) if $self->tp_enabled;
return 1;
}
__PACKAGE__->meta->make_immutable;
1;
##
##
#!/usr/bin/perl
use strict;
use warnings;
use Test::More;
BEGIN { use_ok 'cond_tp' }
my $tc = cond_tp->new();
# the dispatch table
my %test_points = (
test_point_one => \&test_point_one,
test_point_two => \&test_point_two,
);
# setup the callback dispatch only if enabled
if($tc->tp_enabled){
$tc->tp_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();
##
##
aimass@yclt2:~/languages/perl/MooseMeta$ export MYDEBUG_LEVEL=5
aimass@yclt2:~/languages/perl/MooseMeta$ prove -v cond_tp.t
cond_tp.t ..
ok 1 - use cond_tp;
ok 2 - Value of attr bar at test_point_one
ok 3 - Value of lvar_foo at test_point_two
ok 4 - Value of lvar_bar at test_point_two
ok 5 - Result of asub
1..5
ok
All tests successful.
Files=1, Tests=5, 1 wallclock secs ( 0.04 usr 0.01 sys + 0.40 cusr 0.01 csys = 0.46 CPU)
Result: PASS
aimass@yclt2:~/languages/perl/MooseMeta$ export MYDEBUG_LEVEL=4
aimass@yclt2:~/languages/perl/MooseMeta$ prove -v cond_tp.t
cond_tp.t ..
ok 1 - use cond_tp;
ok 2 - Result of asub
1..2
ok
All tests successful.
Files=1, Tests=2, 0 wallclock secs ( 0.03 usr 0.01 sys + 0.39 cusr 0.02 csys = 0.45 CPU)
Result: PASS