view release on metacpan or  search on metacpan

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

    | # Mouse
    (?: (?: rw-accessor | ro-accessor ) \s for )
    | # Template Toolkit
    (?: Parser\.yp )
    | # perl generated
    (?: \/loader\/0x )
/x;

sub new {
  my $class = shift;
  my $self  = {
    criteria         => \@Devel::Cover::DB::Criteria,
    criteria_short   => \@Devel::Cover::DB::Criteria_short,
    runs             => {},
    collected        => {},
    uncoverable_file => [],
    @_,
  };

  $self->{all_criteria}       = [ @{ $self->{criteria} },       "total" ];
  $self->{all_criteria_short} = [ @{ $self->{criteria_short} }, "total" ];
  $self->{base} ||= $self->{db};
  bless $self, $class;

  if (defined $self->{db}) {
    $self->validate_db;
    my $file = "$self->{db}/$DB";
    $self->read($file) if -e $file;
  }

  $self
}

sub criteria           { @{ $_[0]->{criteria} } }
sub criteria_short     { @{ $_[0]->{criteria_short} } }
sub all_criteria       { @{ $_[0]->{all_criteria} } }
sub all_criteria_short { @{ $_[0]->{all_criteria_short} } }

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

  my $io = Devel::Cover::DB::IO->new;
  my $db = eval { $io->read($file) };
  if ($@ or !$db) {
    warn $@;
  } else {
    $self->{runs} = $db->{runs};
  }
  $self
}

sub write {
  my $self = shift;
  $self->{db} = shift if @_;

  croak "No db specified" unless length $self->{db};
  unless (mkdir $self->{db}) {
    croak "Can't mkdir $self->{db}: $!\n" unless -d $self->{db};
  }
  chmod 0777, $self->{db} if $self->{loose_perms};
  $self->validate_db;

  my $db = { runs => $self->{runs} };
  my $io = Devel::Cover::DB::IO->new;
  $io->write($db, "$self->{db}/$DB");
  $self->{structure}->write($self->{base}) if $self->{structure};
  $self
}

sub delete {
  my $self = shift;

  my $db = "";
  $db         = $self->{db} if ref $self;
  $db         = shift       if @_;
  $self->{db} = $db         if ref $self;
  croak "No db specified" unless length $db;

  return $self unless -d $db;

  # TODO - just delete the directory?
  opendir DIR, $db or die "Can't opendir $db: $!";
  my @files = map "$db/$_", map /(.*)/ && $1, grep !/^\.\.?/, readdir DIR;
  closedir DIR or die "Can't closedir $db: $!";
  rmtree(\@files) if @files;

  $self
}

sub clean {
  my $self = shift;

  # remove all lock files
  my $rm_lock = sub {
    unlink if /\.lock$/
  };
  find($rm_lock, $self->{db});
}

sub merge_runs {
  my $self = shift;
  my $db   = $self->{db};
  # print STDERR "merge_runs from $db/runs/*\n";
  # system "ls -al $db/runs";
  return $self unless length $db;
  opendir DIR, "$db/runs" or return $self;
  my @runs = map "$db/runs/$_", grep !/^\.\.?/, readdir DIR;
  closedir DIR or die "Can't closedir $db/runs: $!";

  $self->{changed_files} = {};

  # The ordering is important here.  The runs need to be merged in the order
  # they were created.  We're only at a granularity of one second, but that
  # shouldn't be a problem unless a file is altered and the coverage run
  # created in less than a second.  I think we're OK for now.

  for my $run (sort @runs) {
    # print STDERR "Devel::Cover: merging run $run <$self->{base}>\n";
    my $r = Devel::Cover::DB->new(base => $self->{base}, db => $run);
    $self->merge($r);