package Debug; 

# THIS SHOULD BE CONSIDERED ALPHA CODE
# IMPROVEMENTS FORTHCOMING

use strict;
use warnings;
use Carp::Assert;
use Hook::LexWrap;
use Data::Dumper;
use PPI;

require Exporter;

use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);

@ISA = qw(Exporter);


# CONFIGURATION
push @EXPORT, qw{
	&set_debug_verbose
	&set_debug_quiet
    &hook_subs
    &hook_all_subs
};


# TRACK SUBROUTINE EXECUTION
push @EXPORT, qw{
	&start_sub
	&end_sub
    &dprint
};

## END EXPORTED SUBROUTINES


my $Verbose = 1;
my $SUB_NEST_LIMIT = 200;

my $VOID_CONTEXT_ERROR_MESSAGE =    'The caller of this function must assign the return value. ' . 
                                    'The hooks remain in effect only when the returned value is in lexical scope.';

my @SubStack;


sub set_debug_verbose   { $Verbose = 1 };
sub set_debug_quiet     { $Verbose = 0 };
sub is_verbose          { return $Verbose };


sub dprint($) {
	no warnings;
	return unless $Verbose;

	my ($mesg) = shift;												
    my $print_line = indentation() . $mesg;
    print "$print_line\n";
    return $print_line;
}


sub start_sub {
	return unless $Verbose;

    my $msg = shift || (caller(1))[3];
    assert ( $#SubStack < $SUB_NEST_LIMIT, "Too many subs on stack " . Dumper \@SubStack) if DEBUG;
	assert ( defined $msg ) unless DEBUG;
	
    dprint "SUB: $msg\n";
    push @SubStack, $msg;
}


sub end_sub {
	return unless $Verbose;

    my $msg = shift || (caller(1))[3];
	assert ( $msg !~ m/start_sub/) if DEBUG;
	assert ( $msg !~ m/end_sub/) if DEBUG;
    assert ( $SubStack[$#SubStack] eq $msg, 
        "Stack of size $#SubStack out of synch. Popping $SubStack[$#SubStack], expected $msg\nStack is " . 
        Dumper (\@SubStack) . "\n" ) if DEBUG;

    pop @SubStack;

    dprint "END: $msg";
}


sub indentation() {
    return "\t" x ($#SubStack+1);
}


sub hook_subs(@) { # NOTE: Hooks stay in effect within the lexical scope of the return value
    assert ( defined wantarray, $VOID_CONTEXT_ERROR_MESSAGE ) if DEBUG;

    my @sub_names = @_;

    my $hooks;
    for my $sub_name (@sub_names) {
        push @$hooks, wrap $sub_name,
             pre  => sub { start_sub ($sub_name) },
             post => sub { end_sub ($sub_name) };
    }

    return $hooks;
}


sub hook_all_subs(@) {  # NOTE: Hooks stay in effect within the lexical scope of the return value
    assert ( defined wantarray, $VOID_CONTEXT_ERROR_MESSAGE ) if DEBUG;

    my @caller = caller();
    my $Document = PPI::Document->new("$caller[1]");
    my $sub_nodes = $Document->find( 
        sub { $_[1]->isa('PPI::Statement::Sub') }
    );
    
    my @sub_names;
    for my $sub_node (@$sub_nodes) {
        next if $sub_node->name eq 'BEGIN';
        push @sub_names, $caller[0].'::'.$sub_node->name;
    }    

    return hook_subs(@sub_names);
}


1;

__END__