Revision 7aa53210
Von Moritz Bunkus vor mehr als 7 Jahren hinzugefügt
| SL/LXDebug.pm | ||
|---|---|---|
| 20 | 20 |
|
| 21 | 21 |
use Data::Dumper; |
| 22 | 22 |
use POSIX qw(strftime getpid); |
| 23 |
use Scalar::Util qw(blessed reftype);
|
|
| 23 |
use Scalar::Util qw(blessed refaddr reftype weaken);
|
|
| 24 | 24 |
use Time::HiRes qw(gettimeofday tv_interval); |
| 25 | 25 |
use YAML; |
| 26 | 26 |
use SL::Request (); |
| ... | ... | |
| 157 | 157 |
$self->message(WARN, $message); |
| 158 | 158 |
} |
| 159 | 159 |
|
| 160 |
sub _clone_for_dump {
|
|
| 161 |
my ($src) = @_; |
|
| 162 |
|
|
| 163 |
return undef unless defined($src); |
|
| 164 |
return $src->as_debug_info if blessed($src) && $src->can('as_debug_info');
|
|
| 165 |
return [ map { _clone_for_dump($_) } @{ $src } ] if reftype($src) eq 'ARRAY';
|
|
| 166 |
return { map { ($_ => _clone_for_dump($src->{$_})) } keys %{ $src } } if reftype($src) eq 'HASH';
|
|
| 167 |
return "$src"; |
|
| 168 |
} |
|
| 169 |
|
|
| 170 | 160 |
sub dump {
|
| 171 | 161 |
my ($self, $level, $name, $variable, %options) = @_; |
| 172 | 162 |
|
| 173 |
$variable = _clone_for_dump($variable); |
|
| 163 |
my %dumped; |
|
| 164 |
|
|
| 165 |
my $clone_for_dump; |
|
| 166 |
$clone_for_dump = sub {
|
|
| 167 |
my ($src) = @_; |
|
| 168 |
|
|
| 169 |
return undef if !defined($src); |
|
| 170 |
|
|
| 171 |
my $addr = refaddr($src); |
|
| 172 |
|
|
| 173 |
return $dumped{$addr} if $dumped{$addr // ''};
|
|
| 174 |
|
|
| 175 |
|
|
| 176 |
if (blessed($src) && $src->can('as_debug_info')) {
|
|
| 177 |
$dumped{$addr} = $src->as_debug_info;
|
|
| 178 |
|
|
| 179 |
} elsif (reftype($src) eq 'ARRAY') {
|
|
| 180 |
$dumped{$addr} = [];
|
|
| 181 |
|
|
| 182 |
foreach my $entry (@{ $src }) {
|
|
| 183 |
my $exists = !!$dumped{refaddr($entry) // ''};
|
|
| 184 |
push @{ $dumped{$addr} }, $clone_for_dump->($entry);
|
|
| 185 |
|
|
| 186 |
weaken($dumped{$addr}->[-1]) if $exists;
|
|
| 187 |
|
|
| 188 |
} |
|
| 189 |
|
|
| 190 |
} elsif (reftype($src) eq 'HASH') {
|
|
| 191 |
$dumped{$addr} = {};
|
|
| 192 |
|
|
| 193 |
foreach my $key (keys %{ $src }) {
|
|
| 194 |
my $exists = !!$dumped{refaddr($src->{$key}) // ''};
|
|
| 195 |
$dumped{$addr}->{$key} = $clone_for_dump->($src->{$key});
|
|
| 196 |
|
|
| 197 |
weaken($dumped{$addr}->{$key}) if $exists;
|
|
| 198 |
} |
|
| 199 |
} |
|
| 200 |
|
|
| 201 |
return $dumped{$addr} // "$src";
|
|
| 202 |
}; |
|
| 203 |
|
|
| 204 |
$variable = $clone_for_dump->($variable); |
|
| 174 | 205 |
my $dumper = Data::Dumper->new([$variable]); |
| 175 | 206 |
$dumper->Sortkeys(1); |
| 176 | 207 |
$dumper->Indent(2); |
Auch abrufbar als: Unified diff
LXDebug::dump: Unterstützung für zirkuläre Strukturen
Durch die Umstellung auf vorheriges Reduzieren auf essenzielle
Informationen muss dump() sicherstellen, dass es bei zirkulären
Strukturen nicht in eine Endlosschleife gerät.
Weiterhin müssen alle Rückwärtsreferenzen aufgeweicht
werden (Scalar::Util::weaken), damit sie von der garbage collection
normal aufgeräumt werden.