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