Commit | Line | Data |
---|---|---|
a3b4b767 NT |
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 | ||
7b1af8a6 | 45 | plan(25); |
a3b4b767 NT |
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/Message 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/Message 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/Message 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/Message 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 | } | |
a3b4b767 | 154 | ok($maxlen1 < 1000, "[perl #128020] long body lines are wrapped: maxlen $maxlen1"); |
a3b4b767 | 155 | ok($maxlen2 > 1000, "long attachment lines are not wrapped: maxlen $maxlen2"); |
7b1af8a6 TR |
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 | |
71aef030 | 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."); |
7b1af8a6 TR |
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; |