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