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