File Coverage

blib/lib/Devel/Scope.pm

Criterion	Covered	Total	%
statement	74	81	91.3
branch	12	16	75.0
condition	4	9	44.4
subroutine	13	13	100.0
pod	1	6	16.6
total	104	125	83.2

package Devel::Scope;

use 5.006;
use strict;
use warnings;

use List::Util qw( min );
use Scope::Upper qw( SCOPE );
use Term::Colormap qw( colormap print_colored_text colored_text);
use Time::HiRes qw( tv_interval gettimeofday );

require Exporter;
our @ISA       = qw( Exporter );
our @EXPORT_OK = qw( debug debug_enable debug_disable );

our $VERSION = '0.12';

my %default_config = (
    'DEVEL_SCOPE_DEPTH'                => 0,
    'DEVEL_SCOPE_MIN_DECIMAL_PLACES'   => 10,
    'DEVEL_SCOPE_TIME_FORMAT'          => '%06f',
    'DEVEL_SCOPE_TIME_LOG_BASE'        => 5,
    'DEVEL_SCOPE_TIME_LOG_OFFSET'      => 4,
);

my %config = validate_env_vars();

my $time_format = $config{'DEVEL_SCOPE_TIME_FORMAT'};
my $format_total_and_elapsed = "[ $time_format : $time_format ]";

my $debug_min_elapsed = 10 ** (-1 * $config{'DEVEL_SCOPE_MIN_DECIMAL_PLACES'} );
my $log_base = log( $config{ 'DEVEL_SCOPE_TIME_LOG_BASE' } );

#               blue  cyan  green  yellow  orange  red
my $colormap = [ 201,   51,    46,    226,    202, 196 ];

my $start_time = [ gettimeofday ];
my $tic = $start_time;
my $last_file = '';

debug("Using " . __PACKAGE__ . ' with ');
for my $key (sort keys %config) {
    debug("    " . $key . '=' . $config{$key});
}
debug("[ total seconds, seconds since last debug call ]");
debug('D-2 means Depth = 2 ( relative to the file or subroutine )');
debug('L-4 means Line number 4');
debug('Stars indicate time spent between debug calls:');
for my $time_level (1..5) {
    my $sec = seconds_for_time_level($time_level);
    my $color_index = min($time_level, $#$colormap);
    my $stars = colored_text($colormap->[$color_index],
                             "(" . ('*'x$time_level) . ")");
    debug("$stars : > $sec seconds");
}
debug("-"x40);

sub debug {
    return if not defined $ENV{'DEVEL_SCOPE_DEPTH'};
    $config{'DEVEL_SCOPE_DEPTH'} = $ENV{'DEVEL_SCOPE_DEPTH'};
    my $toc = [ gettimeofday ];

    my ($message) = join(' ', @_);
    my $depth = SCOPE(1);

    my ($pack0, $file0, $line0) = caller(); # If in main
    return if ($depth > $config{'DEVEL_SCOPE_DEPTH'}) and ($pack0 ne __PACKAGE__);

    my ($package, $filename, $line, $subroutine) = caller(1);
    if (defined $subroutine) {
        if ($subroutine eq 'main::' or $subroutine eq '(eval)') {
            $subroutine = '';
        } else {
            $subroutine .= "()";
        }
        $subroutine =~ s|^main::||;
    } else {
        $line = $line0;
        $subroutine = '';
        $filename = $file0;
    }

    my $elapsed = tv_interval( $tic, $toc );
    return unless $elapsed >= $debug_min_elapsed;

    my $total_elapsed = tv_interval( $start_time, $toc );
    my $time_output = sprintf($format_total_and_elapsed,
                              $total_elapsed, $elapsed);

    # Time level capped at the number of colors in our colormap
    my $time_level = int( $config{'DEVEL_SCOPE_TIME_LOG_OFFSET'}
                          + ( log($elapsed) / $log_base ));

    if ($filename eq $last_file) {
        $filename = '';
    } else {
        output("DEVEL_SCOPE Entering $filename \n");
        $last_file = $filename;
    }

    output("$time_output D-$depth L-$line $subroutine : ");
    if ($time_level > 0) {
        # Highligh longer running steps with stars (* = fastish, ***** = slow )
        my $color_index = min($time_level, $#$colormap);
        print_colored_text($colormap->[$color_index],
                           "(" . ('*'x$time_level) . ")");
        print " : ";
    }
    output("$message\n");
    $tic = [ gettimeofday ];
}

sub seconds_for_time_level {
    my ($level) = @_;
    my $offset = $config{'DEVEL_SCOPE_TIME_LOG_OFFSET'};
    return exp( ($level - $offset) * $log_base );
}

sub output {
    my ($msg) = @_;

    {
        local $| = 1;
        print $msg;
    }
}

sub debug_disable {
    my $previous_value = $ENV{'DEVEL_SCOPE_DEPTH'};
    delete $ENV{'DEVEL_SCOPE_DEPTH'};
    delete $config{'DEVEL_SCOPE_DEPTH'};
    return $previous_value;
}

sub debug_enable {
    my ($depth) = @_;
    $depth ||= $default_config{'DEVEL_SCOPE_DEPTH'};

    $ENV{'DEVEL_SCOPE_DEPTH'} = $depth;
    $config{'DEVEL_SCOPE_DEPTH'} = $depth;

    return $depth;
}

sub validate_env_vars {
    my $env_prefix = 'DEVEL_SCOPE_';
    my @env_vars_maybe = grep { m|^$env_prefix| } keys %ENV;

    my %config = %default_config;
    for my $env_var (@env_vars_maybe) {
        if ( not defined $config{$env_var} ) {
            print "Invalid " . __PACKAGE__ . " env variable '$env_var'\n";
            print "Possible variable names: [name=default]\n";
            for my $key ( sort keys %config ) {
                print "    " . $key . '=' . $config{$key} . "\n";
            }
            die "\n";
        } else {
            $config{ $env_var } = $ENV{ $env_var };
        }
    }

    return %config;
}

1; # End of Devel::Scope

__END__