LXDebug: Zeitstempel mit Millisekunden-Auflösung ausgeben
[kivitendo-erp.git] / SL / LXDebug.pm
1 package LXDebug;
2
3 use constant NONE               =>  0;
4 use constant INFO               =>  1;
5 use constant DEBUG1             =>  1 << 1;
6 use constant DEBUG2             =>  1 << 2;
7 use constant QUERY              =>  1 << 3;
8 use constant TRACE              =>  1 << 4;
9 use constant BACKTRACE_ON_ERROR =>  1 << 5;
10 use constant REQUEST_TIMER      =>  1 << 6;
11 use constant REQUEST            =>  1 << 7;
12 use constant WARN               =>  1 << 8;
13 use constant TRACE2             =>  1 << 9;
14 use constant ALL                => (1 << 10) - 1;
15 use constant DEVEL              => INFO | DEBUG1 | QUERY | TRACE | BACKTRACE_ON_ERROR | REQUEST_TIMER;
16
17 use constant FILE_TARGET   => 0;
18 use constant STDERR_TARGET => 1;
19
20 use Data::Dumper;
21 use POSIX qw(strftime getppid);
22 use Time::HiRes qw(gettimeofday tv_interval);
23 use YAML;
24 use SL::Request ();
25
26 use strict;
27
28 my ($text_diff_available);
29
30 our $global_level = NONE();
31 our $watch_form   = 0;
32 our $file_name;
33
34 sub new {
35   my $type = shift;
36   my $self = {};
37
38   _init_globals_from_config();
39
40   $self->{"calldepth"}  = 0;
41   $self->{"file"}       = $file_name || "/tmp/lx-office-debug.log";
42   $self->{"target"}     = FILE_TARGET;
43   $self->{"level"}      = 0;
44
45   while ($_[0]) {
46     $self->{ $_[0] } = $_[1];
47     shift;
48     shift;
49   }
50
51   bless($self, $type);
52 }
53
54 my $globals_inited_from_config;
55 sub _init_globals_from_config {
56   return if $globals_inited_from_config;
57   $globals_inited_from_config = 1;
58
59   my $cfg = $::lx_office_conf{debug} || {};
60
61   $global_level = NONE() if $cfg->{global_level} =~ /NONE/;
62   foreach my $level (grep { $_} split(m/\s+/, $cfg->{global_level})) {
63     $global_level |= eval "${level}()";
64   }
65
66   $watch_form = $cfg->{watch_form};
67   $file_name  = $cfg->{file_name} || "/tmp/lx-office-debug.log";
68 }
69
70 sub set_target {
71   my ($self, $target, $file) = @_;
72
73   if ((FILE_TARGET == $target) && $file) {
74     $self->{"file"}   = $file;
75     $self->{"target"} = FILE_TARGET;
76
77   } elsif (STDERR_TARGET == $target) {
78     $self->{"target"} = STDERR_TARGET;
79   }
80 }
81
82 sub enter_sub {
83   my $self  = shift;
84   my $level = shift || 0;
85
86   return 1 unless ($global_level & TRACE);          # ignore if traces aren't active
87   return 1 if $level && !($global_level & TRACE2);  # ignore if level of trace isn't active
88
89   my ($package, $filename, $line, $subroutine) = caller(1);
90   my ($dummy1, $self_filename, $self_line) = caller(0);
91
92   my $indent = " " x $self->{"calldepth"}++;
93   my $time = $self->get_request_time || '';
94
95   if (!defined($package)) {
96     $self->_write('sub' . $level, $indent . "\\ $time top-level?\n");
97   } else {
98     $self->_write('sub' . $level, $indent
99                     . "\\ $time ${subroutine} in "
100                     . "${self_filename}:${self_line} called from "
101                     . "${filename}:${line}\n");
102   }
103   return 1;
104 }
105
106 sub leave_sub {
107   my $self  = shift;
108   my $level = shift || 0;
109
110   return 1 unless ($global_level & TRACE);           # ignore if traces aren't active
111   return 1 if $level && !($global_level & TRACE2);   # ignore if level of trace isn't active
112
113   my ($package, $filename, $line, $subroutine) = caller(1);
114   my ($dummy1, $self_filename, $self_line) = caller(0);
115
116   my $indent = " " x --$self->{"calldepth"};
117   my $time = $self->want_request_timer ? $self->get_request_time || '' : '';
118
119   if (!defined($package)) {
120     $self->_write('sub' . $level, $indent . "/ $time top-level?\n");
121   } else {
122     $self->_write('sub' . $level, $indent . "/ $time ${subroutine} in " . "${self_filename}:${self_line}\n");
123   }
124   return 1;
125 }
126
127 sub show_backtrace {
128   my ($self, $force) = @_;
129
130   return 1 unless ($force || ($global_level & BACKTRACE_ON_ERROR));
131
132   $self->message(0, "Starting full caller dump:");
133   my $level = 0;
134   while (my ($dummy, $filename, $line, $subroutine) = caller $level) {
135     $self->message(0, "  ${subroutine} from ${filename}:${line}");
136     $level++;
137   }
138
139   return 1;
140 }
141
142 sub message {
143   no warnings;
144   my ($self, $level, $message) = @_;
145
146   $self->_write(level2string($level), $message) if (($self->{"level"} | $global_level) & $level || !$level);
147 }
148 sub warn {
149   no warnings;
150   my ($self, $message) = @_;
151   $self->message(WARN, $message);
152 }
153
154 sub dump {
155   my ($self, $level, $name, $variable, %options) = @_;
156
157   my $password;
158   if ($variable && ('Form' eq ref $variable) && defined $variable->{password}) {
159     $password             = $variable->{password};
160     $variable->{password} = 'X' x 8;
161   }
162
163   my $dumper = Data::Dumper->new([$variable]);
164   $dumper->Sortkeys(1);
165   $dumper->Indent(2);
166   $dumper->$_($options{$_}) for keys %options;
167   my $output = $dumper->Dump();
168   $self->message($level, "dumping ${name}:\n" . $output);
169
170   $variable->{password} = $password if (defined $password);
171
172   # Data::Dumper does not reset the iterator belonging to this hash
173   # if 'Sortkeys' is true. Therefore clear the iterator manually.
174   # See "perldoc -f each".
175   if ($variable && (('HASH' eq ref $variable) || ('Form' eq ref $variable))) {
176     keys %{ $variable };
177   }
178
179   return $output;
180 }
181
182 sub dump_yaml {
183   my ($self, $level, $name, $variable) = @_;
184
185   $self->message($level, "dumping ${name}:\n" . YAML::Dump($variable));
186 }
187
188 sub dump_sql_result {
189   my ($self, $level, $prefix, $results) = @_;
190
191   if (!$results || !scalar @{ $results }) {
192     $self->message($level, "Empty result set");
193     return;
194   }
195
196   my %column_lengths = map { $_, length $_ } keys %{ $results->[0] };
197
198   foreach my $row (@{ $results }) {
199     map { $column_lengths{$_} = length $row->{$_} if (length $row->{$_} > $column_lengths{$_}) } keys %{ $row };
200   }
201
202   my @sorted_names = sort keys %column_lengths;
203   my $format       = join '|', map { '%' . $column_lengths{$_} . 's' } @sorted_names;
204
205   $prefix .= ' ' if $prefix;
206
207   $self->message($level, $prefix . sprintf($format, @sorted_names));
208   $self->message($level, $prefix . join('+', map { '-' x $column_lengths{$_} } @sorted_names));
209
210   foreach my $row (@{ $results }) {
211     $self->message($level, $prefix . sprintf($format, map { $row->{$_} } @sorted_names));
212   }
213   $self->message($level, $prefix . sprintf('(%d row%s)', scalar @{ $results }, scalar @{ $results } > 1 ? 's' : ''));
214 }
215
216 sub dump_object {
217   my ($self, $level, $text, $object) = @_;
218
219   my $copy;
220   if ($object) {
221     $copy->{$_} = $object->$_ for $object->meta->columns;
222   }
223
224   $self->dump($level, $text, $copy);
225 }
226
227 sub show_diff {
228   my ($self, $level, $item1, $item2, %params) = @_;
229
230   if (!$self->_load_text_diff) {
231     $self->warn("Perl module Text::Diff is not available");
232     return;
233   }
234
235   my @texts = map { ref $_ ? YAML::Dump($_) : $_ } ($item1, $item2);
236
237   $self->message($level, Text::Diff::diff(\$texts[0], \$texts[1], \%params));
238 }
239
240 sub _load_text_diff {
241   $text_diff_available = eval("use Text::Diff (); 1;") ? 1 : 0 unless defined $text_diff_available;
242   return $text_diff_available;
243 }
244
245 sub enable_sub_tracing {
246   my ($self) = @_;
247   $global_level |= TRACE;
248 }
249
250 sub disable_sub_tracing {
251   my ($self) = @_;
252   $global_level &= ~ TRACE;
253 }
254
255 sub is_tracing_enabled {
256   my ($self) = @_;
257   return $global_level & TRACE;
258 }
259
260 sub _write {
261   no warnings;
262   my ($self, $prefix, $message) = @_;
263   my @now  = gettimeofday();
264   my $date = strftime("%Y-%m-%d %H:%M:%S." . sprintf('%03d', int($now[1] / 1000)) . " $$ [" . getppid() . "] ${prefix}: ", localtime($now[0]));
265   local *FILE;
266
267   chomp($message);
268   $self->_write_raw("${date}${message}\n");
269 }
270
271 sub _write_raw {
272   my ($self, $message) = @_;
273   local *FILE;
274   if ((FILE_TARGET == $self->{"target"})
275       && open(FILE, ">>", $self->{"file"})) {
276     print FILE $message;
277     close FILE;
278
279   } elsif (STDERR_TARGET == $self->{"target"}) {
280     print STDERR $message;
281   }
282 }
283
284 sub level2string {
285   no warnings;
286   # use $_[0] as a bit mask and return levelstrings separated by /
287   join '/', qw(info debug1 debug2 query trace error_call_trace request_timer WARNING)[ grep { (reverse split //, sprintf "%08b", $_[0])[$_] } 0..7 ]
288 }
289
290 sub begin_request {
291   my $self = shift;
292   return 1 unless want_request_timer();
293   $self->set_request_timer;
294 }
295
296 sub end_request {
297   my $self = shift;
298   return 1 unless want_request_timer();
299   $self->_write("time", $self->get_request_time);
300
301   $self->{calldepth} = 0;
302 }
303
304 sub log_time {
305   my ($self, @slurp) = @_;
306   return 1 unless want_request_timer();
307   $self->_write("time", $self->get_request_time() . (@slurp ? " (@slurp)" : ''));
308 }
309
310 sub get_request_time {
311   my $self = shift;
312   return $self->want_request_timer && $self->{request_start} ? tv_interval($self->{request_start}) : undef;
313 }
314
315 sub set_request_timer {
316   my $self = shift;
317   $self->{request_start} = [gettimeofday];
318 }
319
320 sub want_request_timer {
321   $global_level & REQUEST_TIMER;
322 }
323
324 sub file {
325   @_ == 2 ? $_[0]->{file} = $_[1] : $_[0]->{file};
326 }
327
328 sub _by_name {
329   my ($self, $level) = @_;
330   my $meth = $self->can(uc $level);
331   die 'unknown level' unless $meth;
332   $meth->();
333 }
334
335 sub level_by_name {
336   my ($self, $level, $val) = @_;
337   if (@_ == 3) {
338     $global_level |=  $self->_by_name($level) if  $val;
339     $global_level &= ~$self->_by_name($level) if !$val;
340   }
341   return $global_level & $self->_by_name($level);
342 }
343
344 sub is_request_logging_enabled {
345   my ($self) = @_;
346   return $global_level & REQUEST;
347 }
348
349 sub add_request_params {
350   my ($self, $key, $value) = @_;
351   return unless $self->is_request_logging_enabled;
352   return if $key =~ /password/;
353
354   push @{ $::request->{debug}{PARAMS} ||= [] }, [ $key => $value ];
355 }
356
357 sub log_request {
358   my ($self, $type, $controller, $action) = @_;
359   return unless $self->is_request_logging_enabled;
360
361   my $session_id = $::auth->create_or_refresh_session;
362
363   my $template = <<EOL;
364 *************************************
365  $ENV{REQUEST_METHOD} $ENV{SCRIPT_NAME}    $session_id ($::myconfig{login})
366    routing: $type, controller: $controller, action: $action
367 EOL
368
369   $self->_write('Request', $template);
370
371   my $params = join "\n   ", map {
372     "$_->[0] = $_->[1]"
373   } @{ $::request->{debug}{PARAMS} || [] };
374
375   $self->_write_raw(<<EOL);
376
377  Params
378    $params
379 EOL
380 }
381
382 1;
383 __END__
384
385 =pod
386
387 =encoding utf8
388
389 =head1 NAME
390
391 LXDebug - kivitendo debugging facilities
392
393 =head1 SYNOPSIS
394
395 This module provides functions for debugging kivitendo. An instance is
396 always created as the global variable C<$::lxdebug> at the earliest
397 possible moment.
398
399 Debugging is mostly logging of information. Each log function has a
400 I<level> and an I<object> to be logged. The configuration file as well
401 as this module's functions determine which levels get logged, and
402 which file they're logged to.
403
404 =head1 LOG LEVELS
405
406 The available log levels are:
407
408 =over 4
409
410 =item C<NONE>
411
412 Always output the message regardless of the active levels. Only use
413 this temporarily.
414
415 =item C<INFO>
416
417 Informational, not an error, more important than C<DEBUG1>.
418
419 =item C<DEBUG1>
420
421 Important debugging information.
422
423 =item C<DEBUG2>
424
425 Less important debugging information that occurs often and spams the
426 log.
427
428 =item C<QUERY>
429
430 Log all queries executed by the L<SL::DBUtils> utility methods.
431
432 =item C<TRACE>
433
434 Log sub calls and exits via the L<enter_sub>/L<leave_sub> functions,
435 but only if they're called with a log level that is falsish
436 (e.g. none, C<undef>, 0).
437
438 =item C<TRACE2>
439
440 Log sub calls and exits via the L<enter_sub>/L<leave_sub> functions
441 even if they're called with a log level of 2. Will only have an effect
442 if C<TRACE> is set as well.
443
444 =item C<BACKTRACE_ON_ERROR>
445
446 Log a stack trace when an error is output.
447
448 =item C<REQUEST_TIMER>
449
450 Log each request's total execution time when it finishes.
451
452 =item C<WARN>
453
454 Important warnings.
455
456 =item C<ALL>
457
458 All of the above.
459
460 =item C<DEVEL>
461
462 Shortcut for C<INFO | QUERY | TRACE | BACKTRACE_ON_ERROR | REQUEST_TIMER>.
463
464 =back
465
466 =head1 CONFIGURATION
467
468 C<SL::LXDebug> gets its configuration from the C<[debug]> section of
469 the C<config/kivitendo.conf> configuration file. The available options
470 are:
471
472 =over 4
473
474 =item C<global_level>
475
476 A string of log level names that should be activated by
477 default. Multiple log levels are separated by C<|>.
478
479 =item C<watch_form>
480
481 A boolean (C<1> or C<0>). Turns on the C<$::form> watch facility. If
482 this is enabled then any key inside C<$::form> can be monitored for
483 changes. For example:
484
485   # Start watching 'action'
486   $::form->{"Watchdog::action"} = 1;
487   # Stop watching 'invtotal'
488   $::form->{"Watchdog::invtotal"} = 0;
489
490 A log message is written when the watchdog is enabled for a variable
491 and for each subsequent change. The log message includes the place
492 (file name and line number) of the instruction changing the key.
493
494 Note that this entails a performance penalty. Also only the keys
495 themselves are monitored -- not the references they point to. E.g. the
496 following would not trigger a change:
497
498   $::form->{"Watchdog::some_hash"} = 1;
499   # Does not trigger:
500   $::form->{some_hash}->{some_value} = 42;
501   # This does trigger:
502   $::form->{some_hash} = { something => 'else' };
503
504 =item C<keep_temp_files>
505
506 A boolean (C<1> or C<0>). If turned on then certain temporary files
507 are not removed but kept in the C<users> directory. These include the
508 temporary files used during printing, e.g. LaTeX files.
509
510 =item C<file_name>
511
512 The path and file name of the debug log file. Must be a location
513 writeable by the web server process.
514
515 =back
516
517 =head1 FUNCTIONS
518
519 =over 4
520
521 =item C<enter_sub [$level]>
522
523 =item C<leave_sub [$level]>
524
525 Pairs of these can be put near the beginning/end of a sub. They'll
526 cause a trace to be written to the log file if the C<TRACE> level is
527 active.
528
529 If C<$level> is given then the log messages will only be logged if the
530 global log level C<TRACE2> is active as well.
531
532 =item C<enable_sub_tracing>
533
534 =item C<disable_sub_tracing>
535
536 Enables/disables sub tracing with L<enter_sub>/L<leave_sub> temporarily.
537
538 =item C<is_tracing_enabled>
539
540 Returns whether or not the C<TRACE> debug level is active.
541
542 =item C<show_backtrace [$force]>
543
544 Logs a stack backtrace if C<$force> is trueish or if the log level
545 C<BACKTRACE_ON_ERROR> is active.
546
547 =item C<message $level, $message>
548
549 Logs the message C<$message> if the log level C<$level> is active. The
550 message will be prefixed with a word describing the log level.
551
552 =item C<warn $message>
553
554 Equivalent to C<message WARN(), $message>.
555
556 =item C<dump $level, $name, $variable>
557
558 Logs a message that the variable named C<$name> is dumped along with a
559 dump of the variable C<$variable> created by the L<Data::Dumper>
560 module. Will log a warning if said module is not available. Will only
561 log if the log level C<$level> is active.
562
563 =item C<dump_yaml $level, $name, $variable>
564
565 Logs a message that the variable named C<$name> is dumped along with a
566 dump of the variable C<$variable> created by the C<YAML> module. Will
567 only log if the log level C<$level> is active.
568
569 =item C<dump_sql $level, $prefix, $results>
570
571 Dumps the result of an SQL query in tabular form. Will only log if the
572 log level C<$level> is active.
573
574 =item C<show_diff $level, $item1, $item2, %params>
575
576 Logs a unified diff of the textual representations of C<$item1> and
577 C<$item2>. Requires the module L<Text::Diff> and logs a warning if
578 said module is not available.
579
580 C<$item1> and C<$item2> are dumped via L<YAML::Dumper> before diffing
581 if they're non-scalars.
582
583 Will only log if the log level C<$level> is active.
584
585 =item C<begin_request>
586
587 =item C<end_request>
588
589 =item C<log_time>
590
591 =item C<set_request_timer>
592
593 =item C<want_request_timer>
594
595 Internal functions used to log the current request's exeuction time
596 (log level C<REQUEST_TIMER>).
597
598 =item C<get_request_time>
599
600 Returns the current request's elapsed execution time in seconds.
601
602 =item C<file [$file_name]>
603
604 Sets and/or returns the file name this instance logs to.
605
606 =item C<level_by_name $level[, $val]>
607
608 Returns if a log level C<$level> is active. C<$level> is a string
609 representation, not one of the level constants from above.
610
611 If C<$val> is given then said level will be turned on (if C<$val> is
612 trueish) or off (if C<$val> is falsish).
613
614 =back
615
616 =head1 BUGS
617
618 Nothing here yet.
619
620 =head1 AUTHOR
621
622 Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>,
623 Sven Schöling E<lt>s.schoeling@linet-services.deE<gt>
624
625 =cut