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;


##</code><code>##

#!/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();


##</code><code>##

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

##</code><code>##

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 decl via new()
        predicate => 'has_tp_enabled', # inform test code that TPs are enabled
        default => 1,
        writer => undef, # always read-only       
      )
    );
    $meta->add_attribute(
      tp_callback => (
        accessor => 'tp_callback', # default is rw
        predicate => 'has_tp_callback', #inform test code about 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, # 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;


##</code><code>##

#!/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();


##</code><code>##

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