Einen Filter für den Kunden-/Lieferantentypen bei Berichten über Kunden-/Lieferantens...
[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 ALL    => 31;
10
11 use constant FILE_TARGET   => 0;
12 use constant STDERR_TARGET => 1;
13
14 use POSIX qw(strftime);
15
16 my $data_dumper_available;
17
18 BEGIN {
19   eval("use Data::Dumper");
20   $data_dumper_available = $@ ? 0 : 1;
21
22   $global_level      = NONE;
23 }
24
25 sub new {
26   my $type = shift;
27   my $self = {};
28
29   $self->{"calldepth"}  = 0;
30   $self->{"file"}       = "/tmp/lx-office-debug.log";
31   $self->{"target"}     = FILE_TARGET;
32   $self->{"level"}      = 0;
33   $self->{"watchedvars"} = {};
34
35   while ($_[0]) {
36     $self->{ $_[0] } = $_[1];
37     shift;
38     shift;
39   }
40
41   bless($self, $type);
42 }
43
44 sub set_target {
45   my ($self, $target, $file) = @_;
46
47   if ((FILE_TARGET == $target) && $file) {
48     $self->{"file"}   = $file;
49     $self->{"target"} = FILE_TARGET;
50
51   } elsif (STDERR_TARGET == $target) {
52     $self->{"target"} = STDERR_TARGET;
53   }
54 }
55
56 sub enter_sub {
57   my ($self, $level) = @_;
58   $level *= 1;
59
60   check_watched_form_variables();
61
62   return 1 unless ($global_level & TRACE);          # ignore if traces aren't active
63   return 1 if $level && !($global_level & $level);  # ignore if level of trace isn't active
64
65   my ($package, $filename, $line, $subroutine) = caller(1);
66   my ($dummy1, $self_filename, $self_line) = caller(0);
67
68   my $indent = " " x $self->{"calldepth"}++;
69
70   if (!defined($package)) {
71     $self->_write('sub' . $level, $indent . "\\ top-level?\n");
72   } else {
73     $self->_write('sub' . $level, $indent
74                     . "\\ ${subroutine} in "
75                     . "${self_filename}:${self_line} called from "
76                     . "${filename}:${line}\n");
77   }
78   return 1;
79 }
80
81 sub leave_sub {
82   my ($self, $level) = @_;
83   $level *= 1;
84
85   $self->check_watched_form_variables();
86
87   return 1 unless ($global_level & TRACE);           # ignore if traces aren't active
88   return 1 if $level && !($global_level & $level);   # ignore if level of trace isn't active
89
90   my ($package, $filename, $line, $subroutine) = caller(1);
91   my ($dummy1, $self_filename, $self_line) = caller(0);
92
93   my $indent = " " x --$self->{"calldepth"};
94
95   if (!defined($package)) {
96     $self->_write('sub' . $level, $indent . "/ top-level?\n");
97   } else {
98     $self->_write('sub' . $level, $indent . "/ ${subroutine} in " . "${self_filename}:${self_line}\n");
99   }
100   return 1;
101 }
102
103 sub message {
104   my ($self, $level, $message) = @_;
105   $self->_write(level2string($level), $message) if (($self->{"level"} | $global_level) & $level || !$level);
106 }
107
108 sub dump {
109   my ($self, $level, $name, $variable) = @_;
110
111   if ($data_dumper_available) {
112     $self->message($level, "dumping ${name}:\n" . Dumper($variable));
113   } else {
114     $self->message($level,
115                    "dumping ${name}: Data::Dumper not available; "
116                      . "variable cannot be dumped");
117   }
118 }
119
120 sub enable_sub_tracing {
121   my ($self) = @_;
122   $self->{level} | TRACE;
123 }
124
125 sub disable_sub_tracing {
126   my ($self) = @_;
127   $self->{level} & ~ TRACE;
128 }
129
130 sub _write {
131   my ($self, $prefix, $message) = @_;
132   my $date = strftime("%Y-%m-%d %H:%M:%S $$ ${prefix}: ", localtime(time()));
133   local *FILE;
134
135   chomp($message);
136
137   if ((FILE_TARGET == $self->{"target"})
138       && open(FILE, ">>" . $self->{"file"})) {
139     print(FILE "${date}${message}\n");
140     close(FILE);
141
142   } elsif (STDERR_TARGET == $self->{"target"}) {
143     print(STDERR "${date}${message}\n");
144   }
145 }
146
147 sub level2string {
148   # use $_[0] as a bit mask and return levelstrings separated by /
149   join '/', qw(info debug1 debug2 query trace)[ grep { (reverse split //, sprintf "%05b", $_[0])[$_] } 0..4 ]
150 }
151
152 sub watch_form_variable {
153   my ($self, $var) = @_;
154
155   $self->{"watchedvars"}->{$var} = $main::form->{$var};
156   $self->_write("WATCH", "Adding \$form->{$var} with current value \"$main::form->{$var}\"");
157 }
158
159 sub check_watched_form_variables {
160   my ($self) = @_;
161
162   return unless $main::form;
163
164   foreach my $var (sort(keys(%{ $self->{"watchedvars"} }))) {
165     if ($main::form->{$var} ne $self->{"watchedvars"}->{$var}) {
166       $self->_write("WATCH", "Variable \$form->{$var} changed from \"" .
167                     $self->{"watchedvars"}->{$var} . "\" to \"" .
168                     $main::form->{$var} . "\"");
169       $self->{"watchedvars"}->{$var} = $main::form->{$var};
170     }
171   }
172 }
173
174 1;