From: Moritz Bunkus <m.bunkus@linet-services.de>
Date: Wed, 1 Mar 2017 15:54:59 +0000 (+0100)
Subject: LXDebug::dump: Unterstützung für zirkuläre Strukturen
X-Git-Tag: release-3.5.4~1237
X-Git-Url: http://wagnertech.de/git?a=commitdiff_plain;h=7aa53210c8a1d396b5295551b9122b8690698894;p=kivitendo-erp.git

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 cedd5baec..e22dc0f5e 100644
--- 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);