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