File Coverage

blib/lib/Net/SIP/Debug.pm
Criterion Covered Total %
statement 34 118 28.8
branch 5 72 6.9
condition 1 32 3.1
subroutine 13 17 76.4
pod 7 7 100.0
total 60 246 24.3


line stmt bran cond sub pod time code
1             package Net::SIP::Debug;
2 44     44   256 use strict;
  44         77  
  44         1098  
3 44     44   183 use warnings;
  44         63  
  44         1054  
4 44     44   180 use Carp;
  44         78  
  44         1988  
5 44     44   22780 use Data::Dumper;
  44         258532  
  44         2513  
6 44     44   19680 use Time::HiRes 'gettimeofday';
  44         51971  
  44         162  
7 44     44   7271 use Scalar::Util 'looks_like_number';
  44         85  
  44         1913  
8 44     44   222 use base 'Exporter';
  44         858  
  44         47960  
9             our @EXPORT = qw( DEBUG DEBUG_DUMP LEAK_TRACK $DEBUG );
10             our @EXPORT_OK = qw( debug stacktrace );
11              
12              
13             our $DEBUG = 0; # exported fast check: if false no kind of debugging is done
14             our $level = 0; # needed global for source filter
15              
16             my %level4package; # package specific level
17             my $debug_prefix = 'DEBUG:'; # default prefix
18             my $debug_sub; # alternative sub to STDERR output
19              
20              
21             ##############################################################
22             # set level, scope etc from use. Usually used at the
23             # start, e.g. perl -MNet::SIP::Debug=level program
24             # Args: @args
25             # @args: something for sub level, rest to Exporter
26             # Returns: NONE
27             ##############################################################
28             sub import {
29 986     986   62788 my $class = shift;
30 986         1686 my (@export,@level);
31 986         2115 for (@_) {
32 0 0 0     0 if ( ref eq 'CODE' ) {
    0 0        
33             # set debug sub
34 0         0 $debug_sub = $_;
35             } elsif ( m{[=\*]} || m{^\d} || m{::} ) {
36 0         0 push @level,$_
37             } else {
38 0         0 push @export,$_
39             }
40             }
41 986 50       2468 $class->level(@level) if @level;
42 986 50       1900 $class->export_to_level(1,@export) if @export;
43 986 50 33     389321 $class->export_to_level(1) if ! @export && ! @level;
44             }
45              
46             ##############################################################
47             # set/get debug level
48             # Args: ($class,@spec)
49             # @spec: number|package|package=number for setting
50             # global|package specific debug level. If package
51             # is postfixed with '*' the level will be used for
52             # subpackages too.
53             # Returns: NONE|level
54             # level: if not @spec level for the current package
55             # (first outside Net::SIP::Debug in caller stack) will
56             # be returned
57             ##############################################################
58             sub level {
59 0     0 1 0 shift; # class
60 0 0       0 if ( @_ ) {
61 0 0       0 my @level = @_ >1 ? split( m{[^\w:=\*]+}, $_[0] ): @_;
62 0         0 foreach (@level) {
63 0 0       0 if ( m{^\d+$} ) {
    0          
64 0         0 $level = $_;
65             } elsif ( m{^([\w:]+)(\*)?(?:=(\d+))?$} ) {
66             # package || package=level
67 0 0 0     0 my $l = defined($3) ? $3: $level || 1;
68 0         0 my $name = $1;
69 0         0 my $below = $2;
70 0         0 my @names = ( $name );
71 0 0       0 push @names, "Net::".$name if $name =~ m{^SIP\b};
72 0 0       0 push @names, "Net::SIP::".$name if $name !~ m{^Net::SIP\b};
73 0         0 foreach (@names) {
74 0         0 $level4package{$_} = $l;
75 0 0       0 $level4package{$_.'::'} = $l if $below;
76             }
77             }
78             }
79 0         0 $DEBUG = grep { $_>0 } ($level, values(%level4package));
  0         0  
80              
81             } else {
82             # check
83 0 0       0 $DEBUG or return 0;
84 0 0       0 if ( %level4package ) {
85             # check if there is a specific level for this package
86 0         0 my $pkg;
87 0         0 for( my $i=0;1;$i++ ) {
88             # find first frame outside of this package
89 0         0 ($pkg) = caller($i);
90 0 0 0     0 last if !$pkg or $pkg ne __PACKAGE__;
91             }
92 0 0       0 return $level if !$pkg;
93              
94             # find exakt match
95 0         0 my $l = $level4package{$pkg};
96 0 0       0 return $l if defined($l);
97              
98             # find match for upper packages, e.g. if there is an entry for
99             # 'Net::SIP::' it matches everything below Net::SIP
100 0         0 while ( $pkg =~s{::\w+(::)?$}{::} ) {
101 0 0       0 return $l if defined( $l = $level4package{$pkg} );
102             }
103             }
104             }
105 0         0 return $level
106             }
107              
108             ################################################################
109             # set prefix
110             # default prefix is 'DEBUG:' but in forking apps it might
111             # be useful to change it to "DEBUG($$):" or similar
112             # Args: $class,$prefix
113             # Returns: NONE
114             ################################################################
115             sub set_prefix {
116 55     55 1 200386 (undef,$debug_prefix) = @_
117             }
118              
119             ################################################################
120             # write debug output if debugging enabled for caller
121             # Args: ?$level, ( $message | $fmt,@arg )
122             # $level: if first arg is number it's interpreted as debug level
123             # $message: single message
124             # $fmt: format for sprintf
125             # @arg: arguments for sprintf after format
126             # Returns: NONE
127             ################################################################
128 40732     40732 1 138108 sub DEBUG { goto &debug }
129             sub debug {
130 40732 50   40732 1 124608 $DEBUG or return;
131 0   0     0 my $level = __PACKAGE__->level || return;
132 0         0 my $prefix = $debug_prefix;
133 0 0 0     0 if (@_>1 and looks_like_number($_[0])) {
134 0         0 my $when = shift;
135 0 0       0 return if $when>$level;
136 0         0 $prefix .= "<$when>";
137             }
138 0         0 my ($msg,@arg) = @_;
139 0 0       0 return if !defined($msg);
140 0         0 if ( 1 || $msg !~ m{^\w+:} ) {
141             # Message hat keinen eigenen "Prefix:", also mit Funktion[Zeile] prefixen
142 0         0 my ($sub) = (caller(1))[3];
143 0         0 my $line = (caller(0))[2];
144 0 0       0 $sub =~s{^main::}{} if $sub;
145 0   0     0 $sub ||= 'Main';
146 0         0 $msg = "$sub\[$line]: ".$msg;
147             }
148              
149 0 0       0 if ( @arg ) {
150             # $msg als format-string für sprintf ansehen
151 44     44   309 no warnings 'uninitialized';
  44         86  
  44         26584  
152 0         0 $msg = sprintf($msg,@arg);
153             }
154              
155             # if $debug_sub use this
156 0 0       0 return $debug_sub->($msg) if $debug_sub;
157              
158             # alle Zeilen mit DEBUG: prefixen
159 0         0 $prefix = sprintf "%.4f %s",scalar(gettimeofday()),$prefix;
160 0         0 $msg = $prefix." ".$msg;
161 0         0 $msg =~s{\n}{\n$prefix\t}g;
162 0 0       0 return $msg if defined wantarray; # don't print
163 0         0 $msg =~s{[^[:space:][:print:]]}{_}g;
164 0         0 print STDERR $msg,"\n";
165             }
166              
167             ################################################################
168             # Dumps structure if debugging enabled
169             # Args: ?$level,@data
170             # $level: if first arg is number it's interpreted as debug level
171             # @data: what to be dumped, if @data>1 will dump \@data, else $data[0]
172             # Returns: NONE
173             ################################################################
174             sub DEBUG_DUMP {
175 53 50   53 1 232 $DEBUG or return;
176 0   0       my $level = __PACKAGE__->level || return;
177 0           my $when;
178 0 0 0       if (@_>1 and looks_like_number($_[0])) {
179 0           $when = shift;
180 0 0         return if $when>$level;
181             }
182 0 0         @_ = Dumper( @_>1 ? \@_:$_[0] );
183 0 0         unshift @_,$when if defined $when;
184 0           goto &debug;
185             }
186              
187             ################################################################
188             # return stacktrace
189             # Args: $message | $fmt,@arg
190             # Returns: $stacktrace
191             # $stacktrace: stracktrace including debug info from args
192             ################################################################
193             sub stacktrace {
194 0     0 1   return Carp::longmess( debug(@_) );
195             }
196              
197              
198             ################################################################
199             # helps to track leaks, e.g. where refcounts will never go to
200             # zero because of circular references...
201             # will build proxy object around reference and will inform when
202             # LEAK_TRACK is called or when object gets destroyed. If Devel::Peek
203             # is available it will Devel::Peek::Dump the object on each
204             # LEAK_TRACK (better would be to just show the refcount of the
205             # reference inside the object, but Devel::Peek dumps to STDERR
206             # and I didn't found any other package to provide the necessary
207             # functionality)
208             # Args: $ref
209             # Returns: $ref
210             # $ref: reblessed original reference if not reblessed yet
211             ################################################################
212             sub LEAK_TRACK {
213 0     0 1   my $class = ref($_[0]);
214 0           my $leak_pkg = '__LEAK_TRACK__';
215              
216 0           my ($file,$line) = (caller(0))[1,2];
217 0           my $count = Devel::Peek::SvREFCNT($_[0]);
218              
219 0 0         if ( $class =~m{^$leak_pkg} ) {
220             # only print info
221 0           warn "$_[0] +++ refcount($count) tracking from $file:$line\n";
222 0           Devel::Peek::Dump($_[0],1);
223 0           return $_[0];
224             }
225              
226 0 0 0       unless ( $class eq 'HASH' || $class eq 'ARRAY' || $class eq 'SCALAR' ) {
      0        
227             # need to create wrapper package ?
228 0           $leak_pkg .= '::'.$class;
229 0 0         if ( ! UNIVERSAL::can( $leak_pkg, 'DESTROY' )) {
230 0           eval <
231             package $leak_pkg;
232             our \@ISA = qw( $class );
233             sub DESTROY {
234             warn "\$_[0] --- destroy\n";
235             \$_[0]->SUPER::DESTROY;
236             }
237             EOL
238 0 0         die $@ if $@;
239             }
240             }
241              
242 0           bless $_[0], $leak_pkg;
243 0           warn "$_[0] +++ refcount($count) starting tracking called from $file:$line\n";
244 0           Devel::Peek::Dump($_[0],1);
245 0           return $_[0];
246             }
247              
248             {
249             package __LEAK_TRACK__;
250             sub DESTROY {
251 0     0     my ($file,$line) = (caller(0))[1,2];
252 0           warn "$_[0] --- destroy in $file:$line\n";
253             }
254             }
255              
256             eval 'require Devel::Peek';
257             if ( $@ ) {
258             # cannot be loaded
259             *{ 'Devel::Peek::Dump' } = sub {};
260             *{ 'Devel::Peek::SvREFCNT' } = sub { 'unknown' };
261             }
262              
263              
264             =for experimental_use_only
265              
266             # works, but startup of programs using this is noticably slower, therefore
267             # not enabled by default
268              
269             use Filter::Simple;
270             FILTER_ONLY( code => sub {
271              
272             # replace DEBUG(...) with
273             # - if Debug::level around it (faster, because expressions inside debug
274             # get only evaluated if debugging is active)
275             # - no warnings for expressions, because in often debug messages
276             # are quick and dirty
277             # FIXME: do it for DEBUG_DUMP too
278             # cannot use Text::Balanced etc because placeholder might contain ')' which
279             # should not be matched
280              
281             my $code = '';
282             {
283             local $_ = $_; # copy
284             while (1) {
285             $code .=
286             s{\ADEBUG\s*\(}{}s ? '' :
287             s{\A(.*?[^\w:])DEBUG\s*\(}{}s ? $1 :
288             last;
289             my $level = 1;
290             my $inside = '';
291             while ( s{\A((?:$Filter::Simple::placeholder|.)*?)([()])}{}s ) {
292             $inside .= $1;
293             $level += ( $2 eq '(' ) ? +1:-1;
294             last if !$level;
295             $inside .= $2;
296             }
297             $level && die "unbalanced brackets in DEBUG(..)";
298             $code .= "if (\$Debug::level) { no warnings; Debug::debug($inside) }";
299             }
300             $code .= $_; # rest
301             }
302             $_ = $code;
303             });
304              
305             =cut
306              
307             1;