| 1 | #!./perl |
| 2 | use strict; |
| 3 | |
| 4 | # test that perlbug generates somewhat sane reports, but don't |
| 5 | # actually send them |
| 6 | |
| 7 | BEGIN { |
| 8 | chdir 't' if -d 't'; |
| 9 | @INC = '../lib'; |
| 10 | } |
| 11 | |
| 12 | require './test.pl'; |
| 13 | |
| 14 | # lifted from perl5db.t |
| 15 | my $extracted_program = '../utils/perlbug'; # unix, nt, ... |
| 16 | if ($^O eq 'VMS') { $extracted_program = '[-.utils]perlbug.com'; } |
| 17 | if (!(-e $extracted_program)) { |
| 18 | print "1..0 # Skip: $extracted_program was not built\n"; |
| 19 | exit 0; |
| 20 | } |
| 21 | |
| 22 | my $result; |
| 23 | my $testreport = 'test.rep'; |
| 24 | unlink $testreport; |
| 25 | |
| 26 | sub _slurp { |
| 27 | my $file = shift; |
| 28 | ok(-f $file, "saved report $file exists"); |
| 29 | open(F, '<', $file) or return undef; |
| 30 | local $/; |
| 31 | my $ret = <F>; |
| 32 | close F; |
| 33 | $ret; |
| 34 | } |
| 35 | |
| 36 | sub _dump { |
| 37 | my $file = shift; |
| 38 | my $contents = shift; |
| 39 | open(F, '>', $file) or return; |
| 40 | print F $contents; |
| 41 | close F; |
| 42 | return 1; |
| 43 | } |
| 44 | |
| 45 | plan(25); |
| 46 | |
| 47 | |
| 48 | # check -d |
| 49 | $result = runperl( progfile => $extracted_program, |
| 50 | args => ['-d'] ); |
| 51 | like($result, qr/Site configuration information/, |
| 52 | 'config information dumped with -d'); |
| 53 | |
| 54 | |
| 55 | # check -v |
| 56 | $result = runperl( progfile => $extracted_program, |
| 57 | args => ['-d', '-v'] ); |
| 58 | like($result, qr/Complete configuration data/, |
| 59 | 'full config information dumped with -d -v'); |
| 60 | |
| 61 | # check that we need -t |
| 62 | $result = runperl( progfile => $extracted_program, |
| 63 | stderr => 1, # perlbug dies with "\n"; |
| 64 | stdin => undef); |
| 65 | like($result, qr/Please use perlbug interactively./, |
| 66 | 'checks for terminal in non-test mode'); |
| 67 | |
| 68 | |
| 69 | # test -okay (mostly noninteractive) |
| 70 | $result = runperl( progfile => $extracted_program, |
| 71 | args => ['-okay', '-F', $testreport] ); |
| 72 | like($result, qr/Report saved/, 'build report saved'); |
| 73 | like(_slurp($testreport), qr/Perl reported to build OK on this system/, |
| 74 | 'build report looks sane'); |
| 75 | unlink $testreport; |
| 76 | |
| 77 | |
| 78 | # test -nokay (a bit more interactive) |
| 79 | $result = runperl( progfile => $extracted_program, |
| 80 | stdin => 'f', # save to File |
| 81 | args => ['-t', |
| 82 | '-nokay', |
| 83 | '-e', 'file', |
| 84 | '-F', $testreport] ); |
| 85 | like($result, qr/Report saved/, 'build failure report saved'); |
| 86 | like(_slurp($testreport), qr/This is a build failure report for perl/, |
| 87 | 'build failure report looks sane'); |
| 88 | unlink $testreport; |
| 89 | |
| 90 | |
| 91 | # test a regular report |
| 92 | $result = runperl( progfile => $extracted_program, |
| 93 | # no CLI options for these |
| 94 | stdin => "\n" # Module |
| 95 | . "\n" # Category |
| 96 | . "\n" # Severity |
| 97 | . "\n" # Editor |
| 98 | . "f", # save to File |
| 99 | args => ['-t', |
| 100 | # runperl has trouble with whitespace |
| 101 | '-s', "testingperlbug", |
| 102 | '-r', 'username@example.com', |
| 103 | '-c', 'none', |
| 104 | '-b', 'testreportbody', |
| 105 | '-e', 'file', |
| 106 | '-F', $testreport] ); |
| 107 | like($result, qr/Report saved/, 'fake bug report saved'); |
| 108 | my $contents = _slurp($testreport); |
| 109 | like($contents, qr/Subject: testingperlbug/, |
| 110 | 'Subject included in fake bug report'); |
| 111 | like($contents, qr/testreportbody/, 'body included in fake bug report'); |
| 112 | unlink $testreport; |
| 113 | |
| 114 | |
| 115 | # test wrapping of long lines |
| 116 | my $body = 'body.txt'; |
| 117 | unlink $body; |
| 118 | my $A = 'A'x9; |
| 119 | ok(_dump($body, ("$A "x120)), 'wrote 1200-char body to file'); |
| 120 | |
| 121 | my $attachment = 'attached.txt'; |
| 122 | unlink $attachment; |
| 123 | my $B = 'B'x9; |
| 124 | ok(_dump($attachment, ("$B "x120)), 'wrote 1200-char attachment to file'); |
| 125 | |
| 126 | $result = runperl( progfile => $extracted_program, |
| 127 | stdin => "testing perlbug\n" # Subject |
| 128 | . "\n" # Module |
| 129 | . "\n" # Category |
| 130 | . "\n" # Severity |
| 131 | . "f", # save to File |
| 132 | args => ['-t', |
| 133 | '-r', 'username@example.com', |
| 134 | '-c', 'none', |
| 135 | '-f', $body, |
| 136 | '-p', $attachment, |
| 137 | '-e', 'file', |
| 138 | '-F', $testreport] ); |
| 139 | like($result, qr/Report saved/, 'fake bug report saved'); |
| 140 | my $contents = _slurp($testreport); |
| 141 | unlink $testreport, $body, $attachment; |
| 142 | like($contents, qr/Subject: testing perlbug/, |
| 143 | 'Subject included in fake bug report'); |
| 144 | like($contents, qr/$A/, 'body included in fake bug report'); |
| 145 | like($contents, qr/$B/, 'attachment included in fake bug report'); |
| 146 | |
| 147 | my $maxlen1 = 0; # body |
| 148 | my $maxlen2 = 0; # attachment |
| 149 | for (split(/\n/, $contents)) { |
| 150 | my $len = length; |
| 151 | $maxlen1 = $len if $len > $maxlen1 and !/$B/; |
| 152 | $maxlen2 = $len if $len > $maxlen2 and /$B/; |
| 153 | } |
| 154 | ok($maxlen1 < 1000, "[perl #128020] long body lines are wrapped: maxlen $maxlen1"); |
| 155 | ok($maxlen2 > 1000, "long attachment lines are not wrapped: maxlen $maxlen2"); |
| 156 | |
| 157 | $result = runperl( progfile => $extracted_program, stderr => 1, args => ['-o'] ); # Invalid option |
| 158 | like($result, qr/^\s*This program is designed/, "No leading error messages with help from invalid arg."); |
| 159 | |
| 160 | $result = runperl( progfile => $extracted_program, stderr => 1, args => ['--help'] ); # Invalid option |
| 161 | like($result, qr/^\s*perlbug version \d+\.\d+\n+This program is designed/, "No leading error messages with help from --help and version is displayed."); |
| 162 | |
| 163 | $result = runperl( progfile => $extracted_program, stderr => 1, args => ['--version'] ); # Invalid option |
| 164 | like($result, qr/^perlbug version \d+\.\d+\n$/, "No leading error messages with --version"); |
| 165 | #print $result; |