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