X-Git-Url: http://wagnertech.de/gitweb/gitweb.cgi/kivitendo-erp.git/blobdiff_plain/142f7c2cd402db32f71bef206a6399c62c56bdfa..ab96e204a2beec2302b1850df50f45a6e67a13c4:/SL/LXDebug.pm diff --git a/SL/LXDebug.pm b/SL/LXDebug.pm index 76edd8257..6a8ca5af5 100644 --- a/SL/LXDebug.pm +++ b/SL/LXDebug.pm @@ -1,19 +1,22 @@ package LXDebug; -use constant NONE => 0; -use constant INFO => 1; -use constant DEBUG1 => 2; -use constant DEBUG2 => 4; -use constant QUERY => 8; -use constant TRACE => 16; -use constant BACKTRACE_ON_ERROR => 32; -use constant ALL => 63; +use constant NONE => 0; +use constant INFO => 1; +use constant DEBUG1 => 1 << 1; +use constant DEBUG2 => 1 << 2; +use constant QUERY => 1 << 3; +use constant TRACE => 1 << 4; +use constant BACKTRACE_ON_ERROR => 1 << 5; +use constant ALL => (1 << 6) - 1; +use constant DEVEL => INFO | QUERY | TRACE | BACKTRACE_ON_ERROR; use constant FILE_TARGET => 0; use constant STDERR_TARGET => 1; use POSIX qw(strftime); +use YAML; + my $data_dumper_available; our $global_level; @@ -108,7 +111,7 @@ sub show_backtrace { $self->message(BACKTRACE_ON_ERROR, "Starting full caller dump:"); my $level = 0; while (my ($dummy, $filename, $line, $subroutine) = caller $level) { - $self->message(BACKTRACE_ON_ERROR, "${subroutine} from ${filename}:${line}"); + $self->message(BACKTRACE_ON_ERROR, " ${subroutine} from ${filename}:${line}"); $level++; } @@ -125,7 +128,9 @@ sub dump { my ($self, $level, $name, $variable) = @_; if ($data_dumper_available) { - $self->message($level, "dumping ${name}:\n" . Dumper($variable)); + my $dumper = Data::Dumper->new([$variable]); + $dumper->Sortkeys(1); + $self->message($level, "dumping ${name}:\n" . $dumper->Dump()); } else { $self->message($level, "dumping ${name}: Data::Dumper not available; " @@ -133,6 +138,40 @@ sub dump { } } +sub dump_yaml { + my ($self, $level, $name, $variable) = @_; + + $self->message($level, "dumping ${name}:\n" . YAML::Dump($variable)); +} + +sub dump_sql_result { + my ($self, $level, $prefix, $results) = @_; + + if (!$results || !scalar @{ $results }) { + $self->message($level, "Empty result set"); + return; + } + + my %column_lengths = map { $_, length $_ } keys %{ $results->[0] }; + + foreach my $row (@{ $results }) { + map { $column_lengths{$_} = length $row->{$_} if (length $row->{$_} > $column_lengths{$_}) } keys %{ $row }; + } + + my @sorted_names = sort keys %column_lengths; + my $format = join '|', map { '%' . $column_lengths{$_} . 's' } @sorted_names; + + $prefix .= ' ' if $prefix; + + $self->message($level, $prefix . sprintf($format, @sorted_names)); + $self->message($level, $prefix . join('+', map { '-' x $column_lengths{$_} } @sorted_names)); + + foreach my $row (@{ $results }) { + $self->message($level, $prefix . sprintf($format, map { $row->{$_} } @sorted_names)); + } + $self->message($level, $prefix . sprintf('(%d row%s)', scalar @{ $results }, scalar @{ $results } > 1 ? 's' : '')); +} + sub enable_sub_tracing { my ($self) = @_; $self->{level} | TRACE;