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