xref: /openbsd-src/gnu/usr.bin/perl/lib/perlbug.t (revision f6aab3d83b51b91c24247ad2c2573574de475a82) 
1#!./perl
2use strict;
3
4# test that perlbug generates somewhat sane reports, but don't
5# actually send them
6
7BEGIN {
8    chdir 't' if -d 't';
9    @INC = '../lib';
10}
11
12require './test.pl';
13
14# lifted from perl5db.t
15my $extracted_program = '../utils/perlbug'; # unix, nt, ...
16if ($^O eq 'VMS') { $extracted_program = '[-.utils]perlbug.com'; }
17if (!(-e $extracted_program)) {
18    print "1..0 # Skip: $extracted_program was not built\n";
19    exit 0;
20}
21
22my $result;
23my $testreport = 'test.rep';
24unlink $testreport;
25
26sub _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
36sub _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
45plan(25);
46
47
48# check -d
49$result = runperl( progfile => $extracted_program,
50                   args     => ['-d'] );
51like($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'] );
58like($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);
65like($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] );
72like($result, qr/Report saved/, 'build report saved');
73like(_slurp($testreport), qr/Perl reported to build OK on this system/,
74     'build report looks sane');
75unlink $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] );
85like($result, qr/Report saved/, 'build failure report saved');
86like(_slurp($testreport), qr/This is a build failure report for perl/,
87     'build failure report looks sane');
88unlink $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] );
107like($result, qr/Report saved/, 'fake bug report saved');
108my $contents = _slurp($testreport);
109like($contents, qr/Subject: testingperlbug/,
110     'Subject included in fake bug report');
111like($contents, qr/testreportbody/, 'body included in fake bug report');
112unlink $testreport;
113
114
115# test wrapping of long lines
116my $body = 'body.txt';
117unlink $body;
118my $A = 'A'x9;
119ok(_dump($body, ("$A "x120)), 'wrote 1200-char body to file');
120
121my $attachment = 'attached.txt';
122unlink $attachment;
123my $B = 'B'x9;
124ok(_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] );
139like($result, qr/Report saved/, 'fake bug report saved');
140my $contents = _slurp($testreport);
141unlink $testreport, $body, $attachment;
142like($contents, qr/Subject: testing perlbug/,
143     'Subject included in fake bug report');
144like($contents, qr/$A/, 'body included in fake bug report');
145like($contents, qr/$B/, 'attachment included in fake bug report');
146
147my $maxlen1 = 0; # body
148my $maxlen2 = 0; # attachment
149for (split(/\n/, $contents)) {
150        my $len = length;
151        $maxlen1 = $len if $len > $maxlen1 and !/$B/;
152        $maxlen2 = $len if $len > $maxlen2 and  /$B/;
153}
154ok($maxlen1 < 1000, "[perl #128020] long body lines are wrapped: maxlen $maxlen1");
155ok($maxlen2 > 1000, "long attachment lines are not wrapped: maxlen $maxlen2");
156
157$result = runperl( progfile => $extracted_program, stderr => 1, args => ['-o'] ); # Invalid option
158like($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
161like($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
164like($result, qr/^perlbug version \d+\.\d+\n$/, "No leading error messages with --version");
165#print $result;
166