X-Git-Url: http://wagnertech.de/git?p=kivitendo-erp.git;a=blobdiff_plain;f=SL%2FLXDebug.pm;fp=SL%2FLXDebug.pm;h=a1e19767c7599a37b82f03d5817d3fefac9d95c9;hp=553ab5037c0679d8f72ef3020e9db99a37c8cfae;hb=53593baa211863fbf66540cf1bcc36c8fb37257f;hpb=deb4d2dbb676d7d6f69dfe7815d6e0cb09bd4a44 diff --git a/SL/LXDebug.pm b/SL/LXDebug.pm index 553ab5037..a1e19767c 100644 --- a/SL/LXDebug.pm +++ b/SL/LXDebug.pm @@ -11,17 +11,20 @@ use constant REQUEST_TIMER => 1 << 6; use constant REQUEST => 1 << 7; use constant WARN => 1 << 8; use constant TRACE2 => 1 << 9; -use constant ALL => (1 << 10) - 1; +use constant SHOW_CALLER => 1 << 10; +use constant ALL => (1 << 11) - 1; use constant DEVEL => INFO | DEBUG1 | QUERY | TRACE | BACKTRACE_ON_ERROR | REQUEST_TIMER; use constant FILE_TARGET => 0; use constant STDERR_TARGET => 1; use Data::Dumper; -use POSIX qw(strftime getppid); +use List::MoreUtils qw(all); +use POSIX qw(strftime getpid); +use Scalar::Util qw(blessed refaddr weaken looks_like_number); use Time::HiRes qw(gettimeofday tv_interval); -use YAML; use SL::Request (); +use SL::YAML; use strict; use utf8; @@ -144,7 +147,10 @@ sub message { no warnings; my ($self, $level, $message) = @_; - $self->_write(level2string($level), $message) if (($self->{"level"} | $global_level) & $level || !$level); + my $show_caller = ($level | $global_level) & SHOW_CALLER(); + $level &= ~SHOW_CALLER(); + + $self->_write(level2string($level), $message, show_caller => $show_caller) if (($self->{"level"} | $global_level) & $level || !$level); } sub warn { no warnings; @@ -152,15 +158,50 @@ sub warn { $self->message(WARN, $message); } -sub dump { - my ($self, $level, $name, $variable, %options) = @_; +sub clone_for_dump { + my ($src, $dumped) = @_; + + return undef if !defined($src); + return $src if !ref($src); + + $dumped ||= {}; + my $addr = refaddr($src); + + return $dumped->{$addr} if $dumped->{$addr // ''}; + + + if (blessed($src) && $src->can('as_debug_info')) { + $dumped->{$addr} = $src->as_debug_info; + + } elsif (ref($src) eq 'ARRAY') { + $dumped->{$addr} = []; + + foreach my $entry (@{ $src }) { + my $exists = !!$dumped->{refaddr($entry) // ''}; + push @{ $dumped->{$addr} }, clone_for_dump($entry, $dumped); - my $password; - if ($variable && ('Form' eq ref $variable) && defined $variable->{password}) { - $password = $variable->{password}; - $variable->{password} = 'X' x 8; + weaken($dumped->{$addr}->[-1]) if $exists; + + } + + } elsif (ref($src) =~ m{^(?:HASH|Form|SL::.+)$}) { + $dumped->{$addr} = {}; + + foreach my $key (keys %{ $src }) { + my $exists = !!$dumped->{refaddr($src->{$key}) // ''}; + $dumped->{$addr}->{$key} = clone_for_dump($src->{$key}, $dumped); + + weaken($dumped->{$addr}->{$key}) if $exists; + } } + return $dumped->{$addr} // "$src"; +} + +sub dump { + my ($self, $level, $name, $variable, %options) = @_; + + $variable = clone_for_dump($variable); my $dumper = Data::Dumper->new([$variable]); $dumper->Sortkeys(1); $dumper->Indent(2); @@ -168,22 +209,13 @@ sub dump { my $output = $dumper->Dump(); $self->message($level, "dumping ${name}:\n" . $output); - $variable->{password} = $password if (defined $password); - - # Data::Dumper does not reset the iterator belonging to this hash - # if 'Sortkeys' is true. Therefore clear the iterator manually. - # See "perldoc -f each". - if ($variable && (('HASH' eq ref $variable) || ('Form' eq ref $variable))) { - keys %{ $variable }; - } - return $output; } sub dump_yaml { my ($self, $level, $name, $variable) = @_; - $self->message($level, "dumping ${name}:\n" . YAML::Dump($variable)); + $self->message($level, "dumping ${name}:\n" . SL::YAML::Dump($variable)); } sub dump_sql_result { @@ -200,8 +232,14 @@ sub dump_sql_result { map { $column_lengths{$_} = length $row->{$_} if (length $row->{$_} > $column_lengths{$_}) } keys %{ $row }; } + my %alignment; + foreach my $column (keys %column_lengths) { + my $all_look_like_number = all { (($_->{$column} // '') eq '') || looks_like_number($_->{$column}) } @{ $results }; + $alignment{$column} = $all_look_like_number ? '' : '-'; + } + my @sorted_names = sort keys %column_lengths; - my $format = join '|', map { '%' . $column_lengths{$_} . 's' } @sorted_names; + my $format = join '|', map { '%' . $alignment{$_} . $column_lengths{$_} . 's' } @sorted_names; $prefix .= ' ' if $prefix; @@ -214,17 +252,6 @@ sub dump_sql_result { $self->message($level, $prefix . sprintf('(%d row%s)', scalar @{ $results }, scalar @{ $results } > 1 ? 's' : '')); } -sub dump_object { - my ($self, $level, $text, $object) = @_; - - my $copy; - if ($object) { - $copy->{$_} = $object->$_ for $object->meta->columns; - } - - $self->dump($level, $text, $copy); -} - sub show_diff { my ($self, $level, $item1, $item2, %params) = @_; @@ -233,7 +260,7 @@ sub show_diff { return; } - my @texts = map { ref $_ ? YAML::Dump($_) : $_ } ($item1, $item2); + my @texts = map { ref $_ ? SL::YAML::Dump($_) : $_ } ($item1, $item2); $self->message($level, Text::Diff::diff(\$texts[0], \$texts[1], \%params)); } @@ -260,9 +287,29 @@ sub is_tracing_enabled { sub _write { no warnings; - my ($self, $prefix, $message) = @_; + my ($self, $prefix, $message, %options) = @_; + + my @prefixes = ($prefix); + + if ($options{show_caller}) { + my $level = 1; + while (1) { + my ($package, $filename, $line, $subroutine) = caller($level); + + if (($filename // '') =~ m{LXDebug\.pm$}) { + $level++; + next; + } + + push @prefixes, "${filename}:${line}"; + last; + } + } + + $prefix = join ' ', grep { $_ } @prefixes; + my @now = gettimeofday(); - my $date = strftime("%Y-%m-%d %H:%M:%S." . sprintf('%03d', int($now[1] / 1000)) . " $$ [" . getppid() . "] ${prefix}: ", localtime($now[0])); + my $date = strftime("%Y-%m-%d %H:%M:%S." . sprintf('%03d', int($now[1] / 1000)) . " $$ [" . getpid() . "] ${prefix}: ", localtime($now[0])); local *FILE; chomp($message); @@ -286,7 +333,7 @@ sub _write_raw { sub level2string { no warnings; # use $_[0] as a bit mask and return levelstrings separated by / - join '/', qw(info debug1 debug2 query trace error_call_trace request_timer WARNING)[ grep { (reverse split //, sprintf "%08b", $_[0])[$_] } 0..7 ] + join '/', qw(info debug1 debug2 query trace error_call_trace request_timer request WARNING trace2 show_caller)[ grep { (reverse split //, sprintf "%011b", $_[0])[$_] } 0..11 ] } sub begin_request { @@ -296,9 +343,10 @@ sub begin_request { } sub end_request { - my $self = shift; + my ($self, %params) = @_; return 1 unless want_request_timer(); - $self->_write("time", $self->get_request_time); + + $self->_write("time", sprintf('%f (%s/%s)', $self->get_request_time, $params{script_name}, $params{action})); $self->{calldepth} = 0; } @@ -308,7 +356,10 @@ sub log_time { return 1 unless want_request_timer(); my $now = $self->get_request_time; - my $diff = int((($now - ($self->{previous_log_time} // 0)) * 10_000 + 5) / 10); + + return 1 unless $now; + + my $diff = $self->{previous_log_time} ? int((($now - ($self->{previous_log_time} // 0)) * 10_000 + 5) / 10) : $now * 10_0000 + 5; $self->{previous_log_time} = $now; $self->_write("time", "${now}s Δ ${diff}ms" . (@slurp ? " (@slurp)" : ''));