File Coverage

blib/lib/JIP/Debug.pm

Criterion	Covered	Total	%
statement	68	68	100.0
branch	15	18	83.3
condition	10	11	90.9
subroutine	16	16	100.0
pod	2	7	28.5
total	111	120	92.5

package JIP::Debug;

use base qw(Exporter);

use 5.006;
use strict;
use warnings;
use Devel::StackTrace;
use Carp qw(croak);
use Data::Dumper qw(Dumper);
use Fcntl qw(LOCK_EX LOCK_UN);
use English qw(-no_match_vars);

our $VERSION = '0.999_003';

our @EXPORT_OK = qw(
    to_debug
    to_debug_raw
    to_debug_empty
    to_debug_count
    to_debug_trace
);

our $HANDLE = \*STDERR;

our $MSG_FORMAT      = qq{%s\n%s\n\n};
our $MSG_DELIMITER   = q{-} x 80;
our $MSG_EMPTY_LINES = qq{\n} x 18;

our $DUMPER_INDENT   = 1;
our $DUMPER_DEEPCOPY = 1;
our $DUMPER_SORTKEYS = 1;

our %TRACE_PARAMS = (
    skip_frames => 1, # skip to_debug_trace
);
our %TRACE_AS_STRING_PARAMS;

our $COLOR = 'bright_green';

our $MAYBE_COLORED = sub { return $ARG[0] };
eval {
    require Term::ANSIColor;
    $MAYBE_COLORED = sub { return Term::ANSIColor::colored($ARG[0], $COLOR); };
};

our $MAKE_MSG_HEADER = sub {
    # $MAKE_MSG_HEADER=0, to_debug=1
    my ($package, undef, $line) = caller 1;

    # $MAKE_MSG_HEADER=0, to_debug=1, subroutine=2
    my $subroutine = (caller 2)[3];

    $subroutine = resolve_subroutine_name($subroutine);

    my $text = join q{, }, (
        sprintf('package=%s', $package),
        (defined $subroutine ? sprintf('subroutine=%s', $subroutine) : ()),
        sprintf('line=%d', $line, ),
    );
    $text = qq{[$text]:};

    {
        my $msg_delimiter = defined $MSG_DELIMITER ? $MSG_DELIMITER : q{};
        $text = sprintf qq{%s\n%s\n%s}, $msg_delimiter, $text, $msg_delimiter;
    }

    return $MAYBE_COLORED->($text);
};

our $NO_LABEL_KEY   = '';
our %COUNT_OF_LABEL = ($NO_LABEL_KEY => 0);

# Supported on Perl 5.22+
eval {
    require Sub::Util;

    if (my $set_subname = Sub::Util->can('set_subname')) {
        $set_subname->('MAYBE_COLORED',   $MAYBE_COLORED);
        $set_subname->('MAKE_MSG_HEADER', $MAKE_MSG_HEADER);
    }
};

sub to_debug {
    my $msg_body = do {
        local $Data::Dumper::Indent   = $DUMPER_INDENT;
        local $Data::Dumper::Deepcopy = $DUMPER_DEEPCOPY;
        local $Data::Dumper::Sortkeys = $DUMPER_SORTKEYS;

        Dumper(\@ARG);
    };

    my $msg = sprintf $MSG_FORMAT, $MAKE_MSG_HEADER->(), $msg_body;

    return send_to_output($msg);
}

sub to_debug_raw {
    my $msg_text = shift;

    my $msg = sprintf $MSG_FORMAT, $MAKE_MSG_HEADER->(), $msg_text;

    return send_to_output($msg);
}

sub to_debug_empty {
    my $msg = sprintf $MSG_FORMAT, $MAKE_MSG_HEADER->(), $MSG_EMPTY_LINES;

    return send_to_output($msg);
}

sub to_debug_count {
    my ($label, $cb);
    if (@ARG == 2 && ref $ARG[1] eq 'CODE') {
        ($label, $cb) = @ARG;
    }
    elsif (@ARG == 1 && ref $ARG[0] eq 'CODE') {
        $cb = $ARG[0];
    }
    elsif (@ARG == 1) {
        $label = $ARG[0];
    }

    $label = defined $label && length $label ? $label : $NO_LABEL_KEY;

    my $count = $COUNT_OF_LABEL{$label} || 0;
    $count++;
    $COUNT_OF_LABEL{$label} = $count;

    my $msg_body = sprintf '%s: %d', $label, $count;

    my $msg = sprintf $MSG_FORMAT, $MAKE_MSG_HEADER->(), $msg_body;

    $cb->($label, $count) if defined $cb;

    return send_to_output($msg);
}

sub to_debug_trace {
    my $cb = shift;

    my $trace = Devel::StackTrace->new(%TRACE_PARAMS);

    my $msg_body = $trace->as_string(%TRACE_AS_STRING_PARAMS);
    $msg_body =~ s{\n+$}{}x;

    my $msg = sprintf $MSG_FORMAT, $MAKE_MSG_HEADER->(), $msg_body;

    $cb->($trace) if defined $cb;

    return send_to_output($msg);
}

sub send_to_output {
    my $msg = shift;

    return unless $HANDLE;

    flock $HANDLE, LOCK_EX;
    $HANDLE->print($msg) or croak(sprintf q{Can't write to output: %s}, $OS_ERROR);
    flock $HANDLE, LOCK_UN;

    return 1;
}

sub resolve_subroutine_name {
    my $subroutine = shift;

    return unless defined $subroutine;

    my ($subroutine_name) = $subroutine =~ m{::(\w+)$}x;

    return $subroutine_name;
}

1;

__END__