Revision 847d924b
Von Sven Schöling vor mehr als 14 Jahren hinzugefügt
| SL/LXDebug.pm | ||
|---|---|---|
| 8 | 8 |
use constant TRACE => 1 << 4; |
| 9 | 9 |
use constant BACKTRACE_ON_ERROR => 1 << 5; |
| 10 | 10 |
use constant REQUEST_TIMER => 1 << 6; |
| 11 |
use constant ALL => (1 << 7) - 1; |
|
| 11 |
use constant WARN => 1 << 7; |
|
| 12 |
use constant ALL => (1 << 8) - 1; |
|
| 12 | 13 |
use constant DEVEL => INFO | QUERY | TRACE | BACKTRACE_ON_ERROR | REQUEST_TIMER; |
| 13 | 14 |
|
| 14 | 15 |
use constant FILE_TARGET => 0; |
| ... | ... | |
| 65 | 66 |
} |
| 66 | 67 |
|
| 67 | 68 |
sub enter_sub {
|
| 68 |
my ($self, $level) = @_;
|
|
| 69 |
$level *= 1;
|
|
| 69 |
my $self = shift;
|
|
| 70 |
my $level = shift || 0;
|
|
| 70 | 71 |
|
| 71 | 72 |
return 1 unless ($global_level & TRACE); # ignore if traces aren't active |
| 72 | 73 |
return 1 if $level && !($global_level & $level); # ignore if level of trace isn't active |
| ... | ... | |
| 89 | 90 |
} |
| 90 | 91 |
|
| 91 | 92 |
sub leave_sub {
|
| 92 |
my ($self, $level) = @_;
|
|
| 93 |
$level *= 1;
|
|
| 93 |
my $self = shift;
|
|
| 94 |
my $level = shift || 0;
|
|
| 94 | 95 |
|
| 95 | 96 |
return 1 unless ($global_level & TRACE); # ignore if traces aren't active |
| 96 | 97 |
return 1 if $level && !($global_level & $level); # ignore if level of trace isn't active |
| ... | ... | |
| 125 | 126 |
} |
| 126 | 127 |
|
| 127 | 128 |
sub message {
|
| 129 |
no warnings; |
|
| 128 | 130 |
my ($self, $level, $message) = @_; |
| 129 | 131 |
|
| 130 | 132 |
$self->_write(level2string($level), $message) if (($self->{"level"} | $global_level) & $level || !$level);
|
| 131 | 133 |
} |
| 134 |
sub warn {
|
|
| 135 |
no warnings; |
|
| 136 |
my ($self, $message) = @_; |
|
| 137 |
$self->message(WARN, $message); |
|
| 138 |
} |
|
| 132 | 139 |
|
| 133 | 140 |
sub dump {
|
| 134 | 141 |
my ($self, $level, $name, $variable) = @_; |
| ... | ... | |
| 210 | 217 |
} |
| 211 | 218 |
|
| 212 | 219 |
sub _write {
|
| 220 |
no warnings; |
|
| 213 | 221 |
my ($self, $prefix, $message) = @_; |
| 214 | 222 |
my $date = strftime("%Y-%m-%d %H:%M:%S $$ [" . getppid() . "] ${prefix}: ", localtime(time()));
|
| 215 | 223 |
local *FILE; |
| ... | ... | |
| 227 | 235 |
} |
| 228 | 236 |
|
| 229 | 237 |
sub level2string {
|
| 238 |
no warnings; |
|
| 230 | 239 |
# use $_[0] as a bit mask and return levelstrings separated by / |
| 231 |
join '/', qw(info debug1 debug2 query trace error_call_trace)[ grep { (reverse split //, sprintf "%05b", $_[0])[$_] } 0..5 ]
|
|
| 240 |
join '/', qw(info debug1 debug2 query trace error_call_trace request_timer WARNING)[ grep { (reverse split //, sprintf "%08b", $_[0])[$_] } 0..7 ]
|
|
| 232 | 241 |
} |
| 233 | 242 |
|
| 234 | 243 |
sub begin_request {
|
Auch abrufbar als: Unified diff
Neue Option in LXDebug: LXDebug->WARN.
Sämtliche Perl warnings die auftreten, werden jetzt über einen
Sighandler an LXDebug weitergeleitet, und werden, sofern gewünscht,
in das LxOffice Log geschrieben.
Das ganze soll später dazu dienen, inkrementell die Module von warnings zu
befreien, und später dann das Programm im globalen -w Modus laufen lassen zu
können.