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 <al...@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 _______________________________________________ Pkg-perl-cvs-commits mailing list Pkg-perl-cvs-commits@lists.alioth.debian.org http://lists.alioth.debian.org/cgi-bin/mailman/listinfo/pkg-perl-cvs-commits