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