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(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;