pkg-perl-tools 0.42 / usr / share / perl5 / Debian / PkgPerl / Message.pm

package Debian::PkgPerl::Message;

use strict;
use warnings;

use autodie;
use Carp;
use File::Basename;
use MIME::Lite;
use Term::ReadLine;
use Text::Wrap qw(wrap);
use Proc::InvokeEditor;

=head1 NAME

Debian::PkgPerl::Message - Builds messages to be forwarded.

=head1 SYNOPSIS

    use Debian::PkgPerl::Message;
    my $msg = Debian::PkgPerl::Message->new();
    my $subject = $msg->get_subject();
    my $body = $msg->prepare_body();
    $msg->send_by_mail();

=head1 DESCRIPTION

Helper class that builds different kind of messages to be forwarded
upstream. They may be delivered by mail or comments on a bug tracker.

=cut

my $scissors_line = ( "------8<-----" x 5 ) . "\n";

sub new {
    my $class = shift;
    my %params = @_;

    my %obj = (
        # defaults
        interactive => 1,

        # caller params
        %params,
    );

    return bless \%obj, $class;
}

sub get_subject {
    my $self = shift;

    my $info        = $self->{info};
    my $patch       = $self->{info}{patch};
    my $opt_tracker = $self->{tracker};

    # No need to review subject again
    return $self->{subject}
        if defined $self->{subject}
        and length $self->{subject} > 0;

    my $default = $info->{Subject} // '';
    $default = "[PATCH] $default"
        if $patch and $default !~ /\[PATCH\]/ and $opt_tracker ne 'github';

    my $subject = $default;

    if ( $self->{interactive} ) {
        my $term = Term::ReadLine->new('forward');
        $subject = $term->readline( 'Subject: ', $default );
    }

    $self->{subject} = $subject;
    return $subject;
}

sub edit_message {
    my $self = shift;
    my $body = shift or confess;

    my $opt_tracker_url = $self->{url};

    $body
        = "# Feel free to edit the message contents to your liking.\n"
        . "# Fiddling with the patch itself is probably a bad idea.\n"
        . "# Heading lines starting with '#' are ignored\n"
        . "# Empty message aborts the process\n"
        . "#\n"
        . "# You may want to check if a similar ticket already exists at\n"
        . "#  $opt_tracker_url\n\n"
        . $body;

    $body = Proc::InvokeEditor->edit($body);

    $body =~ s/^#[^\n]*\n//mg while $body =~ /^#/;

    die "Empty message. Terminating.\n" unless $body;

    return $body;
}

sub prepare_body {
    my $self = shift;
    my $body;

    my $bug         = $self->{info}{bug};
    my $opt_dist    = $self->{dist};
    my $info        = $self->{info};
    my $patch       = $self->{info}{patch};
    my $opt_tracker = $self->{tracker};
    my $name        = $self->{name};

    $Text::Wrap::columns = 70;
    $Text::Wrap::huge    = 'overflow';

    if ($bug) {
        $body = "We have the following bug reported to the Debian package "
            . "of $opt_dist ($info->{url}):" . "\n";
        $body .= "\nIt doesn't seem to be a bug in the packaging, "
            . "so you may want to take a look. Thanks!\n";
        $body = wrap( '', '', $body );

        $body .= "\n" . $scissors_line;
        $body .= "\n\`\`\`" if $opt_tracker eq 'github';
        $body .= "\n" . $info->{msg};
        $body .= "\n\`\`\`" if $opt_tracker eq 'github';
        $body .= "\n" . $scissors_line . "\n";

        if ($patch) {
            # bug + patch
            $body
                .= wrap( '', '', "The Debian package of $opt_dist has the following "
                . "patch applied to fix the bug.\n" );
        }
    }
    elsif ($patch) {
        # patch but no bug

        my $pre = ( $opt_tracker eq 'github' ) ? '    ' : '';

        $body
            = "In Debian we are currently applying the following "
            . "patch to $opt_dist.\n"
            . "We thought you might be interested in it too.";
        $body = wrap( '', '', $body );
        $body .= "\n\n";

        open my $patch_fh, '<', $patch;

        while ( my $line = <$patch_fh> ) {
            chomp($line);
            last if $line eq '---';
            last if $line =~ /^--- /;
            last if $line =~ /^diff\h--git\ha\//;
            last if $line =~ /^index\h[0-9a-f]+\.\.[0-9a-f]+\h\d*\h/;
            next if $line =~ /^Forwarded:/;
            $body .= $pre . $line . "\n";
        }
    }
    else {
        die "No patch nor bug!? (a.k.a. should not happen)";
    }

    if ($patch) {
        require Dpkg::Control::Info;
        my $c = Dpkg::Control::Info->new();
        my $vcs_browser = $c->get_source->{'Vcs-Browser'};
        if ( $vcs_browser and $vcs_browser =~ /cgit/ ) {
            $body .= wrap( '', '', "\nThe patch is tracked in our Git repository at "
                  . "$vcs_browser/plain/$patch\n" );
        }
        elsif ( $vcs_browser and $vcs_browser =~ /gitweb/ ) {
            $body .= wrap( '', '', "\nThe patch is tracked in our Git repository at "
                  . "$vcs_browser;a=blob;f=$patch;hb=HEAD\n" );
        }
    }

    $body .= "\nThanks for considering,\n";
    $body .= wrap( '  ', '  ', "$name,\nDebian Perl Group\n" );

    $body = $self->edit_message($body)
        if $self->{interactive};

    return $body;
}

sub send_by_mail {
    my $self = shift;

    my $name            = $self->{name};
    my $email           = $self->{email};
    my $opt_dist        = $self->{dist};
    my $opt_mailto      = $self->{mailto};
    my $patch           = $self->{info}{patch};
    my $opt_tracker_url = $self->{url};

    if (!$opt_mailto) {
        warn "Bug tracker email address not found in META.\n";
        $opt_mailto = 'bug-' . lc($opt_dist) . '@rt.cpan.org';
        warn "Falling back to $opt_mailto\n";
    }

    my $from    = "$name <$email>";
    my $text    = $self->prepare_body();
    my $subject = $self->get_subject();

    my $msg = MIME::Lite->new(
        From    => $from,
        To      => $opt_mailto,
        Subject => $subject,
        Type    => 'multipart/mixed'
    ) or die "Error creating multipart container: $!\n";

    $msg->attach(
        Type => 'TEXT',
        Data => $text
    ) or die "Error adding the text message part: $!\n";

    # add the patch as attachment
    $msg->attach(
        Type        => 'TEXT',
        Path        => $patch,
        Filename    => basename($patch),
        Disposition => 'attachment'
    ) or die "Error adding attachment: $!\n"
        if $patch;

    # the email is not currently sent
    MIME::Lite->send( 'sendmail', '/usr/sbin/sendmail -t' )
        ;    # change mailer to your needs
    $msg->send;

    if (!$opt_mailto) {
        # TODO
        # find bug on https://rt.cpan.org/Public/Dist/Display.html?Name=$opt_dist
        # or via RT::Client::REST and add the URL to the Forwarded header in the patch

        print "Find your ticket on\n"
            . "$opt_tracker_url\n"
            . "and add the ticket URL to $patch\n\n"
            . "Trying to open the URL with sensible-browser now.\n";
        system( 'sensible-browser', $opt_tracker_url );
    }
}

sub get_url {
    my $self = shift;

    return $self->{url};
}

sub get_patch {
    my $self = shift;

    return $self->{info}{patch};
}

=head1 LICENSE AND COPYRIGHT

=over

=item Copyright 2016 Alex Muntada.

=back

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

1;