LXDebug::dump: Interna von Rose-DB- und DateTime-Objekten nicht mehr ausgeben

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.

diff --git a/SL/DB/Object.pm b/SL/DB/Object.pm
index 06596dd4f9aad706ffb444163c63ad701330db62..c258761d17b76eb7ca5c632521f7d99ce28264dd 100755 (executable)
--- 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__
 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>
 
 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
 =back
 
 =head1 AUTHOR

diff --git a/SL/LXDebug.pm b/SL/LXDebug.pm
index e0b7cca3c926cbbf138d9e9cc14324c903d04f61..cedd5baec480f3d063e0215e9ff4d1684d2e108c 100644 (file)
--- 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 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 ();
 use Time::HiRes qw(gettimeofday tv_interval);
 use YAML;
 use SL::Request ();


@@ -156,15 +157,20 @@ sub warn {
   $self->message(WARN, $message);
 }
 
   $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) = @_;
 
 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);
   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);
 
   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;
 }
 
   return $output;
 }
 


@@ -218,17 +215,6 @@ sub dump_sql_result {
   $self->message($level, $prefix . sprintf('(%d row%s)', scalar @{ $results }, scalar @{ $results } > 1 ? 's' : ''));
 }
 
   $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) = @_;
 
 sub show_diff {
   my ($self, $level, $item1, $item2, %params) = @_;