#!/usr/bin/perl
#
# fm-submit - submit project releases to freshmeat.net
#

use Getopt::Long;
use Pod::Usage;
use RPC::XML;
use Net::Netrc;

# Header field names. The key is the stdin header name, the value is an
# array ref containing (short name, RPC field, default). The long option
# name is the same as the key, but in lower case.
#
my %headers = (
  'Project' =>          [ 'p', 'project', undef ],
  'Branch' =>           [ 'b', 'branch_name', 'Default' ],
  'Version' =>          [ 'v', 'version', undef ],
  'Changes' =>          [ 'c', 'changes', undef ],
  'Release-Focus' =>    [ 'r', 'release_focus', undef ],
  'Hide' =>             [ 'x', 'hide_from_frontpage', undef ],
  'License' =>          [ 'l', 'license', undef ],
  'Home-Page-URL' =>    [ 'H', 'url_homepage', undef ],
  'Gzipped-Tar-URL' =>  [ 'G', 'url_tgz', undef ],
  'Bzipped-Tar-URL' =>  [ 'B', 'url_bz2', undef ],
  'Zipped-Tar-URL' =>   [ 'Z', 'url_zip', undef ],
  'Changelog-URL' =>    [ 'C', 'url_changelog', undef ],
  'RPM-URL' =>          [ 'R', 'url_rpm', undef ],
  'Debian-URL' =>       [ 'D', 'url_deb', undef ],
  'OSX-URL' =>          [ 'O', 'url_osx', undef ],
  'BSD-Port-URL' =>     [ 'P', 'url_bsdport', undef ],
  'Purchase-URL' =>     [ 'U', 'url_purchase', undef ],
  'CVS-URL' =>          [ 'S', 'url_cvs', undef ],
  'Mailing-List-URL' => [ 'L', 'url_list', undef ],
  'Mirror-Site-URL' =>  [ 'M', 'url_mirror', undef ],
  'Demo-URL' =>         [ 'E', 'url_demo', undef ],
);

# Our list of options (see "perldoc Getopt::Long").
#
my @optionlist = (
  'help|h|?',
  'man|manual',
  'delete|d',
  'no-stdin|n',
  'noemit|N',
);

# Add each header's command-line option to our list of options.
#
foreach (keys %headers) {
	my $longopt = lc($_);
	push @optionlist, $longopt . '|' . $headers{$_}->[0] . '=s';
}

# Prefix fatal errors with "fm-submit: ".
#
$SIG{__DIE__} = sub { die 'fm-submit: ' . $_[0]; };

my %opts = ();

Getopt::Long::Configure ('bundling');

GetOptions (\%opts, @optionlist) || pod2usage (-verbose => 0);
pod2usage (-verbose => 1) if ($opts{'help'});
pod2usage (-verbose => 2) if ($opts{'man'});

# Hash of values for each header. First, we fill in the defaults.
#
my %release = ();
foreach (keys %headers) {
	$release{$_} = $headers{$_}->[2];
}

# Read information from an RPM if one has been specified.
#
if (defined $ARGV[0]) {
	my $file = $ARGV[0];
	die "$file: $!\n" if (! -s $file);

	$release{'Project'} = rpm_extract ($file, 'name');
	$release{'Version'} = rpm_extract ($file, 'version');
	$release{'License'} = rpm_extract ($file, 'license');
	$release{'Home-Page-URL'} = rpm_extract ($file, 'url');

	$release{'Changes'} = rpm_extract ($file, 'changelogtext');
	$release{'Changes'} =~ s/^- //mg
	  if (defined $release{'Changes'});

	my $source = rpm_extract ($file, 'source') || '';
	if ($source =~ /(\.tar\.gz|\.tgz)$/) {
		$release{'Gzipped-Tar-URL'} = $source;
	} elsif ($source =~ /(\.tar\.bz2)$/) {
		$release{'Bzipped-Tar-URL'} = $source;
	}
}

# Read information from standard input, unless --no-stdin was specified.
#
if (not $opts{'no-stdin'}) {
	my $hdr = 1;
	while (<STDIN>) {
		if (!$hdr) {
			$release{'Changes'} .= $_;
		} else {
			chomp;
			if (/^\s*$/) {
				$release{'Changes'} = '';
				$hdr = 0;
				next;
			}
			if (!/^([^:\s]+):\s*(.+)$/) {
				die "invalid header line: $_\n";
			}
			my ($hdr, $val) = ($1, $2);
			if (not exists $release{$hdr}) {
				die "invalid header name: $hdr\n";
			}
			$release{$hdr} = $val;
		}
	}
}

# Override any of the above if the relevant command line options were given.
#
foreach my $hdr (keys %release) {
	my $optname = lc($hdr);
	$release{$hdr} = $opts{$optname} if (defined $opts{$optname});
}

# Check that we have all the required fields.
#
die "No project name was specified!\n"
  if (not defined $release{'Project'});
die "No release version was specified!\n"
  if (not defined $release{'Version'});
die "No release focus was specified!\n"
  if ((not defined $release{'Release-Focus'}) && (not $opts{'delete'}));
die "No change log was specified!\n"
  if ((not defined $release{'Changes'}) && (not $opts{'delete'}));

# Strip leading and trailing whitespace from the "Changes" field.
#
$release{'Changes'} =~ s/^\s*//s;
$release{'Changes'} =~ s/\s*$//s;
$release{'Changes'} =~ s/^\s*//m;
$release{'Changes'} =~ s/\s*$//m;

if (length $release{'Changes'} > 600) {
	die "Change text is too long - max is 600 characters\n";
}

# Now we translate the filled-in headers to a hash of RPC fields and values.
#
my %rpc = ();
foreach (keys %headers) {
	next if (not defined $release{$_});
	next if ($release{$_} eq '(none)');
	next if ($release{$_} eq '');
	$rpc{$headers{$_}->[1]} = $release{$_};
}

# Dump what we would have sent and just exit if --noemit was specified.
#
if ($opts{'noemit'}) {
	foreach my $key (sort keys %release) {
		next if (not defined $release{$key});
		next if (not defined $rpc{$headers{$key}->[1]});
		next if ($key eq 'Changes');
		print "$key: $release{$key}\n";
	}
	print "\n" . $release{'Changes'} . "\n";
	exit 0;
}


#
# Finally, submit/delete the release to/from freshmeat.
#

my $fm = Freshmeat::XMLRPC->new ();

# Get username/password details from ~/.netrc.
#
my $mach = Net::Netrc->lookup ('freshmeat');
die "Cannot log in: no 'freshmeat' entry found in ~/.netrc\n"
  if (not defined $mach);
my ($login, $password, $account) = $mach->lpa;

$fm->login ($login, $password) || die $fm->error . "\n";

if ($opts{'delete'}) {
	$fm->withdraw_release (
	  $release{'Project'},
	  $release{'Branch'},
	  $release{'Version'}
	) || die $fm->error . "\n";
} else {
	$fm->publish_release (
	  $release{'Project'},
	  $release{'Branch'},
	  $release{'Version'},
	  \%rpc
	) || die $fm->error . "\n";
}

$fm->logout ();

exit 0;


# Return the value of the given field in the given RPM, or undef on error.
#
sub rpm_extract {
	my ($file, $field) = @_;
	my $val = `rpm --queryformat='%{$field}' -qp "$file" 2>/dev/null`;
	chomp $val if (defined $val);
	return $val;
}


=pod

=head1 NAME

fm-submit - submit project releases to freshmeat.net

=head1 SYNOPSIS

B<fm-submit> [options] ...

B<fm-submit> --help | --man

=head1 DESCRIPTION

B<fm-submit> is a tool to submit project release announcements to
freshmeat.net via XML-RPC, from the command line.

Release information is accepted from binary packages (RPMs) named in the
command line, or from an email-like data block on standard input, or from
command-line flags.

If more than one data source is used, command-line values override values
read from standard input, which in turn override values read from binary
packages.

=head1 OPTIONS

=over 8

=item B<-d>, B<--delete>

Delete the specified release rather than submitting it.  With
this option, all data other than Project, Branch, and Release are
ignored.

=item B<-n>, B<--no-stdin>

Process command-line options only; don't read data from
standard input.

=item B<-N>, B<--noemit>

Display the merged record from binary package arguments,
standard input and command-line options to standard output.  Don't
ship it.

=back

=head1 VALUES

In the list below, the header line (see below) is shown first if applicable,
followed by the command line option used to set it.

=over 8

=item B<Project:> B<-p>, B<--project>

Name of the project (freshmeat shortname) to operate on.

=item B<Branch:> B<-b>, B<--branch>

Name of project branch to operate on; defaults to "Default".

=item B<Version:> B<-v>, B<--version>

Version string to be associated with the release.  Conventionally this will
look like "n.n" or "n.n.n", where each "n" is an integer number.

=item B<Changes:> B<-c>, B<--changes>

The Changes field.  Plain text, no more than 600 characters. If no Changes
field or option is aleady present, the changes text is taken from the body
of the RFC-822 message on standard input.

=item B<Release-Focus:> B<-r>, B<--release-focus>

Purpose of this release.  See the table of release-focus types
below.

=item B<Hide:> B<-x>, B<--hide>

If this field is present and has the value "Y", this release will not be
visible on the main freshmeat.net page.

=item B<License:> B<-l>, B<--license>

The license under which the release is issued.  This should ideally be one
of the names of the nodes in the license root category on Freshmeat (see
B<http://freshmeat.net/browse/13/>) but common abbreviations are accepted as
well.

=item B<Home-Page-URL:> B<-H>, B<--home-page-url>

The project home page.

=item B<Gzipped-Tar-URL:> B<-G>, B<--gzipped-tar-url>

The URL where a gzipped tarball of source can be found.

=item B<Bzipped-Tar-URL:> B<-B>, B<--bzipped-tar-url>

The URL where a bzipped tarball of source can be found.

=item B<Zipped-Tar-URL:> B<-Z>, B<--zipped-tar-url>

The URL where a zip of the source can be found.

=item B<Changelog-URL:> B<-C>, B<--changelog-url>

The URL where the project changelog can be found.

=item B<RPM-URL:> B<-R>, B<--rpm-url>

The URL where an installable binary RPM can be found.

=item B<Debian-URL:> B<-D>, B<--debian-url>

The URL where an installable Debian package can be found.

=item B<OSX-URL:> B<-O>, B<--osx-url>

The URL where an OS/X binary can be found.

=item B<BSD-Port-URL:> B<-P>, B<--bsdport-url>

The URL where a BSD Ports package can be found.

=item B<Purchase-URL:> B<-U>, B<--purchase-url>

The URL where the software can be purchased.

=item B<CVS-URL:> B<-S>, B<--cvs-url>

The URL of the CVS for this package.

=item B<Mailing-List-URL:> B<-L>, B<--mailing-list-url>

The URL where you can sign up for project mailing lists.

=item B<Mirror-Site-URL:> B<-M>, B<--mirror-site-url>

The URL where an official mirror site for the project can be found.

=item B<Demo-URL:> B<-E>, B<--demo-url>

The URL where a demonstration site for the package can be found.

=back

The release focus can be any of the following:

  Initial freshmeat announcement  1
  Documentation                   2
  Code cleanup                    3
  Minor feature enhancements      4
  Major feature enhancements      5
  Minor bug fixes                 6
  Major bug fixes                 7
  Minor security fixes            8
  Major security fixes            9

Either the text (case-insensitive) or the number can be used.

=head1 USAGE

Here is an example of a release information record that could be
fed to B<fm-submit> on standard input:

 Project: fm-submit
 Version: 0.0.4
 Release-Focus: Minor feature enhancements
 Hide: N
 Home-Page-URL: http://www.ivarch.com/programs/fm-submit.shtml
 Gzipped-Tar-URL: http://www.ivarch.com/programs/sources/fm-submit-0.0.4.tar.gz

 Code cleanup. Abbreviations for common licenses are now accepted. Some
 minor documentation improvements were made.

More typically, you will run this program in a directory where you have
already made an RPM, giving it the RPM as a file argument. In that case, all
you will normally need to supply is the Release-Focus field; the other
required fields (including, most notably, the Changes field) will be mined
out of the RPM.

Account details for freshmeat.net are read from B<~/.netrc> - see the
B<netrc> manual page for details, but for a quick start, just put something
like this in your B<~/.netrc>:

 machine freshmeat
   login YOUR-FRESHMEAT-USERNAME
   password YOUR-FRESHMEAT-PASSWORD

=head1 RETURN VALUES

B<fm-submit> returns zero on success, 1 on failure.  On failure, an error
string is output on standard error.

=head1 AUTHORS

Andrew Wood E<lt>andrew dot wood at ivarch dot comE<gt>

Based on the Python script B<freshmeat-submit> by Eric S. Raymond.

=cut


#-------------------------------------------------------------------------
#
# Freshmeat::XMLRPC - module for accessing freshmeat.net via XML-RPC
#
# Copyright (C) Andrew Wood
# NO WARRANTY - see COPYING.
#

package Freshmeat::XMLRPC;

use RPC::XML::Client;

use strict;

BEGIN {
	use Exporter ();
	use vars qw($VERSION @ISA);

	$VERSION = '0.0.5';

	@ISA = qw(Exporter);
}


# Constructor function.
#
sub new {
	my ($proto, %init) = @_;
	my $class = ref ($proto) || $proto;
	my $self = {};

	$self->{'_cli'} = RPC::XML::Client->new (
	  'http://freshmeat.net/xmlrpc/'
	);
	$self->{'SID'} = undef;
	$self->{'error'} = '';

	bless ($self, $class);

	return $self;
}


# Destructor function.
#
sub DESTROY {
	my ($self) = @_;

	$self->logout () if (defined $self->{'SID'});
}


# Internal function returning 1 if the response object is OK, or undef if it
# is a failure (and on failure, fills in $self->{'error'}).
#
sub _resp_ok {
	my ($self, $resp) = @_;

	if (not ref $resp) {
		$self->{'error'} = '1 - ' . $resp;
		return undef;
	} elsif ($resp->is_fault) {
		$self->{'error'} = $resp->code . ' - ' . $resp->string;
		return undef;
	}

	return 1;
}


# Return a string describing the last error that occurred.
#
sub error {
	my ($self) = @_;
	return $self->{'error'};
}


# Log in to freshmeat.net with the given username and password, returning
# undef on error or 1 on success.
#
sub login {
	my ($self, $username, $password) = @_;

	# Log out first, if we're already logged in.
	#
	if (defined $self->{'SID'}) {
		$self->logout ();
		$self->{'error'} = '';
	}

	my $resp = $self->{'_cli'}->send_request (
	  'login',
	  RPC::XML::struct->new (
	    'username' => RPC::XML::string->new ($username),
	    'password' => RPC::XML::string->new ($password)
	  )
	);

	return undef if (not _resp_ok ($self, $resp));

	$self->{'API Version'} = $resp->value->{'API Version'};
	$self->{'SID'} = $resp->value->{'SID'};

	my ($major, $minor) = split /\./, $self->{'API Version'};

	if ($major != 1) {
		$self->logout ();
		$self->{'error'} = '2 - API version changed; upgrade required';
		return undef;
	}

	return 1;
}


# End the current session by logging out. Returns undef on error, 1 on
# success.
#
sub logout {
	my ($self) = @_;

	if (not defined $self->{'SID'}) {
		$self->{'error'} = '1 - Cannot log out - logged in';
		return undef;
	}

	my $resp = $self->{'_cli'}->send_request (
	  'logout',
	  RPC::XML::struct->new (
	    'SID' => RPC::XML::string->new ($self->{'SID'})
	  )
	);

	return undef if (not _resp_ok ($self, $resp));

	$self->{'SID'} = undef;

	return 1;
}


# Return an array reference of branch strings for the given project, or
# undef on error.
#
sub fetch_branch_list {
	my ($self, $project) = @_;

	if (not defined $self->{'SID'}) {
		$self->{'error'} = '1 - Not logged in';
		return undef;
	}

	my $resp = $self->{'_cli'}->send_request (
	  'fetch_branch_list',
	  RPC::XML::struct->new (
	    'SID' => RPC::XML::string->new ($self->{'SID'}),
	    'project_name' => RPC::XML::string->new ($project)
	  )
	);

	return undef if (not _resp_ok ($self, $resp));

	return $resp->value;
}


# Return a hash reference containing "changes", "release_focus" and
# "hide_from_frontpage" keys for the pending release
# (project,branch,version), or undef on error.
#
sub fetch_release {
	my ($self, $project, $branch, $version) = @_;

	if (not defined $self->{'SID'}) {
		$self->{'error'} = '1 - Not logged in';
		return undef;
	}

	my $resp = $self->{'_cli'}->send_request (
	  'fetch_branch_list',
	  RPC::XML::struct->new (
	    'SID' => RPC::XML::string->new ($self->{'SID'}),
	    'project_name' => RPC::XML::string->new ($project),
	    'branch_name' => RPC::XML::string->new ($branch),
	    'version' => RPC::XML::string->new ($version)
	  )
	);

	return undef if (not _resp_ok ($self, $resp));

	return {
	  'project_name' => $project,
	  'branch_name' => $branch,
	  'version' => $resp->value->{'version'},
	  'changes' => $resp->value->{'changes'},
	  'release_focus' => $resp->value->{'release_focus'},
	  'hide_from_frontpage' => $resp->value->{'hide_from_frontpage'}
	};
}


# Publish a release for the given project and branch, with the given version
# number, using data from the given hash reference:
#
#   changes             - Changes list, no HTML, character limit 600 chars
#   release_focus       - Release focus ID of new release
#   hide_from_frontpage - Set to 'Y' to hide release from front page
#   license             - Branch license
#   url_homepage        - Homepage
#   url_tgz             - Tar/GZ
#   url_bz2             - Tar/BZ2
#   url_zip             - Zip
#   url_changelog       - Changelog
#   url_rpm             - RPM package
#   url_deb             - Debian package
#   url_osx             - OS X package
#   url_bsdport         - BSD Ports URL
#   url_purchase        - Purchase
#   url_cvs             - CVS tree (cvsweb)
#   url_list            - Mailing list archive
#   url_mirror          - Mirror site
#   url_demo            - Demo site
#
# Returns 1 on success, undef on error.
#
# The "license" and "url_*" fields are optional and will be taken from the
# branch record if they are omitted from the submission. The
# "hide_from_frontpage" option can be omitted and defaults to "do not hide".
#
# Release focus IDs:
#
#   0 - N/A
#   1 - Initial freshmeat announcement
#   2 - Documentation
#   3 - Code cleanup
#   4 - Minor feature enhancements
#   5 - Major feature enhancements
#   6 - Minor bugfixes
#   7 - Major bugfixes
#   8 - Minor security fixes
#   9 - Major security fixes
#
# Either the number or the (case insensitive) string can be given.
#
# The license, if given, should be one of the nodes in the root license
# category at http://freshmeat.net/browse/13/, or a common abbreviation such
# as "GPL" instead of "GNU General Public License (GPL)".
#
sub publish_release {
	my ($self, $project, $branch, $version, $data) = @_;
	my %focuslist = (
	  'na' => 0,
	  'initialfreshmeatannouncement' => 1,
	  'documentation' => 2,
	  'codecleanup' => 3,
	  'minorfeatureenhancements' => 4,
	  'majorfeatureenhancements' => 5,
	  'minorbugfixes' => 6,
	  'majorbugfixes' => 7,
	  'minorsecurityfixes' => 8,
	  'majorsecurityfixes' => 9,
	);
	my %licensemap = (
	  'GPL' => 'GNU General Public License (GPL)',
	  'LGPL' => 'GNU Lesser General Public License (LGPL)',
	  'MIT' => 'MIT/X Consortium License',
	  'MPL' => 'Mozilla Public License (MPL)',
	  'FDL' => 'GNU Free Documentation License (FDL)',
	  'Artistic' => 'Artistic License',
	);
	my %out = ();

	if (not defined $self->{'SID'}) {
		$self->{'error'} = '1 - Not logged in';
		return undef;
	}

	$out{'SID'} = RPC::XML::string->new ($self->{'SID'});
	$out{'project_name'} = RPC::XML::string->new ($project);
	$out{'branch_name'} = RPC::XML::string->new ($branch);
	$out{'version'} = RPC::XML::string->new ($version);

	$out{'changes'} = '';
	$out{'release_focus'} = 0;

	$out{'changes'} = $data->{'changes'}
	  if (defined $data->{'changes'});
	$out{'release_focus'} = $data->{'release_focus'}
	  if (defined $data->{'release_focus'});

	if ($out{'release_focus'} !~ /^\d+$/) {
		$out{'release_focus'} = lc($out{'release_focus'});
		$out{'release_focus'} =~ s/[^a-z]//sg;
		$out{'release_focus'} = $focuslist{$out{'release_focus'}};
		$out{'release_focus'} = 0 if (!defined $out{'release_focus'});
	}

	foreach my $key (
	  'hide_from_frontpage', 'license',
	  'url_homepage', 'url_tgz', 'url_bz2', 'url_zip', 'url_changelog',
	  'url_rpm', 'url_deb', 'url_osx', 'url_bsdport', 'url_purchase',
	  'url_cvs', 'url_list', 'url_mirror', 'url_demo'
	) {
		my $val = $data->{$key};
		next if (not defined $val);
		next if ($val eq '(none)');
		next if ($val eq '');
		#
		# Map license short names to full names.
		#
		if ($key eq 'license') {
			if (defined $licensemap{$val}) {
				$val = $licensemap{$val};
			}
		}
		$out{$key} = RPC::XML::string->new ($val);
	}

	my $resp = $self->{'_cli'}->send_request (
	  'publish_release',
	  RPC::XML::struct->new (%out)
	);

	return undef if (not _resp_ok ($self, $resp));

	if (not defined $resp->value->{'OK'}) {
		$self->{'error'} = '1 - Bad "success" response';
		return undef;
	}

	return 1;
}


# Withdraw the given pending (project,branch,release), returning 1 on
# success, or undef on error.
#
sub withdraw_release {
	my ($self, $project, $branch, $version) = @_;

	if (not defined $self->{'SID'}) {
		$self->{'error'} = '1 - Not logged in';
		return undef;
	}

	my $resp = $self->{'_cli'}->send_request (
	  'withdraw_release',
	  RPC::XML::struct->new (
	    'SID' => RPC::XML::string->new ($self->{'SID'}),
	    'project_name' => RPC::XML::string->new ($project),
	    'branch_name' => RPC::XML::string->new ($branch),
	    'version' => RPC::XML::string->new ($version)
	  )
	);

	return undef if (not _resp_ok ($self, $resp));

	if (not defined $resp->value->{'OK'}) {
		$self->{'error'} = '1 - Bad "success" response';
		return undef;
	}

	return 1;
}

# EOF
