Module::Release::Subversion - Use Subversion instead of CVS with Module::Release

  release_subclass Module::Release::Subversion

  use base qw(Module::Release::Subversion);

package Module::Release::Subversion;

use strict;
use warnings;
use base qw(Exporter Module::Release);

our @EXPORT = qw(check_cvs cvs_tag);

use URI;			# svn URL mangling

our $VERSION = '0.10';

sub check_cvs {
  my $self = shift;

  print "Checking state of Subversion... ";

  my $svn_update = $self->run('svn status --show-updates --verbose 2>&1');

  if($?) {
    die sprintf("\nERROR: svn failed with non-zero exit status: %d\n\n"
		. "Aborting release\n", $? >> 8);
  }

  # Trim $svn_update a bit to make the regex later a little simpler
  $svn_update =~ s/^\?\s+/?/;	# Collapse spaces after /^?/
  # Remove the revision number and author columns
  $svn_update =~ s/^(........)\s+\d+\s+\d+\s+\S+\s+(.*)$/$1 $2/mg;

  my %message = (
		 qr/^C......./   => 'These files have conflicts',
		 qr/^M......./   => 'These files have not been checked in',
		 qr/^........\*/ => 'These files need to be updated',
		 qr/^P......./   => 'These files need to be patched',
		 qr/^A......./   => 'These files were added but not checked in',
		 qr/^D......./   => 'These files are scheduled for deletion',
		 qr/^\?......./  => 'I don\'t know about these files',
		   );

  my @svn_states = keys %message;

  my %svn_state;
  foreach my $state (@svn_states) {
    $svn_state{$state} = [ $svn_update =~ /$state\s+(.*)/gm ];

  }

  my $rule = "-" x 50;
  my $count;
  my $question_count;

  foreach my $key (sort keys %svn_state) {
    my $list = $svn_state{$key};
    next unless @$list;
    $count += @$list unless $key eq qr/^\?......./;
    $question_count += @$list if $key eq qr/^\?......./;

    local $" = "\n\t";
    print "\n\t$message{$key}\n\t$rule\n\t@$list\n";
  }

  die "\nERROR: Subversion is not up-to-date ($count files): Can't release files\n"
    if $count;

  if($question_count) {
    print "\nWARNING: Subversion is not up-to-date ($question_count files unknown); ",
      "continue anwyay? [Ny] " ;
    die "Exiting\n" unless <> =~ /^[yY]/;
  }

  print "Subversion up-to-date\n";
} # check_cvs

sub cvs_tag {
  my $self = shift;

  my $svn_info = $self->run('svn info .');
  if($?) {
    warn sprintf("\nWARNING: 'svn info .' failed with non-zero exit status: %d\n", $? >> 8);
    return;
  }

  $svn_info =~ /^URL: (.*)$/m;
  my $trunk_url = URI->new($1);

  my @tag_url = $trunk_url->path_segments();
  if(! grep /^trunk$/, @tag_url) {
    warn "\nWARNING: Current SVN URL:\n  $trunk_url\ndoes not contain a 'trunk' component\n";
    warn "Aborting tagging.\n";
    return;
  }

  foreach (@tag_url) {		# Find the first 'trunk' component, and
    if($_ eq 'trunk') {		# change it to 'tags'
      $_ = 'tags';
      last;
    }
  }

  my $tag_url = $trunk_url->clone();

  $tag_url->path_segments(@tag_url);

  # Make sure the top-level path exists
  #
  # Can't use $self->run() because of a bug where $fh isn't closed, which
  # stops $? from being properly propogated.  Reported to brian d foy as
  # part of RT#6489
  system "svn list $tag_url 2>&1";
  if($?) {
    warn sprintf("\nWARNING:\n  svn list $tag_url\nfailed with non-zero exit status: %d\n", $? >> 8);
    warn "Assuming tagging directory does not exist in repo.  Please create it.\n";
    warn "\nAborting tagging.\n";
    return;
  }

  my $tag = $self->make_cvs_tag;
  push @tag_url, $tag;
  $tag_url->path_segments(@tag_url);
  print "Tagging release to $tag_url\n";

  system 'svn', 'copy', $trunk_url, $tag_url;

  if ( $? ) {
    # already uploaded, and tagging is not (?) essential, so warn, don't die
    warn sprintf(
		 "\nWARNING: cvs failed with non-zero exit status: %d\n",
		 $? >> 8
		);
  }

} # cvs_tag

1;