utils/perlbug.PL

   1 #!/usr/local/bin/perl
   2
   3 use Config;
   4 use File::Basename qw(&basename &dirname);
   5
   6 # List explicitly here the variables you want Configure to
   7 # generate.  Metaconfig only looks for shell variables, so you
   8 # have to mention them as if they were shell variables, not
   9 # %Config entries.  Thus you write
  10 #  $startperl
  11 # to ensure Configure will look for $Config{startperl}.
  12
  13 # This forces PL files to create target in same directory as PL file.
  14 # This is so that make depend always knows where to find PL derivatives.
  15 chdir dirname($0);
  16 $file = basename($0, '.PL');
  17
  18 open OUT,">$file" or die "Can't create $file: $!";
  19
  20 print "Extracting $file (with variable substitutions)\n";
  21
  22 # In this section, perl variables will be expanded during extraction.
  23 # You can use $Config{...} to use Configure variables.
  24
  25 print OUT <<"!GROK!THIS!";
  26 $Config{startperl}
  27     eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}'
  28         if \$running_under_some_shell;
  29 !GROK!THIS!
  30
  31 # In the following, perl variables are not expanded during extraction.
  32
  33 print OUT <<'!NO!SUBS!';
  34
  35 use Config;
  36 use Getopt::Std;
  37
  38 BEGIN {
  39         eval "use Mail::Send;";
  40         $::HaveSend = ($@ eq "");
  41         eval "use Mail::Util;";
  42         $::HaveUtil = ($@ eq "");
  43 };
  44
  45
  46 use strict;
  47
  48 sub paraprint;
  49
  50
  51 my($Version) = "1.15";
  52
  53 # Changed in 1.06 to skip Mail::Send and Mail::Util if not available.
  54 # Changed in 1.07 to see more sendmail execs, and added pipe output.
  55 # Changed in 1.08 to use correct address for sendmail.
  56 # Changed in 1.09 to close the REP file before calling it up in the editor.
  57 #                 Also removed some old comments duplicated elsewhere.
  58 # Changed in 1.10 to run under VMS without Mail::Send; also fixed
  59 #                 temp filename generation.
  60 # Changed in 1.11 to clean up some text and removed Mail::Send deactivator.
  61 # Changed in 1.12 to check for editor errors, make save/send distinction
  62 #                 clearer and add $ENV{REPLYTO}.
  63 # Changed in 1.13 to hopefully make it more difficult to accidentally
  64 #                 send mail
  65 # Changed in 1.14 to make the prompts a little more clear on providing
  66 #                 helpful information. Also let file read fail gracefully.
  67 # Changed in 1.15 to add warnings to stop people using perlbug for non-bugs.
  68 #                 Also report selected environment variables.
  69
  70 # TODO: Allow the user to re-name the file on mail failure, and
  71 #       make sure failure (transmission-wise) of Mail::Send is
  72 #       accounted for.
  73
  74 my( $file, $usefile, $cc, $address, $perlbug, $testaddress, $filename,
  75     $subject, $from, $verbose, $ed,
  76     $fh, $me, $Is_VMS, $msg, $body, $andcc );
  77
  78 Init();
  79
  80 if($::opt_h) { Help(); exit; }
  81
  82 if(!-t STDIN) {
  83         paraprint <<EOF;
  84 Please use perlbug interactively. If you want to
  85 include a file, you can use the -f switch.
  86 EOF
  87         die "\n";
  88 }
  89
  90 if($::opt_d or !-t STDOUT) { Dump(*STDOUT); exit; }
  91
  92 Query();
  93 Edit() unless $usefile;
  94 NowWhat();
  95 Send();
  96
  97 exit;
  98
  99 sub Init {
 100
 101         # -------- Setup --------
 102
 103         $Is_VMS = $^O eq 'VMS';
 104
 105         getopts("dhva:s:b:f:r:e:SCc:t");
 106
 107
 108         # This comment is needed to notify metaconfig that we are
 109         # using the $perladmin, $cf_by, and $cf_time definitions.
 110
 111
 112         # -------- Configuration ---------
 113
 114         # perlbug address
 115         $perlbug = 'perlbug@perl.com';
 116
 117         # Test address
 118         $testaddress = 'perlbug-test@perl.com';
 119
 120         # Target address
 121         $address = $::opt_a || ($::opt_t ? $testaddress : $perlbug);
 122
 123         # Possible administrator addresses, in order of confidence
 124         # (Note that cf_email is not mentioned to metaconfig, since
 125         # we don't really want it. We'll just take it if we have to.)
 126         $cc = ($::opt_C ? "" : (
 127                 $::opt_c || $::Config{perladmin} || $::Config{cf_email} || $::Config{cf_by}
 128                 ));
 129
 130         # Users address, used in message and in Reply-To header
 131         $from = $::opt_r || "";
 132
 133         # Include verbose configuration information
 134         $verbose = $::opt_v || 0;
 135
 136         # Subject of bug-report message
 137         $subject = $::opt_s || "";
 138
 139         # Send a file
 140         $usefile = ($::opt_f || 0);
 141
 142         # File to send as report
 143         $file = $::opt_f || "";
 144
 145         # Body of report
 146         $body = $::opt_b || "";
 147
 148         # Editor
 149         $ed = ( $::opt_e || $ENV{VISUAL} || $ENV{EDITOR} || $ENV{EDIT} ||
 150                       ($Is_VMS ? "edit/tpu" : "vi")
 151               );
 152
 153
 154         # My username
 155         $me = getpwuid($<);
 156
 157 }
 158
 159
 160 sub Query {
 161
 162         # Explain what perlbug is
 163
 164         paraprint <<EOF;
 165 This program provides an easy way to create a message reporting a bug
 166 in perl, and e-mail it to $address.  It is *NOT* intended for
 167 sending test messages or simply verifying that perl works.  It is *ONLY*
 168 a means of reporting verifiable problems with perl, and any solutions to
 169 such problems, to the people who maintain perl.
 170
 171 EOF
 172
 173
 174         # Prompt for subject of message, if needed
 175         if(! $subject) {
 176                 paraprint <<EOF;
 177 First of all, please provide a subject for the
 178 message. It should be a concise description of
 179 the bug or problem.
 180
 181 EOF
 182                 print "Subject: ";
 183
 184                 $subject = <>;
 185                 chop $subject;
 186
 187                 my($err)=0;
 188                 while( $subject =~ /^\s*$/ ) {
 189                         print "\nPlease enter a subject: ";
 190                         $subject = <>;
 191                         chop $subject;
 192                         if($err++>5) {
 193                                 die "Aborting.\n";
 194                         }
 195                 }
 196         }
 197
 198
 199         # Prompt for return address, if needed
 200         if( !$from) {
 201
 202                 # Try and guess return address
 203                 my($domain);
 204
 205                 if($::HaveUtil) {
 206                         $domain = Mail::Util::maildomain();
 207                 } elsif ($Is_VMS) {
 208                         require Sys::Hostname;
 209                         $domain = Sys::Hostname::hostname();
 210                 } else {
 211                         $domain = `hostname`.".".`domainname`;
 212                         $domain =~ s/[\r\n]+//g;
 213                 }
 214
 215             my($guess);
 216
 217                 if( !$domain) {
 218                         $guess = "";
 219                 } elsif ($Is_VMS && !$::Config{'d_socket'}) {
 220                         $guess = "$domain\:\:$me";
 221                 } else {
 222                         $guess = "$me\@$domain" if $domain;
 223                         $guess = "$me\@unknown.addresss" unless $domain;
 224                         }
 225
 226                 $guess = $ENV{'REPLYTO'} if defined($ENV{'REPLYTO'});
 227                 $guess = $ENV{"REPLY-TO"} if defined($ENV{'REPLY-TO'});
 228
 229                 if( $guess ) {
 230                         paraprint <<EOF;
 231
 232
 233 Your e-mail address will be useful if you need to be contacted. If the
 234 default shown is not your full internet e-mail address, please correct it.
 235
 236 EOF
 237                 } else {
 238                         paraprint <<EOF;
 239
 240 So that you may be contacted if necessary, please enter
 241 your full internet e-mail address here.
 242
 243 EOF
 244                 }
 245                 print "Your address [$guess]: ";
 246
 247                 $from = <>;
 248                 chop $from;
 249
 250                 if($from eq "") { $from = $guess }
 251
 252         }
 253
 254         #if( $from =~ /^(.*)\@(.*)$/ ) {
 255         #       $mailname = $1;
 256         #       $maildomain = $2;
 257         #}
 258
 259         if( $from eq $cc or $me eq $cc ) {
 260                 # Try not to copy ourselves
 261                 $cc = "yourself";
 262         }
 263
 264
 265         # Prompt for administrator address, unless an override was given
 266         if( !$::opt_C and !$::opt_c ) {
 267                 paraprint <<EOF;
 268
 269
 270 A copy of this report can be sent to your local
 271 perl administrator. If the address is wrong, please
 272 correct it, or enter 'none' or 'yourself' to not send
 273 a copy.
 274
 275 EOF
 276
 277                 print "Local perl administrator [$cc]: ";
 278
 279                 my($entry) = scalar(<>);
 280                 chop $entry;
 281
 282                 if($entry ne "") {
 283                         $cc = $entry;
 284                         if($me eq $cc) { $cc = "" }
 285                 }
 286
 287         }
 288
 289         if($cc =~ /^(none|yourself|me|myself|ourselves)$/i) { $cc = "" }
 290
 291         $andcc = " and $cc" if $cc;
 292
 293 editor:
 294
 295         # Prompt for editor, if no override is given
 296         if(! $::opt_e and ! $::opt_f and ! $::opt_b) {
 297                 paraprint <<EOF;
 298
 299
 300 Now you need to supply the bug report. Try to make
 301 the report concise but descriptive. Include any
 302 relevant detail. If you are reporting something
 303 that does not work as you think it should, please
 304 try to include example of both the actual
 305 result, and what you expected.
 306
 307 Some information about your local
 308 perl configuration will automatically be included
 309 at the end of the report. If you are using any
 310 unusual version of perl, please try and confirm
 311 exactly which versions are relevant.
 312
 313 You will probably want to use an editor to enter
 314 the report. If "$ed" is the editor you want
 315 to use, then just press Enter, otherwise type in
 316 the name of the editor you would like to use.
 317
 318 If you would like to use a prepared file, type
 319 "file", and you will be asked for the filename.
 320
 321 EOF
 322
 323                 print "Editor [$ed]: ";
 324
 325                 my($entry) =scalar(<>);
 326                 chop $entry;
 327
 328                 $usefile = 0;
 329                 if($entry eq "file") {
 330                         $usefile = 1;
 331                 } elsif($entry ne "") {
 332                         $ed = $entry;
 333                 }
 334         }
 335
 336
 337         # Generate scratch file to edit report in
 338
 339         {
 340         my($dir) = $Is_VMS ? 'sys$scratch:' : '/tmp/';
 341         $filename = "bugrep0$$";
 342         $filename++ while -e "$dir$filename";
 343         $filename = "$dir$filename";
 344         }
 345
 346
 347         # Prompt for file to read report from, if needed
 348
 349         if( $usefile and ! $file) {
 350 filename:
 351                 paraprint <<EOF;
 352
 353 What is the name of the file that contains your report?
 354
 355 EOF
 356
 357                 print "Filename: ";
 358
 359                 my($entry) = scalar(<>);
 360                 chop($entry);
 361
 362                 if($entry eq "") {
 363                         paraprint <<EOF;
 364
 365 No filename? I'll let you go back and choose an editor again.
 366
 367 EOF
 368                         goto editor;
 369                 }
 370
 371                 if(!-f $entry or !-r $entry) {
 372                         paraprint <<EOF;
 373
 374 I'm sorry, but I can't read from `$entry'. Maybe you mistyped the name of
 375 the file? If you don't want to send a file, just enter a blank line and you
 376 can get back to the editor selection.
 377
 378 EOF
 379                         goto filename;
 380                 }
 381                 $file = $entry;
 382
 383         }
 384
 385
 386         # Generate report
 387
 388         open(REP,">$filename");
 389
 390         print REP <<EOF;
 391 This is a bug report for perl from $from,
 392 generated with the help of perlbug $Version running under perl $].
 393
 394 EOF
 395
 396         if($body) {
 397                 print REP $body;
 398         } elsif($usefile) {
 399                 open(F,"<$file") or die "Unable to read report file from `$file': $!\n";
 400                 while(<F>) {
 401                 print REP $_
 402                 }
 403                 close(F);
 404         } else {
 405                 print REP "[Please enter your report here]\n";
 406         }
 407
 408         Dump(*REP);
 409         close(REP);
 410
 411 }
 412
 413 sub Dump {
 414         local(*OUT) = @_;
 415
 416         print OUT <<EOF;
 417
 418
 419
 420 Site configuration information for perl $]:
 421
 422 EOF
 423
 424         if( $::Config{cf_by} and $::Config{cf_time}) {
 425                 print OUT "Configured by $::Config{cf_by} at $::Config{cf_time}.\n\n";
 426         }
 427
 428         print OUT Config::myconfig;
 429
 430         if($verbose) {
 431                 print OUT "\nComplete configuration data for perl $]:\n\n";
 432                 my($value);
 433                 foreach (sort keys %::Config) {
 434                         $value = $::Config{$_};
 435                         $value =~ s/'/\\'/g;
 436                         print OUT "$_='$value'\n";
 437                 }
 438         }
 439         print OUT <<EOF;
 440
 441
 442 Environment for perl $]:
 443 EOF
 444         for my $env (qw(PATH LD_LIBRARY_PATH
 445                     PERL5LIB PERLLIB PERL5DB
 446                     LC_ALL LC_COLLATE LC_CTYPE LC_MONETARY LC_NUMERIC LC_TIME
 447                     LANG PERL_BADLANG
 448                     SHELL HOME LOGDIR)) {
 449             print OUT "    $env",
 450                       exists $ENV{$env} ? "=$ENV{$env}" : ' (unset)',
 451                       "\n";
 452         }
 453 }
 454
 455 sub Edit {
 456         # Edit the report
 457
 458         if($usefile) {
 459                 $usefile = 0;
 460                 paraprint <<EOF;
 461
 462 Please make sure that the name of the editor you want to use is correct.
 463
 464 EOF
 465                 print "Editor [$ed]: ";
 466
 467                 my($entry) =scalar(<>);
 468                 chop $entry;
 469
 470                 if($entry ne "") {
 471                         $ed = $entry;
 472                 }
 473         }
 474
 475 tryagain:
 476         if(!$usefile and !$body) {
 477                 my($sts) = system("$ed $filename");
 478                 if( $Is_VMS ? !($sts & 1) : $sts ) {
 479                         #print "\nUnable to run editor!\n";
 480                         paraprint <<EOF;
 481
 482 The editor you chose (`$ed') could apparently not be run!
 483 Did you mistype the name of your editor? If so, please
 484 correct it here, otherwise just press Enter.
 485
 486 EOF
 487                         print "Editor [$ed]: ";
 488
 489                         my($entry) =scalar(<>);
 490                         chop $entry;
 491
 492                         if($entry ne "") {
 493                                 $ed = $entry;
 494                                 goto tryagain;
 495                         } else {
 496
 497                         paraprint <<EOF;
 498
 499 You may want to save your report to a file, so you can edit and mail it
 500 yourself.
 501 EOF
 502                         }
 503                 }
 504         }
 505 }
 506
 507 sub NowWhat {
 508
 509         # Report is done, prompt for further action
 510         if( !$::opt_S ) {
 511                 while(1) {
 512
 513                         paraprint <<EOF;
 514
 515
 516 Now that you have completed your report, would you like to send
 517 the message to $address$andcc, display the message on
 518 the screen, re-edit it, or cancel without sending anything?
 519 You may also save the message as a file to mail at another time.
 520
 521 EOF
 522
 523                         print "Action (Send/Display/Edit/Cancel/Save to File): ";
 524                         my($action) = scalar(<>);
 525                         chop $action;
 526
 527                         if( $action =~ /^(f|sa)/i ) { # <F>ile/<Sa>ve
 528                                 print "\n\nName of file to save message in [perlbug.rep]: ";
 529                                 my($file) = scalar(<>);
 530                                 chop $file;
 531                                 if($file eq "") { $file = "perlbug.rep" }
 532
 533                                 open(FILE,">$file");
 534                                 open(REP,"<$filename");
 535                                 print FILE "To: $address\nSubject: $subject\n";
 536                                 print FILE "Cc: $cc\n" if $cc;
 537                                 print FILE "Reply-To: $from\n" if $from;
 538                                 print FILE "\n";
 539                                 while(<REP>) { print FILE }
 540                                 close(REP);
 541                                 close(FILE);
 542
 543                                 print "\nMessage saved in `$file'.\n";
 544                                 exit;
 545
 546                         } elsif( $action =~ /^(d|l|sh)/i ) { # <D>isplay, <L>ist, <Sh>ow
 547                                 # Display the message
 548                                 open(REP,"<$filename");
 549                                 while(<REP>) { print $_ }
 550                                 close(REP);
 551                         } elsif( $action =~ /^se/i ) { # <S>end
 552                                 # Send the message
 553                                 print "\
 554 Are you certain you want to send this message?
 555 Please type \"yes\" if you are: ";
 556                                 my($reply) = scalar(<STDIN>);
 557                                 chop($reply);
 558                                 if( $reply eq "yes" ) {
 559                                         last;
 560                                 } else {
 561                                         paraprint <<EOF;
 562
 563 That wasn't a clear "yes", so I won't send your message. If you are sure
 564 your message should be sent, type in "yes" (without the quotes) at the
 565 confirmation prompt.
 566
 567 EOF
 568
 569                                 }
 570                         } elsif( $action =~ /^[er]/i ) { # <E>dit, <R>e-edit
 571                                 # edit the message
 572                                 Edit();
 573                                 #system("$ed $filename");
 574                         } elsif( $action =~ /^[qc]/i ) { # <C>ancel, <Q>uit
 575                                 1 while unlink($filename);  # remove all versions under VMS
 576                                 print "\nCancelling.\n";
 577                                 exit(0);
 578                         } elsif( $action =~ /^s/ ) {
 579                                 paraprint <<EOF;
 580
 581 I'm sorry, but I didn't understand that. Please type "send" or "save".
 582 EOF
 583                         }
 584
 585                 }
 586         }
 587 }
 588
 589
 590 sub Send {
 591
 592         # Message has been accepted for transmission -- Send the message
 593
 594         if($::HaveSend) {
 595
 596                 $msg = new Mail::Send Subject => $subject, To => $address;
 597
 598                 $msg->cc($cc) if $cc;
 599                 $msg->add("Reply-To",$from) if $from;
 600
 601                 $fh = $msg->open;
 602
 603                 open(REP,"<$filename");
 604                 while(<REP>) { print $fh $_ }
 605                 close(REP);
 606
 607                 $fh->close;
 608
 609         } else {
 610                 if ($Is_VMS) {
 611                         if ( ($address =~ /@/ and $address !~ /^\w+%"/) or
 612                              ($cc      =~ /@/ and $cc      !~ /^\w+%"/) ){
 613                                 my($prefix);
 614                                 foreach (qw[ IN MX SMTP UCX PONY WINS ],'') {
 615                                         $prefix = "$_%",last if $ENV{"MAIL\$PROTOCOL_$_"};
 616                                 }
 617                                 $address = qq[${prefix}"$address"] unless $address =~ /^\w+%"/;
 618                                 $cc = qq[${prefix}"$cc"] unless !$cc || $cc =~ /^\w+%"/;
 619                         }
 620                         $subject =~ s/"/""/g; $address =~ s/"/""/g; $cc =~ s/"/""/g;
 621                         my($sts) = system(qq[mail/Subject="$subject" $filename. "$address","$cc"]);
 622                         if (!($sts & 1)) { die "Can't spawn off mail\n\t(leaving bug report in $filename): $sts\n;" }
 623                 } else {
 624                         my($sendmail) = "";
 625
 626                         foreach (qw(/usr/lib/sendmail /usr/sbin/sendmail /usr/ucblib/sendmail))
 627                         {
 628                                 $sendmail = $_, last if -e $_;
 629                         }
 630
 631                         paraprint <<"EOF" and die "\n" if $sendmail eq "";
 632
 633 I am terribly sorry, but I cannot find sendmail, or a close equivalent, and
 634 the perl package Mail::Send has not been installed, so I can't send your bug
 635 report. We apologize for the inconveniencence.
 636
 637 So you may attempt to find some way of sending your message, it has
 638 been left in the file `$filename'.
 639
 640 EOF
 641
 642                         open(SENDMAIL,"|$sendmail -t");
 643                         print SENDMAIL "To: $address\n";
 644                         print SENDMAIL "Subject: $subject\n";
 645                         print SENDMAIL "Cc: $cc\n" if $cc;
 646                         print SENDMAIL "Reply-To: $from\n" if $from;
 647                         print SENDMAIL "\n\n";
 648                         open(REP,"<$filename");
 649                         while(<REP>) { print SENDMAIL $_ }
 650                         close(REP);
 651
 652                         close(SENDMAIL);
 653                 }
 654
 655         }
 656
 657         print "\nMessage sent.\n";
 658
 659         1 while unlink($filename);  # remove all versions under VMS
 660
 661 }
 662
 663 sub Help {
 664         print <<EOF;
 665
 666 A program to help generate bug reports about perl5, and mail them.
 667 It is designed to be used interactively. Normally no arguments will
 668 be needed.
 669
 670 Usage:
 671 $0  [-v] [-a address] [-s subject] [-b body | -f file ]
 672     [-r returnaddress] [-e editor] [-c adminaddress | -C] [-S] [-t]
 673
 674 Simplest usage:  run "$0", and follow the prompts.
 675
 676 Options:
 677
 678   -v    Include Verbose configuration data in the report
 679   -f    File containing the body of the report. Use this to
 680         quickly send a prepared message.
 681   -S    Send without asking for confirmation.
 682   -a    Address to send the report to. Defaults to `$address'.
 683   -c    Address to send copy of report to. Defaults to `$cc'.
 684   -C    Don't send copy to administrator.
 685   -s    Subject to include with the message. You will be prompted
 686         if you don't supply one on the command line.
 687   -b    Body of the report. If not included on the command line, or
 688         in a file with -f, you will get a chance to edit the message.
 689   -r    Your return address. The program will ask you to confirm
 690         this if you don't give it here.
 691   -e    Editor to use.
 692   -t    Test mode. The target address defaults to `$testaddress'.
 693   -d    Data mode (the default if you redirect or pipe output.)
 694         This prints out your configuration data, without mailing
 695         anything. You can use this with -v to get more complete data.
 696
 697 EOF
 698 }
 699
 700 sub paraprint {
 701     my @paragraphs = split /\n{2,}/, "@_";
 702     print "\n\n";
 703     for (@paragraphs) {   # implicit local $_
 704         s/(\S)\s*\n/$1 /g;
 705             write;
 706             print "\n";
 707     }
 708
 709 }
 710
 711
 712 format STDOUT =
 713 ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< ~~
 714 $_
 715 .
 716 !NO!SUBS!
 717
 718 close OUT or die "Can't close $file: $!";
 719 chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
 720 exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';