$::lxdebug->backtrace_on_error auch im force mode anzeigen
[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 $date = strftime("%Y-%m-%d %H:%M:%S $$ [" . getppid() . "] ${prefix}: ", localtime(time()));
264   local *FILE;
265
266   chomp($message);
267   $self->_write_raw("${date}${message}\n");
268 }
269
270 sub _write_raw {
271   my ($self, $message) = @_;
272   local *FILE;
273   if ((FILE_TARGET == $self->{"target"})
274       && open(FILE, ">>", $self->{"file"})) {
275     print FILE $message;
276     close FILE;
277
278   } elsif (STDERR_TARGET == $self->{"target"}) {
279     print STDERR $message;
280   }
281 }
282
283 sub level2string {
284   no warnings;
285   # use $_[0] as a bit mask and return levelstrings separated by /
286   join '/', qw(info debug1 debug2 query trace error_call_trace request_timer WARNING)[ grep { (reverse split //, sprintf "%08b", $_[0])[$_] } 0..7 ]
287 }
288
289 sub begin_request {
290   my $self = shift;
291   return 1 unless want_request_timer();
292   $self->set_request_timer;
293 }
294
295 sub end_request {
296   my $self = shift;
297   return 1 unless want_request_timer();
298   $self->_write("time", $self->get_request_time);
299
300   $self->{calldepth} = 0;
301 }
302
303 sub log_time {
304   my ($self, @slurp) = @_;
305   return 1 unless want_request_timer();
306   $self->_write("time", $self->get_request_time() . (@slurp ? " (@slurp)" : ''));
307 }
308
309 sub get_request_time {
310   my $self = shift;
311   return $self->want_request_timer && $self->{request_start} ? tv_interval($self->{request_start}) : undef;
312 }
313
314 sub set_request_timer {
315   my $self = shift;
316   $self->{request_start} = [gettimeofday];
317 }
318
319 sub want_request_timer {
320   $global_level & REQUEST_TIMER;
321 }
322
323 sub file {
324   @_ == 2 ? $_[0]->{file} = $_[1] : $_[0]->{file};
325 }
326
327 sub _by_name {
328   my ($self, $level) = @_;
329   my $meth = $self->can(uc $level);
330   die 'unknown level' unless $meth;
331   $meth->();
332 }
333
334 sub level_by_name {
335   my ($self, $level, $val) = @_;
336   if (@_ == 3) {
337     $global_level |=  $self->_by_name($level) if  $val;
338     $global_level &= ~$self->_by_name($level) if !$val;
339   }
340   return $global_level & $self->_by_name($level);
341 }
342
343 sub is_request_logging_enabled {
344   my ($self) = @_;
345   return $global_level & REQUEST;
346 }
347
348 sub add_request_params {
349   my ($self, $key, $value) = @_;
350   return unless $self->is_request_logging_enabled;
351   return if $key =~ /password/;
352
353   push @{ $::request->{debug}{PARAMS} ||= [] }, [ $key => $value ];
354 }
355
356 sub log_request {
357   my ($self, $type, $controller, $action) = @_;
358   return unless $self->is_request_logging_enabled;
359
360   my $session_id = $::auth->create_or_refresh_session;
361
362   my $template = <<EOL;
363 *************************************
364  $ENV{REQUEST_METHOD} $ENV{SCRIPT_NAME}    $session_id ($::myconfig{login})
365    routing: $type, controller: $controller, action: $action
366 EOL
367
368   $self->_write('Request', $template);
369
370   my $params = join "\n   ", map {
371     "$_->[0] = $_->[1]"
372   } @{ $::request->{debug}{PARAMS} || [] };
373
374   $self->_write_raw(<<EOL);
375
376  Params
377    $params
378 EOL
379 }
380
381 1;
382 __END__
383
384 =pod
385
386 =encoding utf8
387
388 =head1 NAME
389
390 LXDebug - kivitendo debugging facilities
391
392 =head1 SYNOPSIS
393
394 This module provides functions for debugging kivitendo. An instance is
395 always created as the global variable C<$::lxdebug> at the earliest
396 possible moment.
397
398 Debugging is mostly logging of information. Each log function has a
399 I<level> and an I<object> to be logged. The configuration file as well
400 as this module's functions determine which levels get logged, and
401 which file they're logged to.
402
403 =head1 LOG LEVELS
404
405 The available log levels are:
406
407 =over 4
408
409 =item C<NONE>
410
411 Always output the message regardless of the active levels. Only use
412 this temporarily.
413
414 =item C<INFO>
415
416 Informational, not an error, more important than C<DEBUG1>.
417
418 =item C<DEBUG1>
419
420 Important debugging information.
421
422 =item C<DEBUG2>
423
424 Less important debugging information that occurs often and spams the
425 log.
426
427 =item C<QUERY>
428
429 Log all queries executed by the L<SL::DBUtils> utility methods.
430
431 =item C<TRACE>
432
433 Log sub calls and exits via the L<enter_sub>/L<leave_sub> functions,
434 but only if they're called with a log level that is falsish
435 (e.g. none, C<undef>, 0).
436
437 =item C<TRACE2>
438
439 Log sub calls and exits via the L<enter_sub>/L<leave_sub> functions
440 even if they're called with a log level of 2. Will only have an effect
441 if C<TRACE> is set as well.
442
443 =item C<BACKTRACE_ON_ERROR>
444
445 Log a stack trace when an error is output.
446
447 =item C<REQUEST_TIMER>
448
449 Log each request's total execution time when it finishes.
450
451 =item C<WARN>
452
453 Important warnings.
454
455 =item C<ALL>
456
457 All of the above.
458
459 =item C<DEVEL>
460
461 Shortcut for C<INFO | QUERY | TRACE | BACKTRACE_ON_ERROR | REQUEST_TIMER>.
462
463 =back
464
465 =head1 CONFIGURATION
466
467 C<SL::LXDebug> gets its configuration from the C<[debug]> section of
468 the C<config/kivitendo.conf> configuration file. The available options
469 are:
470
471 =over 4
472
473 =item C<global_level>
474
475 A string of log level names that should be activated by
476 default. Multiple log levels are separated by C<|>.
477
478 =item C<watch_form>
479
480 A boolean (C<1> or C<0>). Turns on the C<$::form> watch facility. If
481 this is enabled then any key inside C<$::form> can be monitored for
482 changes. For example:
483
484   # Start watching 'action'
485   $::form->{"Watchdog::action"} = 1;
486   # Stop watching 'invtotal'
487   $::form->{"Watchdog::invtotal"} = 0;
488
489 A log message is written when the watchdog is enabled for a variable
490 and for each subsequent change. The log message includes the place
491 (file name and line number) of the instruction changing the key.
492
493 Note that this entails a performance penalty. Also only the keys
494 themselves are monitored -- not the references they point to. E.g. the
495 following would not trigger a change:
496
497   $::form->{"Watchdog::some_hash"} = 1;
498   # Does not trigger:
499   $::form->{some_hash}->{some_value} = 42;
500   # This does trigger:
501   $::form->{some_hash} = { something => 'else' };
502
503 =item C<keep_temp_files>
504
505 A boolean (C<1> or C<0>). If turned on then certain temporary files
506 are not removed but kept in the C<users> directory. These include the
507 temporary files used during printing, e.g. LaTeX files.
508
509 =item C<file_name>
510
511 The path and file name of the debug log file. Must be a location
512 writeable by the web server process.
513
514 =back
515
516 =head1 FUNCTIONS
517
518 =over 4
519
520 =item C<enter_sub [$level]>
521
522 =item C<leave_sub [$level]>
523
524 Pairs of these can be put near the beginning/end of a sub. They'll
525 cause a trace to be written to the log file if the C<TRACE> level is
526 active.
527
528 If C<$level> is given then the log messages will only be logged if the
529 global log level C<TRACE2> is active as well.
530
531 =item C<enable_sub_tracing>
532
533 =item C<disable_sub_tracing>
534
535 Enables/disables sub tracing with L<enter_sub>/L<leave_sub> temporarily.
536
537 =item C<is_tracing_enabled>
538
539 Returns whether or not the C<TRACE> debug level is active.
540
541 =item C<show_backtrace [$force]>
542
543 Logs a stack backtrace if C<$force> is trueish or if the log level
544 C<BACKTRACE_ON_ERROR> is active.
545
546 =item C<message $level, $message>
547
548 Logs the message C<$message> if the log level C<$level> is active. The
549 message will be prefixed with a word describing the log level.
550
551 =item C<warn $message>
552
553 Equivalent to C<message WARN(), $message>.
554
555 =item C<dump $level, $name, $variable>
556
557 Logs a message that the variable named C<$name> is dumped along with a
558 dump of the variable C<$variable> created by the L<Data::Dumper>
559 module. Will log a warning if said module is not available. Will only
560 log if the log level C<$level> is active.
561
562 =item C<dump_yaml $level, $name, $variable>
563
564 Logs a message that the variable named C<$name> is dumped along with a
565 dump of the variable C<$variable> created by the C<YAML> module. Will
566 only log if the log level C<$level> is active.
567
568 =item C<dump_sql $level, $prefix, $results>
569
570 Dumps the result of an SQL query in tabular form. Will only log if the
571 log level C<$level> is active.
572
573 =item C<show_diff $level, $item1, $item2, %params>
574
575 Logs a unified diff of the textual representations of C<$item1> and
576 C<$item2>. Requires the module L<Text::Diff> and logs a warning if
577 said module is not available.
578
579 C<$item1> and C<$item2> are dumped via L<YAML::Dumper> before diffing
580 if they're non-scalars.
581
582 Will only log if the log level C<$level> is active.
583
584 =item C<begin_request>
585
586 =item C<end_request>
587
588 =item C<log_time>
589
590 =item C<set_request_timer>
591
592 =item C<want_request_timer>
593
594 Internal functions used to log the current request's exeuction time
595 (log level C<REQUEST_TIMER>).
596
597 =item C<get_request_time>
598
599 Returns the current request's elapsed execution time in seconds.
600
601 =item C<file [$file_name]>
602
603 Sets and/or returns the file name this instance logs to.
604
605 =item C<level_by_name $level[, $val]>
606
607 Returns if a log level C<$level> is active. C<$level> is a string
608 representation, not one of the level constants from above.
609
610 If C<$val> is given then said level will be turned on (if C<$val> is
611 trueish) or off (if C<$val> is falsish).
612
613 =back
614
615 =head1 BUGS
616
617 Nothing here yet.
618
619 =head1 AUTHOR
620
621 Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>,
622 Sven Schöling E<lt>s.schoeling@linet-services.deE<gt>
623
624 =cut