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.

1 files changed, 158 insertions, 0 deletions

diff --git a/lib/perlbug.t b/lib/perlbug.t
new file mode 100644
index 0000000000..ede26af6d6
--- /dev/null
+++ b/lib/perlbug.t
@@ -0,0 +1,158 @@
+#!./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', 'username@example.com',
+                                '-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', 'username@example.com',
+                                '-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/;
+}
+TODO: {
+local $::TODO = 'long body lines not wrapped yet';
+ok($maxlen1 < 1000, "[perl #128020] long body lines are wrapped: maxlen $maxlen1");
+}
+ok($maxlen2 > 1000, "long attachment lines are not wrapped: maxlen $maxlen2");