Source

perl/cpan_make_release / cpan_make_release.pl

#!/usr/bin/perl -w

=head1 cpan_make_release

Package maintainer helper. Builds, tests, tags and releases the
package to cpan, checking whether Changes were updated in the process.
Nothing interesting, just saves some typing and mistakes.

Assumptions:

- Module::Build is used for distribution

- source is kept in Mercurial

- version_hook.py is used to automatically manage version numbers
  according to tags (see sample-version_hook.py)

- "hg push bitbucket" is to be executed to push sources to published repo

To use install/symlink somewhere in the path:

  ln -s `pwd`/cpan_make_release.pl ~/bin/cpan_make_release

and then for every release:

  cd «package directory»
  cpan_make_release --tag 0.2302

=cut

use FindBin;
use autodie qw(:all);
use Moose::Util::TypeConstraints;
use Carp;
use feature 'say';

# Make shorter errors for type failures
$ENV{MOOSE_ERROR_STYLE} = "croak";

{
    use Path::Class qw(file);
    use File::Which qw(which);
    use DateTime;

    subtype TagNo
      => as 'Str'
      => where { $_ =~ m{^\d+\.\d{2,6}$} }
      => message { "Expected tag with format 1.23 (or 1.2345, or 1.234567)" };

    subtype Executable
      => as 'Str'
      => where {
          s/ .*$//; # Resolve things like emacsclient --create-frame
          my $path = file($_);
          unless($path->is_absolute) {
              $path = which($path) or return 0;
          }
          return -x $path;
         }
      => message { "Editor $_ is not executable program" };
}

{
    package RunMe;
    use Moose;
    with 'MooseX::Getopt';
    
    use Path::Class qw(file);
    use IPC::System::Simple qw(capturex systemx);
    use DateTime;
    use List::Util qw(first);

    has tag => (is=>'ro', isa=>'TagNo', required=>1,
                documentation=>"Version number, for example 0.23 or 0.2304");
    has force => (is=>'ro', isa=>'Bool', required=>0, default=>0,
                  documentation=>"Force given tag in spite it was already used");
    has noupload => (is=>'ro', isa=>'Bool', required=>0, default=>0,
                     documentation=>"Do everything but do not upload distribution to CPAN");
    has editor => (is=>'ro', isa=>'Executable', required=>1, default=>$ENV{EDITOR},
                   documentation=>"Text editor spawned for missing edits");

    sub run {
        my $self = shift;

        # TODO hg root
        unless( -d ".hg" && -f "Build.PL") {
            die "cpan_make_release must be run in module directory (the one with Build.PL and .hg)\n";
        }

        my $dt = DateTime->today->ymd;
        my $tag = $self->tag;

        say "* Sanity checks";

        # Some sanity checks
        $self->ensure_regexps_in_file(
            file(".hg", "hgrc"),
            qr/^pre-tag *= *python:version_hook/,
            "Version hook not installed. See version_hook.py");
        $self->ensure_regexps_in_file(
            file("MANIFEST.SKIP"),
            qr/^\^\\\.hg$/,
            ".hg not skipped. Add it to MANIFEST.SKIP",
            qr/^\^version_hook\\.py$/,
            "version_hook.py not skipped. Add it to MANIFEST.SKIP",
           );

        $self->check_changes_entry($tag);

        # Check for uncommited changes
        my $reply = capturex([0], "hg", "status");
        if($reply) {
            die "Uncommited or unmanaged files in module directory.\nCommit everything before release.\nhg status:\n$reply\n";
        }


        say "* Preliminary build";

        # Perform preliminary build and test
        systemx("perl", "Build.PL");
        systemx("./Build");
        systemx("./Build", "distmeta");
        systemx("./Build", "test");
        systemx("./Build", "distcheck");

        say "* Tag";

        # Put tag
        systemx("hg", "tag", 
                $self->force ? ("-f") : (),
                $self->tag);

        say "* Possibly update README and meta files";
        
        systemx("./Build", "distmeta");
        $self->commit_if_needed("README", "Regenerated README file");

        say "* Sources push";

        # Push changes
        systemx("hg", "push", "bitbucket");

        say "* Final build and test";

        # Clean, build, and test again
        systemx("./Build", "distclean");
        systemx("perl", "Build.PL");
        systemx("./Build");
        systemx("./Build", "test");
        
        say "* Distro";

        $reply = capturex("./Build", "dist");
        print $reply;
        if($reply =~ /^Creating (.*\.tar\.gz)$/m) {
            my $distro = $1;
            unless($self->noupload) {
                print "Uploading $distro\n";
                systemx("cpan-upload", $distro);
            } else {
                print "Remember to do\n    cpan-upload $distro\n";
            }
        }
    }

    sub commit_if_needed {
        my ($self, $file, $message) = @_;
        if( capturex([0], "hg", "status", "-q", $file) ) {
            systemx("hg", "commit", "-m", $message, $file);
        }
    }

    sub check_changes_entry {
        my ($self, $tag) = @_;

        my $changes_file = file("Changes");
        my @lines = $changes_file->openr->getlines;
        if( grep { /^$tag\s+\d{4}-\d{2}-\d{2} *$/ } @lines ) {
            print "Changes entry for $tag already present\n";
        }
        else {

            # Check prev version in Changes
            my $prev_tag = '0';
            foreach (@lines) {
                if( /^(\d+\.\d+)\s+/ ) {
                    $prev_tag = $1;
                    last;
                }
            }
            # Grab log entries as initial text
            my $log_entr = capturex([0], "hg", "log", "-r", "$prev_tag:",
                                    "--template",
                                    '\t* {files}\n\t{desc | tabindent}\n\n');

            # Save preliminary changes
            my $today = DateTime->today->ymd;
            splice(@lines, 1, 0,
                   "\n",
                   "$tag\t$today\n",
                   "PLEASE EDIT THIS PART AND SAVE THE FILE",
                   $log_entr);

            my $changes_fd = $changes_file->openw;
            $changes_fd->print(@lines);
            $changes_fd->close;

            my $editor = $self->editor;
            system("$editor \"$changes_file\"");
        }

        # Re-checking
        my @new_lines = $changes_file->openr->getlines;
        
        if( grep { /PLEASE EDIT/ } @new_lines ) {
            die "Seems you have not edited Changes file. Please do it before retrying\n";
        }
        unless( grep { /^$tag\s+\d{4}-\d{2}-\d{2} *$/ } @lines ) {
            die "Changes entry for $tag missing after edits. Can't continue.\n";
        }

        # Commiting if needed
        $self->commit_if_needed($changes_file, "Updated Changes history");
    }


    sub ensure_regexps_in_file {
        my $self = shift;
        my $file = shift;
        my $rgxp = shift;
        my $comment = shift;
        unless( -f $file ) {
            die "File $file missing. $comment\n";
        }
        my @lines = $file->openr()->getlines();
        while(1) {
            unless( grep { /$rgxp/ } @lines ) {
                die "File $file does not contain expected text.\n$comment\n";
            }
            $rgxp = shift;
            $comment = shift;
            last unless $rgxp;
        }
    }

}

my $run_me = RunMe->new_with_options;
$run_me->run();
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.