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