You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
911 lines
28 KiB
911 lines
28 KiB
package Koha::Release;
|
|
|
|
use Moose;
|
|
use Modern::Perl;
|
|
use POSIX qw(strftime);
|
|
use Template;
|
|
use LWP::Simple;
|
|
use WWW::Mechanize;
|
|
use File::Basename;
|
|
use FindBin qw($Bin);
|
|
use YAML qw(LoadFile DumpFile);
|
|
use List::MoreUtils qw(uniq);
|
|
use Koha::BZ;
|
|
use Text::MultiMarkdown;
|
|
use HTML::TableExtract;
|
|
use IO::Prompt::Tiny qw/prompt/;
|
|
use Encode qw/decode_utf8/;
|
|
|
|
# Set STDIN to unicode for git execution
|
|
use open IN => ":encoding(UTF-8)";
|
|
|
|
has version => (
|
|
is => 'rw',
|
|
isa => 'HashRef',
|
|
default => sub {
|
|
my $version;
|
|
eval {
|
|
require 'kohaversion.pl';
|
|
$version = kohaversion();
|
|
};
|
|
say $version;
|
|
my @parts = split /\./, $version;
|
|
die "No usable version" unless @parts == 4;
|
|
if ( $parts[3] =~ /(.*)-(.*)$/ ) {
|
|
push @parts, $2;
|
|
$parts[3] = $1;
|
|
}
|
|
else {
|
|
push @parts, '';
|
|
}
|
|
$version = {
|
|
major => $parts[0],
|
|
minor => $parts[1],
|
|
release => $parts[2],
|
|
increment => $parts[3],
|
|
additional => $parts[4],
|
|
ismajor => $parts[2] + 0 == 0,
|
|
};
|
|
|
|
# Use .11 if .06 and .05 if .12
|
|
$version->{is_dev} = ( $version->{minor} == 6 || $version->{minor} == 12 ? 1 : 0 );
|
|
my ( $next_major_version, $next_minor_version );
|
|
if ( $version->{is_dev} ) {
|
|
$next_major_version = $version->{minor} == 12 ? $version->{major} + 1 : $version->{major};
|
|
$next_minor_version = ( $version->{minor} + 5 ) % 12;
|
|
} else {
|
|
$next_major_version = $version->{major};
|
|
$next_minor_version = $version->{minor};
|
|
}
|
|
|
|
# Warning:
|
|
# - "next_version" is the current version if we are not in a dev cycle
|
|
# - next_version_human does not content the "additional part" like 'human'
|
|
$version->{next_major} = $next_major_version;
|
|
$version->{next_minor} = $next_minor_version;
|
|
$version->{next_version_human} = sprintf("%d.%02d", $version->{next_major}, $version->{next_minor});
|
|
|
|
my $human = sprintf("%d.%02d.%02d", $version->{major}, $version->{minor}, $version->{release});
|
|
$human .= '_' . $version->{additional} if $version->{additional};
|
|
#$human = $version->{next_version_human}; $human .= '.00'; # When we are in RC!
|
|
$version->{human} = $human;
|
|
$human =~ s/\./_/g;
|
|
$version->{filesys} = $human;
|
|
return $version;
|
|
},
|
|
);
|
|
|
|
has rootdir => (
|
|
is => 'rw',
|
|
isa => 'Str',
|
|
# default => sub {
|
|
# my $rootdir = dirname(__FILE__) . "/../../";
|
|
# return $rootdir;
|
|
#}
|
|
);
|
|
|
|
# Config file: /etc/config.yaml
|
|
has c => (
|
|
is => 'rw',
|
|
isa => 'HashRef',
|
|
lazy => 1,
|
|
builder => '_build_c'
|
|
);
|
|
|
|
sub _build_c {
|
|
my $self = shift;
|
|
my $rootdir = $self->rootdir;
|
|
my $file = $rootdir . "etc/config.yaml";
|
|
unless ( -e $file ) {
|
|
say "$file doesn't exist";
|
|
exit;
|
|
}
|
|
my $defaults = LoadFile($file);
|
|
my $local = {};
|
|
my $user = $rootdir . "etc/user.yaml";
|
|
unless ( -e $user ) {
|
|
say "$user doesn't exist, are you sure you don't want to use it?";
|
|
print "\n\n\n\n";
|
|
} else {
|
|
$local = LoadFile($user);
|
|
}
|
|
my $config = { %{$defaults}, %{$local} };
|
|
return $config;
|
|
}
|
|
|
|
# Dev map file: /etc/dev_map.yaml
|
|
has dev_map => (
|
|
is => 'rw',
|
|
isa => 'HashRef',
|
|
lazy => 1,
|
|
builder => '_build_devs',
|
|
trigger => sub {
|
|
my ( $self, $authors ) = @_;
|
|
my $rootdir = $self->rootdir;
|
|
my $file = $rootdir . "/etc/dev_map.yaml";
|
|
DumpFile( $file, $authors );
|
|
|
|
my $names;
|
|
for my $email ( keys %{$authors} ) {
|
|
for my $name ( keys %{ $authors->{$email} } ) {
|
|
$names->{$name}->{ $authors->{$email}->{$name} } = 1;
|
|
}
|
|
}
|
|
$self->dev_names($names);
|
|
}
|
|
);
|
|
has dev_names => (
|
|
is => 'rw',
|
|
isa => 'HashRef'
|
|
);
|
|
|
|
sub _build_devs {
|
|
my $self = shift;
|
|
my $rootdir = $self->rootdir;
|
|
my $devs = $rootdir."etc/dev_map.yaml";
|
|
unless ( -e $devs ) {
|
|
say "$devs doesn't exist";
|
|
exit;
|
|
}
|
|
my $map = LoadFile($devs);
|
|
return $map;
|
|
}
|
|
|
|
# Sponsor map file: /etc/sponsor_map.yaml
|
|
has sponsor_map => (
|
|
is => 'rw',
|
|
isa => 'HashRef',
|
|
lazy => 1,
|
|
builder => '_build_sponsors',
|
|
trigger => sub {
|
|
my ( $self, $sponsors ) = @_;
|
|
my $rootdir = $self->rootdir;
|
|
my $file = $rootdir . "/etc/sponsor_map.yaml";
|
|
DumpFile( $file, $sponsors );
|
|
}
|
|
);
|
|
sub _build_sponsors {
|
|
my $self = shift;
|
|
my $rootdir = $self->rootdir;
|
|
my $sponsors = $rootdir."etc/sponsor_map.yaml";
|
|
unless ( -e $sponsors ) {
|
|
say "$sponsors doesn't exist";
|
|
exit;
|
|
}
|
|
my $map = LoadFile($sponsors);
|
|
return $map;
|
|
}
|
|
|
|
# The range of commits used to find patches included in the release
|
|
# For example: v3.22.01..3.22.x
|
|
has range => (
|
|
is => 'rw',
|
|
isa => 'Str',
|
|
trigger => sub {
|
|
my ( $self, $range ) = @_;
|
|
|
|
my @commits;
|
|
my $bugs;
|
|
my $authors;
|
|
my $sponsors = {};
|
|
my $signers;
|
|
my $mentors;
|
|
|
|
my $committed;
|
|
my $author_name;
|
|
my $author_email;
|
|
my $author;
|
|
my $bug;
|
|
|
|
my @lines =
|
|
qx|git log --pretty=format:'~-%ct,%an,%ae%n%s%n%n%b%n~----~' $range 2>/dev/null|;
|
|
|
|
my $commit_title;
|
|
for my $line (@lines) {
|
|
|
|
# Start of commit
|
|
if ( $line =~ m/^~-(.*),(.*),(.*)$/g ) {
|
|
|
|
# Reset
|
|
( $committed, $author_name, $author_email, $bug ) =
|
|
( $1, $2, $3, undef );
|
|
$author = $self->_disambiguate_author($author_name, $author_email);
|
|
$authors->{$author}++;
|
|
$commit_title = 1; # Next line will be the commit title
|
|
next;
|
|
}
|
|
|
|
# End of commit
|
|
elsif ( $line =~ m/^~----~$/ ) {
|
|
if ($bug) {
|
|
$bugs->{$bug}->{'authors'}->{$author}++;
|
|
}
|
|
}
|
|
|
|
# Summary line - Grab the bug number when available in commit message
|
|
elsif (
|
|
$commit_title
|
|
&& $line =~ m/^(?:[B|b]ug|BZ)?\s?(?<![a-z]|\.)(\d{3,5})[\s|:|,]/g )
|
|
{
|
|
$bug = $1;
|
|
$bugs->{$bug}->{commits}++;
|
|
push @commits, { committed => $committed, author => $author };
|
|
$commit_title = 0;
|
|
}
|
|
|
|
# Other commit content
|
|
else {
|
|
next if ( $line =~ m/^$/ ); # Skip empty lines
|
|
next if ( !$bug ); # Skip if we're not within a 'bug' commit
|
|
|
|
# Trailers
|
|
if ( $line =~ m/^Signed-off-by:\s(.*)\s<(.*)>$/ ) {
|
|
my ( $name, $email ) = ( $1, $2 );
|
|
my $signer = $self->_disambiguate_author($name, $email);
|
|
$signers->{$signer}++ if $author_email ne $email;
|
|
}
|
|
elsif ( $line =~ m/^Sponsored-by:\s(.*)(?>\s[<\[](.*)[>\]])$/ ) {
|
|
my $sponsor = $self->_disambiguate_sponsor($1, $2);
|
|
$sponsors->{$sponsor->{name}} = $sponsor->{url};
|
|
$bugs->{$bug}->{'sponsors'}->{$sponsor->{name}} = $sponsor->{url};
|
|
}
|
|
elsif ( $line =~ m/^Sponsored-by:\s(.*)$/ ) {
|
|
my $sponsor = $self->_disambiguate_sponsor($1);
|
|
$sponsors->{$sponsor->{name}} = $sponsor->{url};
|
|
$bugs->{$bug}->{'sponsors'}->{$sponsor->{name}} = $sponsor->{url};
|
|
}
|
|
elsif ( $line =~ m/^Mentored-by:\s(.*)\s<(.*)>$/ ) {
|
|
my ( $name, $email ) = ( $1, $2 );
|
|
my $mentor = $self->_disambiguate_author($name, $email);
|
|
$mentors->{$mentor}++;
|
|
$bugs->{$bug}->{'mentors'}->{$mentor}++;
|
|
}
|
|
elsif ( $line =~ m/^Signed-off-by:(.*)$/ ) {
|
|
my ($SO) = ($1);
|
|
$SO =~ s/^\s+|\s+$//g;
|
|
my ($name, $email) = ('', '');
|
|
if ( $SO =~ m/[\w|\.|\-]*@[\w|\.|\-]*$/ ) {
|
|
$email = $SO;
|
|
} else {
|
|
$name = $SO;
|
|
}
|
|
my $signer = $self->_disambiguate_author($name, $email);
|
|
$signers->{$signer}++;
|
|
#warn "Badly formed sign off line on bug $bug: $SO\n";
|
|
}
|
|
}
|
|
}
|
|
|
|
if (@commits) {
|
|
say "Range $range: ", scalar(@commits), " commits";
|
|
$self->range_commits( \@commits );
|
|
|
|
# alphabetised by last 'name' list of authors
|
|
$self->range_authors(
|
|
[
|
|
map { { name => $_, commits => $authors->{$_} } }
|
|
sort {
|
|
my ($alast) = $a =~ /(\S+)$/;
|
|
my ($blast) = $b =~ /(\S+)$/;
|
|
lc($alast) cmp lc($blast)
|
|
} keys %{$authors}
|
|
]
|
|
);
|
|
|
|
# alphabetised by last 'name' list of signers
|
|
$self->range_signers(
|
|
[
|
|
map { { name => $_, signoffs => $signers->{$_} } }
|
|
sort {
|
|
my ($alast) = $a =~ /(\S+)$/;
|
|
my ($blast) = $b =~ /(\S+)$/;
|
|
lc($alast) cmp lc($blast)
|
|
} keys %{$signers}
|
|
]
|
|
);
|
|
|
|
# alphabetised by last 'name' list of mentors
|
|
$self->range_mentors(
|
|
[
|
|
map { { name => $_, mentees => $mentors->{$_} } }
|
|
sort {
|
|
my ($alast) = $a =~ /(\S+)$/;
|
|
my ($blast) = $b =~ /(\S+)$/;
|
|
lc($alast) cmp lc($blast)
|
|
} keys %{$mentors}
|
|
]
|
|
);
|
|
|
|
$self->range_sponsors($sponsors);
|
|
$self->range_bugs($bugs);
|
|
}
|
|
else {
|
|
say "Invalid range: $range";
|
|
exit 1;
|
|
}
|
|
return $range;
|
|
}
|
|
);
|
|
|
|
sub _disambiguate_author {
|
|
my ( $self, $name, $email ) = @_;
|
|
|
|
my $silent = $self->silent;
|
|
|
|
my $authors = $self->dev_map;
|
|
my $names = $self->dev_names;
|
|
if ( !defined( $authors->{$email}->{$name} ) && !$silent ) {
|
|
|
|
print "\n\nNew contributor found with email $email and name $name\n";
|
|
print "Previous matches for this name: "
|
|
. join( " ", ( keys %{ $names->{$name} } ) ) . "\n";
|
|
print "Previous matches for this email: "
|
|
. join( " ", ( keys %{ $authors->{$email} } ) ) . "\n";
|
|
my $author =
|
|
decode_utf8(
|
|
prompt( "Please enter their name for disambiguation:", "$name" ) );
|
|
$authors->{$email}->{$name} = $author;
|
|
|
|
# Update the authoritive map
|
|
$self->dev_map($authors);
|
|
}
|
|
|
|
return exists($authors->{$email}->{$name}) ? $authors->{$email}->{$name} : $name;
|
|
}
|
|
|
|
sub _disambiguate_sponsor {
|
|
my ( $self, $name, $url ) = @_;
|
|
|
|
my $sponsor = $self->_disambiguate_author($name, '');
|
|
|
|
my $silent = $self->silent;
|
|
|
|
my $sponsors = $self->sponsor_map;
|
|
if ( !defined( $sponsors->{$sponsor} ) ) {
|
|
|
|
print "\n\nNew sponsor found with name $sponsor\n";
|
|
print "Setting URL to '$url'\n" if defined($url);
|
|
print "Setting URL to undefined\n" if !defined($url);
|
|
$sponsors->{$sponsor}->{url} = $url;
|
|
|
|
# Update the authoritive map
|
|
$self->sponsor_map($sponsors);
|
|
} elsif ( defined($url) && $sponsors->{$sponsor}->{url} ne $url ) {
|
|
|
|
print "\n\nNew URL found for sponsor $sponsor\n";
|
|
my $update = prompt( "Update from $sponsors->{$sponsor}->{url} to $url? [Y/N]", "N" );
|
|
if ( uc($update) eq 'Y' ) {
|
|
$sponsors->{$sponsor}->{url} = $url;
|
|
$self->sponsor_map($sponsors);
|
|
}
|
|
}
|
|
|
|
return { name => $sponsor, url => $sponsors->{$sponsor}->{url} };
|
|
}
|
|
|
|
has range_commits => ( is => 'rw', isa => 'ArrayRef' );
|
|
has range_authors => ( is => 'rw', isa => 'ArrayRef' );
|
|
has range_sponsors => ( is => 'rw', isa => 'HashRef' );
|
|
has range_mentors => ( is => 'rw', isa => 'ArrayRef' );
|
|
has range_signers => ( is => 'rw', isa => 'ArrayRef' );
|
|
has range_bugs => ( is => 'rw', isa => 'HashRef' );
|
|
|
|
has bz => (
|
|
is => 'rw',
|
|
isa => 'Koha::BZ',
|
|
lazy => 1,
|
|
builder => '_build_bz'
|
|
);
|
|
|
|
|
|
sub trim {
|
|
my ($s) = @_;
|
|
$s =~ s/^\s*(.*?)\s*$/$1/s;
|
|
return $s;
|
|
}
|
|
|
|
|
|
sub _build_bz {
|
|
my $c = shift->c->{bz};
|
|
my $login = $ENV{BZ_login} || $c->{login};
|
|
my $password = $ENV{BZ_password} || $c->{password};
|
|
Koha::BZ->new(
|
|
url => $c->{url},
|
|
login => $login,
|
|
password => $password,
|
|
);
|
|
}
|
|
|
|
has silent => ( is => 'ro', isa => 'Str' );
|
|
|
|
around BUILDARGS => sub {
|
|
my $orig = shift;
|
|
my $class = shift;
|
|
my @args = @_;
|
|
|
|
my $rootdir = dirname(__FILE__) . "/../../";
|
|
push @args, ( rootdir => $rootdir );
|
|
|
|
return $class->$orig(@args);
|
|
};
|
|
|
|
sub BUILD {
|
|
my $self = shift;
|
|
|
|
# Add codename to version
|
|
my $version = $self->version;
|
|
if ( $version->{is_dev} ) {
|
|
$version->{codename} = 'development';
|
|
} else {
|
|
my $walk = $self->c->{master};
|
|
my $step = 0;
|
|
$version->{codename} = 'stable';
|
|
while ( $walk ne $version->{next_version_human} ) {
|
|
my $major = substr( $walk, 0, 2 );
|
|
my $minor = substr( $walk, 3, 2 );
|
|
if ( $minor eq '05' ) {
|
|
$major = $major - 1;
|
|
$minor = '11';
|
|
} else {
|
|
$minor = '05';
|
|
}
|
|
$version->{codename} = $step ? 'old' . $version->{codename} : $version->{codename};
|
|
$step++;
|
|
$walk = $major . "." . $minor;
|
|
}
|
|
}
|
|
$self->version($version);
|
|
}
|
|
|
|
# Modify
|
|
sub updatebz {
|
|
my $self = shift;
|
|
|
|
my $codename = ( $self->version->{release} eq '00' ) ? 'master' : $self->version->{codename};
|
|
say "Change bug status from 'Pushed to ".$codename." to 'RESOLVED FIXED'";
|
|
|
|
my $vars = {};
|
|
$self->bugs($vars);
|
|
$vars = $vars->{bugs};
|
|
my @bugs;
|
|
for ( values %$vars ) {
|
|
for ( values %$_ ) {
|
|
push @bugs, $_->{id} for @$_;
|
|
}
|
|
}
|
|
@bugs = sort { $a <=> $b } @bugs;
|
|
my $response = $self->bz->get("bug?include_fields=id,status,summary&id=" . join(',', @bugs));
|
|
@bugs = @{$response->{bugs}};
|
|
@bugs = grep { $_->{status} =~ /pushed to $codename/i } @bugs;
|
|
|
|
for my $bug (@bugs) {
|
|
say $bug->{id}, ': ', $bug->{summary}, ' -- ', $bug->{status};
|
|
$self->bz->put(
|
|
'bug',
|
|
{ ids => [ $bug->{id} ], status => 'RESOLVED', resolution => 'FIXED' }
|
|
);
|
|
}
|
|
}
|
|
|
|
=head2
|
|
|
|
$self->updatebz_push;
|
|
|
|
This routine is used by the koha-push script to update bugzilla whea release manager/maintainer pushed their respective patches up to the public repository.
|
|
|
|
It will try to intelligently guess branch names to to get the difference between your local branch and what is already available upstream on the hosted repository.
|
|
|
|
=cut
|
|
|
|
sub updatebz_push {
|
|
my $self = shift;
|
|
my $range = shift;
|
|
|
|
my $remote_name = $self->c->{remote} || 'origin';
|
|
my $codename =
|
|
( $self->version->{release} eq '00' )
|
|
? 'master'
|
|
: $self->version->{codename};
|
|
my $status_after = "Pushed to $codename";
|
|
my $next_version =
|
|
( $codename eq 'master' )
|
|
? $self->version->{next_version_human} . ".00"
|
|
: $self->version->{next_version_human};
|
|
|
|
my $local_branch = `git rev-parse --abbrev-ref HEAD`; chomp $local_branch;
|
|
my $remote_branch = ($codename eq 'master') ? 'master' : $self->version->{major} . "." . $self->version->{minor} . ".x";
|
|
die "Are you sure you're on the right branch? $local_branch : $remote_branch" unless ( $local_branch eq $remote_branch );
|
|
$range //= "$remote_name/$remote_branch..HEAD";
|
|
my $fetch = `git fetch $remote_name`;
|
|
|
|
my $vars = {};
|
|
$self->range($range);
|
|
$self->bugs($vars);
|
|
$vars = $vars->{bugs};
|
|
my @bugs;
|
|
for ( values %$vars ) {
|
|
for ( values %$_ ) {
|
|
push @bugs, $_->{id} for @$_;
|
|
}
|
|
}
|
|
|
|
@bugs = sort { $a <=> $b } @bugs;
|
|
my $response = $self->bz->get(
|
|
"bug?include_fields=id,status,summary,cf_release_version,product&id="
|
|
. join( ',', @bugs ) );
|
|
@bugs = @{ $response->{bugs} };
|
|
|
|
# FIXME adjust this for stable branches
|
|
if ( $codename eq 'master' ) {
|
|
say "Going to mark the following bug as 'Pushed to master'";
|
|
for my $bn ( map { $_->{id} } @bugs ) {
|
|
unless ( $bn =~ m|^\d+$| ) {
|
|
say "WARNING - Bug '$bn' is not a valid bug number, skipping";
|
|
next;
|
|
}
|
|
say "- $bn";
|
|
}
|
|
my $mark_as_pushed = prompt('OK?: ');
|
|
exit 0 unless $mark_as_pushed eq 'yes';
|
|
print "\n";
|
|
}
|
|
|
|
for my $bug (@bugs) {
|
|
say "\nWorking on bug ".$bug->{id};
|
|
|
|
# Check bug has correct status
|
|
if ( $codename eq 'master' and $bug->{status} ne 'Passed QA' ) {
|
|
warn sprintf( " * SKIP - Incorrect status found for bug %s -- %s\n", $bug->{id}, $bug->{status} );
|
|
next;
|
|
}
|
|
elsif ( $codename ne 'master'
|
|
and $bug->{status} =~ m/^Pushed to (?:(?:old)*stable|master)$/ )
|
|
{
|
|
warn sprintf( " * SKIP - Incorrect status found for bug %s -- %s\n", $bug->{id}, $bug->{status} );
|
|
next;
|
|
} elsif ( $codename eq 'master' and $bug->{product} ne 'Koha' ) {
|
|
warn sprintf( " * SKIP - Incorrect product found for bug %s -- %s\n", $bug->{id}, $bug->{product} );
|
|
next;
|
|
}
|
|
|
|
my $release_version = $_->{cf_release_version} // '';
|
|
my @release_version = split(", ", $release_version);
|
|
push @release_version, $next_version;
|
|
$release_version = join(", ", @release_version);
|
|
my $id = $bug->{id} + 0;
|
|
|
|
say sprintf " * Changing status from '%s' to '%s' (pushed to %s)", $bug->{status}, $status_after, $release_version;
|
|
$self->bz->put(
|
|
"bug/$id",
|
|
{
|
|
ids => [ $id ],
|
|
status => $status_after,
|
|
cf_release_version => $release_version
|
|
}
|
|
);
|
|
|
|
say " * Adding comment";
|
|
$self->bz->post_comment(
|
|
$id,
|
|
{
|
|
comment => $self->c->{bz}->{comment},
|
|
is_private => 0
|
|
}
|
|
);
|
|
}
|
|
}
|
|
|
|
sub update_authors {
|
|
my $self = shift;
|
|
|
|
my $contributorsfile = 'docs/contributors.yaml';
|
|
unless ( -e $contributorsfile ) {
|
|
say
|
|
"$contributorsfile doesn't exist. Are you sure you're running from /kohaclone?";
|
|
exit;
|
|
}
|
|
my $contributors = LoadFile($contributorsfile);
|
|
|
|
my $range = $self->range;
|
|
my $range_commits = $self->range_commits;
|
|
|
|
for my $commit ( @{$range_commits} ) {
|
|
if ( !exists( $contributors->{ $commit->{author} } )
|
|
|| !exists( $contributors->{ $commit->{author} }->{first_commit} ) )
|
|
{
|
|
$contributors->{ $commit->{author} }->{commits} = 1;
|
|
$contributors->{ $commit->{author} }->{first_commit} =
|
|
$commit->{committed};
|
|
say "New commiter found, check doc/contributors.yaml";
|
|
}
|
|
}
|
|
DumpFile( $contributorsfile, $contributors );
|
|
}
|
|
|
|
sub download_pootle {
|
|
my $self = shift;
|
|
|
|
chdir 'misc/translator/po';
|
|
my $version = $self->version->{next_version} . '/';
|
|
|
|
# Login to Pootle
|
|
my $c = $self->c->{pootle};
|
|
my $login = $ENV{POOTLE_login} || $c->{login};
|
|
my $password = $ENV{POOTLE_password} || $c->{password};
|
|
my $url = $c->{url} . '/accounts/login/';
|
|
my $mech = WWW::Mechanize->new( autocheck => 0 );
|
|
$mech->get($url);
|
|
$mech->submit_form(
|
|
form_name => 'loginform',
|
|
fields => {
|
|
username => $login,
|
|
password => $password,
|
|
}
|
|
);
|
|
if ( $mech->base() =~ /login\/$/ ) {
|
|
say "Invalid login/password to Pootle";
|
|
exit;
|
|
}
|
|
|
|
$url = $c->{url} . "/projects/$version";
|
|
$mech->get($url);
|
|
my $page = $mech->content;
|
|
my @trans;
|
|
while ($page =~ m#<td class="stats-name">\W*<a href="(.*)">\W*<span>(\w*)</span>\W*</a>\W*</td>\W*<td class="stats-graph">\W*<div class="sortkey">([0-9]*)</div>#g) {
|
|
push @trans, $1;
|
|
}
|
|
for my $url (@trans) {
|
|
say $url;
|
|
$url = $c->{url} . $url . "export/zip";
|
|
$mech->get($url);
|
|
unless ($mech->success()) {
|
|
say "Error getting this ZIP";
|
|
next;
|
|
}
|
|
open my $fh, '>', 'toto.zip';
|
|
print $fh $mech->content;
|
|
close $fh;
|
|
qx|unzip -o toto.zip; rm toto.zip|;
|
|
}
|
|
chdir '../../..';
|
|
}
|
|
|
|
# Get all info about translations from Koha Pootle web site
|
|
sub translations {
|
|
my $self = shift;
|
|
my $for_manual = shift || 0;
|
|
|
|
my $url = $self->c->{pootle}->{url}
|
|
. '/projects/'
|
|
. ( $for_manual ? 'man' : '' )
|
|
. $self->version->{next_version_human}
|
|
. '/';
|
|
my $page = get($url);
|
|
unless ($page) {
|
|
say "Unable to get translation at this url: $url";
|
|
return;
|
|
}
|
|
my $translations = [ {language => 'English (USA)'} ];
|
|
|
|
my $translations_parser = HTML::TableExtract->new(
|
|
headers => [ "Name", "Progress", "Total", "Incomplete", "Last Activity" ]
|
|
);
|
|
$translations_parser->parse($page);
|
|
|
|
my $table = $translations_parser->first_table_found();
|
|
return $translations unless $table;
|
|
|
|
foreach my $language ($translations_parser->rows) {
|
|
next if !defined $language;
|
|
my $name = trim( @$language[0] );
|
|
my $progress = trim( @$language[1] );
|
|
$progress /= 10;
|
|
push @$translations, { language => $name, pcent => $progress } if ($progress > 50);
|
|
}
|
|
|
|
$translations = [ sort { $a->{language} cmp $b->{language} } @$translations ];
|
|
|
|
return $translations;
|
|
}
|
|
|
|
# Return bugs list
|
|
sub bugs {
|
|
my ($self, $vars) = @_;
|
|
|
|
my $range = $self->range;
|
|
my $bugs = $self->range_bugs;
|
|
|
|
# Grab a list of bug numbers
|
|
my @bugs = ( keys %{$bugs} );
|
|
return unless @bugs;
|
|
|
|
say "Found bugs: ", ( @bugs + 0 );
|
|
my $response = $self->bz->get( 'bug?id=' . join( ',', @bugs ) );
|
|
my ( $bugs_by_category, $bugscount );
|
|
for ( @{ $response->{bugs} } ) {
|
|
my $severity = $_->{severity};
|
|
my $category =
|
|
$_->{product} =~ /security/ ? 'secu' :
|
|
$severity =~ /blocker|critical|major/ ? 'high' :
|
|
$severity =~ /normal|minor|trivial/ ? 'normal' :
|
|
$severity =~ /enhancement/ ? 'enh' : 'feature';
|
|
my $bug = { id => $_->{id}, desc => $_->{summary} };
|
|
if ( exists( $bugs->{ $_->{id} }->{sponsors} ) ) {
|
|
$bug->{sponsors} = $bugs->{ $_->{id} }->{sponsors};
|
|
}
|
|
if ( $_->{cf_release_notes} ) {
|
|
my $notes = $_->{cf_release_notes};
|
|
$notes =~ s/\r//g;
|
|
$bug->{notes} = [ split("\n", $notes) ];
|
|
}
|
|
push @{ $bugs_by_category->{$category}->{ $_->{component} } }, $bug;
|
|
$category = 'normal' if $category eq 'high';
|
|
$bugscount->{$category}++;
|
|
}
|
|
$vars->{bugs} = $bugs_by_category;
|
|
$vars->{bugscount} = $bugscount;
|
|
}
|
|
|
|
|
|
# Returns a list of added sysprefs. Find syspref in sysprefs.sql not in
|
|
# templates
|
|
sub sysprefs {
|
|
my ($self, $vars) = @_;
|
|
|
|
my $range = $self->range;
|
|
my ($from, $to) =
|
|
$range =~ /(.*)\.\.(.*)/ ? ($1, $2) : ($range, 'HEAD');
|
|
|
|
my $sysprefs_path = 'installer/data/mysql/mandatory/sysprefs.sql';
|
|
my $old_sysprefs_path = 'installer/data/mysql/sysprefs.sql'; # Before 23895
|
|
|
|
my %syspref = map {
|
|
my ($where, $pos) = @$_;
|
|
my @sysprefs = qx{git show $pos:$sysprefs_path 2> /dev/null};
|
|
@sysprefs = qx{git show $pos:$old_sysprefs_path} unless @sysprefs;
|
|
my %all =
|
|
map { $_ => 1 }
|
|
map { /\(\s*'([^']+)'/; $1 }
|
|
grep { /\(\s*'/ }
|
|
@sysprefs;
|
|
$where => \%all
|
|
} ( ['prev', $from], ['curr', $to]);
|
|
|
|
my @sysprefs;
|
|
foreach my $pref (sort keys %{$syspref{curr}} ) {
|
|
push @sysprefs, { name => $pref }
|
|
unless $syspref{prev}->{$pref};
|
|
}
|
|
$vars->{sysprefs} = \@sysprefs if @sysprefs;
|
|
}
|
|
|
|
|
|
sub info {
|
|
my $self = shift;
|
|
|
|
unless ( -e 'kohaversion.pl' ) {
|
|
say "You must run this script being is Koha home directory";
|
|
exit;
|
|
}
|
|
|
|
my $version = $self->version;
|
|
my $range = $self->range;
|
|
|
|
my $vars = { version => $version };
|
|
|
|
$vars->{translations} = $self->translations();
|
|
$vars->{manual_translations} = $self->translations(1);
|
|
|
|
$vars->{branch} = `git branch | grep '*' | sed -e 's/^* //' -e 's#/#-#'`;
|
|
chomp $vars->{branch};
|
|
|
|
$vars->{downloadlink} = "http://download.koha-community.org/koha-" .
|
|
"$version->{major}.$version->{minor}.$version->{release}.tar.gz";
|
|
|
|
$self->bugs($vars);
|
|
$self->sysprefs($vars);
|
|
|
|
$vars->{contributors} = $self->range_authors;
|
|
$vars->{signers} = $self->range_signers;
|
|
$vars->{sponsors} = $self->range_sponsors;
|
|
$vars->{mentors} = $self->range_mentors;
|
|
|
|
my $kohadocs_repo = $self->c->{repo}{kohadocs};
|
|
if ( $kohadocs_repo ) {
|
|
my ( $from_commit, $to_commit ) = split '\.\.', $range;
|
|
my $from_date = `git show -s --format=%ci $from_commit^{commit}`;
|
|
chomp $from_date;
|
|
$to_commit = 'origin/master' unless $to_commit;
|
|
my $closest_from_commit = `git -C $kohadocs_repo rev-list -n 1 --before="$from_date" origin/master`;
|
|
chomp $closest_from_commit;
|
|
my $to_date = `git show -s --format=%ci $to_commit^{commit}`;
|
|
chomp $to_date;
|
|
my $closest_to_commit = `git -C $kohadocs_repo rev-list -n 1 --before="$to_date" origin/master`;
|
|
chomp $closest_to_commit;
|
|
$vars->{manual_contributors} = [ map {
|
|
/\s*(\d*)\s*(.*)\s*$/;
|
|
{ name => $2, commits => $1 }
|
|
} qx(git -C $kohadocs_repo shortlog -s --pretty=short $closest_from_commit..$closest_to_commit| sort -k3 -) ];
|
|
}
|
|
|
|
# contributing companies, with their number of commits, by alphabetical
|
|
# order companies are retrieved from the email address. generic emails
|
|
# like hotmail.com, gmail.com are cumulated in a "undentified"
|
|
# contributor
|
|
my $map = $self->c->{domainmap};
|
|
my $companies;
|
|
foreach (
|
|
qx(git shortlog -s -e --pretty=short $range | sort -k3 -) )
|
|
{
|
|
chop;
|
|
if ($_ =~ /(\d+).*@(.*)>/) {
|
|
my ($nbpatch, $company) = ($1,$2);
|
|
$company = 'Independant Individuals'
|
|
if $company =~ /o2\.pl|gmail\.com|hotmail\.com|\(none\)|yahoo|kanellov\.com|iki\.fi|kohadevbox|icloud\.com|outlook\.com|live\.nl|example\.com|stacmail\.net/;
|
|
$company = $map->{$company} if $map->{$company};
|
|
$companies->{$company} += $nbpatch;
|
|
}
|
|
else {
|
|
print "Failed to parse author for company for: '" . $_ . "'\n";
|
|
}
|
|
}
|
|
$vars->{companies} = [
|
|
map { { name => $_, commits => $companies->{$_} } }
|
|
sort { lc $a cmp lc $b } keys %$companies
|
|
];
|
|
|
|
$vars->{date} = strftime "%d %b %Y", gmtime;
|
|
$vars->{timestamp} = strftime("%d %b %Y %T", gmtime);
|
|
|
|
# Team retrieved from config.yaml
|
|
my $team = $self->c->{team}->{$self->c->{master}};
|
|
$vars->{team} = $team;
|
|
|
|
return $vars;
|
|
}
|
|
|
|
|
|
sub _md_file {
|
|
my $self = shift;
|
|
my $version = $self->version;
|
|
return "misc/release_notes/release_notes_$version->{filesys}.md";
|
|
}
|
|
|
|
sub build_notes {
|
|
my ($self, $html) = @_;
|
|
|
|
my $file = $self->_md_file();
|
|
say "Generate Markdown release notes file: $file";
|
|
|
|
my $tt;
|
|
$tt = Template->new({
|
|
INCLUDE_PATH => $self->rootdir . '/etc',
|
|
ENCODING => 'utf8',
|
|
}) || die $tt->error(), "\n";
|
|
my $vars = $self->info();
|
|
|
|
open( my $fh, '>:encoding(UTF-8)', $file )
|
|
or die "Unable to create $file: $!";
|
|
$tt->process("notes.tt", $vars, $fh) || die $tt->error(), "\n";
|
|
}
|
|
|
|
sub build_html {
|
|
my ($self, $html) = @_;
|
|
|
|
my $file = $self->_md_file();
|
|
say "Generate HTML release notes file '$html' from '$file'";
|
|
unless (-e $file) {
|
|
say "$file doesn't exist. You have to run 'koha-release range notes' first.";
|
|
exit;
|
|
}
|
|
open( my $fh, '>:encoding(UTF-8)', $html )
|
|
or die "Unable to create $file: $!";
|
|
my $m = Text::MultiMarkdown->new();
|
|
my $text = qx|cat $file|;
|
|
|
|
#utf8::decode($text);
|
|
print $fh $m->markdown($text);
|
|
}
|
|
|
|
1;
|
|
|
|
|