view release on metacpan or  search on metacpan

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

        or die "Devel::Cover: Can't open $uncoverable_file: $!\n";
      my $dl = Digest::MD5->new->add($_)->hexdigest;
      print $u "$file $crit $dl $count $type $class $note\n";
    } else {
      warn "Devel::Cover: Can't find line $line in $file.  ",
        "Last line is $.\n";
    }
    close $f or die "Devel::Cover: Can't close $file: $!\n";
  }
}

sub delete_uncoverable {
  my $self = shift;
}

sub clean_uncoverable {
  my $self = shift;
}

sub uncoverable_comments {

  my $self = shift;
  my ($uncoverable, $file, $digest) = @_;

  my $cr    = join "|", @{ $self->{all_criteria} };
  my $uc    = qr/(.*)# uncoverable ($cr)(.*)/;  # regex for uncoverable comments
  my %types = (
    branch    => { true => 0, false => 1 },
    condition => { left => 0, right => 1, false => 2 },
  );

  # Look for uncoverable comments
  open my $fh, "<", $file or do {
    # The warning should have already been given ...
    # warn "Devel::Cover: Warning: can't open $file: $!\n";
    return;
  };
  my @waiting;
  while (<$fh>) {
    chomp;
    # print STDERR "read [$.][$_]\n";
    next unless /$uc/ || @waiting;
    if ($2) {
      my ($code, $criterion, $info) = ($1, $2, $3);
      my ($count, $class, $note, $type) = (1, "default", "");

      if ($criterion eq "branch" || $criterion eq "condition") {
        if ($info =~ /^\s*(\w+)(?:\s|$)/) {
          my $t = $1;
          $type = $types{$criterion}{$t};
          unless (defined $type) {
            warn "Unknown type $t found parsing "
              . "uncoverable $criterion at $file:$.\n";
            $type = 999;  # partly magic number
          }
        }
      }
      # e.g.: count:1 | count:2,5 | count:1,4..7
      my $c = qr/\d+(?:\.\.\d+)?/;
      $count = $1 if $info =~ /count:($c(?:,$c)*)/;
      my @counts = map { m/^(\d+)\.\.(\d+)$/ ? ($1 .. $2) : $_ } split m/,/,
        $count;
      $class = $1 if $info =~ /class:(\w+)/;
      $note  = $1 if $info =~ /note:(.+)/;

      for my $c (@counts) {
        # no warnings "uninitialized";
        # warn "pushing $criterion, $c - 1, $type, $class, $note";
        push @waiting, [ $criterion, $c - 1, $type, $class, $note ];
      }

      next unless $code =~ /\S/;
    }

    # found what we are waiting for
    while (my $w = shift @waiting) {
      my ($criterion, $count, $type, $class, $note) = @$w;
      push @{ $uncoverable->{$digest}{$criterion}{$.}[$count] },
        [ $type, $class, $note ];
    }
  }
  close $fh;

  warn scalar @waiting,
    " unmatched uncoverable comments not found at end of $file\n"
    if @waiting;

  # TODO - read in and merge $self->uncoverable;
  # print Dumper $uncoverable;
}

sub objectify_cover {
  my $self = shift;

  unless (UNIVERSAL::isa($self->{cover}, "Devel::Cover::DB::Cover")) {
    bless $self->{cover}, "Devel::Cover::DB::Cover";
    for my $file (values %{ $self->{cover} }) {
      bless $file, "Devel::Cover::DB::File";
      while (my ($crit, $criterion) = each %$file) {
        next if $crit eq "meta";  # ignore meta data
        my $class = "Devel::Cover::" . ucfirst lc $crit;
        bless $criterion, "Devel::Cover::DB::Criterion";
        for my $line (values %$criterion) {
          for my $o (@$line) {
            die "<$crit:$o>" unless ref $o;
            bless $o, $class;
            bless $o, $class . "_" . $o->type if $o->can("type");
            # print "blessed $crit, $o\n";
          }
        }
      }
    }
    for my $r (keys %{ $self->{runs} }) {
      if (defined $self->{runs}{$r}) {
        bless $self->{runs}{$r}, "Devel::Cover::DB::Run";
      } else {
        delete $self->{runs}{$r};  # DEVEL_COVER_SELF
      }
    }
  }