Permalink
Browse files

Fix up problems storing digests with Storable.

The problem was that Storable could eval code which loaded a module, causing
recursion within Devel::Cover and making the import fail.  Make sure we don't
get recursion in this part of Devel::Cover.

Also, move both IO backends into their own modules.  This wasn't a part of the
solution, but it's something I should have done at first, and I did it to
simplfy the logic whilst tracking down this problem.
  • Loading branch information...
1 parent 95074d6 commit 8c2425dd927fcdabc622340f33cd67cd65facb63 @pjcj committed Apr 29, 2011
Showing with 237 additions and 61 deletions.
  1. +2 −0 MANIFEST
  2. +8 −0 lib/Devel/Cover.pm
  3. +12 −61 lib/Devel/Cover/DB/IO.pm
  4. +113 −0 lib/Devel/Cover/DB/IO/JSON.pm
  5. +102 −0 lib/Devel/Cover/DB/IO/Storable.pm
View
@@ -23,6 +23,8 @@ lib/Devel/Cover/DB.pm
lib/Devel/Cover/DB/Digests.pm
lib/Devel/Cover/DB/File.pm
lib/Devel/Cover/DB/IO.pm
+lib/Devel/Cover/DB/IO/JSON.pm
+lib/Devel/Cover/DB/IO/Storable.pm
lib/Devel/Cover/DB/Structure.pm
lib/Devel/Cover/Op.pm
lib/Devel/Cover/Pod.pm
View
@@ -419,11 +419,18 @@ sub get_coverage
my %File_cache;
+# Recursion in normalised_file() is bad. It can happen if a call from the sub
+# evals something which wants to load a new module. This has happened with
+# the Storable backend. I don't think it happens with the JSON backend.
+my $Normalising;
+
sub normalised_file
{
my ($file) = @_;
return $File_cache{$file} if exists $File_cache{$file};
+ return $file if $Normalising;
+ $Normalising = 1;
my $f = $file;
$file =~ s/ \(autosplit into .*\)$//;
@@ -469,6 +476,7 @@ sub normalised_file
# print STDERR "File: $f => $file\n";
+ $Normalising = 0;
$File_cache{$f} = $file
}
@@ -10,80 +10,31 @@ package Devel::Cover::DB::IO;
use strict;
use warnings;
-use Fcntl ":flock";
-
our $VERSION = "0.76";
my $Format;
BEGIN
{
- $Format = $ENV{DEVEL_COVER_DB_FORMAT} ||
- (eval { require JSON::PP; 1 } ? "JSON" : "Storable");
+ $Format = "Storable" if eval "use Storable; 1";
+ # warn "Storable available\n" if $INC{"Storable.pm"};
+ $Format = "JSON" if eval "use JSON::PP; 1";
+ # warn "JSON::PP available\n" if $INC{"JSON/PP.pm"};
+ die "Can't load either JSON::PP or Storable" unless $Format;
}
sub new
{
my $class = shift;
- my $self =
- {
- format => $Format,
- options => $ENV{DEVEL_COVER_IO_OPTIONS} || "",
- @_
- };
-
- if ($self->{format} eq "Storable")
- {
- require Storable;
- }
- elsif ($self->{format} eq "JSON")
- {
- require JSON::PP;
- }
- else
- {
- die "Devel::Cover: Unrecognised DB format: $self->{format}";
- }
-
- bless $self, $class
-}
-sub read
-{
- my $self = shift;
- my ($file) = @_;
-
- if ($self->{format} eq "Storable")
- {
- return Storable::lock_retrieve($file);
- }
-
- open my $fh, "<", $file or die "Can't open $file: $!";
- flock($fh, LOCK_SH) or die "Cannot lock file: $!\n";
- local $/;
- my $data = JSON::PP::decode_json(<$fh>);
- close $fh or die "Can't close $file: $!";
- $data
-}
+ my $format = $ENV{DEVEL_COVER_DB_FORMAT} || $Format;
+ die "Devel::Cover: Unrecognised DB format: $format"
+ unless $format =~ /^(?:Storable|JSON)$/;
-sub write
-{
- my $self = shift;
- my ($data, $file) = @_;
-
- if ($self->{format} eq "Storable")
- {
- Storable::lock_nstore($data, $file);
- return $self;
- }
-
- my $json = JSON::PP->new->utf8;
- $json->ascii->pretty->canonical if $self->{options} =~ /\bpretty\b/i;
- open my $fh, ">", $file or die "Can't open $file: $!";
- flock($fh, LOCK_EX) or die "Cannot lock file: $!\n";
- print $fh $json->encode($data);
- close $fh or die "Can't close $file: $!";
- $self
+ $class .= "::$format";
+ eval "use $class; 1" or die "Devel::Cover: $@";
+
+ $class->new(options => $ENV{DEVEL_COVER_IO_OPTIONS} || "", @_)
}
1
@@ -0,0 +1,113 @@
+# Copyright 2011, Paul Johnson (pjcj@cpan.org)
+
+# This software is free. It is licensed under the same terms as Perl itself.
+
+# The latest version of this software should be available from my homepage:
+# http://www.pjcj.net
+
+package Devel::Cover::DB::IO::JSON;
+
+use strict;
+use warnings;
+
+use Fcntl ":flock";
+use JSON::PP;
+
+our $VERSION = "0.76";
+
+sub new
+{
+ my $class = shift;
+ my $self = { @_ };
+ bless $self, $class
+}
+
+sub read
+{
+ my $self = shift;
+ my ($file) = @_;
+
+ open my $fh, "<", $file or die "Can't open $file: $!";
+ flock($fh, LOCK_SH) or die "Cannot lock file: $!\n";
+ local $/;
+ my $data = JSON::PP::decode_json(<$fh>);
+ close $fh or die "Can't close $file: $!";
+ $data
+}
+
+sub write
+{
+ my $self = shift;
+ my ($data, $file) = @_;
+
+ my $json = JSON::PP->new->utf8;
+ $json->ascii->pretty->canonical if $self->{options} =~ /\bpretty\b/i;
+ open my $fh, ">", $file or die "Can't open $file: $!";
+ flock($fh, LOCK_EX) or die "Cannot lock file: $!\n";
+ print $fh $json->encode($data);
+ close $fh or die "Can't close $file: $!";
+ $self
+}
+
+1
+
+__END__
+
+=head1 NAME
+
+Devel::Cover::DB::IO::JSON - JSON based IO routines for Devel::Cover::DB
+
+=head1 SYNOPSIS
+
+ use Devel::Cover::DB::IO::JSON;
+
+ my $io = Devel::Cover::DB::IO::JSON->new;
+ my $data = $io->read($file);
+ $io->write($data, $file);
+
+=head1 DESCRIPTION
+
+This module provides JSON based IO routines for Devel::Cover::DB.
+
+=head1 SEE ALSO
+
+ Devel::Cover
+
+=head1 METHODS
+
+=head2 new
+
+ my $io = Devel::Cover::DB::IO::JSON->new;
+
+Contructs the IO object.
+
+=head2 read
+
+ my $data = $io->read($file);
+
+Returns a perl data structure representingthe data read from $file.
+
+=head2 write
+
+ $io->write($data, $file);
+
+Writes $data to $file in the format specified when creating $io.
+
+=head1 BUGS
+
+Huh?
+
+=head1 VERSION
+
+Version 0.76 - 18th April 2011
+
+=head1 LICENCE
+
+Copyright 2001-2011, Paul Johnson (pjcj@cpan.org)
+
+This software is free. It is licensed under the same terms as Perl itself.
+
+The latest version of this software should be available from my homepage:
+http://www.pjcj.net
+
+=cut
@@ -0,0 +1,102 @@
+# Copyright 2011, Paul Johnson (pjcj@cpan.org)
+
+# This software is free. It is licensed under the same terms as Perl itself.
+
+# The latest version of this software should be available from my homepage:
+# http://www.pjcj.net
+
+package Devel::Cover::DB::IO::Storable;
+
+use strict;
+use warnings;
+
+use Storable;
+
+our $VERSION = "0.76";
+
+sub new
+{
+ my $class = shift;
+ my $self = { @_ };
+ bless $self, $class
+}
+
+sub read
+{
+ my $self = shift;
+ my ($file) = @_;
+
+ Storable::lock_retrieve($file)
+}
+
+sub write
+{
+ my $self = shift;
+ my ($data, $file) = @_;
+
+ Storable::lock_nstore($data, $file);
+ $self
+}
+
+1
+
+__END__
+
+=head1 NAME
+
+Devel::Cover::DB::IO::Storable - Storable based IO routines for Devel::Cover::DB
+
+=head1 SYNOPSIS
+
+ use Devel::Cover::DB::IO::Storable;
+
+ my $io = Devel::Cover::DB::IO::Storable->new;
+ my $data = $io->read($file);
+ $io->write($data, $file);
+
+=head1 DESCRIPTION
+
+This module provides Storable based IO routines for Devel::Cover::DB.
+
+=head1 SEE ALSO
+
+ Devel::Cover
+
+=head1 METHODS
+
+=head2 new
+
+ my $io = Devel::Cover::DB::IO::Storable->new;
+
+Contructs the IO object.
+
+=head2 read
+
+ my $data = $io->read($file);
+
+Returns a perl data structure representingthe data read from $file.
+
+=head2 write
+
+ $io->write($data, $file);
+
+Writes $data to $file in the format specified when creating $io.
+
+=head1 BUGS
+
+Huh?
+
+=head1 VERSION
+
+Version 0.76 - 18th April 2011
+
+=head1 LICENCE
+
+Copyright 2001-2011, Paul Johnson (pjcj@cpan.org)
+
+This software is free. It is licensed under the same terms as Perl itself.
+
+The latest version of this software should be available from my homepage:
+http://www.pjcj.net
+
+=cut

0 comments on commit 8c2425d

Please sign in to comment.