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 SHOW_CALLER        =>  1 << 10;
  15 use constant ALL                => (1 << 11) - 1;
  16 use constant DEVEL              => INFO | DEBUG1 | QUERY | TRACE | BACKTRACE_ON_ERROR | REQUEST_TIMER;
  17
  18 use constant FILE_TARGET   => 0;
  19 use constant STDERR_TARGET => 1;
  20
  21 use Data::Dumper;
  22 use POSIX qw(strftime getpid);
  23 use Scalar::Util qw(blessed refaddr weaken);
  24 use Time::HiRes qw(gettimeofday tv_interval);
  25 use YAML;
  26 use SL::Request ();
  27
  28 use strict;
  29 use utf8;
  30
  31 my ($text_diff_available);
  32
  33 our $global_level = NONE();
  34 our $watch_form   = 0;
  35 our $file_name;
  36
  37 sub new {
  38   my $type = shift;
  39   my $self = {};
  40
  41   _init_globals_from_config();
  42
  43   $self->{"calldepth"}  = 0;
  44   $self->{"file"}       = $file_name || "/tmp/lx-office-debug.log";
  45   $self->{"target"}     = FILE_TARGET;
  46   $self->{"level"}      = 0;
  47
  48   while ($_[0]) {
  49     $self->{ $_[0] } = $_[1];
  50     shift;
  51     shift;
  52   }
  53
  54   bless($self, $type);
  55 }
  56
  57 my $globals_inited_from_config;
  58 sub _init_globals_from_config {
  59   return if $globals_inited_from_config;
  60   $globals_inited_from_config = 1;
  61
  62   my $cfg = $::lx_office_conf{debug} || {};
  63
  64   $global_level = NONE() if $cfg->{global_level} =~ /NONE/;
  65   foreach my $level (grep { $_} split(m/\s+/, $cfg->{global_level})) {
  66     $global_level |= eval "${level}()";
  67   }
  68
  69   $watch_form = $cfg->{watch_form};
  70   $file_name  = $cfg->{file_name} || "/tmp/lx-office-debug.log";
  71 }
  72
  73 sub set_target {
  74   my ($self, $target, $file) = @_;
  75
  76   if ((FILE_TARGET == $target) && $file) {
  77     $self->{"file"}   = $file;
  78     $self->{"target"} = FILE_TARGET;
  79
  80   } elsif (STDERR_TARGET == $target) {
  81     $self->{"target"} = STDERR_TARGET;
  82   }
  83 }
  84
  85 sub enter_sub {
  86   my $self  = shift;
  87   my $level = shift || 0;
  88
  89   return 1 unless ($global_level & TRACE);          # ignore if traces aren't active
  90   return 1 if $level && !($global_level & TRACE2);  # ignore if level of trace isn't active
  91
  92   my ($package, $filename, $line, $subroutine) = caller(1);
  93   my ($dummy1, $self_filename, $self_line) = caller(0);
  94
  95   my $indent = " " x $self->{"calldepth"}++;
  96   my $time = $self->get_request_time || '';
  97
  98   if (!defined($package)) {
  99     $self->_write('sub' . $level, $indent . "\\ $time top-level?\n");
 100   } else {
 101     $self->_write('sub' . $level, $indent
 102                     . "\\ $time ${subroutine} in "
 103                     . "${self_filename}:${self_line} called from "
 104                     . "${filename}:${line}\n");
 105   }
 106   return 1;
 107 }
 108
 109 sub leave_sub {
 110   my $self  = shift;
 111   my $level = shift || 0;
 112
 113   return 1 unless ($global_level & TRACE);           # ignore if traces aren't active
 114   return 1 if $level && !($global_level & TRACE2);   # ignore if level of trace isn't active
 115
 116   my ($package, $filename, $line, $subroutine) = caller(1);
 117   my ($dummy1, $self_filename, $self_line) = caller(0);
 118
 119   my $indent = " " x --$self->{"calldepth"};
 120   my $time = $self->want_request_timer ? $self->get_request_time || '' : '';
 121
 122   if (!defined($package)) {
 123     $self->_write('sub' . $level, $indent . "/ $time top-level?\n");
 124   } else {
 125     $self->_write('sub' . $level, $indent . "/ $time ${subroutine} in " . "${self_filename}:${self_line}\n");
 126   }
 127   return 1;
 128 }
 129
 130 sub show_backtrace {
 131   my ($self, $force) = @_;
 132
 133   return 1 unless ($force || ($global_level & BACKTRACE_ON_ERROR));
 134
 135   $self->message(0, "Starting full caller dump:");
 136   my $level = 0;
 137   while (my ($dummy, $filename, $line, $subroutine) = caller $level) {
 138     $self->message(0, "  ${subroutine} from ${filename}:${line}");
 139     $level++;
 140   }
 141
 142   return 1;
 143 }
 144
 145 sub message {
 146   no warnings;
 147   my ($self, $level, $message) = @_;
 148
 149   my $show_caller = ($level | $global_level) & SHOW_CALLER();
 150   $level         &= ~SHOW_CALLER();
 151
 152   $self->_write(level2string($level), $message, show_caller => $show_caller) if (($self->{"level"} | $global_level) & $level || !$level);
 153 }
 154 sub warn {
 155   no warnings;
 156   my ($self, $message) = @_;
 157   $self->message(WARN, $message);
 158 }
 159
 160 sub dump {
 161   my ($self, $level, $name, $variable, %options) = @_;
 162
 163   my %dumped;
 164
 165   my $clone_for_dump;
 166   $clone_for_dump = sub {
 167     my ($src) = @_;
 168
 169     return undef if !defined($src);
 170
 171     my $addr = refaddr($src);
 172
 173     return $dumped{$addr} if $dumped{$addr // ''};
 174
 175
 176     if (blessed($src) && $src->can('as_debug_info')) {
 177       $dumped{$addr} = $src->as_debug_info;
 178
 179     } elsif (ref($src) eq 'ARRAY') {
 180       $dumped{$addr} = [];
 181
 182       foreach my $entry (@{ $src }) {
 183         my $exists = !!$dumped{refaddr($entry) // ''};
 184         push @{ $dumped{$addr} }, $clone_for_dump->($entry);
 185
 186         weaken($dumped{$addr}->[-1]) if $exists;
 187
 188       }
 189
 190     } elsif (ref($src) =~ m{^(?:HASH|Form)$}) {
 191       $dumped{$addr} = {};
 192
 193       foreach my $key (keys %{ $src }) {
 194         my $exists             = !!$dumped{refaddr($src->{$key}) // ''};
 195         $dumped{$addr}->{$key} = $clone_for_dump->($src->{$key});
 196
 197         weaken($dumped{$addr}->{$key}) if $exists;
 198       }
 199     }
 200
 201     return $dumped{$addr} // "$src";
 202   };
 203
 204   $variable  = $clone_for_dump->($variable);
 205   my $dumper = Data::Dumper->new([$variable]);
 206   $dumper->Sortkeys(1);
 207   $dumper->Indent(2);
 208   $dumper->$_($options{$_}) for keys %options;
 209   my $output = $dumper->Dump();
 210   $self->message($level, "dumping ${name}:\n" . $output);
 211
 212   return $output;
 213 }
 214
 215 sub dump_yaml {
 216   my ($self, $level, $name, $variable) = @_;
 217
 218   $self->message($level, "dumping ${name}:\n" . YAML::Dump($variable));
 219 }
 220
 221 sub dump_sql_result {
 222   my ($self, $level, $prefix, $results) = @_;
 223
 224   if (!$results || !scalar @{ $results }) {
 225     $self->message($level, "Empty result set");
 226     return;
 227   }
 228
 229   my %column_lengths = map { $_, length $_ } keys %{ $results->[0] };
 230
 231   foreach my $row (@{ $results }) {
 232     map { $column_lengths{$_} = length $row->{$_} if (length $row->{$_} > $column_lengths{$_}) } keys %{ $row };
 233   }
 234
 235   my @sorted_names = sort keys %column_lengths;
 236   my $format       = join '|', map { '%' . $column_lengths{$_} . 's' } @sorted_names;
 237
 238   $prefix .= ' ' if $prefix;
 239
 240   $self->message($level, $prefix . sprintf($format, @sorted_names));
 241   $self->message($level, $prefix . join('+', map { '-' x $column_lengths{$_} } @sorted_names));
 242
 243   foreach my $row (@{ $results }) {
 244     $self->message($level, $prefix . sprintf($format, map { $row->{$_} } @sorted_names));
 245   }
 246   $self->message($level, $prefix . sprintf('(%d row%s)', scalar @{ $results }, scalar @{ $results } > 1 ? 's' : ''));
 247 }
 248
 249 sub show_diff {
 250   my ($self, $level, $item1, $item2, %params) = @_;
 251
 252   if (!$self->_load_text_diff) {
 253     $self->warn("Perl module Text::Diff is not available");
 254     return;
 255   }
 256
 257   my @texts = map { ref $_ ? YAML::Dump($_) : $_ } ($item1, $item2);
 258
 259   $self->message($level, Text::Diff::diff(\$texts[0], \$texts[1], \%params));
 260 }
 261
 262 sub _load_text_diff {
 263   $text_diff_available = eval("use Text::Diff (); 1;") ? 1 : 0 unless defined $text_diff_available;
 264   return $text_diff_available;
 265 }
 266
 267 sub enable_sub_tracing {
 268   my ($self) = @_;
 269   $global_level |= TRACE;
 270 }
 271
 272 sub disable_sub_tracing {
 273   my ($self) = @_;
 274   $global_level &= ~ TRACE;
 275 }
 276
 277 sub is_tracing_enabled {
 278   my ($self) = @_;
 279   return $global_level & TRACE;
 280 }
 281
 282 sub _write {
 283   no warnings;
 284   my ($self, $prefix, $message, %options) = @_;
 285
 286   my @prefixes = ($prefix);
 287
 288   if ($options{show_caller}) {
 289     my $level = 1;
 290     while (1) {
 291       my ($package, $filename, $line, $subroutine) = caller($level);
 292
 293       if (($filename // '') =~ m{LXDebug\.pm$}) {
 294         $level++;
 295         next;
 296       }
 297
 298       push @prefixes, "${filename}:${line}";
 299       last;
 300     }
 301   }
 302
 303   $prefix = join ' ', grep { $_ } @prefixes;
 304
 305   my @now  = gettimeofday();
 306   my $date = strftime("%Y-%m-%d %H:%M:%S." . sprintf('%03d', int($now[1] / 1000)) . " $$ [" . getpid() . "] ${prefix}: ", localtime($now[0]));
 307   local *FILE;
 308
 309   chomp($message);
 310   $self->_write_raw("${date}${message}\n");
 311 }
 312
 313 sub _write_raw {
 314   my ($self, $message) = @_;
 315   local *FILE;
 316   if ((FILE_TARGET == $self->{"target"})
 317       && open(FILE, ">>", $self->{"file"})) {
 318     binmode FILE, ":utf8";
 319     print FILE $message;
 320     close FILE;
 321
 322   } elsif (STDERR_TARGET == $self->{"target"}) {
 323     print STDERR $message;
 324   }
 325 }
 326
 327 sub level2string {
 328   no warnings;
 329   # use $_[0] as a bit mask and return levelstrings separated by /
 330   join '/', qw(info debug1 debug2 query trace error_call_trace request_timer WARNING)[ grep { (reverse split //, sprintf "%08b", $_[0])[$_] } 0..7 ]
 331 }
 332
 333 sub begin_request {
 334   my $self = shift;
 335   return 1 unless want_request_timer();
 336   $self->set_request_timer;
 337 }
 338
 339 sub end_request {
 340   my ($self, %params) = @_;
 341   return 1 unless want_request_timer();
 342
 343   $self->_write("time", sprintf('%f (%s/%s)', $self->get_request_time, $params{script_name}, $params{action}));
 344
 345   $self->{calldepth} = 0;
 346 }
 347
 348 sub log_time {
 349   my ($self, @slurp) = @_;
 350   return 1 unless want_request_timer();
 351
 352   my $now                    = $self->get_request_time;
 353   my $diff                   = int((($now - ($self->{previous_log_time} // 0)) * 10_000 + 5) / 10);
 354   $self->{previous_log_time} = $now;
 355
 356   $self->_write("time", "${now}s Δ ${diff}ms" . (@slurp ? " (@slurp)" : ''));
 357 }
 358
 359 sub get_request_time {
 360   my $self = shift;
 361   return $self->want_request_timer && $self->{request_start} ? tv_interval($self->{request_start}) : undef;
 362 }
 363
 364 sub set_request_timer {
 365   my $self = shift;
 366   $self->{request_start} = [gettimeofday];
 367 }
 368
 369 sub want_request_timer {
 370   $global_level & REQUEST_TIMER;
 371 }
 372
 373 sub file {
 374   @_ == 2 ? $_[0]->{file} = $_[1] : $_[0]->{file};
 375 }
 376
 377 sub _by_name {
 378   my ($self, $level) = @_;
 379   my $meth = $self->can(uc $level);
 380   die 'unknown level' unless $meth;
 381   $meth->();
 382 }
 383
 384 sub level_by_name {
 385   my ($self, $level, $val) = @_;
 386   if (@_ == 3) {
 387     $global_level |=  $self->_by_name($level) if  $val;
 388     $global_level &= ~$self->_by_name($level) if !$val;
 389   }
 390   return $global_level & $self->_by_name($level);
 391 }
 392
 393 sub is_request_logging_enabled {
 394   my ($self) = @_;
 395   return $global_level & REQUEST;
 396 }
 397
 398 sub add_request_params {
 399   my ($self, $key, $value) = @_;
 400   return unless $self->is_request_logging_enabled;
 401   return if $key =~ /password/;
 402
 403   push @{ $::request->{debug}{PARAMS} ||= [] }, [ $key => $value ];
 404 }
 405
 406 sub log_request {
 407   my ($self, $type, $controller, $action) = @_;
 408   return unless $self->is_request_logging_enabled;
 409
 410   my $session_id = $::auth->create_or_refresh_session;
 411
 412   my $template = <<EOL;
 413 *************************************
 414  $ENV{REQUEST_METHOD} $ENV{SCRIPT_NAME}    $session_id ($::myconfig{login})
 415    routing: $type, controller: $controller, action: $action
 416 EOL
 417
 418   $self->_write('Request', $template);
 419
 420   my $params = join "\n   ", map {
 421     "$_->[0] = $_->[1]"
 422   } @{ $::request->{debug}{PARAMS} || [] };
 423
 424   $self->_write_raw(<<EOL);
 425
 426  Params
 427    $params
 428 EOL
 429 }
 430
 431 1;
 432 __END__
 433
 434 =pod
 435
 436 =encoding utf8
 437
 438 =head1 NAME
 439
 440 LXDebug - kivitendo debugging facilities
 441
 442 =head1 SYNOPSIS
 443
 444 This module provides functions for debugging kivitendo. An instance is
 445 always created as the global variable C<$::lxdebug> at the earliest
 446 possible moment.
 447
 448 Debugging is mostly logging of information. Each log function has a
 449 I<level> and an I<object> to be logged. The configuration file as well
 450 as this module's functions determine which levels get logged, and
 451 which file they're logged to.
 452
 453 =head1 LOG LEVELS
 454
 455 The available log levels are:
 456
 457 =over 4
 458
 459 =item C<NONE>
 460
 461 Always output the message regardless of the active levels. Only use
 462 this temporarily.
 463
 464 =item C<INFO>
 465
 466 Informational, not an error, more important than C<DEBUG1>.
 467
 468 =item C<DEBUG1>
 469
 470 Important debugging information.
 471
 472 =item C<DEBUG2>
 473
 474 Less important debugging information that occurs often and spams the
 475 log.
 476
 477 =item C<QUERY>
 478
 479 Log all queries executed by the L<SL::DBUtils> utility methods.
 480
 481 =item C<TRACE>
 482
 483 Log sub calls and exits via the L<enter_sub>/L<leave_sub> functions,
 484 but only if they're called with a log level that is falsish
 485 (e.g. none, C<undef>, 0).
 486
 487 =item C<TRACE2>
 488
 489 Log sub calls and exits via the L<enter_sub>/L<leave_sub> functions
 490 even if they're called with a log level of 2. Will only have an effect
 491 if C<TRACE> is set as well.
 492
 493 =item C<BACKTRACE_ON_ERROR>
 494
 495 Log a stack trace when an error is output.
 496
 497 =item C<REQUEST_TIMER>
 498
 499 Log each request's total execution time when it finishes.
 500
 501 =item C<WARN>
 502
 503 Important warnings.
 504
 505 =item C<ALL>
 506
 507 All of the above.
 508
 509 =item C<DEVEL>
 510
 511 Shortcut for C<INFO | QUERY | TRACE | BACKTRACE_ON_ERROR | REQUEST_TIMER>.
 512
 513 =back
 514
 515 =head1 CONFIGURATION
 516
 517 C<SL::LXDebug> gets its configuration from the C<[debug]> section of
 518 the C<config/kivitendo.conf> configuration file. The available options
 519 are:
 520
 521 =over 4
 522
 523 =item C<global_level>
 524
 525 A string of log level names that should be activated by
 526 default. Multiple log levels are separated by C<|>.
 527
 528 =item C<watch_form>
 529
 530 A boolean (C<1> or C<0>). Turns on the C<$::form> watch facility. If
 531 this is enabled then any key inside C<$::form> can be monitored for
 532 changes. For example:
 533
 534   # Start watching 'action'
 535   $::form->{"Watchdog::action"} = 1;
 536   # Stop watching 'invtotal'
 537   $::form->{"Watchdog::invtotal"} = 0;
 538
 539 A log message is written when the watchdog is enabled for a variable
 540 and for each subsequent change. The log message includes the place
 541 (file name and line number) of the instruction changing the key.
 542
 543 Note that this entails a performance penalty. Also only the keys
 544 themselves are monitored -- not the references they point to. E.g. the
 545 following would not trigger a change:
 546
 547   $::form->{"Watchdog::some_hash"} = 1;
 548   # Does not trigger:
 549   $::form->{some_hash}->{some_value} = 42;
 550   # This does trigger:
 551   $::form->{some_hash} = { something => 'else' };
 552
 553 =item C<keep_temp_files>
 554
 555 A boolean (C<1> or C<0>). If turned on then certain temporary files
 556 are not removed but kept in the C<users> directory. These include the
 557 temporary files used during printing, e.g. LaTeX files.
 558
 559 =item C<file_name>
 560
 561 The path and file name of the debug log file. Must be a location
 562 writeable by the web server process.
 563
 564 =back
 565
 566 =head1 FUNCTIONS
 567
 568 =over 4
 569
 570 =item C<enter_sub [$level]>
 571
 572 =item C<leave_sub [$level]>
 573
 574 Pairs of these can be put near the beginning/end of a sub. They'll
 575 cause a trace to be written to the log file if the C<TRACE> level is
 576 active.
 577
 578 If C<$level> is given then the log messages will only be logged if the
 579 global log level C<TRACE2> is active as well.
 580
 581 =item C<enable_sub_tracing>
 582
 583 =item C<disable_sub_tracing>
 584
 585 Enables/disables sub tracing with L<enter_sub>/L<leave_sub> temporarily.
 586
 587 =item C<is_tracing_enabled>
 588
 589 Returns whether or not the C<TRACE> debug level is active.
 590
 591 =item C<show_backtrace [$force]>
 592
 593 Logs a stack backtrace if C<$force> is trueish or if the log level
 594 C<BACKTRACE_ON_ERROR> is active.
 595
 596 =item C<message $level, $message>
 597
 598 Logs the message C<$message> if the log level C<$level> is active. The
 599 message will be prefixed with a word describing the log level.
 600
 601 =item C<warn $message>
 602
 603 Equivalent to C<message WARN(), $message>.
 604
 605 =item C<dump $level, $name, $variable>
 606
 607 Logs a message that the variable named C<$name> is dumped along with a
 608 dump of the variable C<$variable> created by the L<Data::Dumper>
 609 module. Will log a warning if said module is not available. Will only
 610 log if the log level C<$level> is active.
 611
 612 =item C<dump_yaml $level, $name, $variable>
 613
 614 Logs a message that the variable named C<$name> is dumped along with a
 615 dump of the variable C<$variable> created by the C<YAML> module. Will
 616 only log if the log level C<$level> is active.
 617
 618 =item C<dump_sql $level, $prefix, $results>
 619
 620 Dumps the result of an SQL query in tabular form. Will only log if the
 621 log level C<$level> is active.
 622
 623 =item C<show_diff $level, $item1, $item2, %params>
 624
 625 Logs a unified diff of the textual representations of C<$item1> and
 626 C<$item2>. Requires the module L<Text::Diff> and logs a warning if
 627 said module is not available.
 628
 629 C<$item1> and C<$item2> are dumped via L<YAML::Dumper> before diffing
 630 if they're non-scalars.
 631
 632 Will only log if the log level C<$level> is active.
 633
 634 =item C<begin_request>
 635
 636 =item C<end_request>
 637
 638 =item C<log_time>
 639
 640 =item C<set_request_timer>
 641
 642 =item C<want_request_timer>
 643
 644 Internal functions used to log the current request's exeuction time
 645 (log level C<REQUEST_TIMER>).
 646
 647 =item C<get_request_time>
 648
 649 Returns the current request's elapsed execution time in seconds.
 650
 651 =item C<file [$file_name]>
 652
 653 Sets and/or returns the file name this instance logs to.
 654
 655 =item C<level_by_name $level[, $val]>
 656
 657 Returns if a log level C<$level> is active. C<$level> is a string
 658 representation, not one of the level constants from above.
 659
 660 If C<$val> is given then said level will be turned on (if C<$val> is
 661 trueish) or off (if C<$val> is falsish).
 662
 663 =back
 664
 665 =head1 BUGS
 666
 667 Nothing here yet.
 668
 669 =head1 AUTHOR
 670
 671 Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>,
 672 Sven Schöling E<lt>s.schoeling@linet-services.deE<gt>
 673
 674 =cut