# Copyright 2001-2024, Paul Johnson (paul@pjcj.net)

# 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::Report::Text;

use strict;
use warnings;

our $VERSION = '1.44'; # VERSION

use Devel::Cover::DB;

sub print_runs {
  my ($db, $options) = @_;
  for my $r (sort { $a->{start} <=> $b->{start} } $db->runs) {
    print "Run:          ", $r->run,                  "\n";
    print "Perl version: ", $r->perl,                 "\n";
    print "OS:           ", $r->OS,                   "\n";
    print "Start:        ", scalar gmtime $r->start,  "\n";
    print "Finish:       ", scalar gmtime $r->finish, "\n";
    print "\n";
    # use Devel::Cover::Dumper; print Dumper $r;
  }
}

sub print_statement {
  my ($db, $file, $options) = @_;

  my $cover = $db->cover;

  print "$file\n\n";
  my $f = $cover->file($file);

  my $fmt  = "%-5s %3s ";
  my @args = ("line", "err");
  for my $ann (@{ $options->{annotations} }) {
    for my $a (0 .. $ann->count - 1) {
      $fmt .= "%-" . $ann->width($a) . "s ";
      push @args, $ann->header($a);
    }
  }
  my %cr;
  @cr{ $db->criteria } = $db->criteria_short;
  for my $c ($db->criteria) {
    if ($options->{show}{$c}) {
      $fmt .= "%6s ";
      push @args, $cr{$c};
    }
  }

  $fmt .= "  %s\n";
  push @args, "code";

  printf $fmt, @args;

  my $autoloader = 0;

  open F, $file or warn("Unable to open $file: $!\n"), return;

  LINE: while (defined(my $l = <F>)) {
    chomp $l;
    my $n = $.;
    $autoloader ||= $l =~ /use\s+AutoLoader/;

    my %criteria;
    for my $c ($db->criteria) {
      next unless $options->{show}{$c};
      my $criterion = $f->$c();
      if ($criterion) {
        my $l = $criterion->location($n);
        $criteria{$c} = $l ? [@$l] : $l;
      }
    }

    # use Devel::Cover::Dumper; print STDERR Dumper(\%criteria);
    my $more = 1;
    while ($more) {
      my @args  = ($n, "");
      my $error = 0;

      for my $ann (@{ $options->{annotations} }) {
        for my $a (0 .. $ann->count - 1) {
          push @args, substr $ann->text($file, $n, $a), 0, $ann->width($a);
          $error ||= $ann->error($file, $n, $a);
        }
      }

      $more = 0;
      for my $c ($db->criteria) {
        next unless $options->{show}{$c};
        my $o = shift @{ $criteria{$c} };
        $more ||= @{ $criteria{$c} };
        my $value
          = $o
          ? ($c =~ /statement|sub|pod|time/)
            ? $o->covered
            : $o->percentage
          : "";
        $value = "-" . $value if $o && $o->uncoverable;
        $value = "*" . $value if $o && $o->error;
        push @args, $value;
        $error ||= $o->error if $o;
      }

      $args[1] = "***" if $error;
      push @args, $l;

      # print join(", ", map { "[$_]" } @args), "\n";
      printf $fmt, @args;

      last LINE if !$autoloader && $l =~ /^__(END|DATA)__/;
      $n = $l = "";
    }
  }

  close F or die "Unable to close $file: $!";
  print "\n\n";
}

sub print_branches {
  my ($db, $file, $options) = @_;

  my $branches = $db->cover->file($file)->branch;

  return unless $branches;

  print "Branches\n";
  print "--------\n\n";

  my $tpl = "%-5s %3s %6s %6s %6s   %s\n";
  printf $tpl, "line", "err", "%", "true", "false", "branch";
  printf $tpl, "-----", "---", ("------") x 3, "------";

  for my $location (sort { $a <=> $b } $branches->items) {
    my $n = 0;
    for my $b (@{ $branches->location($location) }) {
      printf $tpl, $n ? "" : $location, $b->error ? "***" : "",
        ($b->uncoverable ? "-" : "") . $b->percentage,
        map (($b->uncoverable($_) ? "-" : "") . ($b->covered($_) || 0),
          0 .. $b->total - 1),
        $b->text;
      $n++;
    }
  }

  print "\n\n";
}

sub print_conditions {
  my ($db, $file, $options) = @_;

  my $conditions = $db->cover->file($file)->condition;

  return unless $conditions;

  my $template = sub { "%-5s %3s %6s " . ("%6s " x shift) . "  %s\n" };

  my %r;
  for my $location (sort { $a <=> $b } $conditions->items) {
    my %seen;
    for my $c (@{ $conditions->location($location) }) {
      push @{ $r{ $c->type } }, [ $c, $seen{ $c->type }++ ? "" : $location ];
    }
  }

  print "Conditions\n";
  print "----------\n\n";

  my %seen;
  for my $type (sort keys %r) {
    my $tpl;
    for (@{ $r{$type} }) {
      my ($c, $location) = @$_;
      unless ($seen{$type}++) {
        my $headers = $c->headers;
        my $nh      = @$headers;
        $tpl = $template->($nh);
        (my $t = $type) =~ s/_/ /g;
        print "$t conditions\n\n";
        printf $tpl, "line", "err", "%", @$headers, "expr";
        printf $tpl, "-----", "---", ("------") x ($nh + 1), "----";
      }
      printf $tpl, $location, $c->error ? "***" : "",
        ($c->uncoverable ? "-" : "") . $c->percentage,
        map (($c->uncoverable($_) ? "-" : "") . ($c->covered($_) || 0),
          0 .. $c->total - 1),
        $c->text;
    }
    print "\n";
  }

  print "\n";
}

sub print_subroutines {

  my ($db, $file, $options) = @_;

  my $dfil = $db->cover->file($file);
  my $subs = $dfil->subroutine or return;
  my $pods = $options->{show}{pod} && $dfil->pod;
  my $maxh = 8;
  my $maxc = 5;
  my $maxp = 3;
  my $maxs = 10;
  my %subs;

  for my $location ($subs->items) {
    my $l = $subs->location($location);
    my $d = $pods && $pods->location($location);
    for my $sub (@$l) {

      my $h = "$file:$location";
      my $c = ($sub->uncoverable ? "-" : "") . $sub->covered;
      my $e = $pods && shift @$d;
      my $p = $e ? ($e->uncoverable ? "-" : "") . $e->covered : "";
      my $s = $sub->name;

      $maxh = length $h if length $h > $maxh;
      $maxc = length $c if length $c > $maxc;
      $maxp = length $p if $p && length $p > $maxp;
      $maxs = length $s if length $s > $maxs;
      push @{ $subs{ $sub->covered ? "covered" : "uncovered" }{$s} },
        [ $c, $pods ? $p : (), $h ];
    }
  }

  my $template = "%-${maxs}s %${maxc}s ";
  $template .= "%${maxp}s " if $pods;
  $template .= "%-${maxh}s\n";

  for my $type (sort keys %subs) {
    print ucfirst $type,             " Subroutines\n";
    print "-" x (12 + length $type), "\n\n";
    printf $template, "Subroutine", "Count", $pods ? "Pod" : (), "Location";
    printf $template, "-" x $maxs, "-" x $maxc, $pods ? "-" x $maxp : (),
      "-" x $maxh;

    for my $s (sort keys %{ $subs{$type} }) {
      printf $template, $s, @$_
        for sort { $a->[-1] cmp $b->[-1] } @{ $subs{$type}{$s} };
    }
    print "\n";
  }

  print "\n";
}

sub report {
  my ($pkg, $db, $options) = @_;

  print_runs($db, $options);
  for my $file (@{ $options->{file} }) {
    print_statement($db, $file, $options)  if $options->{show}{statement};
    print_branches($db, $file, $options)   if $options->{show}{branch};
    print_conditions($db, $file, $options) if $options->{show}{condition};
    print_subroutines($db, $file, $options)
      if $options->{show}{subroutine} || $options->{show}{pod};
  }
}

1

__END__

=head1 NAME

Devel::Cover::Report::Text - Text backend for Devel::Cover

=head1 VERSION

version 1.44

=head1 SYNOPSIS

 cover -report text

=head1 DESCRIPTION

This module provides a textual reporting mechanism for coverage data.
It is designed to be called from the C<cover> program.

=head1 SEE ALSO

 Devel::Cover

=head1 BUGS

Huh?

=head1 LICENCE

Copyright 2001-2024, Paul Johnson (paul@pjcj.net)

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
