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.

diff --git a/SL/LXDebug.pm b/SL/LXDebug.pm
index cedd5ba..e22dc0f 100644 (file)
--- a/SL/LXDebug.pm
+++ b/SL/LXDebug.pm
@@ -20,7 +20,7 @@ use constant STDERR_TARGET => 1;
 
 use Data::Dumper;
 use POSIX qw(strftime getpid);
-use Scalar::Util qw(blessed reftype);
+use Scalar::Util qw(blessed refaddr reftype weaken);
 use Time::HiRes qw(gettimeofday tv_interval);
 use YAML;
 use SL::Request ();
@@ -157,20 +157,51 @@ sub warn {
   $self->message(WARN, $message);
 }
 
-sub _clone_for_dump {
-  my ($src) = @_;
-
-  return undef unless defined($src);
-  return $src->as_debug_info                                            if blessed($src) && $src->can('as_debug_info');
-  return [ map { _clone_for_dump($_) } @{ $src } ]                      if reftype($src) eq 'ARRAY';
-  return { map { ($_ => _clone_for_dump($src->{$_})) } keys %{ $src } } if reftype($src) eq 'HASH';
-  return "$src";
-}
-
 sub dump {
   my ($self, $level, $name, $variable, %options) = @_;
 
-  $variable  = _clone_for_dump($variable);
+  my %dumped;
+
+  my $clone_for_dump;
+  $clone_for_dump = sub {
+    my ($src) = @_;
+
+    return undef if !defined($src);
+
+    my $addr = refaddr($src);
+
+    return $dumped{$addr} if $dumped{$addr // ''};
+
+
+    if (blessed($src) && $src->can('as_debug_info')) {
+      $dumped{$addr} = $src->as_debug_info;
+
+    } elsif (reftype($src) eq 'ARRAY') {
+      $dumped{$addr} = [];
+
+      foreach my $entry (@{ $src }) {
+        my $exists = !!$dumped{refaddr($entry) // ''};
+        push @{ $dumped{$addr} }, $clone_for_dump->($entry);
+
+        weaken($dumped{$addr}->[-1]) if $exists;
+
+      }
+
+    } elsif (reftype($src) eq 'HASH') {
+      $dumped{$addr} = {};
+
+      foreach my $key (keys %{ $src }) {
+        my $exists             = !!$dumped{refaddr($src->{$key}) // ''};
+        $dumped{$addr}->{$key} = $clone_for_dump->($src->{$key});
+
+        weaken($dumped{$addr}->{$key}) if $exists;
+      }
+    }
+
+    return $dumped{$addr} // "$src";
+  };
+
+  $variable  = $clone_for_dump->($variable);
   my $dumper = Data::Dumper->new([$variable]);
   $dumper->Sortkeys(1);
   $dumper->Indent(2);