Permalink
Switch branches/tags
Nothing to show
Find file Copy path
Fetching contributors…
Cannot retrieve contributors at this time
executable file 464 lines (385 sloc) 12 KB
#!/usr/bin/perl -w
# -*- perl -*-
#
# Author: Slaven Rezic
#
# Copyright (C) 2008,2012,2013,2014,2015,2017,2018 Slaven Rezic. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
#
# Mail: slaven@rezic.de
# WWW: http://www.rezic.de/eserte/
#
use strict;
use Getopt::Long;
use Test::Reporter;
use File::Basename;
use POSIX qw(strftime);
sub check_term_title ();
sub set_term_title ($);
sub _ts ();
my $use_mail;
my $cpan_uid = 'srezic';
my $limit;
my $beta_test;
my $delay_retry = 60;
my $max_retry = 5;
my $fails_first;
my $special_fail_sorting;
GetOptions(
"mail" => \$use_mail,
"cpan-uid=s" => \$cpan_uid,
"limit=i" => \$limit,
"beta" => \$beta_test,
"max-retry=i" => \$max_retry,
"delay-retry=i" => \$delay_retry,
"fails-first!" => \$fails_first,
"special-fail-sorting!" => \$special_fail_sorting,
)
or die "usage: $0 [-mail] [-cpan-uid ...] [-limit number] [-max-retry number] [-fails-first]\n";
#more_metabase_diagnostics(); # XXX maybe run conditionally
my $reportdir = shift || "$ENV{HOME}/var/cpansmoker";
if (!-d $reportdir) {
die "$reportdir does not look like a directory";
}
my @reports = @ARGV;
my $sync_dir = "$reportdir/sync";
my $done_root_dir = "$reportdir/done";
my $done_dir = "$done_root_dir/" . strftime("%Y-%m", localtime);
my $process_dir = "$reportdir/process";
if (!-d $sync_dir) {
warn "Create $sync_dir and move reports to this directory...";
}
if (!-d $done_root_dir) {
mkdir $done_root_dir or die "While creating $done_root_dir: $!";
}
if (!-d $done_dir) {
mkdir $done_dir or die "While creating $done_dir: $!";
}
if (!-d $process_dir) {
mkdir $process_dir or die "While creating $process_dir: $!";
}
# If reports are specified on command line: check that all are below $sync_dir
for my $report (@reports) {
if (index($report, "$sync_dir/") != 0) {
die "$report is not below $sync_dir";
}
}
check_term_title;
if (!@reports) {
@reports = (
glob("$sync_dir/pass.*.rpt"),
glob("$sync_dir/na.*.rpt"),
);
my @fails = glob("$sync_dir/fail.*.rpt");
my @unknowns = glob("$sync_dir/unknown.*.rpt");
if (@fails && $special_fail_sorting) {
#warn qq{INFO: running special "unsimilarity" sorter, which is somewhat slow...\n};
#@fails = UnsimilaritySorter::run(@fails);
@fails = simple_unsimilarity_sorter(@fails);
}
if ($fails_first) {
unshift @reports, @unknowns;
unshift @reports, @fails;
} else {
push @reports, @unknowns;
push @reports, @fails;
}
}
if (!@reports) {
set_term_title 'No reports to send';
exit 0;
}
if ($limit && $limit < scalar(@reports)) {
print STDERR "Limit number of reports from " . scalar(@reports) . "... ";
@reports = @reports[0..$limit-1];
print STDERR "to " . scalar(@reports) . ".\n";
}
my $progress = eval {
require Time::Progress;
Time::Progress->new(min => 0, max => scalar(@reports));
};
my $sending_reports_msg = sub {
my $reports_i = shift;
"Sending reports (" . $reports_i . "/" . scalar(@reports) . ")" . ($progress && $reports_i ? $progress->report(" (yet %Emin)", $reports_i) : '') . ($beta_test ? " [-> BETA]" : "");
};
set_term_title $sending_reports_msg->(0);
my $should_exit;
$SIG{TERM} = $SIG{INT} = sub {
warn "INFO: signal caught, will exit as soon as possible\n";
$should_exit = 1;
};
my $reports_i = 0;
my $term_title_last_changed = time;
REPORTS_LOOP: for my $file (@reports) {
if ($should_exit) {
warn "INFO: now exiting because of signal\n";
last REPORTS_LOOP;
}
$reports_i++;
if (time - $term_title_last_changed >= 1) {
set_term_title $sending_reports_msg->($reports_i);
$term_title_last_changed = time;
}
warn "File $file does not exist anymore?", next if !-r $file;
warn "$file...\n";
my $process_file;
if ($beta_test) {
$process_file = $file;
} else {
$process_file = $process_dir . "/" . basename($file);
rename $file, $process_file
or die "Cannot move $file to $process_file: $!";
}
my @tr_args;
if ($use_mail) {
@tr_args = (from => "srezic\@cpan.org",
transport => "Net::SMTP",
mx => ["localhost"],
);
} else {
my $url = 'https://metabase.cpantesters.org/api/v1/';
if ($beta_test) {
$url = 'http://metabase-beta.cpantesters.org/api/v1';
}
@tr_args = (transport => 'Metabase',
transport_args => [
uri => $url,
id_file => "$ENV{HOME}/.cpanreporter/" . $cpan_uid . "_metabase_id.json",
],
);
}
DO_SEND: {
my $sleep_jitter = 5; # +/-5s
for my $try (1..$max_retry) {
if ($should_exit) {
warn "INFO: now exiting because of signal\n";
last REPORTS_LOOP;
}
my $r = Test::Reporter->new(@tr_args);
# XXX Another TR bug: should not set these two by default
# See https://rt.cpan.org/Ticket/Display.html?id=76447
# XXX see also below
undef $r->{_perl_version}->{_archname};
undef $r->{_perl_version}->{_osvers};
$r->read($process_file);
# XXX fix t::r bug?
# XXX Still problematic in current TR versions using Metabase?
$r->{_subject} =~ s{\n}{}g;
# XXX 2nd half on another TR bug: set the correct values for
# _archname and _osvers
# See https://rt.cpan.org/Ticket/Display.html?id=76447
{
use Config::Perl::V ();
my $perlv = $r->{_perl_version}->{_myconfig};
my $config = Config::Perl::V::summary(Config::Perl::V::plv2hash($perlv));
$r->{_perl_version}->{_archname} = $config->{archname};
$r->{_perl_version}->{_osvers} = $config->{osvers};
}
last DO_SEND if $r->send;
warn "[" . _ts . "] Something failed in $process_file: " . $r->errstr . ".\n";
if ($try == $max_retry) {
die "Stop.\n";
}
my $this_sleep = int($delay_retry + rand(2*$sleep_jitter) - $sleep_jitter);
$this_sleep = 1 if $this_sleep < 1;
warn "Sleeping ${this_sleep}s before retrying...\n";
sleep $this_sleep;
}
die "Should not happen";
}
if (!$beta_test) {
my $done_file = $done_dir . "/" . basename($file);
rename $process_file, $done_file
or die "Cannot move $process_file to $done_file: $!";
}
}
if ($should_exit) {
set_term_title "Report sender terminated";
} else {
set_term_title "Report sender finished";
}
{
my $cannot_xterm_title;
sub check_term_title () {
if (!eval { require XTerm::Conf; 1 }) {
if (!eval { require Term::Title; 1 }) {
$cannot_xterm_title = 1;
}
}
}
sub set_term_title ($) {
return if $cannot_xterm_title;
my $string = shift;
if (defined &XTerm::Conf::xterm_conf_string) {
print STDERR XTerm::Conf::xterm_conf_string(-title => $string);
} else {
Term::Title::set_titlebar($string);
}
}
}
sub _ts () {
strftime("%Y-%m-%d %H:%M:%S", localtime);
}
sub simple_unsimilarity_sorter {
my(@files) = @_;
my @out;
my $letters = 0;
while (@files) {
$letters++;
if ($letters > 1000) {
die "Possible problem, too many iterations (letters=$letters)";
}
my %seen;
for(my $file_i=0; $file_i<=$#files; $file_i++) {
my $file = $files[$file_i];
my $base = basename $file;
$base =~ s{^[^.]+\.}{};
my $prefix = substr($base, 0, $letters);
if (!$seen{$prefix}++) {
push @out, splice @files, $file_i, 1;
$file_i--;
}
}
}
@out;
}
{
package UnsimilaritySorter;
{
my %cache;
sub _normalize ($) {
my $f = shift;
my $normalized = $cache{$f};
return $normalized if defined $normalized;
($normalized = $f) =~ s{^[^.]+\.}{}; # "fail." ...
$normalized =~ s{\.\d+\.\d+\.rpt$}{};
$cache{$f} = $normalized;
}
}
{
my %cache;
sub _get_similarity ($$) {
my($f1,$f2) = @_;
my $similarity = $cache{"$f1 $f2"};
return $similarity if defined $similarity;
$cache{"$f1 $f2"} = $similarity = String::Similarity::similarity($f1, $f2);
}
}
sub run {
my(@unsorted) = @_;
require String::Similarity;
my @sorted = shift @unsorted;
# O(n^3) :-(
while (@unsorted) {
my $min_similarity;
my $min_similarity_file_i;
for my $i (0 .. $#unsorted) {
my $f = $unsorted[$i];
my $f_cmp = _normalize $f;
my $this_max_similarity;
for my $f2 (@sorted) {
my $f2_cmp = _normalize $f2;
#my $similarity = similarity $f_cmp, $f2_cmp, (defined $this_max_similarity ? $this_max_similarity : ());
my $similarity = _get_similarity $f_cmp, $f2_cmp;
if (!defined $this_max_similarity || $similarity > $this_max_similarity) {
$this_max_similarity = $similarity;
}
}
if (!defined $min_similarity || $this_max_similarity < $min_similarity) {
$min_similarity = $this_max_similarity;
$min_similarity_file_i = $i;
}
}
if (!defined $min_similarity_file_i) {
die "should not happen";
}
push @sorted, splice(@unsorted, $min_similarity_file_i, 1);
}
@sorted;
}
}
# XXX monkey patch for more diagnostics
sub more_metabase_diagnostics {
require Metabase::Client::Simple;
no warnings 'once'; # but keep the redefine warning
*Metabase::Client::Simple::submit_fact = sub {
my ( $self, $fact ) = @_;
my $path = sprintf 'submit/%s', $fact->type;
$fact->set_creator( $self->profile->resource )
unless $fact->creator;
my $req_uri = $self->_abs_uri($path);
my $auth = $self->_ua->_uri_escape(
join( ":", $self->profile->resource->guid, $self->secret->content ) );
$req_uri->userinfo($auth);
my @req = (
$req_uri,
{
headers => {
Content_Type => 'application/json',
Accept => 'application/json',
},
content => JSON::MaybeXS->new( { ascii => 1 } )->encode( $fact->as_struct ),
},
);
my $res = $self->_ua->post(@req);
if ( $res->{status} == 401 ) {
if ( $self->guid_exists( $self->profile->guid ) ) {
Carp::confess($self->_error( $res => "authentication failed" ));
}
$self->register; # dies on failure
# should now be registered so try again
$res = $self->_ua->post(@req);
}
unless ( $res->{success} ) {
require Data::Dumper; print STDERR "Line " . __LINE__ . ", File: " . __FILE__ . "\n" . Data::Dumper->new([$res],[qw()])->Indent(1)->Useqq(1)->Sortkeys(1)->Terse(1)->Dump; # XXX
Carp::confess($self->_error( $res => "fact submission failed" ));
}
# This will be something more informational later, like "accepted" or
# "queued," maybe. -- rjbs, 2009-03-30
return 1;
};
}
__END__
=head1 NAME
send_tr_reports.pl - send filed Test::Reporter reports to metabase
=head1 STANDALONE USAGE
Create a directory F<var/cpansmoker/sync> in your C<$HOME> directory
and move the test reports to this directory. Run the script (of course
replace with your cpan user id):
send_tr_reports.pl --cpan-uid=srezic
Reports are first moved to the F<process> subdirectory, then processed
and moved further to the F<done> subdirectory. In case sending to
metabase fails, the report will still be in F<process> and has to be
moved manually to F<sync>.
=head1 SAMPLE COMPLETE WORKFLOW
I<(Warning: this section is probably not useful!)>
See CPAN/CPAN::Reporter configuration below:
The good (non-fail) reports. On the windows machine
ssh 192.168.1.253
cd /cygdrive/c/Users/eserte/ctr
ls sync/* && echo "sync is not empty" || mv *.rpt sync/
rsync -v -a sync/*.rpt eserte@biokovo:var/ctr/new/ && mv sync/*.rpt done/
On the unix machine
ctr_good_or_invalid.pl
send_tr_reports.pl
Now review the fail reports on the windows machine. Invalid ones move
to the invalid/ subdirectory.
=head2 CPAN::REPORTER CONFIGURATION
In /cygdrive/c/Users/eserte/Documents/.cpanreporter/config.ini:
edit_report=default:no
email_from=srezic@cpan.org
send_report=default:yes
transport=File C:\Users\eserte\ctr
Basically the same configuration can be used for cygwin
~/.cpanreporter/config.ini, just use the cygwin path style for the
transport directory.
edit_report=default:no
email_from=srezic@cpan.org
send_report=default:yes
transport=File /cygdrive/c/Users/eserte/ctr
=head1 AUTHOR
Slaven Rezic
=head1 SEE ALSO
L<Test::Reporter>.
=cut