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