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