libnet-sip-perl 0.66-1 / usr / share / perl5 / Net / SIP / Debug.pm

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 );
our @EXPORT_OK = qw( debug stacktrace );


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;
				}
			}
		}

	} else {
		# check
		if ( %level4package ) {
			# check if there is a specific level for this package
			my $pkg;
			for( my $i=1;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 {
	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 {
	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;