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