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