woger

#!/usr/bin/env perl
# Woger - make a release
my $version_banner = <<END;
Woger welease 45
Copyright (c) Reuben Thomas 2007-2024
Released under the GPL version 3, or (at your option) any later version.
END

# On Ubuntu/Debian:
# apt-get install libperl6-slurp-perl libset-scalar-perl s-nail luarocks gh
# (copher is not packaged in Ubuntu/Debian)

# Program dependencies:
#   For email: S-nail: https://www.sdaoden.eu/code.html
#   For SourceForge: copher: https://copher.sourceforge.net/
#   For GitHub: gh: https://github.com/cli/cli
#   For LuaRocks: luarocks: https://luarocks.org/

use 5.10.0;

use warnings;
use strict;

use File::Basename;
use Getopt::Long;
use Text::Wrap;

use Perl6::Slurp;
use Set::Scalar;

my $prog = basename($0);
my ($help_flag, $version_flag, $vars_flag, $dry_run_flag);

my %var_help = (
  package => "package base name",
  package_name => "package text name",
  version => "version number",
  revision => "packaging revision number",
  description => "short project description",
  dist_type => "comma-separated file extensions for distribution archives",
  email => "release email",
  notes => "release notes file",
  home => "home page URL",
);


# Release methods

my %releaser = ();
my %vars;

%{$releaser{null}} = (
  vars => Set::Scalar->new,
  release => sub {
  }
 );

%{$releaser{gnu}} = (
  vars => Set::Scalar->new(),
  release => sub {
    my $upload_commands = `make emit_upload_commands` or die "could not get upload commands\n";
    $upload_commands =~ m|^\./build-aux/gnupload  --to ([a-z]+\.gnu\.org):([^ ]+) [^ ]+\-([^ ]+)\.(tar\.([^ ]+))$|m
      or die "cannot parse upload commands\n";
    my ($upload, $package, $version, $dist_type, $suffix) = ($1, $2, $3, $4, $5);
    my @archives = make_archive_names("$package-$version", $dist_type);
    run("./build-aux/gnupload", "--to", "$upload:$package", @archives)
      or die "gnupload failed\n";

    say STDERR "Waiting for download to become available (may take a few minutes)";
    my $url = "https://$upload/gnu/$package/$package-$version.tar.$suffix";
    # Wait for URL to become available: can take up to 5 minutes
    say STDERR "Checking $url.sig";
    for (my $i = 0; $i < 32; $i++) {
      run("wget", "--quiet", "-O", "-", "$url.sig") and last;
      sleep 10;
    }

    # Download and verify compressed tarball and its signature
    for my $i ($suffix, "$suffix.sig") {
      run("wget", "--quiet", "$url.$i") or last;
      run("gpg", "--verify", basename($url) . ".$i") if $i =~ /\.sig$/;
    }
    $upload_commands =~ /^# send the ([^ ]+) e-mail$/m;
    my $email = $1 or die "cannot parse email address from upload commands\n";
    my $message = slurp(glob($email));
    $message =~ s/^\n//s;
    mail($message); # FIXME: Cope with Mail-Followup-To header
  }
 );

%{$releaser{luarocks}} = (
  vars => Set::Scalar->new("package", "version"),
  release => sub {
    my $revision = $vars{revision} || "1";
    my $rock_suffix = "-$revision.rockspec";
    my @rockspecs = glob("$vars{package}-*$vars{version}$rock_suffix");
    for my $r (@rockspecs) {
      run("luarocks", "upload", $r) or die "luarocks upload of `$r' failed\n";
    }
  }
 );

%{$releaser{lua}} = (
  vars => Set::Scalar->new("description", "home", "notes", "package", "package_name", "version"),
  release => sub {
    my $release_notes = slurp($vars{notes});
    chomp $release_notes;
    my $revision = $vars{revision} || "1";
    my $rock_suffix = "-$revision.rockspec";
    my @rockspecs = glob("$vars{package}-*$vars{version}$rock_suffix");
    my @rocks = @rockspecs;
    my $rocks = join ", ", map { s/$rock_suffix$//; $_ } @rocks;
    my $message = <<END;
I am happy to announce the release of $vars{package_name} $vars{version},
$vars{description}.

$release_notes

Install it with:

  luarocks install $vars{package}

See https://luarocks.org/

$vars{package_name}'s home page is at $vars{home}
END
    mail($message, "lua-l\@lists.lua.org", "[ANN] $vars{package_name} $vars{version} released");
    $releaser{luarocks}{release}();
  }
 );

%{$releaser{sourceforge}} = (
  vars => Set::Scalar->new("dist_type", "notes", "package", "version"),
  release => sub {
    run("copher", "-p", $vars{package}, "-k", $vars{package}, "-r", $vars{version},
        "-N", $vars{notes}, "$vars{package}-$vars{version}.$vars{dist_type}")
          or die "copher failed\n";
    unlink "out.html";
  }
 );

%{$releaser{github}} = (
  vars => Set::Scalar->new("dist_type", "package", "version"),
  release => sub {
    my $tag = "v$vars{version}";
    my @archives = make_archive_names("$vars{package}-$vars{version}", $vars{dist_type});
    my @cmd = ("gh", "release", "create", "$tag", "--title", "Release $tag");
    push @cmd, "--notes-file", $vars{notes} if $vars{notes};
    run(@cmd, @archives) or die "gh release failed\n";
  }
 );


sub run {
  return (system @_) == 0 unless $dry_run_flag;
  say STDERR "Command: ", (join " ", @_);
  return 1;
}

sub make_archive_names {
  my ($base, $dist_types) = @_;
  my @archives = ();
  for my $type (split /,/, $dist_types) {
    push @archives, "$base.$type";
  }
  return @archives;
}

sub mail {
  my ($body, $address, $subject, @attachments) = @_;
  my @args = ("-Sttycharset=utf-8");
  push @args, "-a", $_ foreach @attachments;
  push @args, "-s", $subject if $subject;
  if ($address) {
    push @args, $address;
  } else {
    push @args, "-t";
    $address = "(recipient given in message)";
  }
  unless ($dry_run_flag) {
    open(FILE, "|-", "s-nail", @args);
    print FILE wrap('', '', ($body));
    close FILE or die "mail to $address failed\n";
  } else {
    print wrap('', '', "Email to: $address\n$subject\n\n$body\n");
  }
}

my $methods = join ", ", keys %releaser;

sub usage {
  my ($exit_code) = @_;
  print STDERR <<END;
$prog [OPTION...] METHODS [VARIABLE=value...]
Release a program.

METHODS is a comma-separated list of methods, from:
  $methods

  --dry-run            don't do anything, just display what would be done
  --vars               display the variables needed by METHODS and exit
  --help               display this help and exit
  --version            display version information and exit
END
  exit $exit_code;
}

# Get arguments
my $opts = GetOptions(
  "dry-run", \$dry_run_flag,
  "help" => \$help_flag,
  "version" => \$version_flag,
  "vars" => \$vars_flag,
 ) or usage(1);
if ($version_flag) {
  print STDERR $version_banner;
  exit 0;
}
usage(0) if $help_flag;
usage(1) if $#ARGV == -1;
my @methods = split /,/, shift;
foreach my $arg (@ARGV) {
  $arg =~ s/([A-Za-z0-9_]+)\s*=\s*(.*)/$vars{$1} = $2/e;
}

# Check all methods are known
@methods = grep {
  if (!defined($releaser{$_})) {
    die "no such method $_\n";
  } else {
    1;
  }
} @methods;

# Make a set of all needed variables
my $needed = Set::Scalar->new();
$needed = $needed->union($releaser{$_}{vars}) foreach @methods;

# Write release notes if needed
if ($needed->has("notes")) {
  $vars{notes} ||= "release-notes";
  if (!-e $vars{notes}) {
    die "VISUAL is not set; please set it!\n"
      if -z $ENV{VISUAL};
    run($ENV{VISUAL}, $vars{notes}) == 0 or die "editor failed\n";
  }
}

# Complain about missing variables
my $missing = 0;
foreach my $e ($needed->elements) {
  unless ($vars{$e}) {
    say STDERR "Variable $e missing";
    $missing = 1;
  }
}
if ($vars_flag || $missing) {
  say STDERR "Variables needed:";
  say STDERR "  $_: $var_help{$_}" foreach (sort $needed->elements);
  exit $missing;
}

# Welease!
for my $method (@methods) {
  $releaser{$method}{release}();
}