File Coverage

blib/lib/Net/IMP/Debug.pm

Criterion	Covered	Total	%
statement	13	41	31.7
branch	4	30	13.3
condition	0	7	0.0
subroutine	5	6	83.3
pod	2	2	100.0
total	24	86	27.9

use strict;
use warnings;
package Net::IMP::Debug;

use base 'Exporter';
our @EXPORT = qw($DEBUG debug);
our @EXPORT_OK = qw($DEBUG_RX set_debug);

our $DEBUG = 0;          # is debugging enabled at all
our $DEBUG_RX = undef;   # debug only packages matching given regex
my  $DEBUG_SUB = undef;  # external debug function to call instead of internal

# import exported stuff, special case var => \$debug, func => \$code
sub import {
    # on default import go immediately to Exporter
    goto &Exporter::import if @_ == 1;

    # extract var => \$var from import and alias it to DEBUG
    # extract sub => \$code and set $DEBUG_SUB
    for(my $i=1;$i<@_-1;$i++) {
	if ( $_[$i] eq 'var' ) {
	    *DEBUG = $_[$i+1];
	    splice(@_,$i,2);
	    $i-=2;
	} elsif ( $_[$i] eq 'rxvar' ) {
	    *DEBUG_RX = $_[$i+1];
	    splice(@_,$i,2);
	    $i-=2;
	} elsif ( $_[$i] eq 'sub' ) {
	    $DEBUG_SUB = $_[$i+1];
	    splice(@_,$i,2);
	    $i-=2;
	}
    }

    # call Exporter only if we have remaining args, because we don't
    # want to trigger the default export if user gave args (e.g. var,sub)
    goto &Exporter::import if @_>1;
}

# set debugging properties
sub set_debug {
    $DEBUG    = $_[1] if @_>1 && defined $_[1];
    $DEBUG_RX = $_[2] if @_>2;
}

# print out debug message or forward to external debug func
sub debug {
    $DEBUG or return;
    my $msg = shift;
    $msg = sprintf($msg,@_) if @_;
    if ( $DEBUG_SUB ) {
	@_ = ($msg);
	# goto foreign debug sub
	# if DEBUG_RX is set this ill be done later
	goto &$DEBUG_SUB if ! $DEBUG_RX;
    }

    my ($pkg,$line) = (caller(0))[0,2];
    if ( $DEBUG_RX ) {
	$pkg ||= 'main';
	# does not match wanted package
	return if $pkg !~ $DEBUG_RX;
	# goto foreign debug sub
	goto &$DEBUG_SUB if $DEBUG_SUB;
    }

    my $sub = (caller(1))[3];
    $sub =~s{^main::}{} if $sub;
    $sub ||= 'Main';
    $msg = "${sub}[$line]: ".$msg;

    $msg =~s{^}{DEBUG: }mg;
    print STDERR $msg,"\n";
}


1;
__END__