diff options
author | Ricardo Signes <rjbs@cpan.org> | 2013-01-24 22:44:22 -0500 |
---|---|---|
committer | Ricardo Signes <rjbs@cpan.org> | 2013-01-25 23:32:53 -0500 |
commit | 0d0268b0705058782fcff32c6184f87f39b5ae3b (patch) | |
tree | 2034fb8c2b4a9a791841e5498f81ae46ba63c03a /lib/dumpvar.pl | |
parent | 58cbf594161fa4470048f84f26076c4a69ba49d2 (diff) | |
download | perl-0d0268b0705058782fcff32c6184f87f39b5ae3b.tar.gz |
prevent failures deep in value dumping from aborting
Sometimes, dumpvar's dumpvalue routine gets a value it can't dump. The
simplest example to contrive is the one in this test: a tied hash that
can't tell you its keys. Until now, this would cause the whole dump to
abort as soon as it failed to dump one part.
With this commit, each stringify or unwind is inside an eval. Failed
stringifications or unwindings are replaced with a placeholder showing
the error.
unwind uses return to stop early, and rather than go through contortions
to wrap the eval in something that can then return 1 to test that eval
worked, I've just asserted that this code requires 5.14.0, which made $@
a much more reliable indicator of failure after eval.
Diffstat (limited to 'lib/dumpvar.pl')
-rw-r--r-- | lib/dumpvar.pl | 18 |
1 files changed, 17 insertions, 1 deletions
diff --git a/lib/dumpvar.pl b/lib/dumpvar.pl index 7aadba1854..91153ea5ad 100644 --- a/lib/dumpvar.pl +++ b/lib/dumpvar.pl @@ -1,4 +1,4 @@ -require 5.002; # For (defined ref) +require 5.014; # For more reliable $@ after eval package dumpvar; # Needed for PrettyPrinter only: @@ -58,6 +58,15 @@ sub uniescape { } sub stringify { + my $string; + if (eval { $string = _stringify(@_); 1 }) { + return $string; + } + + return "<< value could not be dumped: $@ >>"; +} + +sub _stringify { (my $__, local $noticks) = @_; for ($__) { local($v) ; @@ -160,6 +169,7 @@ sub unwrap { $sp = " " x $s ; $s += 3 ; + eval { # Check for reused addresses if (ref $v) { my $val = $v; @@ -312,6 +322,12 @@ sub unwrap { print( (' ' x $s) . "FileHandle({$v}) => fileno($fileno)\n" ); } } + }; + if ($@) { + print( (' ' x $s) . "<< value could not be dumped: $@ >>\n"); + } + + return; } sub matchlex { |