utils/perlbug.PL

   1 #!/usr/local/bin/perl
   2
   3 use Config;
   4 use File::Basename qw(&basename &dirname);
   5 use Cwd;
   6 use File::Spec::Functions;
   7
   8 # List explicitly here the variables you want Configure to
   9 # generate.  Metaconfig only looks for shell variables, so you
  10 # have to mention them as if they were shell variables, not
  11 # %Config entries.  Thus you write
  12 #  $startperl
  13 # to ensure Configure will look for $Config{startperl}.
  14 #  $perlpath
  15
  16 # This forces PL files to create target in same directory as PL file.
  17 # This is so that make depend always knows where to find PL derivatives.
  18 $origdir = cwd;
  19 chdir dirname($0);
  20 $file = basename($0, '.PL');
  21 $file .= '.com' if $^O eq 'VMS';
  22
  23 open OUT, ">$file" or die "Can't create $file: $!";
  24
  25 # extract patchlevel.h information
  26
  27 open PATCH_LEVEL, "<" . catfile(updir, "patchlevel.h")
  28     or die "Can't open patchlevel.h: $!";
  29
  30 my $patchlevel_date = (stat PATCH_LEVEL)[9];
  31
  32 while (<PATCH_LEVEL>) {
  33     last if $_ =~ /^\s*static\s+char.*?local_patches\[\]\s*=\s*{\s*$/;
  34 }
  35
  36 my @patches;
  37 while (<PATCH_LEVEL>) {
  38     last if /^\s*}/;
  39     chomp;
  40     s/^\s+,?\s*"?//;
  41     s/"?\s*,?$//;
  42     s/(['\\])/\\$1/g;
  43     push @patches, $_ unless $_ eq 'NULL';
  44 }
  45 my $patch_desc = "'" . join("',\n    '", @patches) . "'";
  46 my $patch_tags = join "", map /(\S+)/ ? "+$1 " : (), @patches;
  47
  48 close(PATCH_LEVEL) or die "Error closing patchlevel.h: $!";
  49
  50 # TO DO (prehaps): store/embed $Config::config_sh into perlbug. When perlbug is
  51 # used, compare $Config::config_sh with the stored version. If they differ then
  52 # append a list of individual differences to the bug report.
  53
  54
  55 print "Extracting $file (with variable substitutions)\n";
  56
  57 # In this section, perl variables will be expanded during extraction.
  58 # You can use $Config{...} to use Configure variables.
  59
  60 my $extract_version = sprintf("v%vd", $^V);
  61
  62 print OUT <<"!GROK!THIS!";
  63 $Config{startperl}
  64     eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}'
  65         if \$running_under_some_shell;
  66
  67 my \$config_tag1 = '$extract_version - $Config{cf_time}';
  68
  69 my \$patchlevel_date = $patchlevel_date;
  70 my \$patch_tags = '$patch_tags';
  71 my \@patches = (
  72     $patch_desc
  73 );
  74 !GROK!THIS!
  75
  76 # In the following, perl variables are not expanded during extraction.
  77
  78 print OUT <<'!NO!SUBS!';
  79
  80 use Config;
  81 use File::Spec;         # keep perlbug Perl 5.005 compatible
  82 use Getopt::Std;
  83 use strict;
  84
  85 sub paraprint;
  86
  87 BEGIN {
  88     eval "use Mail::Send;";
  89     $::HaveSend = ($@ eq "");
  90     eval "use Mail::Util;";
  91     $::HaveUtil = ($@ eq "");
  92 };
  93
  94 my $Version = "1.34";
  95
  96 # Changed in 1.06 to skip Mail::Send and Mail::Util if not available.
  97 # Changed in 1.07 to see more sendmail execs, and added pipe output.
  98 # Changed in 1.08 to use correct address for sendmail.
  99 # Changed in 1.09 to close the REP file before calling it up in the editor.
 100 #                 Also removed some old comments duplicated elsewhere.
 101 # Changed in 1.10 to run under VMS without Mail::Send; also fixed
 102 #                 temp filename generation.
 103 # Changed in 1.11 to clean up some text and removed Mail::Send deactivator.
 104 # Changed in 1.12 to check for editor errors, make save/send distinction
 105 #                 clearer and add $ENV{REPLYTO}.
 106 # Changed in 1.13 to hopefully make it more difficult to accidentally
 107 #                 send mail
 108 # Changed in 1.14 to make the prompts a little more clear on providing
 109 #                 helpful information. Also let file read fail gracefully.
 110 # Changed in 1.15 to add warnings to stop people using perlbug for non-bugs.
 111 #                 Also report selected environment variables.
 112 # Changed in 1.16 to include @INC, and allow user to re-edit if no changes.
 113 # Changed in 1.17 Win32 support added.  GSAR 97-04-12
 114 # Changed in 1.18 add '-ok' option for reporting build success. CFR 97-06-18
 115 # Changed in 1.19 '-ok' default not '-v'
 116 #                 add local patch information
 117 #                 warn on '-ok' if this is an old system; add '-okay'
 118 # Changed in 1.20 Added patchlevel.h reading and version/config checks
 119 # Changed in 1.21 Added '-nok' for reporting build failure DFD 98-05-05
 120 # Changed in 1.22 Heavy reformatting & minor bugfixes HVDS 98-05-10
 121 # Changed in 1.23 Restore -ok(ay): say 'success'; don't prompt
 122 # Changed in 1.24 Added '-F<file>' to save report HVDS 98-07-01
 123 # Changed in 1.25 Warn on failure to open save file. HVDS 98-07-12
 124 # Changed in 1.26 Don't require -t STDIN for -ok. HVDS 98-07-15
 125 # Changed in 1.27 Added Mac OS and File::Spec support CNANDOR 99-07-27
 126 # Changed in 1.28 Additional questions for Perlbugtron RFOLEY 20.03.2000
 127 # Changed in 1.29 Perlbug(tron): auto(-ok), short prompts RFOLEY 05-05-2000
 128 # Changed in 1.30 Added warnings on failure to open files MSTEVENS 13-07-2000
 129 # Changed in 1.31 Add checks on close().Fix my $var unless. TJENNESS 26-07-2000
 130 # Changed in 1.32 Use File::Spec->tmpdir TJENNESS 20-08-2000
 131 # Changed in 1.33 Don't require -t STDOUT for -ok.
 132 # Changed in 1.34 Added Message-Id RFOLEY 18-06-2002
 133
 134 # TODO: - Allow the user to re-name the file on mail failure, and
 135 #       make sure failure (transmission-wise) of Mail::Send is
 136 #       accounted for.
 137 #       - Test -b option
 138
 139 my( $file, $usefile, $cc, $address, $perlbug, $testaddress, $filename, $messageid, $domain,
 140     $subject, $from, $verbose, $ed, $outfile, $Is_MacOS, $category, $severity,
 141     $fh, $me, $Is_MSWin32, $Is_Linux, $Is_VMS, $msg, $body, $andcc, %REP, $ok,
 142     $Is_OpenBSD);
 143
 144 my $perl_version = $^V ? sprintf("v%vd", $^V) : $];
 145
 146 my $config_tag2 = "$perl_version - $Config{cf_time}";
 147
 148 Init();
 149
 150 if ($::opt_h) { Help(); exit; }
 151 if ($::opt_d) { Dump(*STDOUT); exit; }
 152 if (!-t STDIN && !($ok and not $::opt_n)) {
 153     paraprint <<EOF;
 154 Please use perlbug interactively. If you want to
 155 include a file, you can use the -f switch.
 156 EOF
 157     die "\n";
 158 }
 159
 160 Query();
 161 Edit() unless $usefile || ($ok and not $::opt_n);
 162 NowWhat();
 163 Send();
 164
 165 exit;
 166
 167 sub ask_for_alternatives { # (category|severity)
 168     my $name = shift;
 169     my %alts = (
 170         'category' => {
 171             'default' => 'core',
 172             'ok'      => 'install',
 173             'opts'    => [qw(core docs install library utilities)], # patch, notabug
 174         },
 175         'severity' => {
 176             'default' => 'low',
 177             'ok'      => 'none',
 178             'opts'    => [qw(critical high medium low wishlist none)], # zero
 179         },
 180     );
 181     die "Invalid alternative($name) requested\n" unless grep(/^$name$/, keys %alts);
 182     my $alt = "";
 183     if ($ok) {
 184         $alt = $alts{$name}{'ok'};
 185     } else {
 186         my @alts = @{$alts{$name}{'opts'}};
 187         paraprint <<EOF;
 188 Please pick a \u$name from the following:
 189
 190     @alts
 191
 192 EOF
 193         my $err = 0;
 194         do {
 195             if ($err++ > 5) {
 196                 die "Invalid $name: aborting.\n";
 197             }
 198             print "Please enter a \u$name [$alts{$name}{'default'}]: ";
 199             $alt = <>;
 200             chomp $alt;
 201             if ($alt =~ /^\s*$/) {
 202                 $alt = $alts{$name}{'default'};
 203             }
 204         } while !((($alt) = grep(/^$alt/i, @alts)));
 205     }
 206     lc $alt;
 207 }
 208
 209 sub Init {
 210     # -------- Setup --------
 211
 212     $Is_MSWin32 = $^O eq 'MSWin32';
 213     $Is_VMS = $^O eq 'VMS';
 214     $Is_Linux = lc($^O) eq 'linux';
 215     $Is_OpenBSD = lc($^O) eq 'openbsd';
 216     $Is_MacOS = $^O eq 'MacOS';
 217
 218     @ARGV = split m/\s+/,
 219         MacPerl::Ask('Provide command-line args here (-h for help):')
 220         if $Is_MacOS && $MacPerl::Version =~ /App/;
 221
 222     if (!getopts("Adhva:s:b:f:F:r:e:SCc:to:n:")) { Help(); exit; };
 223
 224     # This comment is needed to notify metaconfig that we are
 225     # using the $perladmin, $cf_by, and $cf_time definitions.
 226
 227     # -------- Configuration ---------
 228
 229     # perlbug address
 230     $perlbug = 'perlbug@perl.org';
 231
 232     # Test address
 233     $testaddress = 'perlbug-test@perl.org';
 234
 235     # Target address
 236     $address = $::opt_a || ($::opt_t ? $testaddress : $perlbug);
 237
 238     # Users address, used in message and in Reply-To header
 239     $from = $::opt_r || "";
 240
 241     # Include verbose configuration information
 242     $verbose = $::opt_v || 0;
 243
 244     # Subject of bug-report message
 245     $subject = $::opt_s || "";
 246
 247     # Send a file
 248     $usefile = ($::opt_f || 0);
 249
 250     # File to send as report
 251     $file = $::opt_f || "";
 252
 253     # File to output to
 254     $outfile = $::opt_F || "";
 255
 256     # Body of report
 257     $body = $::opt_b || "";
 258
 259     # Editor
 260     $ed = $::opt_e || $ENV{VISUAL} || $ENV{EDITOR} || $ENV{EDIT}
 261         || ($Is_VMS && "edit/tpu")
 262         || ($Is_MSWin32 && "notepad")
 263         || ($Is_MacOS && '')
 264         || "vi";
 265
 266     # Not OK - provide build failure template by finessing OK report
 267     if ($::opt_n) {
 268         if (substr($::opt_n, 0, 2) eq 'ok' )    {
 269             $::opt_o = substr($::opt_n, 1);
 270         } else {
 271             Help();
 272             exit();
 273         }
 274     }
 275
 276     # OK - send "OK" report for build on this system
 277     $ok = 0;
 278     if ($::opt_o) {
 279         if ($::opt_o eq 'k' or $::opt_o eq 'kay') {
 280             my $age = time - $patchlevel_date;
 281             if ($::opt_o eq 'k' and $age > 60 * 24 * 60 * 60 ) {
 282                 my $date = localtime $patchlevel_date;
 283                 print <<"EOF";
 284 "perlbug -ok" and "perlbug -nok" do not report on Perl versions which
 285 are more than 60 days old.  This Perl version was constructed on
 286 $date.  If you really want to report this, use
 287 "perlbug -okay" or "perlbug -nokay".
 288 EOF
 289                 exit();
 290             }
 291             # force these options
 292             unless ($::opt_n) {
 293                 $::opt_S = 1; # don't prompt for send
 294                 $::opt_b = 1; # we have a body
 295                 $body = "Perl reported to build OK on this system.\n";
 296             }
 297             $::opt_C = 1; # don't send a copy to the local admin
 298             $::opt_s = 1; # we have a subject line
 299             $subject = ($::opt_n ? 'Not ' : '')
 300                     . "OK: perl $perl_version ${patch_tags}on"
 301                     ." $::Config{'archname'} $::Config{'osvers'} $subject";
 302             $ok = 1;
 303         } else {
 304             Help();
 305             exit();
 306         }
 307     }
 308
 309     # Possible administrator addresses, in order of confidence
 310     # (Note that cf_email is not mentioned to metaconfig, since
 311     # we don't really want it. We'll just take it if we have to.)
 312     #
 313     # This has to be after the $ok stuff above because of the way
 314     # that $::opt_C is forced.
 315     $cc = $::opt_C ? "" : (
 316         $::opt_c || $::Config{'perladmin'}
 317         || $::Config{'cf_email'} || $::Config{'cf_by'}
 318     );
 319
 320     if ($::HaveUtil) {
 321                 $domain = Mail::Util::maildomain();
 322     } elsif ($Is_MSWin32) {
 323                 $domain = $ENV{'USERDOMAIN'};
 324     } else {
 325                 require Sys::Hostname;
 326                 $domain = Sys::Hostname::hostname();
 327     }
 328
 329     # Message-Id - rjsf
 330     $messageid = "<$::Config{'version'}_${$}_".time."\@$domain>";
 331
 332     # My username
 333     $me = $Is_MSWin32 ? $ENV{'USERNAME'}
 334             : $^O eq 'os2' ? $ENV{'USER'} || $ENV{'LOGNAME'}
 335             : $Is_MacOS ? $ENV{'USER'}
 336             : eval { getpwuid($<) };    # May be missing
 337
 338     $from = $::Config{'cf_email'}
 339        if !$from && $::Config{'cf_email'} && $::Config{'cf_by'} && $me &&
 340                ($me eq $::Config{'cf_by'});
 341 } # sub Init
 342
 343 sub Query {
 344     # Explain what perlbug is
 345     unless ($ok) {
 346         paraprint <<EOF;
 347 This program provides an easy way to create a message reporting a bug
 348 in perl, and e-mail it to $address.  It is *NOT* intended for
 349 sending test messages or simply verifying that perl works, *NOR* is it
 350 intended for reporting bugs in third-party perl modules.  It is *ONLY*
 351 a means of reporting verifiable problems with the core perl distribution,
 352 and any solutions to such problems, to the people who maintain perl.
 353
 354 If you're just looking for help with perl, try posting to the Usenet
 355 newsgroup comp.lang.perl.misc.  If you're looking for help with using
 356 perl with CGI, try posting to comp.infosystems.www.programming.cgi.
 357 EOF
 358     }
 359
 360     # Prompt for subject of message, if needed
 361
 362     if (TrivialSubject($subject)) {
 363         $subject = '';
 364     }
 365
 366     unless ($subject) {
 367         paraprint <<EOF;
 368 First of all, please provide a subject for the
 369 message. It should be a concise description of
 370 the bug or problem. "perl bug" or "perl problem"
 371 is not a concise description.
 372 EOF
 373
 374         my $err = 0;
 375         do {
 376             print "Subject: ";
 377             $subject = <>;
 378             chomp $subject;
 379             if ($err++ == 5) {
 380                 die "Aborting.\n";
 381             }
 382         } while (TrivialSubject($subject));
 383     }
 384
 385     # Prompt for return address, if needed
 386     unless ($from) {
 387         # Try and guess return address
 388         my $guess;
 389
 390         $guess = $ENV{'REPLY-TO'} || $ENV{'REPLYTO'} || '';
 391         if ($Is_MacOS) {
 392             require Mac::InternetConfig;
 393             $guess = $Mac::InternetConfig::InternetConfig{
 394                 Mac::InternetConfig::kICEmail()
 395             };
 396         }
 397
 398         unless ($guess) {
 399                 # move $domain to where we can use it elsewhere
 400         if ($domain) {
 401                 if ($Is_VMS && !$::Config{'d_socket'}) {
 402                     $guess = "$domain\:\:$me";
 403                 } else {
 404                     $guess = "$me\@$domain" if $domain;
 405                 }
 406             }
 407         }
 408
 409         if ($guess) {
 410             unless ($ok) {
 411                 paraprint <<EOF;
 412 Your e-mail address will be useful if you need to be contacted. If the
 413 default shown is not your full internet e-mail address, please correct it.
 414 EOF
 415             }
 416         } else {
 417             paraprint <<EOF;
 418 So that you may be contacted if necessary, please enter
 419 your full internet e-mail address here.
 420 EOF
 421         }
 422
 423         if ($ok && $guess) {
 424             # use it
 425             $from = $guess;
 426         } else {
 427             # verify it
 428             print "Your address [$guess]: ";
 429             $from = <>;
 430             chomp $from;
 431             $from = $guess if $from eq '';
 432         }
 433     }
 434
 435     if ($from eq $cc or $me eq $cc) {
 436         # Try not to copy ourselves
 437         $cc = "yourself";
 438     }
 439
 440     # Prompt for administrator address, unless an override was given
 441     if( !$::opt_C and !$::opt_c ) {
 442         paraprint <<EOF;
 443 A copy of this report can be sent to your local
 444 perl administrator. If the address is wrong, please
 445 correct it, or enter 'none' or 'yourself' to not send
 446 a copy.
 447 EOF
 448         print "Local perl administrator [$cc]: ";
 449         my $entry = scalar <>;
 450         chomp $entry;
 451
 452         if ($entry ne "") {
 453             $cc = $entry;
 454             $cc = '' if $me eq $cc;
 455         }
 456     }
 457
 458     $cc = '' if $cc =~ /^(none|yourself|me|myself|ourselves)$/i;
 459     $andcc = " and $cc" if $cc;
 460
 461     # Prompt for editor, if no override is given
 462 editor:
 463     unless ($::opt_e || $::opt_f || $::opt_b) {
 464         paraprint <<EOF;
 465 Now you need to supply the bug report. Try to make
 466 the report concise but descriptive. Include any
 467 relevant detail. If you are reporting something
 468 that does not work as you think it should, please
 469 try to include example of both the actual
 470 result, and what you expected.
 471
 472 Some information about your local
 473 perl configuration will automatically be included
 474 at the end of the report. If you are using any
 475 unusual version of perl, please try and confirm
 476 exactly which versions are relevant.
 477
 478 You will probably want to use an editor to enter
 479 the report. If "$ed" is the editor you want
 480 to use, then just press Enter, otherwise type in
 481 the name of the editor you would like to use.
 482
 483 If you would like to use a prepared file, type
 484 "file", and you will be asked for the filename.
 485 EOF
 486         print "Editor [$ed]: ";
 487         my $entry =scalar <>;
 488         chomp $entry;
 489
 490         $usefile = 0;
 491         if ($entry eq "file") {
 492             $usefile = 1;
 493         } elsif ($entry ne "") {
 494             $ed = $entry;
 495         }
 496     }
 497
 498     # Prompt for category of bug
 499     $category ||= ask_for_alternatives('category');
 500
 501     # Prompt for severity of bug
 502     $severity ||= ask_for_alternatives('severity');
 503
 504     # Generate scratch file to edit report in
 505     $filename = filename();
 506
 507     # Prompt for file to read report from, if needed
 508     if ($usefile and !$file) {
 509 filename:
 510         paraprint <<EOF;
 511 What is the name of the file that contains your report?
 512 EOF
 513         print "Filename: ";
 514         my $entry = scalar <>;
 515         chomp $entry;
 516
 517         if ($entry eq "") {
 518             paraprint <<EOF;
 519 No filename? I'll let you go back and choose an editor again.
 520 EOF
 521             goto editor;
 522         }
 523
 524         unless (-f $entry and -r $entry) {
 525             paraprint <<EOF;
 526 I'm sorry, but I can't read from `$entry'. Maybe you mistyped the name of
 527 the file? If you don't want to send a file, just enter a blank line and you
 528 can get back to the editor selection.
 529 EOF
 530             goto filename;
 531         }
 532         $file = $entry;
 533     }
 534
 535     # Generate report
 536     open(REP,">$filename") or die "Unable to create report file `$filename': $!\n";
 537     my $reptype = !$ok ? "bug" : $::opt_n ? "build failure" : "success";
 538
 539     print REP <<EOF;
 540 This is a $reptype report for perl from $from,
 541 generated with the help of perlbug $Version running under perl $perl_version.
 542
 543 EOF
 544
 545     if ($body) {
 546         print REP $body;
 547     } elsif ($usefile) {
 548         open(F, "<$file")
 549                 or die "Unable to read report file from `$file': $!\n";
 550         while (<F>) {
 551             print REP $_
 552         }
 553         close(F) or die "Error closing `$file': $!";
 554     } else {
 555         print REP <<EOF;
 556
 557 -----------------------------------------------------------------
 558 [Please enter your report here]
 559
 560
 561
 562 [Please do not change anything below this line]
 563 -----------------------------------------------------------------
 564 EOF
 565     }
 566     Dump(*REP);
 567     close(REP) or die "Error closing report file: $!";
 568
 569     # read in the report template once so that
 570     # we can track whether the user does any editing.
 571     # yes, *all* whitespace is ignored.
 572     open(REP, "<$filename") or die "Unable to open report file `$filename': $!\n";
 573     while (<REP>) {
 574         s/\s+//g;
 575         $REP{$_}++;
 576     }
 577     close(REP) or die "Error closing report file `$filename': $!";
 578 } # sub Query
 579
 580 sub Dump {
 581     local(*OUT) = @_;
 582
 583     print OUT <<EFF;
 584 ---
 585 Flags:
 586     category=$category
 587     severity=$severity
 588 EFF
 589     if ($::opt_A) {
 590         print OUT <<EFF;
 591     ack=no
 592 EFF
 593     }
 594     print OUT <<EFF;
 595 ---
 596 EFF
 597     print OUT "This perlbug was built using Perl $config_tag1\n",
 598             "It is being executed now by  Perl $config_tag2.\n\n"
 599         if $config_tag2 ne $config_tag1;
 600
 601     print OUT <<EOF;
 602 Site configuration information for perl $perl_version:
 603
 604 EOF
 605     if ($::Config{cf_by} and $::Config{cf_time}) {
 606         print OUT "Configured by $::Config{cf_by} at $::Config{cf_time}.\n\n";
 607     }
 608     print OUT Config::myconfig;
 609
 610     if (@patches) {
 611         print OUT join "\n    ", "Locally applied patches:", @patches;
 612         print OUT "\n";
 613     };
 614
 615     print OUT <<EOF;
 616
 617 ---
 618 \@INC for perl $perl_version:
 619 EOF
 620     for my $i (@INC) {
 621         print OUT "    $i\n";
 622     }
 623
 624     print OUT <<EOF;
 625
 626 ---
 627 Environment for perl $perl_version:
 628 EOF
 629     my @env =
 630         qw(PATH LD_LIBRARY_PATH LANG PERL_BADLANG SHELL HOME LOGDIR LANGUAGE);
 631     push @env, $Config{ldlibpthname} if $Config{ldlibpthname} ne '';
 632     push @env, grep /^(?:PERL|LC_|LANG|CYGWIN)/, keys %ENV;
 633     my %env;
 634     @env{@env} = @env;
 635     for my $env (sort keys %env) {
 636         print OUT "    $env",
 637                 exists $ENV{$env} ? "=$ENV{$env}" : ' (unset)',
 638                 "\n";
 639     }
 640     if ($verbose) {
 641         print OUT "\nComplete configuration data for perl $perl_version:\n\n";
 642         my $value;
 643         foreach (sort keys %::Config) {
 644             $value = $::Config{$_};
 645             $value =~ s/'/\\'/g;
 646             print OUT "$_='$value'\n";
 647         }
 648     }
 649 } # sub Dump
 650
 651 sub Edit {
 652     # Edit the report
 653     if ($usefile || $body) {
 654         paraprint <<EOF;
 655 Please make sure that the name of the editor you want to use is correct.
 656 EOF
 657         print "Editor [$ed]: ";
 658         my $entry =scalar <>;
 659         chomp $entry;
 660         $ed = $entry unless $entry eq '';
 661     }
 662
 663 tryagain:
 664     my $sts;
 665     $sts = system("$ed $filename") unless $Is_MacOS;
 666     if ($Is_MacOS) {
 667         require ExtUtils::MakeMaker;
 668         ExtUtils::MM_MacOS::launch_file($filename);
 669         paraprint <<EOF;
 670 Press Enter when done.
 671 EOF
 672         scalar <>;
 673     }
 674     if ($sts) {
 675         paraprint <<EOF;
 676 The editor you chose (`$ed') could apparently not be run!
 677 Did you mistype the name of your editor? If so, please
 678 correct it here, otherwise just press Enter.
 679 EOF
 680         print "Editor [$ed]: ";
 681         my $entry =scalar <>;
 682         chomp $entry;
 683
 684         if ($entry ne "") {
 685             $ed = $entry;
 686             goto tryagain;
 687         } else {
 688             paraprint <<EOF;
 689 You may want to save your report to a file, so you can edit and mail it
 690 yourself.
 691 EOF
 692         }
 693     }
 694
 695     return if ($ok and not $::opt_n) || $body;
 696     # Check that we have a report that has some, eh, report in it.
 697     my $unseen = 0;
 698
 699     open(REP, "<$filename") or die "Couldn't open `$filename': $!\n";
 700     # a strange way to check whether any significant editing
 701     # have been done: check whether any new non-empty lines
 702     # have been added. Yes, the below code ignores *any* space
 703     # in *any* line.
 704     while (<REP>) {
 705         s/\s+//g;
 706         $unseen++ if $_ ne '' and not exists $REP{$_};
 707     }
 708
 709     while ($unseen == 0) {
 710         paraprint <<EOF;
 711 I am sorry but it looks like you did not report anything.
 712 EOF
 713         print "Action (Retry Edit/Cancel) ";
 714         my ($action) = scalar(<>);
 715         if ($action =~ /^[re]/i) { # <R>etry <E>dit
 716             goto tryagain;
 717         } elsif ($action =~ /^[cq]/i) { # <C>ancel, <Q>uit
 718             Cancel();
 719         }
 720     }
 721 } # sub Edit
 722
 723 sub Cancel {
 724     1 while unlink($filename);  # remove all versions under VMS
 725     print "\nCancelling.\n";
 726     exit(0);
 727 }
 728
 729 sub NowWhat {
 730     # Report is done, prompt for further action
 731     if( !$::opt_S ) {
 732         while(1) {
 733             paraprint <<EOF;
 734 Now that you have completed your report, would you like to send
 735 the message to $address$andcc, display the message on
 736 the screen, re-edit it, display/change the subject,
 737 or cancel without sending anything?
 738 You may also save the message as a file to mail at another time.
 739 EOF
 740       retry:
 741             print "Action (Send/Display/Edit/Subject/Save to File): ";
 742             my $action = scalar <>;
 743             chomp $action;
 744
 745             if ($action =~ /^(f|sa)/i) { # <F>ile/<Sa>ve
 746                 my $file_save = $outfile || "perlbug.rep";
 747                 print "\n\nName of file to save message in [$file_save]: ";
 748                 my $file = scalar <>;
 749                 chomp $file;
 750                 $file = $file_save if $file eq "";
 751
 752                 unless (open(FILE, ">$file")) {
 753                     print "\nError opening $file: $!\n\n";
 754                     goto retry;
 755                 }
 756                 open(REP, "<$filename") or die "Couldn't open file `$filename': $!\n";
 757                 print FILE "To: $address\nSubject: $subject\n";
 758                 print FILE "Cc: $cc\n" if $cc;
 759                 print FILE "Reply-To: $from\n" if $from;
 760                 print FILE "Message-Id: $messageid\n" if $messageid;
 761                 print FILE "\n";
 762                 while (<REP>) { print FILE }
 763                 close(REP) or die "Error closing report file `$filename': $!";
 764                 close(FILE) or die "Error closing $file: $!";
 765
 766                 print "\nMessage saved in `$file'.\n";
 767                 exit;
 768             } elsif ($action =~ /^(d|l|sh)/i ) { # <D>isplay, <L>ist, <Sh>ow
 769                 # Display the message
 770                 open(REP, "<$filename") or die "Couldn't open file `$filename': $!\n";
 771                 while (<REP>) { print $_ }
 772                 close(REP) or die "Error closing report file `$filename': $!";
 773             } elsif ($action =~ /^su/i) { # <Su>bject
 774                 print "Subject: $subject\n";
 775                 print "If the above subject is fine, just press Enter.\n";
 776                 print "If not, type in the new subject.\n";
 777                 print "Subject: ";
 778                 my $reply = scalar <STDIN>;
 779                 chomp $reply;
 780                 if ($reply ne '') {
 781                     unless (TrivialSubject($reply)) {
 782                         $subject = $reply;
 783                         print "Subject: $subject\n";
 784                     }
 785                 }
 786             } elsif ($action =~ /^se/i) { # <S>end
 787                 # Send the message
 788                 print "Are you certain you want to send this message?\n"
 789                     . 'Please type "yes" if you are: ';
 790                 my $reply = scalar <STDIN>;
 791                 chomp $reply;
 792                 if ($reply eq "yes") {
 793                     last;
 794                 } else {
 795                     paraprint <<EOF;
 796 That wasn't a clear "yes", so I won't send your message. If you are sure
 797 your message should be sent, type in "yes" (without the quotes) at the
 798 confirmation prompt.
 799 EOF
 800                 }
 801             } elsif ($action =~ /^[er]/i) { # <E>dit, <R>e-edit
 802                 # edit the message
 803                 Edit();
 804             } elsif ($action =~ /^[qc]/i) { # <C>ancel, <Q>uit
 805                 Cancel();
 806             } elsif ($action =~ /^s/i) {
 807                 paraprint <<EOF;
 808 I'm sorry, but I didn't understand that. Please type "send" or "save".
 809 EOF
 810             }
 811         }
 812     }
 813 } # sub NowWhat
 814
 815 sub TrivialSubject {
 816     my $subject = shift;
 817     if ($subject =~
 818         /^(y(es)?|no?|help|perl( (bug|problem))?|bug|problem)$/i ||
 819         length($subject) < 4 ||
 820         $subject !~ /\s/) {
 821         print "\nThat doesn't look like a good subject.  Please be more verbose.\n\n";
 822         return 1;
 823     } else {
 824         return 0;
 825     }
 826 }
 827
 828 sub Send {
 829     # Message has been accepted for transmission -- Send the message
 830     if ($outfile) {
 831         open SENDMAIL, ">$outfile" or die "Couldn't open '$outfile': $!\n";
 832         goto sendout;
 833     }
 834
 835     # on linux certain mail implementations won't accept the subject
 836     # as "~s subject" and thus the Subject header will be corrupted
 837     # so don't use Mail::Send to be safe
 838     if ($::HaveSend && !$Is_Linux && !$Is_OpenBSD) {
 839         $msg = new Mail::Send Subject => $subject, To => $address;
 840         $msg->cc($cc) if $cc;
 841         $msg->add("Reply-To",$from) if $from;
 842
 843         $fh = $msg->open;
 844         open(REP, "<$filename") or die "Couldn't open `$filename': $!\n";
 845         while (<REP>) { print $fh $_ }
 846         close(REP) or die "Error closing $filename: $!";
 847         $fh->close;
 848
 849         print "\nMessage sent.\n";
 850     } elsif ($Is_VMS) {
 851         if ( ($address =~ /@/ and $address !~ /^\w+%"/) or
 852              ($cc      =~ /@/ and $cc      !~ /^\w+%"/) ) {
 853             my $prefix;
 854             foreach (qw[ IN MX SMTP UCX PONY WINS ], '') {
 855                 $prefix = "$_%", last if $ENV{"MAIL\$PROTOCOL_$_"};
 856             }
 857             $address = qq[${prefix}"$address"] unless $address =~ /^\w+%"/;
 858             $cc = qq[${prefix}"$cc"] unless !$cc || $cc =~ /^\w+%"/;
 859         }
 860         $subject =~ s/"/""/g; $address =~ s/"/""/g; $cc =~ s/"/""/g;
 861         my $sts = system(qq[mail/Subject="$subject" $filename. "$address","$cc"]);
 862         if ($sts) {
 863             die <<EOF;
 864 Can't spawn off mail
 865         (leaving bug report in $filename): $sts
 866 EOF
 867         }
 868     } else {
 869         my $sendmail = "";
 870         for (qw(/usr/lib/sendmail /usr/sbin/sendmail /usr/ucblib/sendmail)) {
 871             $sendmail = $_, last if -e $_;
 872         }
 873         if ($^O eq 'os2' and $sendmail eq "") {
 874             my $path = $ENV{PATH};
 875             $path =~ s:\\:/: ;
 876             my @path = split /$Config{'path_sep'}/, $path;
 877             for (@path) {
 878                 $sendmail = "$_/sendmail", last if -e "$_/sendmail";
 879                 $sendmail = "$_/sendmail.exe", last if -e "$_/sendmail.exe";
 880             }
 881         }
 882
 883         paraprint(<<"EOF"), die "\n" if $sendmail eq "";
 884 I am terribly sorry, but I cannot find sendmail, or a close equivalent, and
 885 the perl package Mail::Send has not been installed, so I can't send your bug
 886 report. We apologize for the inconvenience.
 887
 888 So you may attempt to find some way of sending your message, it has
 889 been left in the file `$filename'.
 890 EOF
 891         open(SENDMAIL, "|$sendmail -t -oi") || die "'|$sendmail -t -oi' failed: $!";
 892 sendout:
 893         print SENDMAIL "To: $address\n";
 894         print SENDMAIL "Subject: $subject\n";
 895         print SENDMAIL "Cc: $cc\n" if $cc;
 896         print SENDMAIL "Reply-To: $from\n" if $from;
 897         print SENDMAIL "Message-Id: $messageid\n" if $messageid;
 898         print SENDMAIL "\n\n";
 899         open(REP, "<$filename") or die "Couldn't open `$filename': $!\n";
 900         while (<REP>) { print SENDMAIL $_ }
 901         close(REP) or die "Error closing $filename: $!";
 902
 903         if (close(SENDMAIL)) {
 904             printf "\nMessage %s.\n", $outfile ? "saved" : "sent";
 905         } else {
 906             warn "\nSendmail returned status '", $? >> 8, "'\n";
 907         }
 908     }
 909     1 while unlink($filename);  # remove all versions under VMS
 910 } # sub Send
 911
 912 sub Help {
 913     print <<EOF;
 914
 915 A program to help generate bug reports about perl5, and mail them.
 916 It is designed to be used interactively. Normally no arguments will
 917 be needed.
 918
 919 Usage:
 920 $0  [-v] [-a address] [-s subject] [-b body | -f inpufile ] [ -F outputfile ]
 921     [-r returnaddress] [-e editor] [-c adminaddress | -C] [-S] [-t] [-h]
 922 $0  [-v] [-r returnaddress] [-A] [-ok | -okay | -nok | -nokay]
 923
 924 Simplest usage:  run "$0", and follow the prompts.
 925
 926 Options:
 927
 928   -v    Include Verbose configuration data in the report
 929   -f    File containing the body of the report. Use this to
 930         quickly send a prepared message.
 931   -F    File to output the resulting mail message to, instead of mailing.
 932   -S    Send without asking for confirmation.
 933   -a    Address to send the report to. Defaults to `$address'.
 934   -c    Address to send copy of report to. Defaults to `$cc'.
 935   -C    Don't send copy to administrator.
 936   -s    Subject to include with the message. You will be prompted
 937         if you don't supply one on the command line.
 938   -b    Body of the report. If not included on the command line, or
 939         in a file with -f, you will get a chance to edit the message.
 940   -r    Your return address. The program will ask you to confirm
 941         this if you don't give it here.
 942   -e    Editor to use.
 943   -t    Test mode. The target address defaults to `$testaddress'.
 944   -d    Data mode.  This prints out your configuration data, without mailing
 945         anything. You can use this with -v to get more complete data.
 946   -A    Don't send a bug received acknowledgement to the return address.
 947   -ok   Report successful build on this system to perl porters
 948         (use alone or with -v). Only use -ok if *everything* was ok:
 949         if there were *any* problems at all, use -nok.
 950   -okay As -ok but allow report from old builds.
 951   -nok  Report unsuccessful build on this system to perl porters
 952         (use alone or with -v). You must describe what went wrong
 953         in the body of the report which you will be asked to edit.
 954   -nokay As -nok but allow report from old builds.
 955   -h    Print this help message.
 956
 957 EOF
 958 }
 959
 960 sub filename {
 961     my $dir = File::Spec->tmpdir();
 962     $filename = "bugrep0$$";
 963     $filename++ while -e File::Spec->catfile($dir, $filename);
 964     $filename = File::Spec->catfile($dir, $filename);
 965 }
 966
 967 sub paraprint {
 968     my @paragraphs = split /\n{2,}/, "@_";
 969     print "\n\n";
 970     for (@paragraphs) {   # implicit local $_
 971         s/(\S)\s*\n/$1 /g;
 972         write;
 973         print "\n";
 974     }
 975 }
 976
 977 format STDOUT =
 978 ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< ~~
 979 $_
 980 .
 981
 982 __END__
 983
 984 =head1 NAME
 985
 986 perlbug - how to submit bug reports on Perl
 987
 988 =head1 SYNOPSIS
 989
 990 B<perlbug> S<[ B<-v> ]> S<[ B<-a> I<address> ]> S<[ B<-s> I<subject> ]>
 991 S<[ B<-b> I<body> | B<-f> I<inputfile> ]> S<[ B<-F> I<outputfile> ]>
 992 S<[ B<-r> I<returnaddress> ]>
 993 S<[ B<-e> I<editor> ]> S<[ B<-c> I<adminaddress> | B<-C> ]>
 994 S<[ B<-S> ]> S<[ B<-t> ]>  S<[ B<-d> ]>  S<[ B<-A> ]>  S<[ B<-h> ]>
 995
 996 B<perlbug> S<[ B<-v> ]> S<[ B<-r> I<returnaddress> ]>
 997  S<[ B<-A> ]> S<[ B<-ok> | B<-okay> | B<-nok> | B<-nokay> ]>
 998
 999 =head1 DESCRIPTION
1000
1001 A program to help generate bug reports about perl or the modules that
1002 come with it, and mail them.
1003
1004 If you have found a bug with a non-standard port (one that was not part
1005 of the I<standard distribution>), a binary distribution, or a
1006 non-standard module (such as Tk, CGI, etc), then please see the
1007 documentation that came with that distribution to determine the correct
1008 place to report bugs.
1009
1010 C<perlbug> is designed to be used interactively. Normally no arguments
1011 will be needed.  Simply run it, and follow the prompts.
1012
1013 If you are unable to run B<perlbug> (most likely because you don't have
1014 a working setup to send mail that perlbug recognizes), you may have to
1015 compose your own report, and email it to B<perlbug@perl.org>.  You might
1016 find the B<-d> option useful to get summary information in that case.
1017
1018 In any case, when reporting a bug, please make sure you have run through
1019 this checklist:
1020
1021 =over 4
1022
1023 =item What version of Perl you are running?
1024
1025 Type C<perl -v> at the command line to find out.
1026
1027 =item Are you running the latest released version of perl?
1028
1029 Look at http://www.perl.com/ to find out.  If it is not the latest
1030 released version, get that one and see whether your bug has been
1031 fixed.  Note that bug reports about old versions of Perl, especially
1032 those prior to the 5.0 release, are likely to fall upon deaf ears.
1033 You are on your own if you continue to use perl1 .. perl4.
1034
1035 =item Are you sure what you have is a bug?
1036
1037 A significant number of the bug reports we get turn out to be documented
1038 features in Perl.  Make sure the behavior you are witnessing doesn't fall
1039 under that category, by glancing through the documentation that comes
1040 with Perl (we'll admit this is no mean task, given the sheer volume of
1041 it all, but at least have a look at the sections that I<seem> relevant).
1042
1043 Be aware of the familiar traps that perl programmers of various hues
1044 fall into.  See L<perltrap>.
1045
1046 Check in L<perldiag> to see what any Perl error message(s) mean.
1047 If message isn't in perldiag, it probably isn't generated by Perl.
1048 Consult your operating system documentation instead.
1049
1050 If you are on a non-UNIX platform check also L<perlport>, as some
1051 features may be unimplemented or work differently.
1052
1053 Try to study the problem under the Perl debugger, if necessary.
1054 See L<perldebug>.
1055
1056 =item Do you have a proper test case?
1057
1058 The easier it is to reproduce your bug, the more likely it will be
1059 fixed, because if no one can duplicate the problem, no one can fix it.
1060 A good test case has most of these attributes: fewest possible number
1061 of lines; few dependencies on external commands, modules, or
1062 libraries; runs on most platforms unimpeded; and is self-documenting.
1063
1064 A good test case is almost always a good candidate to be on the perl
1065 test suite.  If you have the time, consider making your test case so
1066 that it will readily fit into the standard test suite.
1067
1068 Remember also to include the B<exact> error messages, if any.
1069 "Perl complained something" is not an exact error message.
1070
1071 If you get a core dump (or equivalent), you may use a debugger
1072 (B<dbx>, B<gdb>, etc) to produce a stack trace to include in the bug
1073 report.  NOTE: unless your Perl has been compiled with debug info
1074 (often B<-g>), the stack trace is likely to be somewhat hard to use
1075 because it will most probably contain only the function names and not
1076 their arguments.  If possible, recompile your Perl with debug info and
1077 reproduce the dump and the stack trace.
1078
1079 =item Can you describe the bug in plain English?
1080
1081 The easier it is to understand a reproducible bug, the more likely it
1082 will be fixed.  Anything you can provide by way of insight into the
1083 problem helps a great deal.  In other words, try to analyze the
1084 problem (to the extent you can) and report your discoveries.
1085
1086 =item Can you fix the bug yourself?
1087
1088 A bug report which I<includes a patch to fix it> will almost
1089 definitely be fixed.  Use the C<diff> program to generate your patches
1090 (C<diff> is being maintained by the GNU folks as part of the B<diffutils>
1091 package, so you should be able to get it from any of the GNU software
1092 repositories).  If you do submit a patch, the cool-dude counter at
1093 perlbug@perl.org will register you as a savior of the world.  Your
1094 patch may be returned with requests for changes, or requests for more
1095 detailed explanations about your fix.
1096
1097 Here are some clues for creating quality patches: Use the B<-c> or
1098 B<-u> switches to the diff program (to create a so-called context or
1099 unified diff).  Make sure the patch is not reversed (the first
1100 argument to diff is typically the original file, the second argument
1101 your changed file).  Make sure you test your patch by applying it with
1102 the C<patch> program before you send it on its way.  Try to follow the
1103 same style as the code you are trying to patch.  Make sure your patch
1104 really does work (C<make test>, if the thing you're patching supports
1105 it).
1106
1107 =item Can you use C<perlbug> to submit the report?
1108
1109 B<perlbug> will, amongst other things, ensure your report includes
1110 crucial information about your version of perl.  If C<perlbug> is unable
1111 to mail your report after you have typed it in, you may have to compose
1112 the message yourself, add the output produced by C<perlbug -d> and email
1113 it to B<perlbug@perl.org>.  If, for some reason, you cannot run
1114 C<perlbug> at all on your system, be sure to include the entire output
1115 produced by running C<perl -V> (note the uppercase V).
1116
1117 Whether you use C<perlbug> or send the email manually, please make
1118 your Subject line informative.  "a bug" not informative.  Neither is
1119 "perl crashes" nor "HELP!!!".  These don't help.
1120 A compact description of what's wrong is fine.
1121
1122 =back
1123
1124 Having done your bit, please be prepared to wait, to be told the bug
1125 is in your code, or even to get no reply at all.  The Perl maintainers
1126 are busy folks, so if your problem is a small one or if it is difficult
1127 to understand or already known, they may not respond with a personal reply.
1128 If it is important to you that your bug be fixed, do monitor the
1129 C<Changes> file in any development releases since the time you submitted
1130 the bug, and encourage the maintainers with kind words (but never any
1131 flames!).  Feel free to resend your bug report if the next released
1132 version of perl comes out and your bug is still present.
1133
1134 =head1 OPTIONS
1135
1136 =over 8
1137
1138 =item B<-a>
1139
1140 Address to send the report to.  Defaults to B<perlbug@perl.org>.
1141
1142 =item B<-A>
1143
1144 Don't send a bug received acknowledgement to the reply address.
1145 Generally it is only a sensible to use this option if you are a
1146 perl maintainer actively watching perl porters for your message to
1147 arrive.
1148
1149 =item B<-b>
1150
1151 Body of the report.  If not included on the command line, or
1152 in a file with B<-f>, you will get a chance to edit the message.
1153
1154 =item B<-C>
1155
1156 Don't send copy to administrator.
1157
1158 =item B<-c>
1159
1160 Address to send copy of report to.  Defaults to the address of the
1161 local perl administrator (recorded when perl was built).
1162
1163 =item B<-d>
1164
1165 Data mode (the default if you redirect or pipe output).  This prints out
1166 your configuration data, without mailing anything.  You can use this
1167 with B<-v> to get more complete data.
1168
1169 =item B<-e>
1170
1171 Editor to use.
1172
1173 =item B<-f>
1174
1175 File containing the body of the report.  Use this to quickly send a
1176 prepared message.
1177
1178 =item B<-F>
1179
1180 File to output the results to instead of sending as an email. Useful
1181 particularly when running perlbug on a machine with no direct internet
1182 connection.
1183
1184 =item B<-h>
1185
1186 Prints a brief summary of the options.
1187
1188 =item B<-ok>
1189
1190 Report successful build on this system to perl porters. Forces B<-S>
1191 and B<-C>. Forces and supplies values for B<-s> and B<-b>. Only
1192 prompts for a return address if it cannot guess it (for use with
1193 B<make>). Honors return address specified with B<-r>.  You can use this
1194 with B<-v> to get more complete data.   Only makes a report if this
1195 system is less than 60 days old.
1196
1197 =item B<-okay>
1198
1199 As B<-ok> except it will report on older systems.
1200
1201 =item B<-nok>
1202
1203 Report unsuccessful build on this system.  Forces B<-C>.  Forces and
1204 supplies a value for B<-s>, then requires you to edit the report
1205 and say what went wrong.  Alternatively, a prepared report may be
1206 supplied using B<-f>.  Only prompts for a return address if it
1207 cannot guess it (for use with B<make>). Honors return address
1208 specified with B<-r>.  You can use this with B<-v> to get more
1209 complete data.  Only makes a report if this system is less than 60
1210 days old.
1211
1212 =item B<-nokay>
1213
1214 As B<-nok> except it will report on older systems.
1215
1216 =item B<-r>
1217
1218 Your return address.  The program will ask you to confirm its default
1219 if you don't use this option.
1220
1221 =item B<-S>
1222
1223 Send without asking for confirmation.
1224
1225 =item B<-s>
1226
1227 Subject to include with the message.  You will be prompted if you don't
1228 supply one on the command line.
1229
1230 =item B<-t>
1231
1232 Test mode.  The target address defaults to B<perlbug-test@perl.org>.
1233
1234 =item B<-v>
1235
1236 Include verbose configuration data in the report.
1237
1238 =back
1239
1240 =head1 AUTHORS
1241
1242 Kenneth Albanowski (E<lt>kjahds@kjahds.comE<gt>), subsequently I<doc>tored
1243 by Gurusamy Sarathy (E<lt>gsar@activestate.comE<gt>), Tom Christiansen
1244 (E<lt>tchrist@perl.comE<gt>), Nathan Torkington (E<lt>gnat@frii.comE<gt>),
1245 Charles F. Randall (E<lt>cfr@pobox.comE<gt>), Mike Guy
1246 (E<lt>mjtg@cam.a.ukE<gt>), Dominic Dunlop (E<lt>domo@computer.orgE<gt>),
1247 Hugo van der Sanden (E<lt>hv@crypt.org<gt>),
1248 Jarkko Hietaniemi (E<lt>jhi@iki.fiE<gt>), Chris Nandor
1249 (E<lt>pudge@pobox.comE<gt>), Jon Orwant (E<lt>orwant@media.mit.eduE<gt>,
1250 and Richard Foley (E<lt>richard@rfi.netE<gt>).
1251
1252 =head1 SEE ALSO
1253
1254 perl(1), perldebug(1), perldiag(1), perlport(1), perltrap(1),
1255 diff(1), patch(1), dbx(1), gdb(1)
1256
1257 =head1 BUGS
1258
1259 None known (guess what must have been used to report them?)
1260
1261 =cut
1262
1263 !NO!SUBS!
1264
1265 close OUT or die "Can't close $file: $!";
1266 chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
1267 exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';
1268 chdir $origdir;