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