view release on metacpan or  search on metacpan

lib/Devel/Cover/DB/Structure.pm  view on Meta::CPAN

  }
  $digest
}

sub digest {
  my $self = shift;
  my ($file) = @_;

  # print STDERR "Opening $file for MD5 digest\n";

  my $digest;
  if (open my $fh, "<", $file) {
    binmode $fh;
    $digest = Digest::MD5->new->addfile($fh)->hexdigest;
  } else {
    print STDERR "Devel::Cover: Warning: can't open $file "
      . "for MD5 digest: $!\n"
      unless lc $file eq "-e"
      or $Devel::Cover::Silent
      or $file =~ $Devel::Cover::DB::Ignore_filenames;
    # require "Cwd"; print STDERR Carp::longmess("in " . Cwd::cwd());
  }
  $digest
}

sub get_count {
  my $self = shift;
  my ($file, $criterion) = @_;
  $self->{count}{$criterion}{$file}
}

sub add_count {
  my $self = shift;
  # warn Carp::longmess("undefined file") unless defined $self->{file};
  return unless defined $self->{file};  # can happen during self_cover
  my ($criterion) = @_;
  $self->{additional_count}{$criterion}{ $self->{file} }++
    if $self->{additional};
  (
    $self->{count}{$criterion}{ $self->{file} }++,
    !$self->reuse($self->{file}) || $self->{additional},
  )
}

sub delete_file {
  my $self = shift;
  my ($file) = @_;
  delete $self->{f}{$file};
}

# TODO - concurrent runs updating structure?

sub write {
  my $self = shift;
  my ($dir) = @_;
  # print STDERR Dumper $self;
  $dir .= "/structure";
  unless (mkdir $dir) {
    confess "Can't mkdir $dir: $!" unless -d $dir;
  }
  chmod 0777, $dir if $self->{loose_perms};
  for my $file (sort keys %{ $self->{f} }) {
    $self->{f}{$file}{file} = $file;
    my $digest = $self->{f}{$file}{digest};
    $digest = $1 if defined $digest && $digest =~ /(.*)/;  # ie tainting
    unless ($digest) {
      print STDERR "Can't find digest for $file"
        unless $Devel::Cover::Silent
        || $file =~ $Devel::Cover::DB::Ignore_filenames
        || ($Devel::Cover::Self_cover && $file =~ q|/Devel/Cover[./]|);
      next;
    }
    my $df_final = "$dir/$digest";
    my $df_temp  = "$dir/.$digest.$$";
    # TODO - determine if Structure has changed to save writing it
    # my $f = $df; my $n = 1; $df = $f . "." . $n++ while -e $df;
    my $io = Devel::Cover::DB::IO->new;
    $io->write($self->{f}{$file}, $df_temp);  # unless -e $df;
    unless (rename $df_temp, $df_final) {
      unless ($Devel::Cover::Silent) {
        if (-e $df_final) {
          print STDERR "Can't rename $df_temp to $df_final "
            . "(which exists): $!";
          $self->debuglog(
            "Can't rename $df_temp to $df_final " . "(which exists): $!")
            if DEBUG;
        } else {
          print STDERR "Can't rename $df_temp to $df_final: $!";
          $self->debuglog("Can't rename $df_temp to $df_final: $!") if DEBUG;
        }
      }
      unless (unlink $df_temp) {
        print STDERR "Can't remove $df_temp after failed rename: $!"
          unless $Devel::Cover::Silent;
        $self->debuglog("Can't remove $df_temp after failed rename: $!")
          if DEBUG;
      }
    }
  }
}

sub read {

  my $self     = shift;
  my ($digest) = @_;
  my $file     = "$self->{base}/structure/$digest";
  my $io       = Devel::Cover::DB::IO->new;
  my $s        = eval { $io->read($file) };

  if ($@ or !$s) {
    $self->debuglog("read retrieve $file failed: $@") if DEBUG;
    die $@;
  }
  if (DEBUG) {
    foreach my $key (qw(file digest)) {
      if (!defined $s->{$key}) {
        $self->debuglog("retrieve $file had no $key entry. Got:\n", $s);
      }
    }
  }
  my $d = $self->digest($s->{file});