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