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;
15 use constant FILE_TARGET => 0;
16 use constant STDERR_TARGET => 1;
18 use POSIX qw(strftime getppid);
19 use Time::HiRes qw(gettimeofday tv_interval);
24 my ($data_dumper_available, $text_diff_available);
31 eval("use Data::Dumper");
32 $data_dumper_available = $@ ? 0 : 1;
42 _init_globals_from_config();
44 $self->{"calldepth"} = 0;
45 $self->{"file"} = $file_name || "/tmp/lx-office-debug.log";
46 $self->{"target"} = FILE_TARGET;
50 $self->{ $_[0] } = $_[1];
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;
63 my $cfg = $::lx_office_conf{debug} || {};
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}()";
70 $watch_form = $cfg->{watch_form};
71 $file_name = $cfg->{file_name} || "/tmp/lx-office-debug.log";
75 my ($self, $target, $file) = @_;
77 if ((FILE_TARGET == $target) && $file) {
78 $self->{"file"} = $file;
79 $self->{"target"} = FILE_TARGET;
81 } elsif (STDERR_TARGET == $target) {
82 $self->{"target"} = STDERR_TARGET;
88 my $level = shift || 0;
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
93 my ($package, $filename, $line, $subroutine) = caller(1);
94 my ($dummy1, $self_filename, $self_line) = caller(0);
96 my $indent = " " x $self->{"calldepth"}++;
97 my $time = $self->get_request_time || '';
99 if (!defined($package)) {
100 $self->_write('sub' . $level, $indent . "\\ $time top-level?\n");
102 $self->_write('sub' . $level, $indent
103 . "\\ $time ${subroutine} in "
104 . "${self_filename}:${self_line} called from "
105 . "${filename}:${line}\n");
112 my $level = shift || 0;
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
117 my ($package, $filename, $line, $subroutine) = caller(1);
118 my ($dummy1, $self_filename, $self_line) = caller(0);
120 my $indent = " " x --$self->{"calldepth"};
121 my $time = $self->want_request_timer ? $self->get_request_time : '';
123 if (!defined($package)) {
124 $self->_write('sub' . $level, $indent . "/ $time top-level?\n");
126 $self->_write('sub' . $level, $indent . "/ $time ${subroutine} in " . "${self_filename}:${self_line}\n");
132 my ($self, $force) = @_;
134 return 1 unless ($force || ($global_level & BACKTRACE_ON_ERROR));
136 $self->message(BACKTRACE_ON_ERROR, "Starting full caller dump:");
138 while (my ($dummy, $filename, $line, $subroutine) = caller $level) {
139 $self->message(BACKTRACE_ON_ERROR, " ${subroutine} from ${filename}:${line}");
148 my ($self, $level, $message) = @_;
150 $self->_write(level2string($level), $message) if (($self->{"level"} | $global_level) & $level || !$level);
154 my ($self, $message) = @_;
155 $self->message(WARN, $message);
159 my ($self, $level, $name, $variable) = @_;
161 if ($data_dumper_available) {
163 if ($variable && ('Form' eq ref $variable) && defined $variable->{password}) {
164 $password = $variable->{password};
165 $variable->{password} = 'X' x 8;
168 my $dumper = Data::Dumper->new([$variable]);
169 $dumper->Sortkeys(1);
170 $self->message($level, "dumping ${name}:\n" . $dumper->Dump());
172 $variable->{password} = $password if (defined $password);
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))) {
182 $self->message($level,
183 "dumping ${name}: Data::Dumper not available; "
184 . "variable cannot be dumped");
189 my ($self, $level, $name, $variable) = @_;
191 $self->message($level, "dumping ${name}:\n" . YAML::Dump($variable));
194 sub dump_sql_result {
195 my ($self, $level, $prefix, $results) = @_;
197 if (!$results || !scalar @{ $results }) {
198 $self->message($level, "Empty result set");
202 my %column_lengths = map { $_, length $_ } keys %{ $results->[0] };
204 foreach my $row (@{ $results }) {
205 map { $column_lengths{$_} = length $row->{$_} if (length $row->{$_} > $column_lengths{$_}) } keys %{ $row };
208 my @sorted_names = sort keys %column_lengths;
209 my $format = join '|', map { '%' . $column_lengths{$_} . 's' } @sorted_names;
211 $prefix .= ' ' if $prefix;
213 $self->message($level, $prefix . sprintf($format, @sorted_names));
214 $self->message($level, $prefix . join('+', map { '-' x $column_lengths{$_} } @sorted_names));
216 foreach my $row (@{ $results }) {
217 $self->message($level, $prefix . sprintf($format, map { $row->{$_} } @sorted_names));
219 $self->message($level, $prefix . sprintf('(%d row%s)', scalar @{ $results }, scalar @{ $results } > 1 ? 's' : ''));
223 my ($self, $level, $item1, $item2, %params) = @_;
225 if (!$self->_load_text_diff) {
226 $self->warn("Perl module Text::Diff is not available");
230 my @texts = map { ref $_ ? YAML::Dump($_) : $_ } ($item1, $item2);
232 $self->message($level, Text::Diff::diff(\$texts[0], \$texts[1], \%params));
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;
240 sub enable_sub_tracing {
242 $global_level |= TRACE;
245 sub disable_sub_tracing {
247 $global_level &= ~ TRACE;
250 sub is_tracing_enabled {
252 return $global_level & TRACE;
257 my ($self, $prefix, $message) = @_;
258 my $date = strftime("%Y-%m-%d %H:%M:%S $$ [" . getppid() . "] ${prefix}: ", localtime(time()));
263 if ((FILE_TARGET == $self->{"target"})
264 && open(FILE, ">>" . $self->{"file"})) {
265 print(FILE "${date}${message}\n");
268 } elsif (STDERR_TARGET == $self->{"target"}) {
269 print(STDERR "${date}${message}\n");
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 ]
281 return 1 unless want_request_timer();
282 $self->set_request_timer;
287 return 1 unless want_request_timer();
288 $self->_write("time", $self->get_request_time);
290 $self->{calldepth} = 0;
295 return 1 unless want_request_timer();
296 $self->_write("time", $self->get_request_time);
299 sub get_request_time {
301 return $self->want_request_timer && $self->{request_start} ? tv_interval($self->{request_start}) : undef;
304 sub set_request_timer {
306 $self->{request_start} = [gettimeofday];
309 sub want_request_timer {
310 $global_level & REQUEST_TIMER;
314 @_ == 2 ? $_[0]->{file} = $_[1] : $_[0]->{file};
318 my ($self, $level) = @_;
319 my $meth = $self->can(uc $level);
320 die 'unknown level' unless $meth;
325 my ($self, $level, $val) = @_;
327 $global_level |= $self->_by_name($level) if $val;
328 $global_level &= ~$self->_by_name($level) if !$val;
330 return $global_level & $self->_by_name($level);
342 LXDebug - Lx-Office debugging facilities
346 This module provides functions for debugging Lx-Office. An instance is
347 always created as the global variable C<$::lxdebug> at the earliest
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.
357 The available log levels are:
363 Always output the message regardless of the active levels. Only use
368 Informational, not an error, more important than C<DEBUG1>.
372 Important debugging information.
376 Less important debugging information that occurs often and spams the
381 Log all queries executed by the L<SL::DBUtils> utility methods.
385 Log sub calls and exits via the L<enter_sub>/L<leave_sub> functions.
387 =item C<BACKTRACE_ON_ERROR>
389 Log a stack trace when an error is output.
391 =item C<REQUEST_TIMER>
393 Log each request's total execution time when it finishes.
405 Shortcut for C<INFO | QUERY | TRACE | BACKTRACE_ON_ERROR | REQUEST_TIMER>.
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
417 =item C<global_level>
419 A string of log level names that should be activated by
420 default. Multiple log levels are separated by C<|>.
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:
428 # Start watching 'action'
429 $::form->{"Watchdog::action"} = 1;
430 # Stop watching 'invtotal'
431 $::form->{"Watchdog::invtotal"} = 0;
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.
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:
441 $::form->{"Watchdog::some_hash"} = 1;
443 $::form->{some_hash}->{some_value} = 42;
445 $::form->{some_hash} = { something => 'else' };
447 =item C<show_debug_menu>
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.
456 restarting the FastCGI process by forcefully exiting after the
461 enabling and disabling function tracing,
465 enabling and disabling certain debug levels.
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.
473 =item C<keep_temp_files>
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.
481 The path and file name of the debug log file. Must be a location
482 writeable by the web server process.
490 =item C<enter_sub [$level]>
492 =item C<leave_sub [$level]>
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
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.
501 =item C<enable_sub_tracing>
503 =item C<disable_sub_tracing>
505 Enables/disables sub tracing with L<enter_sub>/L<leave_sub> temporarily.
507 =item C<is_tracing_enabled>
509 Returns whether or not the C<TRACE> debug level is active.
511 =item C<show_backtrace [$force]>
513 Logs a stack backtrace if C<$force> is trueish or if the log level
514 C<BACKTRACE_ON_ERROR> is active.
516 =item C<message $level, $message>
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.
521 =item C<warn $message>
523 Equivalent to C<message WARN(), $message>.
525 =item C<dump $level, $name, $variable>
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.
532 =item C<dump_yaml $level, $name, $variable>
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.
538 =item C<dump_sql $level, $prefix, $results>
540 Dumps the result of an SQL query in tabular form. Will only log if the
541 log level C<$level> is active.
543 =item C<show_diff $level, $item1, $item2, %params>
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.
549 C<$item1> and C<$item2> are dumped via L<YAML::Dumper> before diffing
550 if they're non-scalars.
552 Will only log if the log level C<$level> is active.
554 =item C<begin_request>
560 =item C<set_request_timer>
562 =item C<want_request_timer>
564 Internal functions used to log the current request's exeuction time
565 (log level C<REQUEST_TIMER>).
567 =item C<get_request_time>
569 Returns the current request's elapsed execution time in seconds.
571 =item C<file [$file_name]>
573 Sets and/or returns the file name this instance logs to.
575 =item C<level_by_name $level[, $val]>
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.
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).
591 Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>,
592 Sven Schöling E<lt>s.schoeling@linet-services.deE<gt>