File Coverage

blib/lib/CIPP/Debug.pm

Criterion	Covered	Total	%
statement	6	57	10.5
branch	0	30	0.0
condition	0	9	0.0
subroutine	2	8	25.0
pod	0	6	0.0
total	8	110	7.2

package CIPP::Debug;

use strict;
use Data::Dumper;

#---------------------------------------------------------------------
# Debugging stuff
#
# Setzen/Abfragen des Debugging Levels. Wenn als Klassenmethode
# aufgerufen, wird das Debugging klassenweit eingeschaltet. Als
# Objektmethode aufgerufen, wird Debugging nur für das entsprechende
# Objekt eingeschaltet.
#
# Level:	0	Debugging deaktiviert
#		1	nur aktive Debugging Ausgaben
#		2	Call Trace, Subroutinen Namen
#		3	Call Trace, Subroutinen Namen + Argumente
#
# Debuggingausgaben erfolgen im Klartext auf STDERR.
#---------------------------------------------------------------------

sub debug_level {
	my $thing = shift;
	my $debug;
	if ( ref $thing ) {
		$thing->{debug} = shift if @_;
		$debug = $thing->{debug};
	} else {
		$CIPP::DEBUG = shift if @_;
		$debug = $CIPP::DEBUG;
	}

	if ( $debug ) {
		$CIPP::DEBUG::TIME = scalar(localtime(time));
		print STDERR
			"--- START ------------------------------------\n",
			"$$: $CIPP::DEBUG::TIME - DEBUG LEVEL $debug\n";
	}

	return $debug;
}

#---------------------------------------------------------------------
# Klassen/Objekt Methode
#
# Gibt je nach Debugginglevel entsprechende Call Trace Informationen
# aus bzw. tut gar nichts, wenn Debugging abgeschaltet ist.
#---------------------------------------------------------------------

sub trace_in {
	my $thing = shift;
	my $debug = $CIPP::DEBUG;
	$debug = $thing->{debug} if ref $thing and $thing->{debug};
	return if $debug < 2;

	# Level 1: Methodenaufrufe
	if ( $debug == 2 ) {
		my @c1 = caller (1);
		my @c2 = caller (2);
		print STDERR "$$: TRACE IN : $c1[3] (-> $c2[3])\n";
	}

	# Level 2: Methodenaufrufe mit Parametern
	if ( $debug == 3 ) {
		package DB;
		my @c = caller (1);
		my $args = '"'.(join('","',@DB::args)).'"';
		my @c2 = caller (2);
		print STDERR "$$: TRACE IN : $c[3] (-> $c2[3])\n\t($args)\n";
	}

	1;
}

sub trace_out {
	my $thing = shift;
	my $debug = $CIPP::DEBUG;
	$debug = $thing->{debug} if ref $thing and $thing->{debug};
	return if $debug < 2;

	my @c1 = caller (1);
	my @c2 = caller (2);
	print STDERR "$$: TRACE OUT: $c1[3] (-> $c2[3])";

	if ( $debug == 2 ) {
		print STDERR " DATA: ", Dumper(@_);
	} else {
		print STDERR "\n";
	}

	1;
}

sub dump {
	my $thing = shift;
#	my $debug = $CIPP::DEBUG;
#	$debug = $thing->{debug} if ref $thing and $thing->{debug};
#	return if not $debug;

	if ( @_ ) {
		print STDERR Dumper(@_);
	} else {
		print STDERR Dumper($thing);
	}
}

sub debug {
	my $thing = shift;
	my $debug = $CIPP::DEBUG;
	$debug = $thing->{debug} if ref $thing and $thing->{debug};
	return if not $debug;

	my @c1 = caller (1);
	print STDERR "$$: DEBUG    : $c1[3]: ", join (",", @_), "\n";
	1;
}

sub dump_html {
	my $thing = shift;

	if ( @_ ) {
		print "",Dumper(@_),"\n";
	} else {
		print "",Dumper($thing),"\n";
	}
}
1;