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


line stmt bran cond sub pod time code
1 8     8   45 use strict;
  8         15  
  8         175  
2 8     8   32 use warnings;
  8         13  
  8         212  
3             package Net::IMP::Debug;
4              
5 8     8   32 use base 'Exporter';
  8         15  
  8         3522  
6             our @EXPORT = qw($DEBUG debug);
7             our @EXPORT_OK = qw($DEBUG_RX set_debug);
8              
9             our $DEBUG = 0; # is debugging enabled at all
10             our $DEBUG_RX = undef; # debug only packages matching given regex
11             my $DEBUG_SUB = undef; # external debug function to call instead of internal
12              
13             # import exported stuff, special case var => \$debug, func => \$code
14             sub import {
15             # on default import go immediately to Exporter
16 39 100   39   11775 goto &Exporter::import if @_ == 1;
17              
18             # extract var => \$var from import and alias it to DEBUG
19             # extract sub => \$code and set $DEBUG_SUB
20 8         34 for(my $i=1;$i<@_-1;$i++) {
21 0 0       0 if ( $_[$i] eq 'var' ) {
    0          
    0          
22 0         0 *DEBUG = $_[$i+1];
23 0         0 splice(@_,$i,2);
24 0         0 $i-=2;
25             } elsif ( $_[$i] eq 'rxvar' ) {
26 0         0 *DEBUG_RX = $_[$i+1];
27 0         0 splice(@_,$i,2);
28 0         0 $i-=2;
29             } elsif ( $_[$i] eq 'sub' ) {
30 0         0 $DEBUG_SUB = $_[$i+1];
31 0         0 splice(@_,$i,2);
32 0         0 $i-=2;
33             }
34             }
35              
36             # call Exporter only if we have remaining args, because we don't
37             # want to trigger the default export if user gave args (e.g. var,sub)
38 8 50       361 goto &Exporter::import if @_>1;
39             }
40              
41             # set debugging properties
42             sub set_debug {
43 0 0 0 0 1 0 $DEBUG = $_[1] if @_>1 && defined $_[1];
44 0 0       0 $DEBUG_RX = $_[2] if @_>2;
45             }
46              
47             # print out debug message or forward to external debug func
48             sub debug {
49 293 50   293 1 7800 $DEBUG or return;
50 0           my $msg = shift;
51 0 0         $msg = sprintf($msg,@_) if @_;
52 0 0         if ( $DEBUG_SUB ) {
53 0           @_ = ($msg);
54             # goto foreign debug sub
55             # if DEBUG_RX is set this ill be done later
56 0 0         goto &$DEBUG_SUB if ! $DEBUG_RX;
57             }
58              
59 0           my ($pkg,$line) = (caller(0))[0,2];
60 0 0         if ( $DEBUG_RX ) {
61 0   0       $pkg ||= 'main';
62             # does not match wanted package
63 0 0         return if $pkg !~ $DEBUG_RX;
64             # goto foreign debug sub
65 0 0         goto &$DEBUG_SUB if $DEBUG_SUB;
66             }
67              
68 0           my $sub = (caller(1))[3];
69 0 0         $sub =~s{^main::}{} if $sub;
70 0   0       $sub ||= 'Main';
71 0           $msg = "${sub}[$line]: ".$msg;
72              
73 0           $msg =~s{^}{DEBUG: }mg;
74 0           print STDERR $msg,"\n";
75             }
76              
77              
78             1;
79             __END__