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