Release-Checklist/scripts/makewww.pl
#!/usr/bin/env perl
use 5.20.0;
use warnings;
our $VERSION = "1.33 - 2020-11-13";
our $CMD = $0 =~ s{.*/}{}r;
sub usage {
my $err = shift and select STDERR;
say "usage: $CMD [-v] [--git=author] [--travis=id] AUTHOR\n";
exit $err;
} # usage
use Getopt::Long qw(:config bundling);
my $opt_v = 0;
GetOptions (
"help|?" => sub { usage (0); },
"v|verbose:1" => \$opt_v,
"time!" => \my $opt_t,
"g|git=s" => \my $git_id,
"t|travis=s" => \my $travis_id,
"s|svg!" => \my $opt_svg,
) or usage (1);
my $author = shift or usage (1);
$author = uc $author;
my $auid1 = substr $author, 0, 1;
my $auid3 = "$auid1/" . substr $author, 0, 2;
use LWP;
use JSON::XS;
use YAML::Tiny;
use Data::Peek;
use LWP::UserAgent;
use HTML::Entities;
use HTML::TreeBuilder;
use List::Util qw( sum0 );
use Encode qw( encode decode );
use Date::Calc qw( Parse_Date Date_to_Time );
use Time::HiRes qw( gettimeofday tv_interval );
use MetaCPAN::Client;
use CPAN::Testers::WWW::Reports::Query::AJAX;
my $mcpan = MetaCPAN::Client->new ();
my $mauthor = $mcpan->author ($author);
$ENV{PERL_LWP_SSL_VERIFY_HOSTNAME} = 0;
my $ua = LWP::UserAgent->new;
$ua->agent ("Opera/30");
# A dist is https://metacpan.org/release/$dist_name
# A release is https://metacpan.org/release/$author/$release
# A module is https://metacpan.org/pod/$module
# or https://metacpan.org/pod/release/$author/$release/$file_path
my %mod;
$opt_v and say "Fetch releases from $author";
{ my $ar = $mauthor->releases;
while (my $rr = $ar->next) {
my $mod = $rr->distribution =~ s{-}{::}gr; # Yeah, not 100% correct
$opt_v > 1 and say " $mod";
my $repo = "";
if (my $rrr = $rr->{data}{resources}{repository}) {
$repo = $rrr->{web} || $rrr->{url} || "";
}
if ($repo =~ m{\bgithub\.com\b}) {
$repo =~ s{^git\@github.com:}{https://github.com/};
$repo =~ s{^git:}{https:};
$repo =~ s{\.git$}{};
$repo =~ m{github.com/([^/]+)} and $git_id //= $1;
}
$mod{$mod} = {
git => $repo,
data => $rr->{data} // {},
};
$opt_v > 2 and say " $repo";
}
}
$git_id //= lc $author;
$travis_id //= $git_id;
my $buffer = "";
open my $html, ">:encoding(utf-8)", \$buffer;
header ();
modules ();
footer ();
close $html;
open $html, ">", "$author.html";
print $html $buffer;
close $html;
sub href {
my ($txt, $ref, $ttl, $dtl) = (@_, "", "", "");
if (ref $txt eq "HASH") {
$ttl = encode_entities ($txt->{title});
$dtl = encode_entities ($txt->{dtitle});
$txt = encode_entities ($txt->{text});
}
$ttl //= "";
$dtl //= "";
$txt //= "";
$ttl and $ttl = qq{ title="$ttl"};
$dtl and $ttl .= qq{ data-title="$dtl"};
$ref && $ref ne "-" ? qq{<a href="$ref"$ttl>$txt</a>} : $txt // "-";
} # href
sub dta {
my ($tag, %attr, @arg) = ("td");
for (@_) {
if (ref $_ eq "ARRAY") {
local $" = " ";
$tag .= qq{ class="@$_"};
next;
}
push @arg, $_;
}
my $info = @arg > 2 ? join " ", "", splice @arg, 2 : "";
my $link = href (@arg);
if ($tag =~ m{class=".*\b(pass|na|warn|fail|gray)[ "]}) {
my $c = $1;
$link =~ s{<a \K}{class="$c" };
}
say $html " <$tag>$link$info</td>";
} # dta
my $t0;
my %time;
sub t_used {
my $now = [ gettimeofday ];
my $d = tv_interval ($t0, $now);
$t0 = $now;
return $d;
} # t_used
sub show_times {
say STDERR "--- cumulative times used";
printf STDERR "%-11s : %7.3f\n", $_, $time{$_} for sort keys %time;
} # show_times
sub modules {
print $html <<"EOH";
<tr class="boxed">
<td class="boxed">
<p class="header">${author}'s modules</p>
<table>
<thead>
<tr>
<th><a href="https://v1.metacpan.org/author/$author">Distribution</a></th>
<th>vsn</th>
<th class="rhdr">released</th>
<th class="tci" colspan="4"><a href="https://github.com/$git_id">repo</a></th>
<th class="rhdr"><a href="https://rt.cpan.org/Public/Dist/ByMaintainer.html?Name=$author">RT</a></th>
<th class="center">doc</th>
<th class="tci"><a href="https://travis-ci.org/profile/$travis_id">TravisCI</a></th>
<th class="cpants"><a href="https://cpants.perl.org/author/$author">kwalitee</a></th>
<th class="rhdr"><a href="http://cpancover.com">cover</a></th>
<th class="rhdr" colspan="3"><a href="http://www.cpantesters.org/author/$auid1/$author.html">cpantesters</a></th>
<th class="rhdr"><span style="color: green">✔</span><span style="color: red">✘</span></th>
<th class="rhdr"><a href="http://deps.cpantesters.org">↝</a></th>
<th class="rhdr" style="color: red">♥</th>
<th class="rhdr" style="color: black">★</th>
</tr>
</thead>
<tbody>
EOH
my $coverage = {};
my $r;
$r = $ua->get ("http://cpancover.com/latest/cpancover.json") and $r->is_success and
$coverage = eval { decode_json ($r->content) } // {};
my $do_dr = 1; # Count downriver. Disable if it takes too long
my $eo = 0;
foreach my $mod (sort keys %mod) {
$opt_v and say $mod;
my $m = $mod{$mod}; $m->{skip} and next;
my $dist = $mod =~ s/::/-/gr;
$t0 = [ gettimeofday ];
$opt_v > 1 and warn " Base CPAN data\n";
my $data = eval { $mcpan->module ($mod)->{data} } || {};
if ($m->{data}) {
$data->{$_} = $m->{data}{$_} for keys %{$m->{data}};
}
$time{init} += t_used;
$data->{fav} = $mcpan->favorite ({ distribution => $dist })->{total} || "-";
$time{favorite} += t_used;
my $rating = "";
$data->{rating} = { text => "-" };
if (my $rs = $mcpan->rating ({ distribution => $dist })->scroller) {
$opt_v > 1 and warn " Fetch rating\n";
my $n = $rs->total;
if ($r = $rs->next) {
$rating = "https://cpanratings.perl.org/d/$dist";
$data->{rating} = {
text => $r->{_source}{rating},
dtitle => "$n votes",
};
}
}
$time{rating} += t_used;
$data->{version} //= "*";
my $mcpd = eval { $mcpan->distribution ($dist) };
my $mcpr = eval { $mcpan->release ($dist) };
# Kwalitee
my $kwtc = "none";
if ($opt_svg) {
my $svg_url = "https://cpants.cpanauthors.org/dist/$dist.svg";
$r = $ua->get ($svg_url);
$r && $r->is_success and $data->{kwalitee} = qq{<img src="$svg_url" />};
}
unless (defined $data->{kwalitee}) {
$opt_v > 1 and warn " Fetch kwalitee\n";
$r = $ua->get ("https://cpants.cpanauthors.org/dist/$dist");
my $tree = HTML::TreeBuilder->new;
$tree->parse_content ($r && $r->is_success ? decode ("utf-8", $r->content) : "");
if (my ($dl) = $tree->look_down (_tag => "dl", class => "small")) {
my ($dt, %dl) = ("");
foreach my $d ($dl->look_down (_tag => qr{^d[td]$})) {
my $txt = $d->as_text;
if ($d->tag eq "dt") {
$dt = lc $txt;
next;
}
$dl{$dt} //= $txt;
}
$data->{kwk} = $dl{"kwalitee"};
$data->{kwc} = $dl{"core kwalitee"};
$data->{kwr} = $dl{"release date"};
$data->{kwalitee} = join " / " =>
$data->{kwc} || "-", $data->{kwk} || " - ";
$data->{kwc} and $kwtc = $data->{kwc} >= 100 ? "pass"
: $data->{kwc} >= 80 ? "na"
: $data->{kwc} >= 60 ? "warn" : "fail";
}
}
$time{kwalitee} += t_used;
# GIT repo and last commit
my $git = $m->{git}; # // "https://github.com/$git_id/$dist",
my $git_tag = {
text => "git",
dtitle => "",
};
my $git_clss = [ "git" ];
if ($git =~ m/\b github.com \b/x) {
$opt_v > 1 and warn " Fetch github master commits\n";
$r = $ua->get ("$git/commits/master");
my $tree = HTML::TreeBuilder->new;
$tree->parse_content ($r && $r->is_success ? decode ("utf-8", $r->content) : "");
# Get most recent commit date
for ($tree->look_down (_tag => "div", class => "commit-group-title")) {
# Commits on Apr 24, 2015
my ($y, $m, $d) = Parse_Date ($_->as_text =~ s/^\s*Commits\s+on\s*//r) or next;
$git_tag->{dtitle} = sprintf "%4d-%02d-%02d", $y, $m, $d;
my $t = Date_to_Time ($y, $m, $d, 0, 0, 0) or next;
my $span = int ((time - $t) / 86400);
push @$git_clss,
$span <= 7 ? "pass" : # green, <= 1 week
$span <= 30 ? "na" : # yellow, <= 30 days
$span <= 182 ? "warn" : # orange, <= 6 months
"fail" ; # red
#warn sprintf "%4d-%02d-%02d %3d %s\n", $y, $m, $d, $span, $dist;
last;
}
}
$git eq "" && !$git_tag->{dtitle} and $git_tag = "-";
$time{git} += t_used;
# CPANTESTER results
if ($mcpr and my $t = $mcpr->tests) {
$data->{cptst} = [ map { $t->{$_} // "" } qw( pass na fail unknown ) ];
}
else {
$opt_v > 1 and warn " Fetch cpantesters\n";
!defined $data->{cptst} and
$data->{cptst} =
($r = CPAN::Testers::WWW::Reports::Query::AJAX->new (dist => $dist))
? [ $r->pass, $r->na, $r->fail, $r->unknown ]
: [ "", "", "", "" ];
}
$opt_v > 7 and warn " (@{$data->{cptst}})\n";
$time{cpantesters} += t_used;
# RT tickets
my $rt = $m->{rt} // "https://rt.cpan.org/Public/Dist/Display.html?Name=$dist";
# https://rt.cpan.org/Dist/Display.html?Name=$dist";
# https://rt.cpan.org/Dist/Display.html?Queue=DBD%3A%3ACSV
my $rt_tag = "*";
if ($rt =~ m{/rt.cpan.org/}) {
if ($mcpd and $r = $mcpd->bugs and my $brt = $r->{rt}) {
$rt_tag = sum0 map { $brt->{$_} || 0 } qw( open new );
# Possibly use a popup to show active, closed, new, open,
# patched, rejected, resolved, stalled
}
elsif ($r = $ua->get ($rt) and $r->is_success) {
$opt_v > 1 and warn " Fetching RT ticket list\n";
$opt_v > 2 and warn " $rt\n";
my $tree = HTML::TreeBuilder->new;
$tree->parse_content (decode ("utf-8", $r->content));
#$opt_v > 8 and warn $tree->as_HTML (undef, " ", {});
my %id;
$id{$_->attr ("href")}++ for
$tree->look_down (_tag => "a", href => qr{^/Ticket/Display.html\?id=[0-9]+$});
$opt_v > 8 and DDumper \%id;
$rt_tag = scalar keys %id;
}
else {
warn $r->status_line;
}
}
$time{rt} += t_used;
# Github issues
my $issues;
my $issues_tag = $git ? "-" : "";
my $issue_class = [ "date" ];
my %pr = (
"open" => [ "-", undef ],
"closed" => [ "-", undef ],
);
if ($git =~ m/\b github.com \b/x) {
if ($mcpd and $r = $mcpd->bugs and my $bgh = $r->{github}) {
# source, closed, open, active
$issues_tag = $bgh->{open};
}
else {
$opt_v > 1 and warn " Fetch github issues\n";
my $il = "$git/issues";
$r = $ua->get ($il);
my $tree = HTML::TreeBuilder->new;
if ($r && $r->is_success) {
$issues = $il;
$issues_tag = "0";
$tree->parse_content (decode ("utf-8", $r->content));
# Get most recent commit date
my $ib = $il =~ s{^https?://github.com}{}r;
$rt_tag eq "*" and $rt_tag = 0;
for ($tree->look_down (_tag => "a",
href => qr{$ib\?q=is(?:%3A|:)open\+is(?:%3A|:)issue$})) {
$_->as_text =~ m/^\s*([0-9]+)\s+Open/i or next;
$issues_tag = $1;
}
}
}
$issues_tag =~ m/^[0-9]+$/ and push @$issue_class, (
$issues_tag == 0 ? "pass" :
$issues_tag < 10 ? "na" :
$issues_tag < 25 ? "warn" : "fail");
my $tree = HTML::TreeBuilder->new;
$r = $ua->get ("$git/pulls");
$tree->parse_content ($r && $r->is_success ? decode ("utf-8", $r->content) : "");
foreach my $a ($tree->look_down (_tag => "a", href => qr{/issues\?q=is%3A})) {
my $t = lc $a->as_text;
$t =~ m/^\s* ([0-9]+) \s+ ( open | closed ) \s*$/x or next;
$pr{$2} = [ $1 + 0, "$git/pulls?q=is%3Apr+is%3A$2" ];
}
}
$time{github} += t_used;
$rt_tag =~ m/^[-0-9]?$/ or
$rt_tag = ($mcpd ? $mcpd->bugs->{rt}{active} // "" : "") || "*";
$time{rt_tag} += t_used;
# Downriver deps
my $rd = $mcpd ? $mcpd->river->{total} : undef;
$rd //= $data->{rd} // ($do_dr ? do {
$r = $ua->get ("http://deps.cpantesters.org/depended-on-by.pl?module=$mod");
my $tree = HTML::TreeBuilder->new;
$tree->parse_content ($r && $r->is_success ? $r->content : "");
my $x = 0;
$x++ for $tree->look_down (_tag => "li");
$x;
} : "\x{2241}");
$rd ||= "-";
$time{downriver} += do {
my $tdr = t_used;
$tdr > 120 and $do_dr = 0; # On FAIL this takes 180+ seconds
$tdr;
};
my $cos = "-";
my $cos_class = [ "rd" ];
{ $r = $ua->get ("http://deps.cpantesters.org/?module=$mod&perl=5.22.0&os=any+OS");
my $tree = HTML::TreeBuilder->new;
$tree->parse_content ($r && $r->is_success ? $r->content : "");
foreach my $tr ($tree->look_down (_tag => "tr", class => "results_chances")) {
my @td = $tr->look_down (_tag => "td");
if (@td && $td[-1]->as_text =~ m/\b([0-9]+)\s*%/) {
$cos = $1 + 0;
push @$cos_class,
$cos < 50 ? "fail" :
$cos < 75 ? "warn" :
$cos < 95 ? "na" : "pass";
}
}
}
$time{success} += t_used;
# Release date
my $rel_date = ($data->{date} // " ") =~ s/T.*//r;
my $rel_clss = [ "date" ];
if (my ($y, $m, $d) = ($rel_date =~ m/^(\d+)-(\d+)-(\d+)\b/)) {
my $t = Date_to_Time ($y, $m, $d, 0, 0, 0) or next;
my $span = int ((time - $t) / 86400);
push @$rel_clss,
$span <= 30 ? "pass" : # green, <= 30 days
$span <= 182 ? "na" : # yellow, <= 6 months
$span <= 365 ? "warn" : # orange, <= 1 year
"fail" ; # red
}
$time{release} += t_used;
# Travis CI
my $tci = $m->{tci} // ($git ? "https://travis-ci.org/$travis_id/$dist/builds" : "");
my $tci_tag = $tci ? "*" : "";
my $tci_class = [ "tci" ];
if ($tci =~ m/travis-ci/ and $r = $ua->get ($tci =~ s{/builds$}{.svg}r) and $r->is_success) {
my %bs = map { $_ => 1 } ($r->content =~ m{<text[^>]+>([^<]+)</text>}g);
delete $bs{build};
$tci_tag = join "/" => sort keys %bs;
push @$tci_class,
$bs{passing} ? "pass" :
$bs{failing} ? "fail" :
$bs{error} ? "warn" : "na";
}
$time{travis} += t_used;
if ($tci_tag =~ m{^(?:unknown|\*|)$} && $git =~ m{\b github\.com \b}x) {
$tci = "https://travis-ci.org/profile";
$tci_tag = "add";
$tci_class = [ "tci", "gray" ];
}
# ChangeLog
$m->{cpan} //= "https://v1.metacpan.org/release/$dist";
my $cll = $m->{cpan} =~ m/metacpan/ ? "https://v1.metacpan.org/changes/distribution/$dist" : "";
$time{changelog} += t_used;
# Coverage
# http://cpancover.com/latest//Text-CSV_XS-1.18/index.html
$data->{cover} //= {
branch => "-",
condition => "-",
pod => "-",
statement => "\x{237d}", # SHOULDERED OPEN BOX (uncovered)
subroutine => "-",
total => "-",
};
my $cvrr;
if (my $c = $coverage->{$dist}{$data->{version}}{coverage}{total}) {
$data->{cover}{$_} = $c->{$_} for keys %$c;
$cvrr = "http://cpancover.com/latest/$dist-$data->{version}/index.html";
}
my $cvrl = join " \n" => map {
(sprintf "%-10s: %6s", $_, $data->{cover}{$_}) =~ s/ /\x{00a0}/gr; # NBSP
} sort keys %{$data->{cover}};
my $cvrt = { text => $data->{cover}{statement}, dtitle => $cvrl };
my $cvrc = $data->{cover}{total} eq "-" ? "none"
: $data->{cover}{total} eq "\x{237d}" ? "none"
: $data->{cover}{total} eq "n/a" ? "none"
: $data->{cover}{total} >= 90 ? "pass"
: $data->{cover}{total} >= 70 ? "na"
: $data->{cover}{total} >= 50 ? "warn" : "fail";
$time{coverage} += t_used;
my $trc = $eo++ % 2 ? q{ class="other"} : "";
say $html qq{ <tr$trc>};
dta ( { text => $dist, title => $data->{abstract} // $mod }, $m->{cpan});
dta (["version" ], $data->{version}, $cll);
dta ($rel_clss, $rel_date);
dta ($git_clss, $git_tag || "-", $git);
dta ($issue_class, $issues_tag, $issues);
dta ($issue_class, $pr{"open"}[0], $pr{"open"}[1]);
dta ($issue_class, $pr{"closed"}[0], $pr{"closed"}[1]);
dta (["rt" ], $rt_tag, $rt);
dta (["center" ], "doc", $m->{doc} // "https://v1.metacpan.org/module/$mod");
dta ($tci_class, $tci_tag || "-", $tci);
dta (["kwt",$kwtc ], $data->{kwalitee}, $m->{cpants} // "https://cpants.cpanauthors.org/dist/$dist");
dta (["cvr",$cvrc ], $cvrt, $cvrr);
dta (["cpt","pass"], $data->{cptst}[0] // "", $m->{ct} // "http://www.cpantesters.org/show/$dist.html");
dta (["cpt","na" ], $data->{cptst}[1] // "");
dta (["cpt","fail"], $data->{cptst}[2] // "", $m->{ctm} // "http://matrix.cpantesters.org/?dist=$dist");
dta ($cos_class, $cos, "http://deps.cpantesters.org/?module=$mod&perl=5.22.0&os=Any+OS");
dta (["rd" ], $rd, $m->{rd} // "http://deps.cpantesters.org/depended-on-by.pl?module=$mod");
dta (["kwt" ], $data->{fav},
$data->{fav} eq "-" ? undef : "https://v1.metacpan.org/release/$dist/plussers");
dta (["kwt" ], $data->{rating}, $rating);
say $html qq{ </tr>};
$opt_t && $opt_v and show_times;
}
print $html <<"EOH";
<tr><td colspan="19"><hr /></td></tr>
<tr>
<td><a href="http://backpan.perl.org/authors/id/$auid3/$author/">BackPAN</a></td>
<td colspan="11"><a href="http://analysis.cpantesters.org/?author=$author&age=91.3&SUBMIT_xxx=Submit">CPANTESTERS analysis</a></td>
<td colspan="3" class="center"><a href="http://matrix.cpantesters.org/?author=$author">matrix</a></td>
<td colspan="4"></td>
</tr>
</tbody>
</table>
</td>
</tr>
EOH
$opt_t && !$opt_v and show_times;
} # modules
sub header {
print $html <<"EOH";
<?xml version="1.0" encoding="utf-8"?>
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.1//EN" "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd">
<html xmlns="http://www.w3.org/1999/xhtml" lang="en">
<head>
<meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
<meta name="Generator" content="makewww.pl" />
<meta name="Author" content="H.Merijn Brand" />
<meta name="Description" content="Perl" />
<title>$author - Perl QA page</title>
<link rel="stylesheet" type="text/css" href="tux.css" />
</head>
<body>
<table>
EOH
} # header
sub footer {
my @d = localtime;
my $stamp = sprintf "%04d-%02d-%02d", $d[5] + 1900, $d[4] + 1, $d[3];
print $html <<"EOH";
<tr class="boxed">
<td class="boxed">
<p class="header">Perl resources:</p>
<table>
<tr>
<td><a href="http://amsterdam.pm.org/">Amsterdam Perl Mongers</a></td>
<td><a href="http://www.perl.org">perl.org</a></td>
</tr>
<tr>
<td><a href="https://v1.metacpan.org">CPAN</a></td>
<td><a href="http://backpan.perl.org">BackPAN</a></td>
</tr>
<tr>
<td><a href="http://www.perlmonks.org">Perl Monks</a></td>
<td><a href="http://use.perl.org">use perl;</a></td>
</tr>
<tr>
<td><a href="http://www.cpantesters.org">cpantesters</a></td>
<td><a href="http://matrix.cpantesters.org">matrix</a></td>
</tr>
<tr>
<td><a href="http://blogs.perl.org">perl blogs</a></td>
<td><a href="http://p3rl.org">p3rl</a></td>
</tr>
<tr>
<td><a href="http://doc.perl6.org">perl6 documentation</a></td>
<td><a href="http://modules.perl6.org">perl6 modules</a></td>
</tr>
<tr>
<td><a href="http://www.perl.org/docs.html">perl5 documentation</a></td>
<td><a href="http://www.perl.org/learn.html">learning perl</a></td>
</tr>
</table>
</td>
</tr>
</table>
<table>
<tr>
<td class="footer"> </td>
<td class="footer" style="text-align:center">
last update: $stamp
</td>
<td></td>
</tr>
</table>
</body>
</html>
EOH
} # footer