view release on metacpan or  search on metacpan

lib/CPAN/Testers/ParseReport.pm  view on Meta::CPAN

                $in_env_context = 0;
                $expect_toolchain=1;
                $expecting_toolchain_soon=0;
                $moduleunpack = {
                                 tpl => 'a'.length($1).'a'.length($2).'a*',
                                 type => 3,
                                };
            }
        }
        if (/toolchain versions installed/) {
            $in_env_context = 0;
            $expecting_toolchain_soon=1;
        }
    }                           # LINE
    if (! $extract{"mod:CPANPLUS"} && $extract{"meta:writer"} =~ /^CPANPLUS\s(\d+(\.\d+))$/) {
        $extract{"mod:CPANPLUS"} = $1;
    }
    if (! $extract{"meta:perl"} && $fallback_p5) {
        my($p5,$patch) = split /\s+patch\s+/, $fallback_p5;
        $extract{"meta:perl"} = $p5;
        $extract{"conf:git_describe"} = $patch if defined $patch;
    }
    $extract{guid} = $guid;
    if (my $filtercbbody = $Opt{filtercb}) {
        my $filtercb = eval('sub {'.$filtercbbody.'}');
        $filtercb->(\%extract);
    }
    if ($Opt{solve}) {
        if ($extract{"conf:osvers"} && $extract{"conf:archname"}) {
            $extract{"conf:archname+osvers"} = join " ", @extract{"conf:archname","conf:osvers"};
        }
        if ($extract{"meta:perl"} && $extract{"conf:osname"}) {
            $extract{"meta:osname+perl"} = join " ", @extract{"conf:osname","meta:perl"};
        }
        my $data = $dumpvars->{"==DATA=="} ||= [];
        push @$data, \%extract;
    }
    # ---- %extract finished ----
    my $diag = "";
    if (my $qr = $Opt{dumpvars}) {
        $qr = qr/$qr/;
        while (my($k,$v) = each %extract) {
            if ($k =~ $qr) {
                $dumpvars->{$k}{$v}{$extract{"meta:ok"}}++;
            }
        }
    }
    for my $want (@q) {
        my $have  = $extract{$want} || "";
        $diag .= " $want\[$have]";
    }
    binmode \*STDERR, ":encoding(UTF-8)";
    printf STDERR " %-4s %36s%s\n", $extract{"meta:ok"}, $guid, $diag unless $Opt{quiet};
    if ($Opt{raw}) {
        $report =~ s/\s+\z//;
        print STDERR $report, "\n================\n" unless $Opt{quiet};
    }
    if ($Opt{interactive}) {
        eval { require IO::Prompt; 1; } or
            die "Option '--interactive' requires IO::Prompt installed";
        local @ARGV;
        local $ARGV;
        my $ans = IO::Prompt::prompt
            (
             -p => "View $guid? [onechar: ynq] ",
             -d => "y",
             -u => qr/[ynq]/,
             -onechar,
            );
        print STDERR "\n" unless $Opt{quiet};
        if ($ans eq "y") {
	    my($report) = _get_cooked_report($target, \%Opt);
            $Opt{pager} ||= "less";
            open my $lfh, "|-", $Opt{pager} or die "Could not fork '$Opt{pager}': $!";
            local $/;
            print {$lfh} $report;
            close $lfh or die "Could not close pager: $!"
        } elsif ($ans eq "q") {
            $Signal++;
            return;
        }
    }
    return \%extract;
}

sub _get_cooked_report {
    my($target, $Opt_ref) = @_;
    my($report, $isHTML);
    if ($report = $Opt_ref->{article}) {
        $isHTML = $report =~ /^</;
        undef $target;
    }
    if ($target) {
        local $/;
        my $raw_report;
        if (0) {
        } elsif (-e $target) {
            open my $fh, '<', $target or die "Could not open '$target': $!";
            $raw_report = <$fh>;
        } elsif (-e "$target.gz") {
            open my $fh, "<", "$target.gz" or die "Could not open '$target.gz': $!";

#     Opens a gzip (.gz) file for reading or writing. The mode parameter
#   is as in fopen ("rb" or "wb") but can also include a compression level
#   ("wb9") or a strategy: 'f' for filtered data as in "wb6f", 'h' for
#   Huffman only compression as in "wb1h", or 'R' for run-length encoding
#   as in "wb1R". (See the description of deflateInit2 for more information
#   about the strategy parameter.)

            my $gz = Compress::Zlib::gzopen($fh, "rb");
            $raw_report = "";
            my $buffer;
            while (my $bytesread = $gz->gzread($buffer)) {
                $raw_report .= $buffer;
            }
        } else {
            die "Could not find '$target' or '$target.gz'";
        }
        $isHTML = $raw_report =~ /^</;
        if ($isHTML) {
            if ($raw_report =~ m{^<\?.+?<html.+?<head.+?<body.+?<pre[^>]*>(.+)</pre>.*</body>.*</html>}s) {