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