15759b3d2Safresh1#!./perl 25759b3d2Safresh1use strict; 35759b3d2Safresh1 45759b3d2Safresh1# test that perlbug generates somewhat sane reports, but don't 55759b3d2Safresh1# actually send them 65759b3d2Safresh1 75759b3d2Safresh1BEGIN { 85759b3d2Safresh1 chdir 't' if -d 't'; 95759b3d2Safresh1 @INC = '../lib'; 105759b3d2Safresh1} 115759b3d2Safresh1 125759b3d2Safresh1require './test.pl'; 135759b3d2Safresh1 145759b3d2Safresh1# lifted from perl5db.t 155759b3d2Safresh1my $extracted_program = '../utils/perlbug'; # unix, nt, ... 165759b3d2Safresh1if ($^O eq 'VMS') { $extracted_program = '[-.utils]perlbug.com'; } 175759b3d2Safresh1if (!(-e $extracted_program)) { 185759b3d2Safresh1 print "1..0 # Skip: $extracted_program was not built\n"; 195759b3d2Safresh1 exit 0; 205759b3d2Safresh1} 215759b3d2Safresh1 225759b3d2Safresh1my $result; 235759b3d2Safresh1my $testreport = 'test.rep'; 245759b3d2Safresh1unlink $testreport; 255759b3d2Safresh1 265759b3d2Safresh1sub _slurp { 275759b3d2Safresh1 my $file = shift; 285759b3d2Safresh1 ok(-f $file, "saved report $file exists"); 295759b3d2Safresh1 open(F, '<', $file) or return undef; 305759b3d2Safresh1 local $/; 315759b3d2Safresh1 my $ret = <F>; 325759b3d2Safresh1 close F; 335759b3d2Safresh1 $ret; 345759b3d2Safresh1} 355759b3d2Safresh1 365759b3d2Safresh1sub _dump { 375759b3d2Safresh1 my $file = shift; 385759b3d2Safresh1 my $contents = shift; 395759b3d2Safresh1 open(F, '>', $file) or return; 405759b3d2Safresh1 print F $contents; 415759b3d2Safresh1 close F; 425759b3d2Safresh1 return 1; 435759b3d2Safresh1} 445759b3d2Safresh1 455759b3d2Safresh1plan(25); 465759b3d2Safresh1 475759b3d2Safresh1 485759b3d2Safresh1# check -d 495759b3d2Safresh1$result = runperl( progfile => $extracted_program, 505759b3d2Safresh1 args => ['-d'] ); 515759b3d2Safresh1like($result, qr/Site configuration information/, 525759b3d2Safresh1 'config information dumped with -d'); 535759b3d2Safresh1 545759b3d2Safresh1 555759b3d2Safresh1# check -v 565759b3d2Safresh1$result = runperl( progfile => $extracted_program, 575759b3d2Safresh1 args => ['-d', '-v'] ); 585759b3d2Safresh1like($result, qr/Complete configuration data/, 595759b3d2Safresh1 'full config information dumped with -d -v'); 605759b3d2Safresh1 615759b3d2Safresh1# check that we need -t 625759b3d2Safresh1$result = runperl( progfile => $extracted_program, 635759b3d2Safresh1 stderr => 1, # perlbug dies with "\n"; 645759b3d2Safresh1 stdin => undef); 655759b3d2Safresh1like($result, qr/Please use perlbug interactively./, 665759b3d2Safresh1 'checks for terminal in non-test mode'); 675759b3d2Safresh1 685759b3d2Safresh1 695759b3d2Safresh1# test -okay (mostly noninteractive) 705759b3d2Safresh1$result = runperl( progfile => $extracted_program, 715759b3d2Safresh1 args => ['-okay', '-F', $testreport] ); 72de8cc8edSafresh1like($result, qr/Report saved/, 'build report saved'); 735759b3d2Safresh1like(_slurp($testreport), qr/Perl reported to build OK on this system/, 745759b3d2Safresh1 'build report looks sane'); 755759b3d2Safresh1unlink $testreport; 765759b3d2Safresh1 775759b3d2Safresh1 785759b3d2Safresh1# test -nokay (a bit more interactive) 795759b3d2Safresh1$result = runperl( progfile => $extracted_program, 805759b3d2Safresh1 stdin => 'f', # save to File 815759b3d2Safresh1 args => ['-t', 825759b3d2Safresh1 '-nokay', 835759b3d2Safresh1 '-e', 'file', 845759b3d2Safresh1 '-F', $testreport] ); 85de8cc8edSafresh1like($result, qr/Report saved/, 'build failure report saved'); 865759b3d2Safresh1like(_slurp($testreport), qr/This is a build failure report for perl/, 875759b3d2Safresh1 'build failure report looks sane'); 885759b3d2Safresh1unlink $testreport; 895759b3d2Safresh1 905759b3d2Safresh1 915759b3d2Safresh1# test a regular report 925759b3d2Safresh1$result = runperl( progfile => $extracted_program, 935759b3d2Safresh1 # no CLI options for these 945759b3d2Safresh1 stdin => "\n" # Module 955759b3d2Safresh1 . "\n" # Category 965759b3d2Safresh1 . "\n" # Severity 975759b3d2Safresh1 . "\n" # Editor 985759b3d2Safresh1 . "f", # save to File 995759b3d2Safresh1 args => ['-t', 1005759b3d2Safresh1 # runperl has trouble with whitespace 1015759b3d2Safresh1 '-s', "testingperlbug", 1025759b3d2Safresh1 '-r', 'username@example.com', 1035759b3d2Safresh1 '-c', 'none', 1045759b3d2Safresh1 '-b', 'testreportbody', 1055759b3d2Safresh1 '-e', 'file', 1065759b3d2Safresh1 '-F', $testreport] ); 107de8cc8edSafresh1like($result, qr/Report saved/, 'fake bug report saved'); 1085759b3d2Safresh1my $contents = _slurp($testreport); 1095759b3d2Safresh1like($contents, qr/Subject: testingperlbug/, 1105759b3d2Safresh1 'Subject included in fake bug report'); 1115759b3d2Safresh1like($contents, qr/testreportbody/, 'body included in fake bug report'); 1125759b3d2Safresh1unlink $testreport; 1135759b3d2Safresh1 1145759b3d2Safresh1 1155759b3d2Safresh1# test wrapping of long lines 1165759b3d2Safresh1my $body = 'body.txt'; 1175759b3d2Safresh1unlink $body; 1185759b3d2Safresh1my $A = 'A'x9; 1195759b3d2Safresh1ok(_dump($body, ("$A "x120)), 'wrote 1200-char body to file'); 1205759b3d2Safresh1 1215759b3d2Safresh1my $attachment = 'attached.txt'; 1225759b3d2Safresh1unlink $attachment; 1235759b3d2Safresh1my $B = 'B'x9; 1245759b3d2Safresh1ok(_dump($attachment, ("$B "x120)), 'wrote 1200-char attachment to file'); 1255759b3d2Safresh1 1265759b3d2Safresh1$result = runperl( progfile => $extracted_program, 1275759b3d2Safresh1 stdin => "testing perlbug\n" # Subject 1285759b3d2Safresh1 . "\n" # Module 1295759b3d2Safresh1 . "\n" # Category 1305759b3d2Safresh1 . "\n" # Severity 1315759b3d2Safresh1 . "f", # save to File 1325759b3d2Safresh1 args => ['-t', 1335759b3d2Safresh1 '-r', 'username@example.com', 1345759b3d2Safresh1 '-c', 'none', 1355759b3d2Safresh1 '-f', $body, 1365759b3d2Safresh1 '-p', $attachment, 1375759b3d2Safresh1 '-e', 'file', 1385759b3d2Safresh1 '-F', $testreport] ); 139de8cc8edSafresh1like($result, qr/Report saved/, 'fake bug report saved'); 1405759b3d2Safresh1my $contents = _slurp($testreport); 1415759b3d2Safresh1unlink $testreport, $body, $attachment; 1425759b3d2Safresh1like($contents, qr/Subject: testing perlbug/, 1435759b3d2Safresh1 'Subject included in fake bug report'); 1445759b3d2Safresh1like($contents, qr/$A/, 'body included in fake bug report'); 1455759b3d2Safresh1like($contents, qr/$B/, 'attachment included in fake bug report'); 1465759b3d2Safresh1 1475759b3d2Safresh1my $maxlen1 = 0; # body 1485759b3d2Safresh1my $maxlen2 = 0; # attachment 1495759b3d2Safresh1for (split(/\n/, $contents)) { 1505759b3d2Safresh1 my $len = length; 151*f2a19305Safresh1 # content lines setting path-like environment variables like PATH, PERLBREW_PATH, MANPATH,... 152*f2a19305Safresh1 # will start "\s*xxxxPATH=" where "xxx" is zero or more non white space characters. These lines can 153*f2a19305Safresh1 # easily get over 1000 characters (see ok-test below) with no internal spaces, so they 154*f2a19305Safresh1 # will not get wrapped at white space. 155*f2a19305Safresh1 # See also https://github.com/perl/perl5/issues/15544 for more information 156*f2a19305Safresh1 $maxlen1 = $len if $len > $maxlen1 and !/(?:$B|^\s*\S*PATH=)/; 1575759b3d2Safresh1 $maxlen2 = $len if $len > $maxlen2 and /$B/; 1585759b3d2Safresh1} 1595759b3d2Safresh1ok($maxlen1 < 1000, "[perl #128020] long body lines are wrapped: maxlen $maxlen1"); 1605759b3d2Safresh1ok($maxlen2 > 1000, "long attachment lines are not wrapped: maxlen $maxlen2"); 1615759b3d2Safresh1 1625759b3d2Safresh1$result = runperl( progfile => $extracted_program, stderr => 1, args => ['-o'] ); # Invalid option 1635759b3d2Safresh1like($result, qr/^\s*This program is designed/, "No leading error messages with help from invalid arg."); 1645759b3d2Safresh1 1655759b3d2Safresh1$result = runperl( progfile => $extracted_program, stderr => 1, args => ['--help'] ); # Invalid option 1665759b3d2Safresh1like($result, qr/^\s*perlbug version \d+\.\d+\n+This program is designed/, "No leading error messages with help from --help and version is displayed."); 1675759b3d2Safresh1 1685759b3d2Safresh1$result = runperl( progfile => $extracted_program, stderr => 1, args => ['--version'] ); # Invalid option 1695759b3d2Safresh1like($result, qr/^perlbug version \d+\.\d+\n$/, "No leading error messages with --version"); 1705759b3d2Safresh1#print $result; 171