Globale Variablen für Druckvorlagen nach %::lx_office_conf verschoben
[kivitendo-erp.git] / 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;
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 enable_sub_tracing {
223   my ($self) = @_;
224   $global_level |= TRACE;
225 }
226
227 sub disable_sub_tracing {
228   my ($self) = @_;
229   $global_level &= ~ TRACE;
230 }
231
232 sub is_tracing_enabled {
233   my ($self) = @_;
234   return $global_level & TRACE;
235 }
236
237 sub _write {
238   no warnings;
239   my ($self, $prefix, $message) = @_;
240   my $date = strftime("%Y-%m-%d %H:%M:%S $$ [" . getppid() . "] ${prefix}: ", localtime(time()));
241   local *FILE;
242
243   chomp($message);
244
245   if ((FILE_TARGET == $self->{"target"})
246       && open(FILE, ">>" . $self->{"file"})) {
247     print(FILE "${date}${message}\n");
248     close(FILE);
249
250   } elsif (STDERR_TARGET == $self->{"target"}) {
251     print(STDERR "${date}${message}\n");
252   }
253 }
254
255 sub level2string {
256   no warnings;
257   # use $_[0] as a bit mask and return levelstrings separated by /
258   join '/', qw(info debug1 debug2 query trace error_call_trace request_timer WARNING)[ grep { (reverse split //, sprintf "%08b", $_[0])[$_] } 0..7 ]
259 }
260
261 sub begin_request {
262   my $self = shift;
263   return 1 unless want_request_timer();
264   $self->set_request_timer;
265 }
266
267 sub end_request {
268   my $self = shift;
269   return 1 unless want_request_timer();
270   $self->_write("time", $self->get_request_time);
271
272   $self->{calldepth} = 0;
273 }
274
275 sub log_time {
276   my $self = shift;
277   return 1 unless want_request_timer();
278   $self->_write("time", $self->get_request_time);
279 }
280
281 sub get_request_time {
282   my $self = shift;
283   return $self->want_request_timer && $self->{request_start} ? tv_interval($self->{request_start}) : undef;
284 }
285
286 sub set_request_timer {
287   my $self = shift;
288   $self->{request_start} = [gettimeofday];
289 }
290
291 sub want_request_timer {
292   $global_level & REQUEST_TIMER;
293 }
294
295 1;