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