File Coverage

blib/lib/HTTP/OAI/Debug.pm
Criterion Covered Total %
statement 13 29 44.8
branch 2 16 12.5
condition n/a
subroutine 5 8 62.5
pod 0 5 0.0
total 20 58 34.4


line stmt bran cond sub pod time code
1             package HTTP::OAI::Debug;
2              
3             =pod
4              
5             =head1 NAME
6              
7             B - debug the HTTP::OAI libraries
8              
9             =head1 DESCRIPTION
10              
11             This package is a copy of L and exposes the same API. In addition to "trace", "debug" and "conns" this exposes a "sax" level for debugging SAX events.
12              
13             =cut
14              
15             require Exporter;
16             @ISA = qw(Exporter);
17             @EXPORT_OK = qw(level trace debug conns);
18              
19             our $VERSION = '4.12';
20              
21 11     11   68 use Carp ();
  11         16  
  11         4926  
22              
23             my @levels = qw(trace debug conns sax);
24             %current_level = ();
25              
26              
27             sub import
28             {
29 11     11   22 my $pack = shift;
30 11         20 my $callpkg = caller(0);
31 11         18 my @symbols = ();
32 11         18 my @levels = ();
33 11         25 for (@_) {
34 0 0       0 if (/^[-+]/) {
35 0         0 push(@levels, $_);
36             }
37             else {
38 0         0 push(@symbols, $_);
39             }
40             }
41 11         507 Exporter::export($pack, $callpkg, @symbols);
42 11         35 level(@levels);
43             }
44              
45              
46             sub level
47             {
48 11     11 0 253 for (@_) {
49 0 0       0 if ($_ eq '+') { # all on
    0          
    0          
50             # switch on all levels
51 0         0 %current_level = map { $_ => 1 } @levels;
  0         0  
52             }
53             elsif ($_ eq '-') { # all off
54 0         0 %current_level = ();
55             }
56             elsif (/^([-+])(\w+)$/) {
57 0         0 $current_level{$2} = $1 eq '+';
58             }
59             else {
60 0         0 Carp::croak("Illegal level format $_");
61             }
62             }
63             }
64              
65              
66 22 50   22 0 150 sub trace { _log(@_) if $current_level{'trace'}; }
67 0 0   0 0 0 sub debug { _log(@_) if $current_level{'debug'}; }
68 0 0   0 0 0 sub conns { _log(@_) if $current_level{'conns'}; }
69 1289 50   1289 0 49989 sub sax { _log(@_) if $current_level{'sax'}; }
70              
71              
72             sub _log
73             {
74 0     0     my $msg = shift;
75 0           $msg =~ s/\n$//;
76 0           $msg =~ s/\n/\\n/g;
77              
78 0           my($package,$filename,$line,$sub) = caller(2);
79 0           print STDERR "$sub: $msg\n";
80             }
81              
82             1;