package Net::SIP::Debug;
use strict;
use warnings;
use Carp;
use Data::Dumper;
use Time::HiRes 'gettimeofday';
use Scalar::Util 'looks_like_number';
use base 'Exporter';
our @EXPORT = qw( DEBUG DEBUG_DUMP LEAK_TRACK $DEBUG );
our @EXPORT_OK = qw( debug stacktrace );
our $DEBUG = 0; # exported fast check: if false no kind of debugging is done
our $level = 0; # needed global for source filter
my %level4package; # package specific level
my $debug_prefix = 'DEBUG:'; # default prefix
my $debug_sub; # alternative sub to STDERR output
##############################################################
# set level, scope etc from use. Usually used at the
# start, e.g. perl -MNet::SIP::Debug=level program
# Args: @args
# @args: something for sub level, rest to Exporter
# Returns: NONE
##############################################################
sub import {
my $class = shift;
my (@export,@level);
for (@_) {
if ( ref eq 'CODE' ) {
# set debug sub
$debug_sub = $_;
} elsif ( m{[=\*]} || m{^\d} || m{::} ) {
push @level,$_
} else {
push @export,$_
}
}
$class->level(@level) if @level;
$class->export_to_level(1,@export) if @export;
$class->export_to_level(1) if ! @export && ! @level;
}
##############################################################
# set/get debug level
# Args: ($class,@spec)
# @spec: number|package|package=number for setting
# global|package specific debug level. If package
# is postfixed with '*' the level will be used for
# subpackages too.
# Returns: NONE|level
# level: if not @spec level for the current package
# (first outside Net::SIP::Debug in caller stack) will
# be returned
##############################################################
sub level {
shift; # class
if ( @_ ) {
my @level = @_ >1 ? split( m{[^\w:=\*]+}, $_[0] ): @_;
foreach (@level) {
if ( m{^\d+$} ) {
$level = $_;
} elsif ( m{^([\w:]+)(\*)?(?:=(\d+))?$} ) {
# package || package=level
my $l = defined($3) ? $3: $level || 1;
my $name = $1;
my $below = $2;
my @names = ( $name );
push @names, "Net::".$name if $name =~ m{^SIP\b};
push @names, "Net::SIP::".$name if $name !~ m{^Net::SIP\b};
foreach (@names) {
$level4package{$_} = $l;
$level4package{$_.'::'} = $l if $below;
}
}
}
$DEBUG = grep { $_>0 } ($level, values(%level4package));
} else {
# check
$DEBUG or return 0;
if ( %level4package ) {
# check if there is a specific level for this package
my $pkg;
for( my $i=0;1;$i++ ) {
# find first frame outside of this package
($pkg) = caller($i);
last if !$pkg or $pkg ne __PACKAGE__;
}
return $level if !$pkg;
# find exakt match
my $l = $level4package{$pkg};
return $l if defined($l);
# find match for upper packages, e.g. if there is an entry for
# 'Net::SIP::' it matches everything below Net::SIP
while ( $pkg =~s{::\w+(::)?$}{::} ) {
return $l if defined( $l = $level4package{$pkg} );
}
}
}
return $level
}
################################################################
# set prefix
# default prefix is 'DEBUG:' but in forking apps it might
# be useful to change it to "DEBUG($$):" or similar
# Args: $class,$prefix
# Returns: NONE
################################################################
sub set_prefix {
(undef,$debug_prefix) = @_
}
################################################################
# write debug output if debugging enabled for caller
# Args: ?$level, ( $message | $fmt,@arg )
# $level: if first arg is number it's interpreted as debug level
# $message: single message
# $fmt: format for sprintf
# @arg: arguments for sprintf after format
# Returns: NONE
################################################################
sub DEBUG { goto &debug }
sub debug {
$DEBUG or return;
my $level = __PACKAGE__->level || return;
my $prefix = $debug_prefix;
if (@_>1 and looks_like_number($_[0])) {
my $when = shift;
return if $when>$level;
$prefix .= "<$when>";
}
my ($msg,@arg) = @_;
return if !defined($msg);
if ( 1 || $msg !~ m{^\w+:} ) {
# Message hat keinen eigenen "Prefix:", also mit Funktion[Zeile] prefixen
my ($sub) = (caller(1))[3];
my $line = (caller(0))[2];
$sub =~s{^main::}{} if $sub;
$sub ||= 'Main';
$msg = "$sub\[$line]: ".$msg;
}
if ( @arg ) {
# $msg als format-string für sprintf ansehen
no warnings 'uninitialized';
$msg = sprintf($msg,@arg);
}
# if $debug_sub use this
return $debug_sub->($msg) if $debug_sub;
# alle Zeilen mit DEBUG: prefixen
$prefix = sprintf "%.4f %s",scalar(gettimeofday()),$prefix;
$msg = $prefix." ".$msg;
$msg =~s{\n}{\n$prefix\t}g;
return $msg if defined wantarray; # don't print
$msg =~s{[^[:space:][:print:]]}{_}g;
print STDERR $msg,"\n";
}
################################################################
# Dumps structure if debugging enabled
# Args: ?$level,@data
# $level: if first arg is number it's interpreted as debug level
# @data: what to be dumped, if @data>1 will dump \@data, else $data[0]
# Returns: NONE
################################################################
sub DEBUG_DUMP {
$DEBUG or return;
my $level = __PACKAGE__->level || return;
my $when;
if (@_>1 and looks_like_number($_[0])) {
$when = shift;
return if $when>$level;
}
@_ = Dumper( @_>1 ? \@_:$_[0] );
unshift @_,$when if defined $when;
goto &debug;
}
################################################################
# return stacktrace
# Args: $message | $fmt,@arg
# Returns: $stacktrace
# $stacktrace: stracktrace including debug info from args
################################################################
sub stacktrace {
return Carp::longmess( debug(@_) );
}
################################################################
# helps to track leaks, e.g. where refcounts will never go to
# zero because of circular references...
# will build proxy object around reference and will inform when
# LEAK_TRACK is called or when object gets destroyed. If Devel::Peek
# is available it will Devel::Peek::Dump the object on each
# LEAK_TRACK (better would be to just show the refcount of the
# reference inside the object, but Devel::Peek dumps to STDERR
# and I didn't found any other package to provide the necessary
# functionality)
# Args: $ref
# Returns: $ref
# $ref: reblessed original reference if not reblessed yet
################################################################
sub LEAK_TRACK {
my $class = ref($_[0]);
my $leak_pkg = '__LEAK_TRACK__';
my ($file,$line) = (caller(0))[1,2];
my $count = Devel::Peek::SvREFCNT($_[0]);
if ( $class =~m{^$leak_pkg} ) {
# only print info
warn "$_[0] +++ refcount($count) tracking from $file:$line\n";
Devel::Peek::Dump($_[0],1);
return $_[0];
}
unless ( $class eq 'HASH' || $class eq 'ARRAY' || $class eq 'SCALAR' ) {
# need to create wrapper package ?
$leak_pkg .= '::'.$class;
if ( ! UNIVERSAL::can( $leak_pkg, 'DESTROY' )) {
eval <<EOL;
package $leak_pkg;
our \@ISA = qw( $class );
sub DESTROY {
warn "\$_[0] --- destroy\n";
\$_[0]->SUPER::DESTROY;
}
EOL
die $@ if $@;
}
}
bless $_[0], $leak_pkg;
warn "$_[0] +++ refcount($count) starting tracking called from $file:$line\n";
Devel::Peek::Dump($_[0],1);
return $_[0];
}
{
package __LEAK_TRACK__;
sub DESTROY {
my ($file,$line) = (caller(0))[1,2];
warn "$_[0] --- destroy in $file:$line\n";
}
}
eval 'require Devel::Peek';
if ( $@ ) {
# cannot be loaded
*{ 'Devel::Peek::Dump' } = sub {};
*{ 'Devel::Peek::SvREFCNT' } = sub { 'unknown' };
}
=for experimental_use_only
# works, but startup of programs using this is noticably slower, therefore
# not enabled by default
use Filter::Simple;
FILTER_ONLY( code => sub {
# replace DEBUG(...) with
# - if Debug::level around it (faster, because expressions inside debug
# get only evaluated if debugging is active)
# - no warnings for expressions, because in often debug messages
# are quick and dirty
# FIXME: do it for DEBUG_DUMP too
# cannot use Text::Balanced etc because placeholder might contain ')' which
# should not be matched
my $code = '';
{
local $_ = $_; # copy
while (1) {
$code .=
s{\ADEBUG\s*\(}{}s ? '' :
s{\A(.*?[^\w:])DEBUG\s*\(}{}s ? $1 :
last;
my $level = 1;
my $inside = '';
while ( s{\A((?:$Filter::Simple::placeholder|.)*?)([()])}{}s ) {
$inside .= $1;
$level += ( $2 eq '(' ) ? +1:-1;
last if !$level;
$inside .= $2;
}
$level && die "unbalanced brackets in DEBUG(..)";
$code .= "if (\$Debug::level) { no warnings; Debug::debug($inside) }";
}
$code .= $_; # rest
}
$_ = $code;
});
=cut
1;