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