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