perlop: fix documentation for s/// "false" return value
[perl.git] / lib / perlbug.t
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(22);
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 }
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");