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