Möglichkeit, den Dateinamen für Debugmeldungen zu ändern.
[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 ALL                => (1 << 7) - 1;
12 use constant DEVEL              => INFO | QUERY | TRACE | BACKTRACE_ON_ERROR | REQUEST_TIMER;
13
14 use constant FILE_TARGET   => 0;
15 use constant STDERR_TARGET => 1;
16
17 use POSIX qw(strftime);
18 use Time::HiRes qw(gettimeofday tv_interval);
19 use YAML;
20
21 use strict;
22
23 my $data_dumper_available;
24
25 our $global_level;
26 our $watch_form;
27 our $file_name;
28
29 BEGIN {
30   eval("use Data::Dumper");
31   $data_dumper_available = $@ ? 0 : 1;
32
33   $global_level      = NONE;
34   $watch_form        = 0;
35 }
36
37 sub new {
38   my $type = shift;
39   my $self = {};
40
41   $self->{"calldepth"}  = 0;
42   $self->{"file"}       = $file_name || "/tmp/lx-office-debug.log";
43   $self->{"target"}     = FILE_TARGET;
44   $self->{"level"}      = 0;
45
46   while ($_[0]) {
47     $self->{ $_[0] } = $_[1];
48     shift;
49     shift;
50   }
51
52   bless($self, $type);
53 }
54
55 sub set_target {
56   my ($self, $target, $file) = @_;
57
58   if ((FILE_TARGET == $target) && $file) {
59     $self->{"file"}   = $file;
60     $self->{"target"} = FILE_TARGET;
61
62   } elsif (STDERR_TARGET == $target) {
63     $self->{"target"} = STDERR_TARGET;
64   }
65 }
66
67 sub enter_sub {
68   my ($self, $level) = @_;
69   $level *= 1;
70
71   return 1 unless ($global_level & TRACE);          # ignore if traces aren't active
72   return 1 if $level && !($global_level & $level);  # ignore if level of trace isn't active
73
74   my ($package, $filename, $line, $subroutine) = caller(1);
75   my ($dummy1, $self_filename, $self_line) = caller(0);
76
77   my $indent = " " x $self->{"calldepth"}++;
78
79   if (!defined($package)) {
80     $self->_write('sub' . $level, $indent . "\\ top-level?\n");
81   } else {
82     $self->_write('sub' . $level, $indent
83                     . "\\ ${subroutine} in "
84                     . "${self_filename}:${self_line} called from "
85                     . "${filename}:${line}\n");
86   }
87   return 1;
88 }
89
90 sub leave_sub {
91   my ($self, $level) = @_;
92   $level *= 1;
93
94   return 1 unless ($global_level & TRACE);           # ignore if traces aren't active
95   return 1 if $level && !($global_level & $level);   # ignore if level of trace isn't active
96
97   my ($package, $filename, $line, $subroutine) = caller(1);
98   my ($dummy1, $self_filename, $self_line) = caller(0);
99
100   my $indent = " " x --$self->{"calldepth"};
101
102   if (!defined($package)) {
103     $self->_write('sub' . $level, $indent . "/ top-level?\n");
104   } else {
105     $self->_write('sub' . $level, $indent . "/ ${subroutine} in " . "${self_filename}:${self_line}\n");
106   }
107   return 1;
108 }
109
110 sub show_backtrace {
111   my ($self, $force) = @_;
112
113   return 1 unless ($force || ($global_level & BACKTRACE_ON_ERROR));
114
115   $self->message(BACKTRACE_ON_ERROR, "Starting full caller dump:");
116   my $level = 0;
117   while (my ($dummy, $filename, $line, $subroutine) = caller $level) {
118     $self->message(BACKTRACE_ON_ERROR, "  ${subroutine} from ${filename}:${line}");
119     $level++;
120   }
121
122   return 1;
123 }
124
125 sub message {
126   my ($self, $level, $message) = @_;
127
128   $self->_write(level2string($level), $message) if (($self->{"level"} | $global_level) & $level || !$level);
129 }
130
131 sub dump {
132   my ($self, $level, $name, $variable) = @_;
133
134   if ($data_dumper_available) {
135     my $password;
136     if ($variable && ('Form' eq ref $variable) && defined $variable->{password}) {
137       $password             = $variable->{password};
138       $variable->{password} = 'X' x 8;
139     }
140
141     my $dumper = Data::Dumper->new([$variable]);
142     $dumper->Sortkeys(1);
143     $self->message($level, "dumping ${name}:\n" . $dumper->Dump());
144
145     $variable->{password} = $password if (defined $password);
146
147     # Data::Dumper does not reset the iterator belonging to this hash
148     # if 'Sortkeys' is true. Therefore clear the iterator manually.
149     # See "perldoc -f each".
150     if ($variable && (('HASH' eq ref $variable) || ('Form' eq ref $variable))) {
151       keys %{ $variable };
152     }
153
154   } else {
155     $self->message($level,
156                    "dumping ${name}: Data::Dumper not available; "
157                      . "variable cannot be dumped");
158   }
159 }
160
161 sub dump_yaml {
162   my ($self, $level, $name, $variable) = @_;
163
164   $self->message($level, "dumping ${name}:\n" . YAML::Dump($variable));
165 }
166
167 sub dump_sql_result {
168   my ($self, $level, $prefix, $results) = @_;
169
170   if (!$results || !scalar @{ $results }) {
171     $self->message($level, "Empty result set");
172     return;
173   }
174
175   my %column_lengths = map { $_, length $_ } keys %{ $results->[0] };
176
177   foreach my $row (@{ $results }) {
178     map { $column_lengths{$_} = length $row->{$_} if (length $row->{$_} > $column_lengths{$_}) } keys %{ $row };
179   }
180
181   my @sorted_names = sort keys %column_lengths;
182   my $format       = join '|', map { '%' . $column_lengths{$_} . 's' } @sorted_names;
183
184   $prefix .= ' ' if $prefix;
185
186   $self->message($level, $prefix . sprintf($format, @sorted_names));
187   $self->message($level, $prefix . join('+', map { '-' x $column_lengths{$_} } @sorted_names));
188
189   foreach my $row (@{ $results }) {
190     $self->message($level, $prefix . sprintf($format, map { $row->{$_} } @sorted_names));
191   }
192   $self->message($level, $prefix . sprintf('(%d row%s)', scalar @{ $results }, scalar @{ $results } > 1 ? 's' : ''));
193 }
194
195 sub enable_sub_tracing {
196   my ($self) = @_;
197   $global_level |= TRACE;
198 }
199
200 sub disable_sub_tracing {
201   my ($self) = @_;
202   $global_level &= ~ TRACE;
203 }
204
205 sub is_tracing_enabled {
206   my ($self) = @_;
207   return $global_level & TRACE;
208 }
209
210 sub _write {
211   my ($self, $prefix, $message) = @_;
212   my $date = strftime("%Y-%m-%d %H:%M:%S $$ ${prefix}: ", localtime(time()));
213   local *FILE;
214
215   chomp($message);
216
217   if ((FILE_TARGET == $self->{"target"})
218       && open(FILE, ">>" . $self->{"file"})) {
219     print(FILE "${date}${message}\n");
220     close(FILE);
221
222   } elsif (STDERR_TARGET == $self->{"target"}) {
223     print(STDERR "${date}${message}\n");
224   }
225 }
226
227 sub level2string {
228   # use $_[0] as a bit mask and return levelstrings separated by /
229   join '/', qw(info debug1 debug2 query trace error_call_trace)[ grep { (reverse split //, sprintf "%05b", $_[0])[$_] } 0..5 ]
230 }
231
232 sub begin_request {
233   my $self = shift;
234   return 1 unless ($global_level & REQUEST_TIMER);
235   $self->{request_start} = [gettimeofday];
236 }
237
238 sub end_request {
239   my $self = shift;
240   return 1 unless ($global_level & REQUEST_TIMER);
241   $self->_write("time", tv_interval($self->{request_start}));
242
243   $self->{calldepth} = 0;
244 }
245
246 1;