X-Git-Url: http://wagnertech.de/git?a=blobdiff_plain;f=SL%2FLXDebug.pm;h=553ab5037c0679d8f72ef3020e9db99a37c8cfae;hb=b8ee6b6ed46e55095b955ee1800b8a4b8d8ccc3f;hp=ffd4fa1f3f2b6c6ab993bc98488b32a2a4549718;hpb=83a428a3645a67a34d5b1ee8d2d7cf8add292305;p=kivitendo-erp.git diff --git a/SL/LXDebug.pm b/SL/LXDebug.pm index ffd4fa1f3..553ab5037 100644 --- a/SL/LXDebug.pm +++ b/SL/LXDebug.pm @@ -8,34 +8,30 @@ 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 ALL => (1 << 10) - 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 Time::HiRes qw(gettimeofday tv_interval); use YAML; +use SL::Request (); 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 +130,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++; } @@ -157,33 +153,31 @@ sub warn { } sub dump { - my ($self, $level, $name, $variable) = @_; + my ($self, $level, $name, $variable, %options) = @_; - if ($data_dumper_available) { - my $password; - if ($variable && ('Form' eq ref $variable) && defined $variable->{password}) { - $password = $variable->{password}; - $variable->{password} = 'X' x 8; - } - - my $dumper = Data::Dumper->new([$variable]); - $dumper->Sortkeys(1); - $self->message($level, "dumping ${name}:\n" . $dumper->Dump()); + my $password; + if ($variable && ('Form' eq ref $variable) && defined $variable->{password}) { + $password = $variable->{password}; + $variable->{password} = 'X' x 8; + } - $variable->{password} = $password if (defined $password); + 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); - # 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 }; - } + $variable->{password} = $password if (defined $password); - } else { - $self->message($level, - "dumping ${name}: Data::Dumper not available; " - . "variable cannot be dumped"); + # 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 { @@ -220,6 +214,17 @@ 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) = @_; @@ -256,18 +261,25 @@ 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 @now = gettimeofday(); + my $date = strftime("%Y-%m-%d %H:%M:%S." . sprintf('%03d', int($now[1] / 1000)) . " $$ [" . getppid() . "] ${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; } } @@ -294,7 +306,12 @@ 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; + my $diff = int((($now - ($self->{previous_log_time} // 0)) * 10_000 + 5) / 10); + $self->{previous_log_time} = $now; + + $self->_write("time", "${now}s Δ ${diff}ms" . (@slurp ? " (@slurp)" : '')); } sub get_request_time { @@ -331,6 +348,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(<