#!/usr/bin/perl

use SOAP::Lite;
use RT::Client::REST;
use RT::Client::REST::Ticket;
use Proc::InvokeEditor;

use warnings;
use strict;

=head1 NAME

forward-bug - Forward Debian bug to CPAN's request tracker

=head1 SYNOPSIS

 forward-bug BUGNUMBER [DISTRIBUTION]

 Examples:
   $ forward-bug 555555 Some-Dist # explicitly set dist name
   $ forward-bug 32412314         # make f-b read dist name from debian/control

=head1 CONFIGURATION

B<forward-bug.pl> read the file C<~/.pause> for the configuration. The format is
the same that L<cpan-upload> requires:

  user YOUR-PAUSE-ID
  password YOUR-PAUSE-PASSWORD

If the distribution name is not set from the command-line B<forward-bug>
will also look at the C<Homepage> field in the C<debian/control> file or the
C<Source> filed in C<debian/copyright> and extracts the name from there.

=cut

my $bug  = $ARGV[0];
my $dist = $ARGV[1];

die 'Err: Provide valid bug number' if !$bug;

if ( !$dist ) {
    open my $dctrl, '<', 'debian/control'
        or die "Err: Can't open debian/control for reading: $!";

    while ( my $line = <$dctrl> ) {
        if ( $line =~ /^Homepage/ ) {
            if ( $line
                =~ m{(?:http://search\.cpan\.org/dist|https://metacpan\.org/release)/(.*)/}
                )
            {
                $dist = $1;
            }
        }
    }

    close $dctrl or warn "Warn: Cannot close debian/control from reading: $!";
}

if ( !$dist ) {
    open my $dcopyright, '<', 'debian/copyright'
        or die "Err: Can't open debian/copyright for reading: $!";

    while ( my $line = <$dcopyright> ) {
        if ( $line =~ /^Source/ ) {
            if ( $line
                =~ m{(?:http://search\.cpan\.org/dist|https://metacpan\.org/release)/(.*)/}
                )
            {
                $dist = $1;
            }
        }
    }

    close $dcopyright
        or warn "Cannot close debian/copyright from reading: $!";
}

die 'Err: Provide valid distribution name' if !$dist;

# retrieve bug info
my $soap = SOAP::Lite->uri('Debbugs/SOAP')
    ->proxy('http://bugs.debian.org/cgi-bin/soap.cgi');

my $info = $soap->get_status($bug)->result()->{$bug};

if ( $info->{'done'} ) {
    die 'Err: Bug already closed';
}

if ( $info->{'forwarded'} ) {
    die 'Err: Bug already forwarded at ' . $info->{'forwarded'};
}

# (cf. http://wiki.debian.org/DebbugsSoapInterface)
# try to get the body of the first message
# get_bug_log() fails with a SOAP error for some bugs. cf. #635018
my $log;
eval { $log = $soap->get_bug_log($bug)->result(); };
if ($@) {
    $log = undef;
}
else {
    $log = $log->[0]->{body};
}

# RT config
my $rtserver = 'https://rt.cpan.org';
my %rtlogin;

open my $pauserc, '<', $ENV{'HOME'} . '/.pause'
    or die "Err: Can't open ~/.pause for reading: $!";

while (<$pauserc>) {
    chomp;
    next unless $_ and $_ !~ /^\s*#/;

    my ( $k, $v ) = /^\s*(\w+)\s+(.+)$/;
    $rtlogin{$k} = $v;
}

close $pauserc or warn "Cannot close ~/.pause from reading: $!";

die 'Err: Provide valid PAUSE credentials'
    if not $rtlogin{'user'}
        or not $rtlogin{'password'};

my $name = $ENV{'DEBFULLNAME'};
my $email
    = $ENV{'DEBEMAIL'}
    || $ENV{'EMAIL'}
    || die "Err: Set a valid email address";

if ( !$name ) {
    $name = ( getpwuid($<) )[6];
    $name =~ s/,.*//;
}

my $body = "This bug has been forwarded from http://bugs.debian.org/$bug\n";
$body .= "\n$log\n" if $log;
$body .= "\nThanks in advance,\n";
$body .= "$name, Debian Perl Group\n";

# generate body for ticket
my $text = Proc::InvokeEditor->edit($body);

# RT REST
my $rt = RT::Client::REST->new( server => $rtserver );

# login to RT
$rt->login( username => $rtlogin{'user'}, password => $rtlogin{'password'} );

# create new RT ticket
my $ticket = RT::Client::REST::Ticket->new(
    rt        => $rt,
    queue     => $dist,
    subject   => $info->{'subject'},
    requestor => [$email],
)->store( text => $text );

# set Debian bug as 'forwarded'
my $url = 'http://rt.cpan.org/Public/Bug/Display.html?id=' . $ticket->id;
system( '/usr/bin/bts', 'forwarded', $info->{'bug_num'}, $url );

=head1 AUTHOR

Alessandro Ghedini <ghedo@debian.org>

=head1 LICENSE AND COPYRIGHT

Copyright 2011 Alessandro Ghedini.

This program is free software; you can redistribute it and/or modify it
under the terms of either: the GNU General Public License as published
by the Free Software Foundation; or the Artistic License.

See http://dev.perl.org/licenses/ for more information.

=cut