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