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