[pkg-perl-tools] 01/04: Extract message subs into a Message class
Alex Muntada
alexm-guest at moszumanska.debian.org
Fri Dec 2 23:27:25 UTC 2016
This is an automated email from the git hooks/post-receive script.
alexm-guest pushed a commit to branch master
in repository pkg-perl-tools.
commit 95e32da7f4614d31a94134b973a8708bc6ff0b5b
Author: Alex Muntada <alexm at alexm.org>
Date: Fri Dec 2 18:26:07 2016 +0100
Extract message subs into a Message class
---
lib/Debian/PkgPerl/Message.pm | 207 ++++++++++++++++++++++++++++++++++++++++++
scripts/forward | 168 ++--------------------------------
2 files changed, 214 insertions(+), 161 deletions(-)
diff --git a/lib/Debian/PkgPerl/Message.pm b/lib/Debian/PkgPerl/Message.pm
new file mode 100644
index 0000000..2da91a0
--- /dev/null
+++ b/lib/Debian/PkgPerl/Message.pm
@@ -0,0 +1,207 @@
+package Debian::PkgPerl::Message;
+
+use strict;
+use warnings;
+
+use autodie;
+use Carp;
+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 = @_;
+
+ return bless \%params, $class;
+}
+
+sub get_subject {
+ my $default = ( $bug ? $bug_info{Subject} : $patch_info{Subject} ) // '';
+ $default = "[PATCH] $default"
+ if $patch and $default !~ /\[PATCH\]/ and $opt_tracker ne 'github';
+
+ my $term = Term::ReadLine->new('forward');
+
+ return $term->readline( 'Subject: ', $default );
+}
+
+sub edit_message {
+ my $body = shift or confess;
+
+ $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 $body;
+
+ $Text::Wrap::columns = 70;
+ $Text::Wrap::huge = 'overflow';
+
+ if ($bug) {
+ $body = "We have the following bug reported to the Debian package "
+ . "of $opt_dist ($bug_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" . $bug_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
+
+ $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";
+
+ if ( $opt_tracker ne 'github' ) {
+ 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 .= $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" );
+
+ return edit_message($body);
+}
+
+sub send_by_mail {
+ my $from = "$name <$email>";
+ my $text = prepare_body();
+ my $subject = 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 );
+ }
+}
+
+=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;
diff --git a/scripts/forward b/scripts/forward
index d7598b5..2f6c10e 100755
--- a/scripts/forward
+++ b/scripts/forward
@@ -4,20 +4,16 @@ use autodie;
use Carp;
use CPAN::Meta;
use Cwd qw(getcwd);
-use MIME::Lite;
use File::Basename;
use File::HomeDir;
use File::Slurp qw(read_file write_file);
use File::Spec;
use Getopt::Long;
-use Term::ReadLine;
use Time::Piece qw(localtime);
-use Text::Wrap qw(wrap);
-use Proc::InvokeEditor;
-use MIME::Lite;
use YAML::XS qw(LoadFile);
use Debian::PkgPerl::Bug;
use Debian::PkgPerl::Patch;
+use Debian::PkgPerl::Message;
use Debian::PkgPerl::GitHub;
use warnings;
@@ -189,8 +185,6 @@ die "'$arg1' is not recognized as neither bug nor patch file name.\n"
. "Please use the --mode option.\n"
unless $opt_mode;
-my $scissors_line = ( "------8<-----" x 5 ) . "\n";
-
my ( $patch, $bug );
my ( %patch_info, %bug_info );
@@ -221,15 +215,7 @@ my $bug_info = Debian::PkgPerl::Bug->new(
);
%bug_info = $bug_info->retrieve_bug_info() if $bug;
-sub get_subject {
- my $default = ( $bug ? $bug_info{Subject} : $patch_info{Subject} ) // '';
- $default = "[PATCH] $default"
- if $patch and $default !~ /\[PATCH\]/ and $opt_tracker ne 'github';
-
- my $term = Term::ReadLine->new('forward');
-
- return $term->readline( 'Subject: ', $default );
-}
+my $message = Debian::PkgPerl::Message->new();
sub detect_dist {
return $upstream_metadata->{Name}
@@ -305,129 +291,11 @@ sub read_pause_credentials {
or not $rt_login{'password'};
}
-sub prepare_body {
- my $body;
-
- $Text::Wrap::columns = 70;
- $Text::Wrap::huge = 'overflow';
-
- if ($bug) {
- $body = "We have the following bug reported to the Debian package "
- . "of $opt_dist ($bug_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" . $bug_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
-
- $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";
-
- if ( $opt_tracker ne 'github' ) {
- 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 .= $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" );
-
- return edit_message($body);
-}
-
-sub send_by_mail {
- my $from = "$name <$email>";
- my $text = prepare_body();
- my $subject = 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 submit_cpan_rt {
read_pause_credentials();
# prepare subject
- my $subject = get_subject();
+ my $subject = $message->get_subject();
# There are two ways for submitting RT tickets: email and REST
# The email way is to send the mail, then use RT::Client::REST to find the
@@ -436,7 +304,7 @@ sub submit_cpan_rt {
# comment. Ticket creation doesn't support attachments directly.
# Prepare body
- my $body = prepare_body();
+ my $body = $message->prepare_body();
my $ticket_url;
@@ -504,9 +372,9 @@ sub submit_github {
my $gh = Debian::PkgPerl::GitHub->new( tracker => $opt_tracker_url );
# prepare subject
- my $subject = get_subject();
+ my $subject = $message->get_subject();
- my $body = prepare_body();
+ my $body = $message->prepare_body();
my $issue_url;
@@ -527,28 +395,6 @@ ISSUE_CREATED:
mark_bug_as_forwarded($issue_url) if $bug;
}
-sub edit_message {
- my $body = shift or confess;
-
- $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 mark_patch_as_forwarded {
my $url = shift;
@@ -652,7 +498,7 @@ sub detect_tracker {
}
if ($opt_use_mail) {
- send_by_mail();
+ $message->send_by_mail();
}
elsif ( $opt_tracker eq 'cpan' ) {
submit_cpan_rt();
--
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/pkg-perl/packages/pkg-perl-tools.git
More information about the Pkg-perl-cvs-commits
mailing list