#!/usr/bin/env perl

#   Copyright (c) MediaTek USA Inc., 2023-2024
#
#   This program is free software;  you can redistribute it and/or modify
#   it under the terms of the GNU General Public License as published by
#   the Free Software Foundation; either version 2 of the License, or (at
#   your option) any later version.
#
#   This program is distributed in the hope that it will be useful, but
#   WITHOUT ANY WARRANTY;  without even the implied warranty of
#   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
#   General Public License for more details.
#
#   You should have received a copy of the GNU General Public License
#   along with this program;  if not, see
#   <http://www.gnu.org/licenses/>.
#
#
# perl2lcov [--output mydata.info] [--test-name name] [options] cover_db+
#
#   This script traverses perl coverage information in one or more coverage
#   data directories (generated by the perl Devel::Cover module) and
#   translates it into LCOV .info format.
#
#   In addition to common options supported by other tools in the LCOV
#   suite (e.g., --comment, --version-script, --ignore-error, --substitute,
#   --exclude, etc.), the tool options are:
#
#      --output filename:
#          The lcov data will be written to the specified file - or to
#          the file called 'perlcov.info' in the current run directory
#          if this option is not used.
#
#      --test-name name:
#          Coverage info will be associated with the testcase name provided.
#          It is not necessary to provide a name.
#
# See the Devel::Cover documentation for directions on how to generate
# perl coverage data.

use Devel::Cover::DB;
use Devel::Cover::Truth_Table;
use strict;
use warnings;
use Getopt::Long;

# Windows path handling - see comment in jacoco2lcov
use lib "/usr/lib/lcov";
use lcovutil qw($tool_name);

sub print_usage
{
    local *HANDLE = $_[0];

    print(HANDLE <<END_OF_USAGE);
Usage: $tool_name [OPTIONS] TRACEFILE_PATTERN(S)

Translate Perl coverage directory generated by Devel::Cover to LCOV .info
file format.

In addition to common options supported by other tools in the LCOV
suite (e.g., --comment, --version-script, --ignore-error, --substitute,
--exclude, etc.), the tool options are:

  --output filename:
      The lcov data will be written to the specified file - or to
      the file called 'perlcov.info' in the current run directory
      if this option is not used.

  --test-name name:
      Coverage info will be associated with the testcase name provided.
      It is not necessary to provide a name.

See the Devel::Cover documentation for directions on how to generate
perl coverage data.

For example:

    # write Perl line, branch, condition, and subroutine coverage data to
    #  'myPerlDB' in the current directory
  \$ perl -MDevel::Cover=-db,.\/myPerlDB,-coverage,statement,branch,condition,subroutine,-silent,1 myScript.pl
    # OR: write all the coverage types that Perl knows about to 'myPerlDB2' -
    #   note that perl2lcov will ignore types it does not understand/does
    #   not use (pod, time, and path)
  \$ perl -MDevel::Cover=-db,.\/myPerlDB2,-silent,1 myScript.pl
    # run 'cover' from the Devel::Cover installation - to extract runtime
    #   data into a usable form.  This will also generate an HTML report
    #   in 'myCoverDB'
  \$ cover myCoverDB -silent 1
    # run perl2lcov translator to produce LCOV format data:
  \$ perl2lcov -o perldata.info [--test-name myTestName] myCoverDB
    # and generate a genhtml-format coverage report:
  \$ genhtml -o html_report perldata.info ...

Note that the data generated by Devel::Cover is not always internally
consistent.  For example:

  - some which are never called, do not appear in the coverage data.

  - sometimes, a line will appear to be executed (non-zero hit count) but
    none of its contained branch expressions have been evaluated.
    (If the line was executed, then at least one branch condition must have
    been evaluated.

This can cause the various tools in the lcov package to generate errors of
type 'inconsistent'.
In that case, you can:

  - skip consistency checks entirely:  see the 'skip_consistency_checks' section
    in man lcovrc(5)

  - ignore the error:  see the '--ignore-error' section in man genhtml(1)

  - exclude the offending code: see the '--exclude', '--filter', and
    '--omit-lines' sections in man genhtml(1).

END_OF_USAGE
}

sub findPackage
{
    my ($extents, $line) = @_;
    return undef unless @$extents;

    my $min = 0;
    my $max = $#$extents;
    my $best;
    while ($min <= $max) {
        my $mid = int(($min + $max) / 2);
        my $v   = $extents->[$mid];
        if ($line < $v->[0]) {
            $max = $mid - 1;
        } elsif ($line > $v->[0]) {
            $best = $v;
            $min  = $mid + 1;
        } else {
            # line number matched...which ought not to happen because
            # Devel::Cover reports subroutine start as first executable
            # line in the function.
            # That won't be the line containing "package ..." - unless the
            # user wrote the whole thing on one line.  Not clever.  Deserves
            # to lose, if something in here breaks.
            return $v;
        }
    }
    return $best;
}

sub heredocTag
{
    # The terminator of the first heredoc introduced at or after $offset in $l,
    #   as ($tag, $indented, $end) - or the empty list if there is none.  Perl
    #   reads '<<' followed immediately by an identifier or a quoted string as
    #   an introducer, and anything else (including '<< SHIFT' with a space) as
    #   a left shift, so this matches only what perl itself would.
    my ($l, $offset) = @_;
    return ()
        unless substr($l, $offset) =~
        /<<(~?)(?:"([^"]*)"|'([^']*)'|([A-Za-z_]\w*))/;
    my $tag = defined($2) ? $2 : defined($3) ? $3 : $4;
    return ($tag, $1 eq '~', $offset + $+[0]);
}

sub scanDeclarations
{
    # The 'package' and 'sub' declarations in $filename, as two lists of
    #   [lineNumber, name] in increasing line order.  Devel::Cover says where
    #   each subroutine starts but not where it ends, so these are what bounds
    #   one:  a subroutine ends at the last executable line before the next
    #   declaration.
    #
    # This is a scan and not a parse, but it does know about the text which
    #   looks like a declaration without being one:  a heredoc body, POD, and
    #   everything after '__END__' or '__DATA__'.  What it does not know about
    #   is a declaration inside a multi-line quoted string - telling that from
    #   code needs a lexer, and guessing it wrong would drop a real declaration,
    #   which is worse than keeping a false one.
    my $filename = shift;
    my (@packageExtents, @functionExtents);
    my $fh;
    if (!open($fh, '<', $filename)) {
        lcovutil::ignorable_error($lcovutil::ERROR_SOURCE,
                      "unable to read '$filename' for package/sub extents: $!");
        return (\@packageExtents, \@functionExtents);
    }
    my @lines = <$fh>;
    close($fh);

    my $inPod  = 0;
    my $lineNo = 0;    # after the fetch below:  the line number of $l
    while ($lineNo <= $#lines) {
        my $l = $lines[$lineNo++];
        if ($inPod) {
            $inPod = 0 if $l =~ /^=cut/;
            next;
        }
        if ($l =~ /^=\w/) {
            # POD, until '=cut'
            $inPod = 1;
            next;
        }
        # nothing after these is code.  Checked below the POD arms, because
        #   inside POD this is text like everything else
        last if $l =~ /^__(END|DATA)__\s*$/;
        if ($l =~ /^\s*package\s+([\w:']+)/) {
            push(@packageExtents, [$lineNo, $1 . '::']);
        } elsif ($l =~ /^\s*sub\s+([^\s({;]+)/) {
            push(@functionExtents, [$lineNo, $1]);
        }
        # a heredoc body is text.  Skip to the terminator - but only when there
        #   is one, so that a '<<TAG' inside a string cannot swallow the rest of
        #   the file
        my $offset = 0;
        while (my ($tag, $indented, $next) = heredocTag($l, $offset)) {
            $offset = $next;
            my $pattern = $indented ? qr/^\s*\Q$tag\E\s*$/ : qr/^\Q$tag\E\s*$/;
            foreach my $i ($lineNo .. $#lines) {
                next unless $lines[$i] =~ $pattern;
                $lineNo = $i + 1;    # resume after the terminator
                last;
            }
        }
    }
    return (\@packageExtents, \@functionExtents);
}

$lcovutil::br_coverage                        = 1;
$lcovutil::func_coverage                      = 1;
$lcovutil::derive_function_end_line           = 1;
$lcovutil::derive_function_end_line_all_files = 1;
lcovutil::save_cmd_line(\@ARGV, $lcovutil::tool_dir);
lcovutil::set_extensions('perl', '.*');

my $testname    = '';
my $output_file = 'perlcov.info';
our %options = ('test-name=s' => \$testname,
                'output|o=s'  => \$output_file,);
if (!lcovutil::parseOptions({}, \%options)) {
    print(STDERR "Use $lcovutil::tool_name --help to get usage information.\n");
    exit(1);
}

# translate windows paths, if necessary
lcovutil::posix_paths(\$output_file, \@ARGV);

my $info = TraceFile->new();

foreach my $db_path (@ARGV) {
    # parse the other files first - to grab the data we want -
    #   Not quite sure how to map 'cond' to LCOV branch coverage.

    # save a readable message before remapping the $db
    my $msg =
        "$db_path appears to be empty; perhaps you need to run 'cover $db_path' before executing $0.";
    my $db    = Devel::Cover::DB->new(db => $db_path);
    my $cover = $db->cover;
    my @items = $cover->items;
    if (!@items) {
        lcovutil::ignorable_error($lcovutil::ERROR_EMPTY, $msg);
        next;
    }
    foreach my $file ($cover->items) {
        # '$file' is Devel::Cover's own key and is what every lookup into the
        #   coverage DB below has to use.  '$filename' is the name this file is
        #   reported under:  '--substitute' applied, then resolved against
        #   '--source-directory' - the same two steps, in the same order, that
        #   'bin/llvm2lcov' takes.  Everything about the file as reported - its
        #   entry in the TraceFile, its version, its checksum, and the scan for
        #   'package' and 'sub' declarations below - now goes by '$filename';
        #   each of those used to go by the DB key, which is not necessarily
        #   the name of a file which is there to be read.
        my $filename = ReadCurrentSource::resolve_path($file, 1);
        lcovutil::info("process $filename" .
                ($filename ne $file ? " (substituted from $file)" : '') . "\n");
        if (TraceFile::skipCurrentFile($filename)) {
            lcovutil::info("   (excluded)\n");
            next;
        }
        my $f           = $cover->file($file);
        my $fileData    = $info->data($filename);
        my $functionMap = $fileData->testfnc($testname);
        my $lineMap     = $fileData->test($testname);
        my $branchMap   = $fileData->testbr($testname);

        # use statement coverage to mark un-evaluated branches
        my ($stmts, $branches, $conditions, $subroutines);
        my @packageExtents;
        # Devel::Cover doesn't instrument all the functions in every file -
        # so need a workaround to find better extents for some of them
        my @functionExtents;

        foreach my $criteria ($f->items) {
            # some types we don't use.
            next if (grep({ $_ eq $criteria } ('pod', 'time', 'path')));
            my $c = $f->criterion($criteria);
            if ($criteria eq 'branch') {
                $branches = $c;
            } elsif ($criteria eq 'condition') {
                $conditions = $c;
            } elsif ($criteria eq 'subroutine') {
                $subroutines = $c;
                if (-f $filename) {
                    # Scan for 'package' and 'sub' declarations in-process.
                    my ($p, $fn) = scanDeclarations($filename);
                    @packageExtents  = @$p;
                    @functionExtents = @$fn;
                }
            } elsif ($criteria eq 'statement') {
                $stmts = $c;
            } else {
                lcovutil::ignorable_error($lcovutil::ERROR_UNKNOWN_CATEGORY,
                                          "unexpected data type '$criteria'");
            }
        }
        if (!defined($stmts)) {
            # this seems to happen sometimes if we re-run 'cover' multiple
            # times on the same DB - e.g., during testing.
            lcovutil::ignorable_error($lcovutil::ERROR_UNSUPPORTED,
                              "unable to process $file without statement data");
            next;
        }
        # the checksum and the version belong to the file as it is reported
        if ($lcovutil::verify_checksum &&
            !-f $filename) {
            lcovutil::ignorable_error($lcovutil::ERROR_SOURCE,
                       "cannot read '$filename': unable to compute --checksum");
        }
        my $version;
        $version = lcovutil::extractFileVersion($filename) if -f $filename;
        $fileData->version($version) if defined($version) && $version ne '';

        # run through data to verify that there are no branch, function, or
        #  conditional coverpoints where there is no line data
        foreach my $c (['branch', $branches],
                       ['condition', $conditions],
                       ['subroutine', $subroutines]
        ) {
            next unless defined($c->[1]);
            foreach my $line ($c->[1]->items) {
                lcovutil::ignorable_error(
                                   $lcovutil::ERROR_INCONSISTENT_DATA,
                                   'found ' .
                                       $c->[0] .
                                       " coverpoint on $line but no lineCov there"
                ) unless defined($stmts->location($line));
            }
        }

        foreach my $line ($stmts->items) {
            my $l         = $stmts->location($line);
            my $lineCount = $l->[0]->[0];
            $lineMap->append($line, $lineCount);

            if ($subroutines) {
                my $s = $subroutines->location($line);
                if (defined($s)) {
                    my ($count, $name) = @{$s->[0]};
                    if ($name !~ /(BEGIN|__ANON__)/) {
                        my $p = findPackage(\@packageExtents, $line);
                        if (defined($p)) {
                            $name = $p->[1] . $name;
                        }
                        $functionMap->define_function($name, $line);
                        $functionMap->add_count($name, $count);
                    }
                }
            }
            if (defined($conditions)) {
                my $cond = $conditions->location($line);
                if (defined($cond)) {
                    my @br = $conditions->truth_table($line);
                    my @subst;
                    # the intent of this transform is for the branchExpr
                    #   to show which parts of the condition have evaluated
                    #   to true or false.
                    # However, this doesn't quite work because the truth
                    #   table computed by Devel::Cover is sometimes ordered
                    #   with the dependent clause after the independent
                    #   one - and sometimes the opposite.
                    # For the moment:  punt when we don't grok
                    foreach my $block (@br) {
                        my $counts = $block->[0];
                        my $expr   = $block->[1];
                        # a multi-line construct (e.g. 'eval { ... } || ...')
                        # can carry newlines in its text; collapse them so the
                        # whole BRDA record stays on one line (perl2lcov and
                        # genhtml expect a single-line record).
                        $expr =~ s/\s*\R\s*/ /g;
                        my $simplified = $expr;
                        for (my $i = 0; $i <= $#subst; ++$i) {
                            my ($from, $to) = @{$subst[$i]};
                            $simplified =~ s/\Q$from\E/$to/;
                        }
                        my @expr;
                        while ($simplified =~
                               /(.+?)\s+(and|or|xor|&&|\|\|)\s+(.+)/) {
                            $simplified = $3;
                            (my $e = $1) =~ s/^\s+|\s+$//g;
                            push(@expr, $e);
                        }
                        push(@expr, $simplified);
                        #@expr = split(/\s+(and|or|xor|&&|\|\|)\s+/, $simplified);
                        $block = BranchBlock->new();
                        my $branchID = 0;
                        foreach my $entry (@$counts) {
                            my $taken =
                                $lineCount == 0 ? '-' : $entry->{covered};
                            my $inputs     = $entry->{inputs};
                            my $branchExpr = '';
                            if (scalar(@$inputs) == scalar(@expr)) {
                                # this is the case we expect..
                                my $sep = '';
                                for (my $i = 0; $i <= $#$inputs; ++$i) {
                                    my $v = $inputs->[$i];
                                    next if ($v eq 'X');
                                    $branchExpr .= $sep;
                                    $branchExpr .= " ! " if $v eq '0';
                                    $branchExpr .= $expr[$i];
                                    $sep = ', ';
                                }
                                for (my $i = 0; $i <= $#subst; ++$i) {
                                    my ($to, $from) = @{$subst[$i]};
                                    $branchExpr =~ s/$from/($to)/;
                                }
                                $branchExpr =~ s/^\s+|\s+$//g;
                            } else {
                                # punt.  Just report the original Devel::Cover
                                # expressions.  Hope the user can sort it out
                                $branchExpr = $expr;
                            }
                            $block->appendElement(BranchElement->new(
                                             $branchID++, $taken, $branchExpr, 0
                            ));
                        }
                        $branchMap->insertBlock($block, $line);
                        push(@subst, [$expr, '__' . scalar(@subst) . '__']);
                    }
                    # condition data is more comprehensive than branch
                    # if both exist on the line.
                    next;
                }
            }
            if (defined($branches)) {
                my $br = $branches->location($line);
                if (defined($br)) {
                    my ($true, $false) = @{$br->[0]->[0]};
                    my $expr = $br->[0]->[1]->{'text'};
                    # a multi-line construct (e.g. 'eval { ... } || ...') can
                    # carry newlines in its text; collapse them so the whole
                    # BRDA record stays on one line.
                    $expr =~ s/\s*\R\s*/ /g;
                    # blockID is always zero
                    my $block = BranchBlock->new();
                    my $id    = 0;
                    for my $c ([$true, $expr], [$false, '! ' . $expr]) {
                        # this is not an exception...
                        $block->appendElement(BranchElement->new(
                                         $id++, $lineCount == 0 ? '-' : $c->[0],
                                         $c->[1], 0));
                    }
                    $branchMap->insertBlock($block, $line);
                }
            }
        }
        $branchMap->updateCounts();
        $fileData->sum()->union($lineMap);
        $fileData->sumbr()->union($branchMap);
        $fileData->func()->union($functionMap);

        # have to do this manually due to some Perl quirks -
        # in particular, there may be code outside of the subroutine we are
        # walking...and we want to correct the end line
        TraceFile::_deriveFunctionEndLines($fileData);
        my $lineData = $fileData->sum();
        my $funcData = $fileData->testfnc();

        foreach my $func ($fileData->func()->valuelist()) {
            # where is the nearest 'package' after my start line?
            my $first = $func->line();
            my $end   = $func->end_line();
            next unless defined($end);
            # find package or function enclosing my end line..
            my $last = $end;
            foreach my $ext (\@packageExtents, \@functionExtents) {
                while (1) {
                    my $p = findPackage($ext, $last);
                    if (defined($p) && $p->[0] > $first) {
                        $last = $p->[0] - 1;
                        lcovutil::info(1,
                                       $func->name() .
                                           ": found update end line $last in " .
                                           $p->[1] . "\n");
                        # iterate in case there is another package above the first one
                    } else {
                        last;
                    }
                }
            }
            next unless $last < $end;

            # what is the last executable line before the 'package' or 'sub' decl?
            while ($last > $first) {
                if (defined($lineData->value($last))) {
                    last;
                }
                --$last;
            }
            lcovutil::info(1,
                           "resetting " .
                               $func->name() .
                               " end line to $last (from $end)\n");
            $func->set_end_line($last);

            foreach my $tn ($funcData->keylist()) {
                my $d = $funcData->value($tn);
                # the loop above walks the merged function list, so a particular
                #   testcase need not have an entry at this start line
                my $f = $d->findKey($first);
                $f->set_end_line($last) if defined($f);
            }

        }    #foreach function

    }    # foreach file
}    #foreach cover db

$info->applyFilters();
$info->add_comments(@lcovutil::comments);
$info->write_info_file($output_file, $lcovutil::verify_checksum);

$info->checkCoverageCriteria();
CoverageCriteria::summarize();
my $exit_code = 0 != $CoverageCriteria::coverageCriteriaStatus;

lcovutil::warn_file_patterns();
lcovutil::summarize_cov_filters();
lcovutil::summarize_messages(1);    # silent if no messages

exit $exit_code;
