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