From 7f5edaa695f8e23af197c4b82b66ca2e1bbfc35e Mon Sep 17 00:00:00 2001
From: Moritz Bunkus <m.bunkus@linet-services.de>
Date: Wed, 1 Mar 2017 15:12:02 +0100
Subject: [PATCH] LXDebug::dump: Interna von Rose-DB- und DateTime-Objekten
 nicht mehr ausgeben
MIME-Version: 1.0
Content-Type: text/plain; charset=utf8
Content-Transfer-Encoding: 8bit

dump arbeitet nun nicht mehr direkt auf dem zu dumpenden Objekt,
sondern auf Kopien, die je nach Typ auf ihre essenziellen
Informationen zusammengeschrumpft werden. Dafür kann ein Objekt eine
Methode »as_debug_info« bereitstellen, die eine solche Essenz
zurückgibt.

Für SL::DB::Object ist eine Implementation beigelegt, die nur die
Spalten mit ihren stringifizierten Werten zurückgibt, nicht aber mehr
die ganzen Interna wie z.B. Meta-Informationen enthält.

Arrays und Hashes (und Objekte, die auf diesen simplen Typen basieren
und keine eigene »as_debug_info« zurückgeben) werden rekursiv geklont.

Alles andere definierte wird stringifiziert.

Dafür wurde die Funktion LXDebug::dump_object entfernt, die etwas
Ähnliches gemacht hat, aber nur für eine einzelne Rose-DB-Instanz.
---
 SL/DB/Object.pm | 19 +++++++++++++++++++
 SL/LXDebug.pm   | 38 ++++++++++++--------------------------
 2 files changed, 31 insertions(+), 26 deletions(-)

diff --git a/SL/DB/Object.pm b/SL/DB/Object.pm
index 06596dd4f..c258761d1 100755
--- a/SL/DB/Object.pm
+++ b/SL/DB/Object.pm
@@ -252,6 +252,19 @@ sub presenter {
   }
 }
 
+sub as_debug_info {
+  my ($self) = @_;
+
+  return {
+    map {
+      my $column_name = $_->name;
+      my $value       = $self->$column_name;
+      $value          = !defined($value) ? undef : "${value}";
+      ($_ => $value)
+    } $self->meta->columns
+  };
+}
+
 1;
 
 __END__
@@ -383,6 +396,12 @@ with the same name as the class of the involking object.
 For the full documentation about its capabilites see
 L<SL::DB::Helper::Presenter>
 
+=item C<as_debug_info>
+
+Returns a hash containing solely the essentials for dumping it with
+L<LXDebug/dump>. The returned hash consists of the column names with
+associated column values in stringified form.
+
 =back
 
 =head1 AUTHOR
diff --git a/SL/LXDebug.pm b/SL/LXDebug.pm
index e0b7cca3c..cedd5baec 100644
--- a/SL/LXDebug.pm
+++ b/SL/LXDebug.pm
@@ -20,6 +20,7 @@ use constant STDERR_TARGET => 1;
 
 use Data::Dumper;
 use POSIX qw(strftime getpid);
+use Scalar::Util qw(blessed reftype);
 use Time::HiRes qw(gettimeofday tv_interval);
 use YAML;
 use SL::Request ();
@@ -156,15 +157,20 @@ 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) = @_;
 
-  my $password;
-  if ($variable && ('Form' eq ref $variable) && defined $variable->{password}) {
-    $password             = $variable->{password};
-    $variable->{password} = 'X' x 8;
-  }
-
+  $variable  = _clone_for_dump($variable);
   my $dumper = Data::Dumper->new([$variable]);
   $dumper->Sortkeys(1);
   $dumper->Indent(2);
@@ -172,15 +178,6 @@ sub dump {
   my $output = $dumper->Dump();
   $self->message($level, "dumping ${name}:\n" . $output);
 
-  $variable->{password} = $password if (defined $password);
-
-  # Data::Dumper does not reset the iterator belonging to this hash
-  # if 'Sortkeys' is true. Therefore clear the iterator manually.
-  # See "perldoc -f each".
-  if ($variable && (('HASH' eq ref $variable) || ('Form' eq ref $variable))) {
-    keys %{ $variable };
-  }
-
   return $output;
 }
 
@@ -218,17 +215,6 @@ sub dump_sql_result {
   $self->message($level, $prefix . sprintf('(%d row%s)', scalar @{ $results }, scalar @{ $results } > 1 ? 's' : ''));
 }
 
-sub dump_object {
-  my ($self, $level, $text, $object) = @_;
-
-  my $copy;
-  if ($object) {
-    $copy->{$_} = $object->$_ for $object->meta->columns;
-  }
-
-  $self->dump($level, $text, $copy);
-}
-
 sub show_diff {
   my ($self, $level, $item1, $item2, %params) = @_;
 
-- 
2.20.1