File Coverage

blib/lib/JIP/Debug.pm

Criterion	Covered	Total	%
statement	50	50	100.0
branch	7	12	58.3
condition			n/a
subroutine	13	13	100.0
pod	0	3	0.0
total	70	78	89.7

package JIP::Debug;

use base qw(Exporter);

use 5.006;
use strict;
use warnings;
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_002';
our @EXPORT_OK = qw(to_debug to_debug_raw to_debug_empty);

our $HANDLE = \*STDERR;

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

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

our $COLOR = 'bright_green';

our $MAYBE_COLORED = sub { $ARG[0] };
eval {
    require Term::ANSIColor;
    $MAYBE_COLORED = sub { 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]:};

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

# 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;

        Dumper(\@_);
    };

    my $msg_delimiter = defined $MSG_DELIMITER ? $MSG_DELIMITER : q{};
    $msg_delimiter = $MAYBE_COLORED->($msg_delimiter);

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

    _send_to_output($msg);
}

sub to_debug_raw {
    my $msg_text = shift;

    my $msg_delimiter = defined $MSG_DELIMITER ? $MSG_DELIMITER : q{};
    $msg_delimiter = $MAYBE_COLORED->($msg_delimiter);

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

    _send_to_output($msg);
}

sub to_debug_empty {
    my $msg_delimiter = defined $MSG_DELIMITER ? $MSG_DELIMITER : q{};
    $msg_delimiter = $MAYBE_COLORED->($msg_delimiter);

    my $msg = sprintf qq{%s\n%s%s},
        $msg_delimiter,
        $msg_delimiter,
        qq{\n} x 20;

    _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__