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