This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
perlbug: Add unit tests
authorNiko Tyni <ntyni@debian.org>
Sun, 1 May 2016 19:53:11 +0000 (22:53 +0300)
committerAaron Crane <arc@cpan.org>
Mon, 16 May 2016 12:31:34 +0000 (13:31 +0100)
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.

MANIFEST
Porting/Maintainers.pl
lib/perlbug.t [new file with mode: 0644]

index 7bc78b9..eaeb89c 100644 (file)
--- 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/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
 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
index 0b8595f..a7868ea 100755 (executable)
@@ -1449,6 +1449,7 @@ use File::Glob qw(:case);
                 lib/overload{.pm,.t,64.t}
                 lib/perl5db.{pl,t}
                 lib/perl5db/
                 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}
                 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 (file)
index 0000000..ede26af
--- /dev/null
@@ -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");