In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/c04bead1edb16804f93c1d95979abf8e7477363a?hp=965f9517a764238c745d253495e1c1ef8403b65c>
- Log ----------------------------------------------------------------- commit c04bead1edb16804f93c1d95979abf8e7477363a Author: Niko Tyni <[email protected]> Date: Mon Apr 25 16:31:00 2016 +0300 perlbug: wrap overly long lines Mail transport agents limit the length of message lines at SMTP time. One observed limit is 1000 characters per line. Mail user agents typically work around these limits by MIME-encoding the message. Since perlbug doesn't do that, it needs to limit the length of its lines manually to make sure bug reports get delivered. The longest lines in perlbug reports normally come from Config::myconfig output, particularly 'config_args', which has been observed to exceed 1000 characters on some configurations, causing report rejection. While less likely, the list of local patches is another potential source of overly long lines. Use Text::Wrap (if available) to wrap the body of the report at an arbitrarily chosen and hopefully safe limit of 900 characters. No indentation or continuation line markers are added, though it would be easy to add those if desired. Attachments and mail headers are not wrapped. Bug-Debian: https://bugs.debian.org/822463 M lib/perlbug.t M utils/perlbug.PL commit bd18aea6d95681e1bd5c2cdfd894bd3706e4b819 Author: Niko Tyni <[email protected]> Date: Thu Apr 28 18:50:17 2016 +0300 perlbug: Refactor duplicated file reading code _send_message_mailsend() needs to build the message itself rather than calling build_complete_message() like the other backends, but they can still share the file reading code, and so can the 'display report' part. M utils/perlbug.PL commit a3b4b767538d6cb0592a1428349ec55e219b81b3 Author: Niko Tyni <[email protected]> Date: Sun May 1 22:53:11 2016 +0300 perlbug: Add unit tests Some of these tests have to mimic the interactive interface, which is probably rather fragile. However, as long as -F overrides any actual sending, no mail bombs will hopefully result. M MANIFEST M Porting/Maintainers.pl A lib/perlbug.t commit a2b4240a80b9c49a8a3c43c2bc84ccfeb6ef63af Author: Niko Tyni <[email protected]> Date: Sun May 1 22:19:13 2016 +0300 perlbug: Allow subjects without whitespace in test mode Passing whitespace in an option through test.pl runperl() doesn't seem to work, so relax the check in test mode (-t) for noninteractive testing. M utils/perlbug.PL commit 9cea1b144d6a5c138a4576a9d70366d1949a51db Author: Niko Tyni <[email protected]> Date: Sun May 1 20:06:37 2016 +0300 perlbug: quit main loop on empty answer / eof in test mode This makes it possible to drive perlbug noninteractively without having it go to an infinite loop on end of file. The change has no effect in non-test mode, where the default answer is the empty string. This is groundworks for perlbug unit tests. M utils/perlbug.PL commit fdfa33076f4f175751eccfb62ebb0c926a6307b0 Author: Niko Tyni <[email protected]> Date: Sun May 1 20:02:49 2016 +0300 perlbug: Allow noninteractive use in test mode (-t option) This is groundworks for perlbug unit tests. Not all of the interactive questions can be overridden on the command line, so we will have to pipe in commands. Adapt the test mode ("-t"), which used to just override the recipient address, for this rather than inventing one more new option. M utils/perlbug.PL ----------------------------------------------------------------------- Summary of changes: MANIFEST | 1 + Porting/Maintainers.pl | 1 + lib/perlbug.t | 155 +++++++++++++++++++++++++++++++++++++++++++++++++ utils/perlbug.PL | 46 ++++++++++----- 4 files changed, 188 insertions(+), 15 deletions(-) create mode 100644 lib/perlbug.t diff --git a/MANIFEST b/MANIFEST index 7bc78b9..eaeb89c 100644 --- a/MANIFEST +++ b/MANIFEST @@ -4407,6 +4407,7 @@ lib/perl5db/t/test-warnLevel-option-1 Tests for the Perl debugger lib/perl5db/t/test-w-statement-1 Tests for the Perl debugger lib/perl5db/t/uncalled-subroutine Tests for the Perl debugger lib/perl5db/t/with-subroutine Tests for the Perl debugger +lib/perlbug.t Tests for the Perl bug reporter lib/PerlIO.pm PerlIO support module lib/Pod/t/InputObjects.t See if Pod::InputObjects works lib/Pod/t/Select.t See if Pod::Select works diff --git a/Porting/Maintainers.pl b/Porting/Maintainers.pl index 0b8595f..a7868ea 100755 --- a/Porting/Maintainers.pl +++ b/Porting/Maintainers.pl @@ -1449,6 +1449,7 @@ use File::Glob qw(:case); lib/overload{.pm,.t,64.t} lib/perl5db.{pl,t} lib/perl5db/ + lib/perlbug.t lib/sigtrap.{pm,t} lib/sort.{pm,t} lib/strict.{pm,t} diff --git a/lib/perlbug.t b/lib/perlbug.t new file mode 100644 index 0000000..ed32c04 --- /dev/null +++ b/lib/perlbug.t @@ -0,0 +1,155 @@ +#!./perl +use strict; + +# test that perlbug generates somewhat sane reports, but don't +# actually send them + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +require './test.pl'; + +# lifted from perl5db.t +my $extracted_program = '../utils/perlbug'; # unix, nt, ... +if ($^O eq 'VMS') { $extracted_program = '[-.utils]perlbug.com'; } +if (!(-e $extracted_program)) { + print "1..0 # Skip: $extracted_program was not built\n"; + exit 0; +} + +my $result; +my $testreport = 'test.rep'; +unlink $testreport; + +sub _slurp { + my $file = shift; + ok(-f $file, "saved report $file exists"); + open(F, '<', $file) or return undef; + local $/; + my $ret = <F>; + close F; + $ret; +} + +sub _dump { + my $file = shift; + my $contents = shift; + open(F, '>', $file) or return; + print F $contents; + close F; + return 1; +} + +plan(22); + + +# check -d +$result = runperl( progfile => $extracted_program, + args => ['-d'] ); +like($result, qr/Site configuration information/, + 'config information dumped with -d'); + + +# check -v +$result = runperl( progfile => $extracted_program, + args => ['-d', '-v'] ); +like($result, qr/Complete configuration data/, + 'full config information dumped with -d -v'); + +# check that we need -t +$result = runperl( progfile => $extracted_program, + stderr => 1, # perlbug dies with "\n"; + stdin => undef); +like($result, qr/Please use perlbug interactively./, + 'checks for terminal in non-test mode'); + + +# test -okay (mostly noninteractive) +$result = runperl( progfile => $extracted_program, + args => ['-okay', '-F', $testreport] ); +like($result, qr/Message saved/, 'build report saved'); +like(_slurp($testreport), qr/Perl reported to build OK on this system/, + 'build report looks sane'); +unlink $testreport; + + +# test -nokay (a bit more interactive) +$result = runperl( progfile => $extracted_program, + stdin => 'f', # save to File + args => ['-t', + '-nokay', + '-e', 'file', + '-F', $testreport] ); +like($result, qr/Message saved/, 'build failure report saved'); +like(_slurp($testreport), qr/This is a build failure report for perl/, + 'build failure report looks sane'); +unlink $testreport; + + +# test a regular report +$result = runperl( progfile => $extracted_program, + # no CLI options for these + stdin => "\n" # Module + . "\n" # Category + . "\n" # Severity + . "\n" # Editor + . "f", # save to File + args => ['-t', + # runperl has trouble with whitespace + '-s', "testingperlbug", + '-r', '[email protected]', + '-c', 'none', + '-b', 'testreportbody', + '-e', 'file', + '-F', $testreport] ); +like($result, qr/Message saved/, 'fake bug report saved'); +my $contents = _slurp($testreport); +like($contents, qr/Subject: testingperlbug/, + 'Subject included in fake bug report'); +like($contents, qr/testreportbody/, 'body included in fake bug report'); +unlink $testreport; + + +# test wrapping of long lines +my $body = 'body.txt'; +unlink $body; +my $A = 'A'x9; +ok(_dump($body, ("$A "x120)), 'wrote 1200-char body to file'); + +my $attachment = 'attached.txt'; +unlink $attachment; +my $B = 'B'x9; +ok(_dump($attachment, ("$B "x120)), 'wrote 1200-char attachment to file'); + +$result = runperl( progfile => $extracted_program, + stdin => "testing perlbug\n" # Subject + . "\n" # Module + . "\n" # Category + . "\n" # Severity + . "f", # save to File + args => ['-t', + '-r', '[email protected]', + '-c', 'none', + '-f', $body, + '-p', $attachment, + '-e', 'file', + '-F', $testreport] ); +like($result, qr/Message saved/, 'fake bug report saved'); +my $contents = _slurp($testreport); +unlink $testreport, $body, $attachment; +like($contents, qr/Subject: testing perlbug/, + 'Subject included in fake bug report'); +like($contents, qr/$A/, 'body included in fake bug report'); +like($contents, qr/$B/, 'attachment included in fake bug report'); + +my $maxlen1 = 0; # body +my $maxlen2 = 0; # attachment +for (split(/\n/, $contents)) { + my $len = length; + $maxlen1 = $len if $len > $maxlen1 and !/$B/; + $maxlen2 = $len if $len > $maxlen2 and /$B/; +} +ok($maxlen1 < 1000, "[perl #128020] long body lines are wrapped: maxlen $maxlen1"); +ok($maxlen2 > 1000, "long attachment lines are not wrapped: maxlen $maxlen2"); diff --git a/utils/perlbug.PL b/utils/perlbug.PL index 885785a..6290ca7 100644 --- a/utils/perlbug.PL +++ b/utils/perlbug.PL @@ -76,6 +76,8 @@ BEGIN { $::HaveTemp = ($@ eq ""); eval { require Module::CoreList; }; $::HaveCoreList = ($@ eq ""); + eval { require Text::Wrap; }; + $::HaveWrap = ($@ eq ""); }; my $Version = "1.40"; @@ -101,7 +103,7 @@ Init(); if ($opt{h}) { Help(); exit; } if ($opt{d}) { Dump(*STDOUT); exit; } -if (!-t STDIN && !($ok and not $opt{n})) { +if (!-t STDIN && !$opt{t} && !($ok and not $opt{n})) { paraprint <<"EOF"; Please use $progname interactively. If you want to include a file, you can use the -f switch. @@ -828,16 +830,14 @@ a few options. You can: EOF retry: print $menu; - my $action = _prompt('', "Action (Send/Display/Edit/Subject/Save to File)");; + my $action = _prompt('', "Action (Send/Display/Edit/Subject/Save to File)", + $opt{t} ? 'q' : ''); print "\n"; if ($action =~ /^(f|sa)/i) { # <F>ile/<Sa>ve if ( SaveMessage() ) { exit } } elsif ($action =~ /^(d|l|sh)/i ) { # <D>isplay, <L>ist, <Sh>ow # Display the message - open(REP, '<:raw', $filename) or die "Couldn't open file '$filename': $!\n"; - binmode(REP, ':raw :crlf') if $Is_MSWin32; - while (<REP>) { print $_ } - close(REP) or die "Error closing report file '$filename': $!"; + print _read_report($filename); if ($have_attachment) { print "\n\n---\nAttachment(s):\n"; for my $att (split /\s*,\s*/, $attachments) { print " $att\n"; } @@ -879,7 +879,7 @@ sub TrivialSubject { if ($subject =~ /^(y(es)?|no?|help|perl( (bug|problem))?|bug|problem)$/i || length($subject) < 4 || - $subject !~ /\s/) { + ($subject !~ /\s/ && ! $opt{t})) { # non-whitespace is accepted in test mode print "\nThe subject you entered wasn't very descriptive. Please try again.\n\n"; return 1; } else { @@ -1014,6 +1014,7 @@ sub _prompt { } print $prompt. ($default ? " [$default]" :''). ": "; my $result = scalar(<>); + return $default if !defined $result; # got eof chomp($result); $result =~ s/^\s*(.*?)\s*$/$1/s; if ($default && $result eq '') { @@ -1080,13 +1081,29 @@ ATTACHMENT return $attach; } +sub _read_report { + my $fname = shift; + my $content; + open( REP, "<:raw", $fname ) or die "Couldn't open file '$fname': $!\n"; + binmode(REP, ':raw :crlf') if $Is_MSWin32; + # wrap long lines to make sure the report gets delivered + local $Text::Wrap::columns = 900; + local $Text::Wrap::huge = 'overflow'; + while (<REP>) { + if ($::HaveWrap && /\S/) { # wrap() would remove empty lines + $content .= Text::Wrap::wrap(undef, undef, $_); + } else { + $content .= $_; + } + } + close(REP) or die "Error closing report file '$fname': $!"; + return $content; +} + sub build_complete_message { my $content = _build_header(%{_message_headers()}) . "\n\n"; $content .= _add_body_start() if $have_attachment; - open( REP, "<:raw", $filename ) or die "Couldn't open file '$filename': $!\n"; - binmode(REP, ':raw :crlf') if $Is_MSWin32; - while (<REP>) { $content .= $_; } - close(REP) or die "Error closing report file '$filename': $!"; + $content .= _read_report($filename); $content .= _add_attachments() if $have_attachment; return $content; } @@ -1137,10 +1154,7 @@ sub _send_message_mailsend { $fh = $msg->open; binmode($fh, ':raw'); print $fh _add_body_start() if $have_attachment; - open(REP, "<:raw", $filename) or die "Couldn't open '$filename': $!\n"; - binmode(REP, ':raw :crlf') if $Is_MSWin32; - while (<REP>) { print $fh $_ } - close(REP) or die "Error closing $filename: $!"; + print $fh _read_report($filename); print $fh _add_attachments() if $have_attachment; $fh->close or die "Error sending mail: $!"; @@ -1526,6 +1540,8 @@ supply one on the command line. =item B<-t> Test mode. The target address defaults to B<[email protected]>. +Also makes it possible to command perlbug from a pipe or file, for +testing purposes. =item B<-T> -- Perl5 Master Repository
