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