X-Git-Url: http://wagnertech.de/git?a=blobdiff_plain;f=SL%2FLXDebug.pm;h=a1e19767c7599a37b82f03d5817d3fefac9d95c9;hb=f05bd96b031d7d4ffaf4804704684ae929a0890a;hp=17009ddcf04179ef9ae226cedba6d18d1f4706c3;hpb=49556f01cfe6a395cf5554e1a00dc61d6da0493e;p=kivitendo-erp.git diff --git a/SL/LXDebug.pm b/SL/LXDebug.pm index 17009ddcf..a1e19767c 100644 --- a/SL/LXDebug.pm +++ b/SL/LXDebug.pm @@ -8,34 +8,33 @@ use constant QUERY => 1 << 3; use constant TRACE => 1 << 4; use constant BACKTRACE_ON_ERROR => 1 << 5; use constant REQUEST_TIMER => 1 << 6; -use constant WARN => 1 << 7; -use constant TRACE2 => 1 << 8; -use constant ALL => (1 << 9) - 1; +use constant REQUEST => 1 << 7; +use constant WARN => 1 << 8; +use constant TRACE2 => 1 << 9; +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 POSIX qw(strftime getppid); +use Data::Dumper; +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; -my ($data_dumper_available, $text_diff_available); +my ($text_diff_available); -our $global_level; -our $watch_form; +our $global_level = NONE(); +our $watch_form = 0; our $file_name; -BEGIN { - eval("use Data::Dumper"); - $data_dumper_available = $@ ? 0 : 1; - - $global_level = NONE; - $watch_form = 0; -} - sub new { my $type = shift; my $self = {}; @@ -134,10 +133,10 @@ sub show_backtrace { return 1 unless ($force || ($global_level & BACKTRACE_ON_ERROR)); - $self->message(BACKTRACE_ON_ERROR, "Starting full caller dump:"); + $self->message(0, "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(0, " ${subroutine} from ${filename}:${line}"); $level++; } @@ -148,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; @@ -156,47 +158,64 @@ sub warn { $self->message(WARN, $message); } -sub dump { - my ($self, $level, $name, $variable, %options) = @_; +sub clone_for_dump { + my ($src, $dumped) = @_; - if ($data_dumper_available) { - my $password; - if ($variable && ('Form' eq ref $variable) && defined $variable->{password}) { - $password = $variable->{password}; - $variable->{password} = 'X' x 8; - } + return undef if !defined($src); + return $src if !ref($src); - my $dumper = Data::Dumper->new([$variable]); - $dumper->Sortkeys(1); - $dumper->Indent(2); - $dumper->$_($options{$_}) for keys %options; - my $output = $dumper->Dump(); - $self->message($level, "dumping ${name}:\n" . $output); + $dumped ||= {}; + my $addr = refaddr($src); - $variable->{password} = $password if (defined $password); + 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); + + weaken($dumped->{$addr}->[-1]) if $exists; - # 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; + } elsif (ref($src) =~ m{^(?:HASH|Form|SL::.+)$}) { + $dumped->{$addr} = {}; - } else { - $self->message($level, - "dumping ${name}: Data::Dumper not available; " - . "variable cannot be dumped"); + foreach my $key (keys %{ $src }) { + my $exists = !!$dumped->{refaddr($src->{$key}) // ''}; + $dumped->{$addr}->{$key} = clone_for_dump($src->{$key}, $dumped); - return undef; + 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); + $dumper->$_($options{$_}) for keys %options; + my $output = $dumper->Dump(); + $self->message($level, "dumping ${name}:\n" . $output); + + 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 { @@ -213,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; @@ -235,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)); } @@ -262,26 +287,53 @@ sub is_tracing_enabled { sub _write { no warnings; - my ($self, $prefix, $message) = @_; - my $date = strftime("%Y-%m-%d %H:%M:%S $$ [" . getppid() . "] ${prefix}: ", localtime(time())); + 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)) . " $$ [" . getpid() . "] ${prefix}: ", localtime($now[0])); local *FILE; chomp($message); + $self->_write_raw("${date}${message}\n"); +} +sub _write_raw { + my ($self, $message) = @_; + local *FILE; if ((FILE_TARGET == $self->{"target"}) && open(FILE, ">>", $self->{"file"})) { - print(FILE "${date}${message}\n"); - close(FILE); + binmode FILE, ":utf8"; + print FILE $message; + close FILE; } elsif (STDERR_TARGET == $self->{"target"}) { - print(STDERR "${date}${message}\n"); + print STDERR $message; } } 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 { @@ -291,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; } @@ -301,7 +354,15 @@ sub end_request { sub log_time { my ($self, @slurp) = @_; return 1 unless want_request_timer(); - $self->_write("time", $self->get_request_time() . (@slurp ? " (@slurp)" : '')); + + my $now = $self->get_request_time; + + 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)" : '')); } sub get_request_time { @@ -338,6 +399,44 @@ sub level_by_name { return $global_level & $self->_by_name($level); } +sub is_request_logging_enabled { + my ($self) = @_; + return $global_level & REQUEST; +} + +sub add_request_params { + my ($self, $key, $value) = @_; + return unless $self->is_request_logging_enabled; + return if $key =~ /password/; + + push @{ $::request->{debug}{PARAMS} ||= [] }, [ $key => $value ]; +} + +sub log_request { + my ($self, $type, $controller, $action) = @_; + return unless $self->is_request_logging_enabled; + + my $session_id = $::auth->create_or_refresh_session; + + my $template = <_write('Request', $template); + + my $params = join "\n ", map { + "$_->[0] = $_->[1]" + } @{ $::request->{debug}{PARAMS} || [] }; + + $self->_write_raw(<