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