| 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 | # get patchlevel.h timestamp |
| 26 | |
| 27 | -e catfile(updir, "patchlevel.h") |
| 28 | or die "Can't find patchlevel.h: $!"; |
| 29 | |
| 30 | my $patchlevel_date = (stat _)[9]; |
| 31 | |
| 32 | # TO DO (perhaps): store/embed $Config::config_sh into perlbug. When perlbug is |
| 33 | # used, compare $Config::config_sh with the stored version. If they differ then |
| 34 | # append a list of individual differences to the bug report. |
| 35 | |
| 36 | |
| 37 | print "Extracting $file (with variable substitutions)\n"; |
| 38 | |
| 39 | # In this section, perl variables will be expanded during extraction. |
| 40 | # You can use $Config{...} to use Configure variables. |
| 41 | |
| 42 | my $extract_version = sprintf("%vd", $^V); |
| 43 | |
| 44 | print OUT <<"!GROK!THIS!"; |
| 45 | $Config{startperl} |
| 46 | eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}' |
| 47 | if \$running_under_some_shell; |
| 48 | |
| 49 | my \$config_tag1 = '$extract_version - $Config{cf_time}'; |
| 50 | |
| 51 | my \$patchlevel_date = $patchlevel_date; |
| 52 | !GROK!THIS! |
| 53 | |
| 54 | # In the following, perl variables are not expanded during extraction. |
| 55 | |
| 56 | print OUT <<'!NO!SUBS!'; |
| 57 | my @patches = Config::local_patches(); |
| 58 | my $patch_tags = join "", map /(\S+)/ ? "+$1 " : (), @patches; |
| 59 | |
| 60 | BEGIN { pop @INC if $INC[-1] eq '.' } |
| 61 | use warnings; |
| 62 | use strict; |
| 63 | use Config; |
| 64 | use File::Spec; # keep perlbug Perl 5.005 compatible |
| 65 | use Getopt::Std; |
| 66 | use File::Basename 'basename'; |
| 67 | |
| 68 | $Getopt::Std::STANDARD_HELP_VERSION = 1; |
| 69 | |
| 70 | sub paraprint; |
| 71 | |
| 72 | BEGIN { |
| 73 | eval { require Mail::Send;}; |
| 74 | $::HaveSend = ($@ eq ""); |
| 75 | eval { require Mail::Util; } ; |
| 76 | $::HaveUtil = ($@ eq ""); |
| 77 | # use secure tempfiles wherever possible |
| 78 | eval { require File::Temp; }; |
| 79 | $::HaveTemp = ($@ eq ""); |
| 80 | eval { require Module::CoreList; }; |
| 81 | $::HaveCoreList = ($@ eq ""); |
| 82 | eval { require Text::Wrap; }; |
| 83 | $::HaveWrap = ($@ eq ""); |
| 84 | }; |
| 85 | |
| 86 | our $VERSION = "1.41"; |
| 87 | |
| 88 | #TODO: |
| 89 | # make sure failure (transmission-wise) of Mail::Send is accounted for. |
| 90 | # (This may work now. Unsure of the original author's issue -JESSE 2008-06-08) |
| 91 | # - Test -b option |
| 92 | |
| 93 | my( $file, $usefile, $cc, $address, $bugaddress, $testaddress, $thanksaddress, |
| 94 | $filename, $messageid, $domain, $subject, $from, $verbose, $ed, $outfile, |
| 95 | $fh, $me, $body, $andcc, %REP, $ok, $thanks, $progname, |
| 96 | $Is_MSWin32, $Is_Linux, $Is_VMS, $Is_OpenBSD, |
| 97 | $report_about_module, $category, $severity, |
| 98 | %opt, $have_attachment, $attachments, $has_patch, $mime_boundary |
| 99 | ); |
| 100 | |
| 101 | my $running_noninteractively = !-t STDIN; |
| 102 | |
| 103 | my $perl_version = $^V ? sprintf("%vd", $^V) : $]; |
| 104 | |
| 105 | my $config_tag2 = "$perl_version - $Config{cf_time}"; |
| 106 | |
| 107 | Init(); |
| 108 | |
| 109 | if ($opt{h}) { Help(); exit; } |
| 110 | if ($opt{d}) { Dump(*STDOUT); exit; } |
| 111 | if ($running_noninteractively && !$opt{t} && !($ok and not $opt{n})) { |
| 112 | paraprint <<"EOF"; |
| 113 | Please use $progname interactively. If you want to |
| 114 | include a file, you can use the -f switch. |
| 115 | EOF |
| 116 | die "\n"; |
| 117 | } |
| 118 | |
| 119 | Query(); |
| 120 | Edit() unless $usefile || ($ok and not $opt{n}); |
| 121 | NowWhat(); |
| 122 | if ($outfile) { |
| 123 | save_message_to_disk($outfile); |
| 124 | } else { |
| 125 | Send(); |
| 126 | if ($thanks) { |
| 127 | print "\nThank you for taking the time to send a thank-you message!\n\n"; |
| 128 | |
| 129 | paraprint <<EOF |
| 130 | Please note that mailing lists are moderated, your message may take a while to |
| 131 | show up. |
| 132 | EOF |
| 133 | } else { |
| 134 | print "\nThank you for taking the time to file a bug report!\n\n"; |
| 135 | |
| 136 | paraprint <<EOF |
| 137 | Please note that mailing lists are moderated, your message may take a while to |
| 138 | show up. If you do not receive an automated response acknowledging your message |
| 139 | within a few hours (check your SPAM folder and outgoing mail) please consider |
| 140 | sending an email directly from your mail client to perlbug\@perl.org. |
| 141 | EOF |
| 142 | } |
| 143 | |
| 144 | } |
| 145 | |
| 146 | exit; |
| 147 | |
| 148 | sub ask_for_alternatives { # (category|severity) |
| 149 | my $name = shift; |
| 150 | my %alts = ( |
| 151 | 'category' => { |
| 152 | 'default' => 'core', |
| 153 | 'ok' => 'install', |
| 154 | # Inevitably some of these will end up in RT whatever we do: |
| 155 | 'thanks' => 'thanks', |
| 156 | 'opts' => [qw(core docs install library utilities)], # patch, notabug |
| 157 | }, |
| 158 | 'severity' => { |
| 159 | 'default' => 'low', |
| 160 | 'ok' => 'none', |
| 161 | 'thanks' => 'none', |
| 162 | 'opts' => [qw(critical high medium low wishlist none)], # zero |
| 163 | }, |
| 164 | ); |
| 165 | die "Invalid alternative ($name) requested\n" unless grep(/^$name$/, keys %alts); |
| 166 | my $alt = ""; |
| 167 | my $what = $ok || $thanks; |
| 168 | if ($what) { |
| 169 | $alt = $alts{$name}{$what}; |
| 170 | } else { |
| 171 | my @alts = @{$alts{$name}{'opts'}}; |
| 172 | print "\n\n"; |
| 173 | paraprint <<EOF; |
| 174 | Please pick a $name from the following list: |
| 175 | |
| 176 | @alts |
| 177 | EOF |
| 178 | my $err = 0; |
| 179 | do { |
| 180 | if ($err++ > 5) { |
| 181 | die "Invalid $name: aborting.\n"; |
| 182 | } |
| 183 | $alt = _prompt('', "\u$name", $alts{$name}{'default'}); |
| 184 | $alt ||= $alts{$name}{'default'}; |
| 185 | } while !((($alt) = grep(/^$alt/i, @alts))); |
| 186 | } |
| 187 | lc $alt; |
| 188 | } |
| 189 | |
| 190 | sub HELP_MESSAGE { Help(); exit; } |
| 191 | sub VERSION_MESSAGE { print "perlbug version $VERSION\n"; } |
| 192 | |
| 193 | sub Init { |
| 194 | # -------- Setup -------- |
| 195 | |
| 196 | $Is_MSWin32 = $^O eq 'MSWin32'; |
| 197 | $Is_VMS = $^O eq 'VMS'; |
| 198 | $Is_Linux = lc($^O) eq 'linux'; |
| 199 | $Is_OpenBSD = lc($^O) eq 'openbsd'; |
| 200 | |
| 201 | # perlbug address |
| 202 | $bugaddress = 'perlbug@perl.org'; |
| 203 | |
| 204 | # Test address |
| 205 | $testaddress = 'perlbug-test@perl.org'; |
| 206 | |
| 207 | # Thanks address |
| 208 | $thanksaddress = 'perl-thanks@perl.org'; |
| 209 | |
| 210 | # Defaults if getopts fails. |
| 211 | $address = (basename ($0) =~ /^perlthanks/i) ? $thanksaddress : $bugaddress; |
| 212 | $cc = $::Config{'perladmin'} || $::Config{'cf_email'} || $::Config{'cf_by'} || ''; |
| 213 | |
| 214 | HELP_MESSAGE() unless getopts("Adhva:s:b:f:F:r:e:SCc:to:n:T:p:", \%opt); |
| 215 | |
| 216 | # This comment is needed to notify metaconfig that we are |
| 217 | # using the $perladmin, $cf_by, and $cf_time definitions. |
| 218 | # -------- Configuration --------- |
| 219 | |
| 220 | if (basename ($0) =~ /^perlthanks/i) { |
| 221 | # invoked as perlthanks |
| 222 | $opt{T} = 1; |
| 223 | $opt{C} = 1; # don't send a copy to the local admin |
| 224 | } |
| 225 | |
| 226 | if ($opt{T}) { |
| 227 | $thanks = 'thanks'; |
| 228 | } |
| 229 | |
| 230 | $progname = $thanks ? 'perlthanks' : 'perlbug'; |
| 231 | # Target address |
| 232 | $address = $opt{a} || ($opt{t} ? $testaddress |
| 233 | : $thanks ? $thanksaddress : $bugaddress); |
| 234 | |
| 235 | # Users address, used in message and in From and Reply-To headers |
| 236 | $from = $opt{r} || ""; |
| 237 | |
| 238 | # Include verbose configuration information |
| 239 | $verbose = $opt{v} || 0; |
| 240 | |
| 241 | # Subject of bug-report message |
| 242 | $subject = $opt{s} || ""; |
| 243 | |
| 244 | # Send a file |
| 245 | $usefile = ($opt{f} || 0); |
| 246 | |
| 247 | # File to send as report |
| 248 | $file = $opt{f} || ""; |
| 249 | |
| 250 | # We have one or more attachments |
| 251 | $have_attachment = ($opt{p} || 0); |
| 252 | $mime_boundary = ('-' x 12) . "$VERSION.perlbug" if $have_attachment; |
| 253 | |
| 254 | # Comma-separated list of attachments |
| 255 | $attachments = $opt{p} || ""; |
| 256 | $has_patch = 0; # TBD based on file type |
| 257 | |
| 258 | for my $attachment (split /\s*,\s*/, $attachments) { |
| 259 | unless (-f $attachment && -r $attachment) { |
| 260 | die "The attachment $attachment is not a readable file: $!\n"; |
| 261 | } |
| 262 | $has_patch = 1 if $attachment =~ m/\.(patch|diff)$/; |
| 263 | } |
| 264 | |
| 265 | # File to output to |
| 266 | $outfile = $opt{F} || ""; |
| 267 | |
| 268 | # Body of report |
| 269 | $body = $opt{b} || ""; |
| 270 | |
| 271 | # Editor |
| 272 | $ed = $opt{e} || $ENV{VISUAL} || $ENV{EDITOR} || $ENV{EDIT} |
| 273 | || ($Is_VMS && "edit/tpu") |
| 274 | || ($Is_MSWin32 && "notepad") |
| 275 | || "vi"; |
| 276 | |
| 277 | # Not OK - provide build failure template by finessing OK report |
| 278 | if ($opt{n}) { |
| 279 | if (substr($opt{n}, 0, 2) eq 'ok' ) { |
| 280 | $opt{o} = substr($opt{n}, 1); |
| 281 | } else { |
| 282 | Help(); |
| 283 | exit(); |
| 284 | } |
| 285 | } |
| 286 | |
| 287 | # OK - send "OK" report for build on this system |
| 288 | $ok = ''; |
| 289 | if ($opt{o}) { |
| 290 | if ($opt{o} eq 'k' or $opt{o} eq 'kay') { |
| 291 | my $age = time - $patchlevel_date; |
| 292 | if ($opt{o} eq 'k' and $age > 60 * 24 * 60 * 60 ) { |
| 293 | my $date = localtime $patchlevel_date; |
| 294 | print <<"EOF"; |
| 295 | "perlbug -ok" and "perlbug -nok" do not report on Perl versions which |
| 296 | are more than 60 days old. This Perl version was constructed on |
| 297 | $date. If you really want to report this, use |
| 298 | "perlbug -okay" or "perlbug -nokay". |
| 299 | EOF |
| 300 | exit(); |
| 301 | } |
| 302 | # force these options |
| 303 | unless ($opt{n}) { |
| 304 | $opt{S} = 1; # don't prompt for send |
| 305 | $opt{b} = 1; # we have a body |
| 306 | $body = "Perl reported to build OK on this system.\n"; |
| 307 | } |
| 308 | $opt{C} = 1; # don't send a copy to the local admin |
| 309 | $opt{s} = 1; # we have a subject line |
| 310 | $subject = ($opt{n} ? 'Not ' : '') |
| 311 | . "OK: perl $perl_version ${patch_tags}on" |
| 312 | ." $::Config{'archname'} $::Config{'osvers'} $subject"; |
| 313 | $ok = 'ok'; |
| 314 | } else { |
| 315 | Help(); |
| 316 | exit(); |
| 317 | } |
| 318 | } |
| 319 | |
| 320 | # Possible administrator addresses, in order of confidence |
| 321 | # (Note that cf_email is not mentioned to metaconfig, since |
| 322 | # we don't really want it. We'll just take it if we have to.) |
| 323 | # |
| 324 | # This has to be after the $ok stuff above because of the way |
| 325 | # that $opt{C} is forced. |
| 326 | $cc = $opt{C} ? "" : ( |
| 327 | $opt{c} || $::Config{'perladmin'} |
| 328 | || $::Config{'cf_email'} || $::Config{'cf_by'} |
| 329 | ); |
| 330 | |
| 331 | if ($::HaveUtil) { |
| 332 | $domain = Mail::Util::maildomain(); |
| 333 | } elsif ($Is_MSWin32) { |
| 334 | $domain = $ENV{'USERDOMAIN'}; |
| 335 | } else { |
| 336 | require Sys::Hostname; |
| 337 | $domain = Sys::Hostname::hostname(); |
| 338 | } |
| 339 | |
| 340 | # Message-Id - rjsf |
| 341 | $messageid = "<$::Config{'version'}_${$}_".time."\@$domain>"; |
| 342 | |
| 343 | # My username |
| 344 | $me = $Is_MSWin32 ? $ENV{'USERNAME'} |
| 345 | : $^O eq 'os2' ? $ENV{'USER'} || $ENV{'LOGNAME'} |
| 346 | : eval { getpwuid($<) }; # May be missing |
| 347 | |
| 348 | $from = $::Config{'cf_email'} |
| 349 | if !$from && $::Config{'cf_email'} && $::Config{'cf_by'} && $me && |
| 350 | ($me eq $::Config{'cf_by'}); |
| 351 | } # sub Init |
| 352 | |
| 353 | sub Query { |
| 354 | # Explain what perlbug is |
| 355 | unless ($ok) { |
| 356 | if ($thanks) { |
| 357 | paraprint <<'EOF'; |
| 358 | This program provides an easy way to send a thank-you message back to the |
| 359 | authors and maintainers of perl. |
| 360 | |
| 361 | If you wish to submit a bug report, please run it without the -T flag |
| 362 | (or run the program perlbug rather than perlthanks) |
| 363 | EOF |
| 364 | } else { |
| 365 | paraprint <<"EOF"; |
| 366 | This program provides an easy way to create a message reporting a |
| 367 | bug in the core perl distribution (along with tests or patches) |
| 368 | to the volunteers who maintain perl at $address. To send a thank-you |
| 369 | note to $thanksaddress instead of a bug report, please run 'perlthanks'. |
| 370 | |
| 371 | Please do not use $0 to send test messages, test whether perl |
| 372 | works, or to report bugs in perl modules from CPAN. |
| 373 | |
| 374 | Suggestions for how to find help using Perl can be found at |
| 375 | https://perldoc.perl.org/perlcommunity.html |
| 376 | EOF |
| 377 | } |
| 378 | } |
| 379 | |
| 380 | # Prompt for subject of message, if needed |
| 381 | |
| 382 | if ($subject && TrivialSubject($subject)) { |
| 383 | $subject = ''; |
| 384 | } |
| 385 | |
| 386 | unless ($subject) { |
| 387 | print |
| 388 | "First of all, please provide a subject for the message.\n"; |
| 389 | if ( not $thanks) { |
| 390 | paraprint <<EOF; |
| 391 | This should be a concise description of your bug or problem |
| 392 | which will help the volunteers working to improve perl to categorize |
| 393 | and resolve the issue. Be as specific and descriptive as |
| 394 | you can. A subject like "perl bug" or "perl problem" will make it |
| 395 | much less likely that your issue gets the attention it deserves. |
| 396 | EOF |
| 397 | } |
| 398 | |
| 399 | my $err = 0; |
| 400 | do { |
| 401 | $subject = _prompt('','Subject'); |
| 402 | if ($err++ == 5) { |
| 403 | if ($thanks) { |
| 404 | $subject = 'Thanks for Perl'; |
| 405 | } else { |
| 406 | die "Aborting.\n"; |
| 407 | } |
| 408 | } |
| 409 | } while (TrivialSubject($subject)); |
| 410 | } |
| 411 | $subject = '[PATCH] ' . $subject |
| 412 | if $has_patch && ($subject !~ m/^\[PATCH/i); |
| 413 | |
| 414 | # Prompt for return address, if needed |
| 415 | unless ($opt{r}) { |
| 416 | # Try and guess return address |
| 417 | my $guess; |
| 418 | |
| 419 | $guess = $ENV{'REPLY-TO'} || $ENV{'REPLYTO'} || $ENV{'EMAIL'} |
| 420 | || $from || ''; |
| 421 | |
| 422 | unless ($guess) { |
| 423 | # move $domain to where we can use it elsewhere |
| 424 | if ($domain) { |
| 425 | if ($Is_VMS && !$::Config{'d_socket'}) { |
| 426 | $guess = "$domain\:\:$me"; |
| 427 | } else { |
| 428 | $guess = "$me\@$domain" if $domain; |
| 429 | } |
| 430 | } |
| 431 | } |
| 432 | |
| 433 | if ($guess) { |
| 434 | unless ($ok) { |
| 435 | paraprint <<EOF; |
| 436 | Perl's developers may need your email address to contact you for |
| 437 | further information about your issue or to inform you when it is |
| 438 | resolved. If the default shown is not your email address, please |
| 439 | correct it. |
| 440 | EOF |
| 441 | } |
| 442 | } else { |
| 443 | paraprint <<EOF; |
| 444 | Please enter your full internet email address so that Perl's |
| 445 | developers can contact you with questions about your issue or to |
| 446 | inform you that it has been resolved. |
| 447 | EOF |
| 448 | } |
| 449 | |
| 450 | if ($ok && $guess) { |
| 451 | # use it |
| 452 | $from = $guess; |
| 453 | } else { |
| 454 | # verify it |
| 455 | $from = _prompt('','Your address',$guess); |
| 456 | $from = $guess if $from eq ''; |
| 457 | } |
| 458 | } |
| 459 | |
| 460 | if ($from eq $cc or $me eq $cc) { |
| 461 | # Try not to copy ourselves |
| 462 | $cc = "yourself"; |
| 463 | } |
| 464 | |
| 465 | # Prompt for administrator address, unless an override was given |
| 466 | if( !$opt{C} and !$opt{c} ) { |
| 467 | my $description = <<EOF; |
| 468 | $0 can send a copy of this report to your local perl |
| 469 | administrator. If the address below is wrong, please correct it, |
| 470 | or enter 'none' or 'yourself' to not send a copy. |
| 471 | EOF |
| 472 | my $entry = _prompt($description, "Local perl administrator", $cc); |
| 473 | |
| 474 | if ($entry ne "") { |
| 475 | $cc = $entry; |
| 476 | $cc = '' if $me eq $cc; |
| 477 | } |
| 478 | } |
| 479 | |
| 480 | $cc = '' if $cc =~ /^(none|yourself|me|myself|ourselves)$/i; |
| 481 | if ($cc) { |
| 482 | $andcc = " and $cc" |
| 483 | } else { |
| 484 | $andcc = '' |
| 485 | } |
| 486 | |
| 487 | # Prompt for editor, if no override is given |
| 488 | editor: |
| 489 | unless ($opt{e} || $opt{f} || $opt{b}) { |
| 490 | |
| 491 | my $description; |
| 492 | |
| 493 | chomp (my $common_end = <<"EOF"); |
| 494 | You will probably want to use a text editor to enter the body of |
| 495 | your report. If "$ed" is the editor you want to use, then just press |
| 496 | Enter, otherwise type in the name of the editor you would like to |
| 497 | use. |
| 498 | |
| 499 | If you have already composed the body of your report, you may enter |
| 500 | "file", and $0 will prompt you to enter the name of the file |
| 501 | containing your report. |
| 502 | EOF |
| 503 | |
| 504 | if ($thanks) { |
| 505 | $description = <<"EOF"; |
| 506 | It's now time to compose your thank-you message. |
| 507 | |
| 508 | Some information about your local perl configuration will automatically |
| 509 | be included at the end of your message, because we're curious about |
| 510 | the different ways that people build and use perl. If you'd rather |
| 511 | not share this information, you're welcome to delete it. |
| 512 | |
| 513 | $common_end |
| 514 | EOF |
| 515 | } else { |
| 516 | $description = <<"EOF"; |
| 517 | It's now time to compose your bug report. Try to make the report |
| 518 | concise but descriptive. Please include any detail which you think |
| 519 | might be relevant or might help the volunteers working to improve |
| 520 | perl. If you are reporting something that does not work as you think |
| 521 | it should, please try to include examples of the actual result and of |
| 522 | what you expected. |
| 523 | |
| 524 | Some information about your local perl configuration will automatically |
| 525 | be included at the end of your report. If you are using an unusual |
| 526 | version of perl, it would be useful if you could confirm that you |
| 527 | can replicate the problem on a standard build of perl as well. |
| 528 | |
| 529 | $common_end |
| 530 | EOF |
| 531 | } |
| 532 | |
| 533 | my $entry = _prompt($description, "Editor", $ed); |
| 534 | $usefile = 0; |
| 535 | if ($entry eq "file") { |
| 536 | $usefile = 1; |
| 537 | } elsif ($entry ne "") { |
| 538 | $ed = $entry; |
| 539 | } |
| 540 | } |
| 541 | if ($::HaveCoreList && !$ok && !$thanks) { |
| 542 | my $description = <<EOF; |
| 543 | If your bug is about a Perl module rather than a core language |
| 544 | feature, please enter its name here. If it's not, just hit Enter |
| 545 | to skip this question. |
| 546 | EOF |
| 547 | |
| 548 | my $entry = ''; |
| 549 | while ($entry eq '') { |
| 550 | $entry = _prompt($description, 'Module'); |
| 551 | my $first_release = Module::CoreList->first_release($entry); |
| 552 | if ($entry and not $first_release) { |
| 553 | paraprint <<EOF; |
| 554 | $entry is not a "core" Perl module. Please check that you entered |
| 555 | its name correctly. If it is correct, quit this program, try searching |
| 556 | for $entry on https://rt.cpan.org, and report your issue there. |
| 557 | EOF |
| 558 | |
| 559 | $entry = ''; |
| 560 | } elsif (my $bug_tracker = $Module::CoreList::bug_tracker{$entry}) { |
| 561 | paraprint <<"EOF"; |
| 562 | $entry included with core Perl is copied directly from the CPAN distribution. |
| 563 | Please report bugs in $entry directly to its maintainers using $bug_tracker |
| 564 | EOF |
| 565 | $entry = ''; |
| 566 | } elsif ($entry) { |
| 567 | $category ||= 'library'; |
| 568 | $report_about_module = $entry; |
| 569 | last; |
| 570 | } else { |
| 571 | last; |
| 572 | } |
| 573 | } |
| 574 | } |
| 575 | |
| 576 | # Prompt for category of bug |
| 577 | $category ||= ask_for_alternatives('category'); |
| 578 | |
| 579 | # Prompt for severity of bug |
| 580 | $severity ||= ask_for_alternatives('severity'); |
| 581 | |
| 582 | # Generate scratch file to edit report in |
| 583 | $filename = filename(); |
| 584 | |
| 585 | # Prompt for file to read report from, if needed |
| 586 | if ($usefile and !$file) { |
| 587 | filename: |
| 588 | my $description = <<EOF; |
| 589 | What is the name of the file that contains your report? |
| 590 | EOF |
| 591 | my $entry = _prompt($description, "Filename"); |
| 592 | |
| 593 | if ($entry eq "") { |
| 594 | paraprint <<EOF; |
| 595 | It seems you didn't enter a filename. Please choose to use a text |
| 596 | editor or enter a filename. |
| 597 | EOF |
| 598 | goto editor; |
| 599 | } |
| 600 | |
| 601 | unless (-f $entry and -r $entry) { |
| 602 | paraprint <<EOF; |
| 603 | '$entry' doesn't seem to be a readable file. You may have mistyped |
| 604 | its name or may not have permission to read it. |
| 605 | |
| 606 | If you don't want to use a file as the content of your report, just |
| 607 | hit Enter and you'll be able to select a text editor instead. |
| 608 | EOF |
| 609 | goto filename; |
| 610 | } |
| 611 | $file = $entry; |
| 612 | } |
| 613 | |
| 614 | # Generate report |
| 615 | open(REP, '>:raw', $filename) or die "Unable to create report file '$filename': $!\n"; |
| 616 | binmode(REP, ':raw :crlf') if $Is_MSWin32; |
| 617 | |
| 618 | my $reptype = !$ok ? ($thanks ? 'thank-you' : 'bug') |
| 619 | : $opt{n} ? "build failure" : "success"; |
| 620 | |
| 621 | print REP <<EOF; |
| 622 | This is a $reptype report for perl from $from, |
| 623 | generated with the help of perlbug $VERSION running under perl $perl_version. |
| 624 | |
| 625 | EOF |
| 626 | |
| 627 | if ($body) { |
| 628 | print REP $body; |
| 629 | } elsif ($usefile) { |
| 630 | open(F, '<:raw', $file) |
| 631 | or die "Unable to read report file from '$file': $!\n"; |
| 632 | binmode(F, ':raw :crlf') if $Is_MSWin32; |
| 633 | while (<F>) { |
| 634 | print REP $_ |
| 635 | } |
| 636 | close(F) or die "Error closing '$file': $!"; |
| 637 | } else { |
| 638 | if ($thanks) { |
| 639 | print REP <<'EOF'; |
| 640 | |
| 641 | ----------------------------------------------------------------- |
| 642 | [Please enter your thank-you message here] |
| 643 | |
| 644 | |
| 645 | |
| 646 | [You're welcome to delete anything below this line] |
| 647 | ----------------------------------------------------------------- |
| 648 | EOF |
| 649 | } else { |
| 650 | print REP <<'EOF'; |
| 651 | |
| 652 | ----------------------------------------------------------------- |
| 653 | [Please describe your issue here] |
| 654 | |
| 655 | |
| 656 | |
| 657 | [Please do not change anything below this line] |
| 658 | ----------------------------------------------------------------- |
| 659 | EOF |
| 660 | } |
| 661 | } |
| 662 | Dump(*REP); |
| 663 | close(REP) or die "Error closing report file: $!"; |
| 664 | |
| 665 | # Set up an initial report fingerprint so we can compare it later |
| 666 | _fingerprint_lines_in_report(); |
| 667 | |
| 668 | } # sub Query |
| 669 | |
| 670 | sub Dump { |
| 671 | local(*OUT) = @_; |
| 672 | |
| 673 | # these won't have been set if run with -d |
| 674 | $category ||= 'core'; |
| 675 | $severity ||= 'low'; |
| 676 | |
| 677 | print OUT <<EFF; |
| 678 | --- |
| 679 | Flags: |
| 680 | category=$category |
| 681 | severity=$severity |
| 682 | EFF |
| 683 | |
| 684 | if ($has_patch) { |
| 685 | print OUT <<EFF; |
| 686 | Type=Patch |
| 687 | PatchStatus=HasPatch |
| 688 | EFF |
| 689 | } |
| 690 | |
| 691 | if ($report_about_module ) { |
| 692 | print OUT <<EFF; |
| 693 | module=$report_about_module |
| 694 | EFF |
| 695 | } |
| 696 | if ($opt{A}) { |
| 697 | print OUT <<EFF; |
| 698 | ack=no |
| 699 | EFF |
| 700 | } |
| 701 | print OUT <<EFF; |
| 702 | --- |
| 703 | EFF |
| 704 | print OUT "This perlbug was built using Perl $config_tag1\n", |
| 705 | "It is being executed now by Perl $config_tag2.\n\n" |
| 706 | if $config_tag2 ne $config_tag1; |
| 707 | |
| 708 | print OUT <<EOF; |
| 709 | Site configuration information for perl $perl_version: |
| 710 | |
| 711 | EOF |
| 712 | if ($::Config{cf_by} and $::Config{cf_time}) { |
| 713 | print OUT "Configured by $::Config{cf_by} at $::Config{cf_time}.\n\n"; |
| 714 | } |
| 715 | print OUT Config::myconfig; |
| 716 | |
| 717 | if (@patches) { |
| 718 | print OUT join "\n ", "Locally applied patches:", @patches; |
| 719 | print OUT "\n"; |
| 720 | }; |
| 721 | |
| 722 | print OUT <<EOF; |
| 723 | |
| 724 | --- |
| 725 | \@INC for perl $perl_version: |
| 726 | EOF |
| 727 | for my $i (@INC) { |
| 728 | print OUT " $i\n"; |
| 729 | } |
| 730 | |
| 731 | print OUT <<EOF; |
| 732 | |
| 733 | --- |
| 734 | Environment for perl $perl_version: |
| 735 | EOF |
| 736 | my @env = |
| 737 | qw(PATH LD_LIBRARY_PATH LANG PERL_BADLANG SHELL HOME LOGDIR LANGUAGE); |
| 738 | push @env, $Config{ldlibpthname} if $Config{ldlibpthname} ne ''; |
| 739 | push @env, grep /^(?:PERL|LC_|LANG|CYGWIN)/, keys %ENV; |
| 740 | my %env; |
| 741 | @env{@env} = @env; |
| 742 | for my $env (sort keys %env) { |
| 743 | print OUT " $env", |
| 744 | exists $ENV{$env} ? "=$ENV{$env}" : ' (unset)', |
| 745 | "\n"; |
| 746 | } |
| 747 | if ($verbose) { |
| 748 | print OUT "\nComplete configuration data for perl $perl_version:\n\n"; |
| 749 | my $value; |
| 750 | foreach (sort keys %::Config) { |
| 751 | $value = $::Config{$_}; |
| 752 | $value = '' unless defined $value; |
| 753 | $value =~ s/'/\\'/g; |
| 754 | print OUT "$_='$value'\n"; |
| 755 | } |
| 756 | } |
| 757 | } # sub Dump |
| 758 | |
| 759 | sub Edit { |
| 760 | # Edit the report |
| 761 | if ($usefile || $body) { |
| 762 | my $description = "Please make sure that the name of the editor you want to use is correct."; |
| 763 | my $entry = _prompt($description, 'Editor', $ed); |
| 764 | $ed = $entry unless $entry eq ''; |
| 765 | } |
| 766 | |
| 767 | _edit_file($ed) unless $running_noninteractively; |
| 768 | } |
| 769 | |
| 770 | sub _edit_file { |
| 771 | my $editor = shift; |
| 772 | |
| 773 | my $report_written = 0; |
| 774 | |
| 775 | while ( !$report_written ) { |
| 776 | my $exit_status = system("$editor $filename"); |
| 777 | if ($exit_status) { |
| 778 | my $desc = <<EOF; |
| 779 | The editor you chose ('$editor') could not be run! |
| 780 | |
| 781 | If you mistyped its name, please enter it now, otherwise just press Enter. |
| 782 | EOF |
| 783 | my $entry = _prompt( $desc, 'Editor', $editor ); |
| 784 | if ( $entry ne "" ) { |
| 785 | $editor = $entry; |
| 786 | next; |
| 787 | } else { |
| 788 | paraprint <<EOF; |
| 789 | You may want to save your report to a file, so you can edit and |
| 790 | mail it later. |
| 791 | EOF |
| 792 | return; |
| 793 | } |
| 794 | } |
| 795 | return if ( $ok and not $opt{n} ) || $body; |
| 796 | |
| 797 | # Check that we have a report that has some, eh, report in it. |
| 798 | |
| 799 | unless ( _fingerprint_lines_in_report() ) { |
| 800 | my $description = <<EOF; |
| 801 | It looks like you didn't enter a report. You may [r]etry your edit |
| 802 | or [c]ancel this report. |
| 803 | EOF |
| 804 | my $action = _prompt( $description, "Action (Retry/Cancel) " ); |
| 805 | if ( $action =~ /^[re]/i ) { # <R>etry <E>dit |
| 806 | next; |
| 807 | } elsif ( $action =~ /^[cq]/i ) { # <C>ancel, <Q>uit |
| 808 | Cancel(); # cancel exits |
| 809 | } |
| 810 | } |
| 811 | # Ok. the user did what they needed to; |
| 812 | return; |
| 813 | |
| 814 | } |
| 815 | } |
| 816 | |
| 817 | |
| 818 | sub Cancel { |
| 819 | 1 while unlink($filename); # remove all versions under VMS |
| 820 | print "\nQuitting without sending your message.\n"; |
| 821 | exit(0); |
| 822 | } |
| 823 | |
| 824 | sub NowWhat { |
| 825 | # Report is done, prompt for further action |
| 826 | if( !$opt{S} ) { |
| 827 | while(1) { |
| 828 | my $menu = <<EOF; |
| 829 | |
| 830 | |
| 831 | You have finished composing your message. At this point, you have |
| 832 | a few options. You can: |
| 833 | |
| 834 | * [Se]nd the message to $address$andcc, |
| 835 | * [D]isplay the message on the screen, |
| 836 | * [R]e-edit the message |
| 837 | * Display or change the message's [su]bject |
| 838 | * Save the message to a [f]ile to mail at another time |
| 839 | * [Q]uit without sending a message |
| 840 | |
| 841 | EOF |
| 842 | retry: |
| 843 | print $menu; |
| 844 | my $action = _prompt('', "Action (Send/Display/Edit/Subject/Save to File)", |
| 845 | $opt{t} ? 'q' : ''); |
| 846 | print "\n"; |
| 847 | if ($action =~ /^(f|sa)/i) { # <F>ile/<Sa>ve |
| 848 | if ( SaveMessage() ) { exit } |
| 849 | } elsif ($action =~ /^(d|l|sh)/i ) { # <D>isplay, <L>ist, <Sh>ow |
| 850 | # Display the message |
| 851 | print _read_report($filename); |
| 852 | if ($have_attachment) { |
| 853 | print "\n\n---\nAttachment(s):\n"; |
| 854 | for my $att (split /\s*,\s*/, $attachments) { print " $att\n"; } |
| 855 | } |
| 856 | } elsif ($action =~ /^su/i) { # <Su>bject |
| 857 | my $reply = _prompt( "Subject: $subject", "If the above subject is fine, press Enter. Otherwise, type a replacement now\nSubject"); |
| 858 | if ($reply ne '') { |
| 859 | unless (TrivialSubject($reply)) { |
| 860 | $subject = $reply; |
| 861 | print "Subject: $subject\n"; |
| 862 | } |
| 863 | } |
| 864 | } elsif ($action =~ /^se/i) { # <S>end |
| 865 | # Send the message |
| 866 | my $reply = _prompt( "Are you certain you want to send this message?", 'Please type "yes" if you are','no'); |
| 867 | if ($reply =~ /^yes$/) { |
| 868 | last; |
| 869 | } else { |
| 870 | paraprint <<EOF; |
| 871 | You didn't type "yes", so your message has not yet been sent. |
| 872 | EOF |
| 873 | } |
| 874 | } elsif ($action =~ /^[er]/i) { # <E>dit, <R>e-edit |
| 875 | # edit the message |
| 876 | Edit(); |
| 877 | } elsif ($action =~ /^[qc]/i) { # <C>ancel, <Q>uit |
| 878 | Cancel(); |
| 879 | } elsif ($action =~ /^s/i) { |
| 880 | paraprint <<EOF; |
| 881 | The command you entered was ambiguous. Please type "send", "save" or "subject". |
| 882 | EOF |
| 883 | } |
| 884 | } |
| 885 | } |
| 886 | } # sub NowWhat |
| 887 | |
| 888 | sub TrivialSubject { |
| 889 | my $subject = shift; |
| 890 | if ($subject =~ |
| 891 | /^(y(es)?|no?|help|perl( (bug|problem))?|bug|problem)$/i || |
| 892 | length($subject) < 4 || |
| 893 | ($subject !~ /\s/ && ! $opt{t})) { # non-whitespace is accepted in test mode |
| 894 | print "\nThe subject you entered wasn't very descriptive. Please try again.\n\n"; |
| 895 | return 1; |
| 896 | } else { |
| 897 | return 0; |
| 898 | } |
| 899 | } |
| 900 | |
| 901 | sub SaveMessage { |
| 902 | my $file_save = $outfile || "$progname.rep"; |
| 903 | my $file = _prompt( '', "Name of file to save message in", $file_save ); |
| 904 | save_message_to_disk($file) || return undef; |
| 905 | print "\n"; |
| 906 | paraprint <<EOF; |
| 907 | A copy of your message has been saved in '$file' for you to |
| 908 | send to '$address' with your normal mail client. |
| 909 | EOF |
| 910 | } |
| 911 | |
| 912 | sub Send { |
| 913 | |
| 914 | # Message has been accepted for transmission -- Send the message |
| 915 | |
| 916 | # on linux certain "mail" implementations won't accept the subject |
| 917 | # as "~s subject" and thus the Subject header will be corrupted |
| 918 | # so don't use Mail::Send to be safe |
| 919 | eval { |
| 920 | if ( $::HaveSend && !$Is_Linux && !$Is_OpenBSD ) { |
| 921 | _send_message_mailsend(); |
| 922 | } elsif ($Is_VMS) { |
| 923 | _send_message_vms(); |
| 924 | } else { |
| 925 | _send_message_sendmail(); |
| 926 | } |
| 927 | }; |
| 928 | |
| 929 | if ( my $error = $@ ) { |
| 930 | paraprint <<EOF; |
| 931 | $0 has detected an error while trying to send your message: $error. |
| 932 | |
| 933 | Your message may not have been sent. You will now have a chance to save a copy to disk. |
| 934 | EOF |
| 935 | SaveMessage(); |
| 936 | return; |
| 937 | } |
| 938 | |
| 939 | 1 while unlink($filename); # remove all versions under VMS |
| 940 | } # sub Send |
| 941 | |
| 942 | sub Help { |
| 943 | print <<EOF; |
| 944 | |
| 945 | This program is designed to help you generate and send bug reports |
| 946 | (and thank-you notes) about perl5 and the modules which ship with it. |
| 947 | |
| 948 | In most cases, you can just run "$0" interactively from a command |
| 949 | line without any special arguments and follow the prompts. |
| 950 | |
| 951 | Advanced usage: |
| 952 | |
| 953 | $0 [-v] [-a address] [-s subject] [-b body | -f inpufile ] [ -F outputfile ] |
| 954 | [-r returnaddress] [-e editor] [-c adminaddress | -C] [-S] [-t] [-h] |
| 955 | [-p patchfile ] |
| 956 | $0 [-v] [-r returnaddress] [-A] [-ok | -okay | -nok | -nokay] |
| 957 | |
| 958 | |
| 959 | Options: |
| 960 | |
| 961 | -v Include Verbose configuration data in the report |
| 962 | -f File containing the body of the report. Use this to |
| 963 | quickly send a prepared message. |
| 964 | -p File containing a patch or other text attachment. Separate |
| 965 | multiple files with commas. |
| 966 | -F File to output the resulting mail message to, instead of mailing. |
| 967 | -S Send without asking for confirmation. |
| 968 | -a Address to send the report to. Defaults to '$address'. |
| 969 | -c Address to send copy of report to. Defaults to '$cc'. |
| 970 | -C Don't send copy to administrator. |
| 971 | -s Subject to include with the message. You will be prompted |
| 972 | if you don't supply one on the command line. |
| 973 | -b Body of the report. If not included on the command line, or |
| 974 | in a file with -f, you will get a chance to edit the message. |
| 975 | -r Your return address. The program will ask you to confirm |
| 976 | this if you don't give it here. |
| 977 | -e Editor to use. |
| 978 | -t Test mode. The target address defaults to '$testaddress'. |
| 979 | -T Thank-you mode. The target address defaults to '$thanksaddress'. |
| 980 | -d Data mode. This prints out your configuration data, without mailing |
| 981 | anything. You can use this with -v to get more complete data. |
| 982 | -A Don't send a bug received acknowledgement to the return address. |
| 983 | -ok Report successful build on this system to perl porters |
| 984 | (use alone or with -v). Only use -ok if *everything* was ok: |
| 985 | if there were *any* problems at all, use -nok. |
| 986 | -okay As -ok but allow report from old builds. |
| 987 | -nok Report unsuccessful build on this system to perl porters |
| 988 | (use alone or with -v). You must describe what went wrong |
| 989 | in the body of the report which you will be asked to edit. |
| 990 | -nokay As -nok but allow report from old builds. |
| 991 | -h Print this help message. |
| 992 | |
| 993 | EOF |
| 994 | } |
| 995 | |
| 996 | sub filename { |
| 997 | if ($::HaveTemp) { |
| 998 | # Good. Use a secure temp file |
| 999 | my ($fh, $filename) = File::Temp::tempfile(UNLINK => 1); |
| 1000 | close($fh); |
| 1001 | return $filename; |
| 1002 | } else { |
| 1003 | # Bah. Fall back to doing things less securely. |
| 1004 | my $dir = File::Spec->tmpdir(); |
| 1005 | $filename = "bugrep0$$"; |
| 1006 | $filename++ while -e File::Spec->catfile($dir, $filename); |
| 1007 | $filename = File::Spec->catfile($dir, $filename); |
| 1008 | } |
| 1009 | } |
| 1010 | |
| 1011 | sub paraprint { |
| 1012 | my @paragraphs = split /\n{2,}/, "@_"; |
| 1013 | for (@paragraphs) { # implicit local $_ |
| 1014 | s/(\S)\s*\n/$1 /g; |
| 1015 | write; |
| 1016 | print "\n"; |
| 1017 | } |
| 1018 | } |
| 1019 | |
| 1020 | sub _prompt { |
| 1021 | my ($explanation, $prompt, $default) = (@_); |
| 1022 | if ($explanation) { |
| 1023 | print "\n\n"; |
| 1024 | paraprint $explanation; |
| 1025 | } |
| 1026 | print $prompt. ($default ? " [$default]" :''). ": "; |
| 1027 | my $result = scalar(<>); |
| 1028 | return $default if !defined $result; # got eof |
| 1029 | chomp($result); |
| 1030 | $result =~ s/^\s*(.*?)\s*$/$1/s; |
| 1031 | if ($default && $result eq '') { |
| 1032 | return $default; |
| 1033 | } else { |
| 1034 | return $result; |
| 1035 | } |
| 1036 | } |
| 1037 | |
| 1038 | sub _build_header { |
| 1039 | my %attr = (@_); |
| 1040 | |
| 1041 | my $head = ''; |
| 1042 | for my $header (keys %attr) { |
| 1043 | $head .= "$header: ".$attr{$header}."\n"; |
| 1044 | } |
| 1045 | return $head; |
| 1046 | } |
| 1047 | |
| 1048 | sub _message_headers { |
| 1049 | my %headers = ( To => $address, Subject => $subject ); |
| 1050 | $headers{'Cc'} = $cc if ($cc); |
| 1051 | $headers{'Message-Id'} = $messageid if ($messageid); |
| 1052 | $headers{'Reply-To'} = $from if ($from); |
| 1053 | $headers{'From'} = $from if ($from); |
| 1054 | if ($have_attachment) { |
| 1055 | $headers{'MIME-Version'} = '1.0'; |
| 1056 | $headers{'Content-Type'} = qq{multipart/mixed; boundary=\"$mime_boundary\"}; |
| 1057 | } |
| 1058 | return \%headers; |
| 1059 | } |
| 1060 | |
| 1061 | sub _add_body_start { |
| 1062 | my $body_start = <<"BODY_START"; |
| 1063 | This is a multi-part message in MIME format. |
| 1064 | --$mime_boundary |
| 1065 | Content-Type: text/plain; format=fixed |
| 1066 | Content-Transfer-Encoding: 8bit |
| 1067 | |
| 1068 | BODY_START |
| 1069 | return $body_start; |
| 1070 | } |
| 1071 | |
| 1072 | sub _add_attachments { |
| 1073 | my $attach = ''; |
| 1074 | for my $attachment (split /\s*,\s*/, $attachments) { |
| 1075 | my $attach_file = basename($attachment); |
| 1076 | $attach .= <<"ATTACHMENT"; |
| 1077 | |
| 1078 | --$mime_boundary |
| 1079 | Content-Type: text/x-patch; name="$attach_file" |
| 1080 | Content-Transfer-Encoding: 8bit |
| 1081 | Content-Disposition: attachment; filename="$attach_file" |
| 1082 | |
| 1083 | ATTACHMENT |
| 1084 | |
| 1085 | open my $attach_fh, '<:raw', $attachment |
| 1086 | or die "Couldn't open attachment '$attachment': $!\n"; |
| 1087 | while (<$attach_fh>) { $attach .= $_; } |
| 1088 | close($attach_fh) or die "Error closing attachment '$attachment': $!"; |
| 1089 | } |
| 1090 | |
| 1091 | $attach .= "\n--$mime_boundary--\n"; |
| 1092 | return $attach; |
| 1093 | } |
| 1094 | |
| 1095 | sub _read_report { |
| 1096 | my $fname = shift; |
| 1097 | my $content; |
| 1098 | open( REP, "<:raw", $fname ) or die "Couldn't open file '$fname': $!\n"; |
| 1099 | binmode(REP, ':raw :crlf') if $Is_MSWin32; |
| 1100 | # wrap long lines to make sure the report gets delivered |
| 1101 | local $Text::Wrap::columns = 900; |
| 1102 | local $Text::Wrap::huge = 'overflow'; |
| 1103 | while (<REP>) { |
| 1104 | if ($::HaveWrap && /\S/) { # wrap() would remove empty lines |
| 1105 | $content .= Text::Wrap::wrap(undef, undef, $_); |
| 1106 | } else { |
| 1107 | $content .= $_; |
| 1108 | } |
| 1109 | } |
| 1110 | close(REP) or die "Error closing report file '$fname': $!"; |
| 1111 | return $content; |
| 1112 | } |
| 1113 | |
| 1114 | sub build_complete_message { |
| 1115 | my $content = _build_header(%{_message_headers()}) . "\n\n"; |
| 1116 | $content .= _add_body_start() if $have_attachment; |
| 1117 | $content .= _read_report($filename); |
| 1118 | $content .= _add_attachments() if $have_attachment; |
| 1119 | return $content; |
| 1120 | } |
| 1121 | |
| 1122 | sub save_message_to_disk { |
| 1123 | my $file = shift; |
| 1124 | |
| 1125 | if (-e $file) { |
| 1126 | my $response = _prompt( '', "Overwrite existing '$file'", 'n' ); |
| 1127 | return undef unless $response =~ / yes | y /xi; |
| 1128 | } |
| 1129 | open OUTFILE, '>:raw', $file or do { warn "Couldn't open '$file': $!\n"; return undef}; |
| 1130 | binmode(OUTFILE, ':raw :crlf') if $Is_MSWin32; |
| 1131 | |
| 1132 | print OUTFILE build_complete_message(); |
| 1133 | close(OUTFILE) or do { warn "Error closing $file: $!"; return undef }; |
| 1134 | print "\nMessage saved.\n"; |
| 1135 | return 1; |
| 1136 | } |
| 1137 | |
| 1138 | sub _send_message_vms { |
| 1139 | |
| 1140 | my $mail_from = $from; |
| 1141 | my $rcpt_to_to = $address; |
| 1142 | my $rcpt_to_cc = $cc; |
| 1143 | |
| 1144 | map { $_ =~ s/^[^<]*<//; |
| 1145 | $_ =~ s/>[^>]*//; } ($mail_from, $rcpt_to_to, $rcpt_to_cc); |
| 1146 | |
| 1147 | if ( open my $sff_fh, '|-:raw', 'MCR TCPIP$SYSTEM:TCPIP$SMTP_SFF.EXE SYS$INPUT:' ) { |
| 1148 | print $sff_fh "MAIL FROM:<$mail_from>\n"; |
| 1149 | print $sff_fh "RCPT TO:<$rcpt_to_to>\n"; |
| 1150 | print $sff_fh "RCPT TO:<$rcpt_to_cc>\n" if $rcpt_to_cc; |
| 1151 | print $sff_fh "DATA\n"; |
| 1152 | print $sff_fh build_complete_message(); |
| 1153 | my $success = close $sff_fh; |
| 1154 | if ($success ) { |
| 1155 | print "\nMessage sent\n"; |
| 1156 | return; |
| 1157 | } |
| 1158 | } |
| 1159 | die "Mail transport failed (leaving bug report in $filename): $^E\n"; |
| 1160 | } |
| 1161 | |
| 1162 | sub _send_message_mailsend { |
| 1163 | my $msg = Mail::Send->new(); |
| 1164 | my %headers = %{_message_headers()}; |
| 1165 | for my $key ( keys %headers) { |
| 1166 | $msg->add($key => $headers{$key}); |
| 1167 | } |
| 1168 | |
| 1169 | $fh = $msg->open; |
| 1170 | binmode($fh, ':raw'); |
| 1171 | print $fh _add_body_start() if $have_attachment; |
| 1172 | print $fh _read_report($filename); |
| 1173 | print $fh _add_attachments() if $have_attachment; |
| 1174 | $fh->close or die "Error sending mail: $!"; |
| 1175 | |
| 1176 | print "\nMessage sent.\n"; |
| 1177 | } |
| 1178 | |
| 1179 | sub _probe_for_sendmail { |
| 1180 | my $sendmail = ""; |
| 1181 | for (qw(/usr/lib/sendmail /usr/sbin/sendmail /usr/ucblib/sendmail)) { |
| 1182 | $sendmail = $_, last if -e $_; |
| 1183 | } |
| 1184 | if ( $^O eq 'os2' and $sendmail eq "" ) { |
| 1185 | my $path = $ENV{PATH}; |
| 1186 | $path =~ s:\\:/:; |
| 1187 | my @path = split /$Config{'path_sep'}/, $path; |
| 1188 | for (@path) { |
| 1189 | $sendmail = "$_/sendmail", last if -e "$_/sendmail"; |
| 1190 | $sendmail = "$_/sendmail.exe", last if -e "$_/sendmail.exe"; |
| 1191 | } |
| 1192 | } |
| 1193 | return $sendmail; |
| 1194 | } |
| 1195 | |
| 1196 | sub _send_message_sendmail { |
| 1197 | my $sendmail = _probe_for_sendmail(); |
| 1198 | unless ($sendmail) { |
| 1199 | my $message_start = !$Is_Linux && !$Is_OpenBSD ? <<'EOT' : <<'EOT'; |
| 1200 | It appears that there is no program which looks like "sendmail" on |
| 1201 | your system and that the Mail::Send library from CPAN isn't available. |
| 1202 | EOT |
| 1203 | It appears that there is no program which looks like "sendmail" on |
| 1204 | your system. |
| 1205 | EOT |
| 1206 | paraprint(<<"EOF"), die "\n"; |
| 1207 | $message_start |
| 1208 | Because of this, there's no easy way to automatically send your |
| 1209 | message. |
| 1210 | |
| 1211 | A copy of your message has been saved in '$filename' for you to |
| 1212 | send to '$address' with your normal mail client. |
| 1213 | EOF |
| 1214 | } |
| 1215 | |
| 1216 | open( SENDMAIL, "|-:raw", $sendmail, "-t", "-oi", "-f", $from ) |
| 1217 | || die "'|$sendmail -t -oi -f $from' failed: $!"; |
| 1218 | print SENDMAIL build_complete_message(); |
| 1219 | if ( close(SENDMAIL) ) { |
| 1220 | print "\nMessage sent\n"; |
| 1221 | } else { |
| 1222 | warn "\nSendmail returned status '", $? >> 8, "'\n"; |
| 1223 | } |
| 1224 | } |
| 1225 | |
| 1226 | |
| 1227 | |
| 1228 | # a strange way to check whether any significant editing |
| 1229 | # has been done: check whether any new non-empty lines |
| 1230 | # have been added. |
| 1231 | |
| 1232 | sub _fingerprint_lines_in_report { |
| 1233 | my $new_lines = 0; |
| 1234 | # read in the report template once so that |
| 1235 | # we can track whether the user does any editing. |
| 1236 | # yes, *all* whitespace is ignored. |
| 1237 | |
| 1238 | open(REP, '<:raw', $filename) or die "Unable to open report file '$filename': $!\n"; |
| 1239 | binmode(REP, ':raw :crlf') if $Is_MSWin32; |
| 1240 | while (my $line = <REP>) { |
| 1241 | $line =~ s/\s+//g; |
| 1242 | $new_lines++ if (!$REP{$line}); |
| 1243 | |
| 1244 | } |
| 1245 | close(REP) or die "Error closing report file '$filename': $!"; |
| 1246 | # returns the number of lines with content that wasn't there when last we looked |
| 1247 | return $new_lines; |
| 1248 | } |
| 1249 | |
| 1250 | |
| 1251 | |
| 1252 | format STDOUT = |
| 1253 | ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< ~~ |
| 1254 | $_ |
| 1255 | . |
| 1256 | |
| 1257 | __END__ |
| 1258 | |
| 1259 | =head1 NAME |
| 1260 | |
| 1261 | perlbug - how to submit bug reports on Perl |
| 1262 | |
| 1263 | =head1 SYNOPSIS |
| 1264 | |
| 1265 | B<perlbug> |
| 1266 | |
| 1267 | B<perlbug> S<[ B<-v> ]> S<[ B<-a> I<address> ]> S<[ B<-s> I<subject> ]> |
| 1268 | S<[ B<-b> I<body> | B<-f> I<inputfile> ]> S<[ B<-F> I<outputfile> ]> |
| 1269 | S<[ B<-r> I<returnaddress> ]> |
| 1270 | S<[ B<-e> I<editor> ]> S<[ B<-c> I<adminaddress> | B<-C> ]> |
| 1271 | S<[ B<-S> ]> S<[ B<-t> ]> S<[ B<-d> ]> S<[ B<-A> ]> S<[ B<-h> ]> S<[ B<-T> ]> |
| 1272 | |
| 1273 | B<perlbug> S<[ B<-v> ]> S<[ B<-r> I<returnaddress> ]> |
| 1274 | S<[ B<-A> ]> S<[ B<-ok> | B<-okay> | B<-nok> | B<-nokay> ]> |
| 1275 | |
| 1276 | B<perlthanks> |
| 1277 | |
| 1278 | =head1 DESCRIPTION |
| 1279 | |
| 1280 | |
| 1281 | This program is designed to help you generate bug reports |
| 1282 | (and thank-you notes) about perl5 and the modules which ship with it. |
| 1283 | |
| 1284 | In most cases, you can just run it interactively from a command |
| 1285 | line without any special arguments and follow the prompts. |
| 1286 | |
| 1287 | If you have found a bug with a non-standard port (one that was not |
| 1288 | part of the I<standard distribution>), a binary distribution, or a |
| 1289 | non-core module (such as Tk, DBI, etc), then please see the |
| 1290 | documentation that came with that distribution to determine the |
| 1291 | correct place to report bugs. |
| 1292 | |
| 1293 | Bug reports should be submitted to the GitHub issue tracker at |
| 1294 | L<https://github.com/Perl/perl5/issues>. The B<perlbug@perl.org> |
| 1295 | address no longer automatically opens tickets. You can use this tool |
| 1296 | to compose your report and save it to a file which you can then submit |
| 1297 | to the issue tracker. |
| 1298 | |
| 1299 | In extreme cases, B<perlbug> may not work well enough on your system |
| 1300 | to guide you through composing a bug report. In those cases, you |
| 1301 | may be able to use B<perlbug -d> or B<perl -V> to get system |
| 1302 | configuration information to include in your issue report. |
| 1303 | |
| 1304 | |
| 1305 | When reporting a bug, please run through this checklist: |
| 1306 | |
| 1307 | =over 4 |
| 1308 | |
| 1309 | =item What version of Perl you are running? |
| 1310 | |
| 1311 | Type C<perl -v> at the command line to find out. |
| 1312 | |
| 1313 | =item Are you running the latest released version of perl? |
| 1314 | |
| 1315 | Look at L<http://www.perl.org/> to find out. If you are not using the |
| 1316 | latest released version, please try to replicate your bug on the |
| 1317 | latest stable release. |
| 1318 | |
| 1319 | Note that reports about bugs in old versions of Perl, especially |
| 1320 | those which indicate you haven't also tested the current stable |
| 1321 | release of Perl, are likely to receive less attention from the |
| 1322 | volunteers who build and maintain Perl than reports about bugs in |
| 1323 | the current release. |
| 1324 | |
| 1325 | This tool isn't appropriate for reporting bugs in any version |
| 1326 | prior to Perl 5.0. |
| 1327 | |
| 1328 | =item Are you sure what you have is a bug? |
| 1329 | |
| 1330 | A significant number of the bug reports we get turn out to be |
| 1331 | documented features in Perl. Make sure the issue you've run into |
| 1332 | isn't intentional by glancing through the documentation that comes |
| 1333 | with the Perl distribution. |
| 1334 | |
| 1335 | Given the sheer volume of Perl documentation, this isn't a trivial |
| 1336 | undertaking, but if you can point to documentation that suggests |
| 1337 | the behaviour you're seeing is I<wrong>, your issue is likely to |
| 1338 | receive more attention. You may want to start with B<perldoc> |
| 1339 | L<perltrap> for pointers to common traps that new (and experienced) |
| 1340 | Perl programmers run into. |
| 1341 | |
| 1342 | If you're unsure of the meaning of an error message you've run |
| 1343 | across, B<perldoc> L<perldiag> for an explanation. If the message |
| 1344 | isn't in perldiag, it probably isn't generated by Perl. You may |
| 1345 | have luck consulting your operating system documentation instead. |
| 1346 | |
| 1347 | If you are on a non-UNIX platform B<perldoc> L<perlport>, as some |
| 1348 | features may be unimplemented or work differently. |
| 1349 | |
| 1350 | You may be able to figure out what's going wrong using the Perl |
| 1351 | debugger. For information about how to use the debugger B<perldoc> |
| 1352 | L<perldebug>. |
| 1353 | |
| 1354 | =item Do you have a proper test case? |
| 1355 | |
| 1356 | The easier it is to reproduce your bug, the more likely it will be |
| 1357 | fixed -- if nobody can duplicate your problem, it probably won't be |
| 1358 | addressed. |
| 1359 | |
| 1360 | A good test case has most of these attributes: short, simple code; |
| 1361 | few dependencies on external commands, modules, or libraries; no |
| 1362 | platform-dependent code (unless it's a platform-specific bug); |
| 1363 | clear, simple documentation. |
| 1364 | |
| 1365 | A good test case is almost always a good candidate to be included in |
| 1366 | Perl's test suite. If you have the time, consider writing your test case so |
| 1367 | that it can be easily included into the standard test suite. |
| 1368 | |
| 1369 | =item Have you included all relevant information? |
| 1370 | |
| 1371 | Be sure to include the B<exact> error messages, if any. |
| 1372 | "Perl gave an error" is not an exact error message. |
| 1373 | |
| 1374 | If you get a core dump (or equivalent), you may use a debugger |
| 1375 | (B<dbx>, B<gdb>, etc) to produce a stack trace to include in the bug |
| 1376 | report. |
| 1377 | |
| 1378 | NOTE: unless your Perl has been compiled with debug info |
| 1379 | (often B<-g>), the stack trace is likely to be somewhat hard to use |
| 1380 | because it will most probably contain only the function names and not |
| 1381 | their arguments. If possible, recompile your Perl with debug info and |
| 1382 | reproduce the crash and the stack trace. |
| 1383 | |
| 1384 | =item Can you describe the bug in plain English? |
| 1385 | |
| 1386 | The easier it is to understand a reproducible bug, the more likely |
| 1387 | it will be fixed. Any insight you can provide into the problem |
| 1388 | will help a great deal. In other words, try to analyze the problem |
| 1389 | (to the extent you can) and report your discoveries. |
| 1390 | |
| 1391 | =item Can you fix the bug yourself? |
| 1392 | |
| 1393 | If so, that's great news; bug reports with patches are likely to |
| 1394 | receive significantly more attention and interest than those without |
| 1395 | patches. Please submit your patch via the GitHub Pull Request workflow |
| 1396 | as described in B<perldoc> L<perlhack>. You may also send patches to |
| 1397 | B<perl5-porters@perl.org>. When sending a patch, create it using |
| 1398 | C<git format-patch> if possible, though a unified diff created with |
| 1399 | C<diff -pu> will do nearly as well. |
| 1400 | |
| 1401 | Your patch may be returned with requests for changes, or requests for more |
| 1402 | detailed explanations about your fix. |
| 1403 | |
| 1404 | Here are a few hints for creating high-quality patches: |
| 1405 | |
| 1406 | Make sure the patch is not reversed (the first argument to diff is |
| 1407 | typically the original file, the second argument your changed file). |
| 1408 | Make sure you test your patch by applying it with C<git am> or the |
| 1409 | C<patch> program before you send it on its way. Try to follow the |
| 1410 | same style as the code you are trying to patch. Make sure your patch |
| 1411 | really does work (C<make test>, if the thing you're patching is covered |
| 1412 | by Perl's test suite). |
| 1413 | |
| 1414 | =item Can you use C<perlbug> to submit a thank-you note? |
| 1415 | |
| 1416 | Yes, you can do this by either using the C<-T> option, or by invoking |
| 1417 | the program as C<perlthanks>. Thank-you notes are good. It makes people |
| 1418 | smile. |
| 1419 | |
| 1420 | =back |
| 1421 | |
| 1422 | Please make your issue title informative. "a bug" is not informative. |
| 1423 | Neither is "perl crashes" nor is "HELP!!!". These don't help. A compact |
| 1424 | description of what's wrong is fine. |
| 1425 | |
| 1426 | Having done your bit, please be prepared to wait, to be told the |
| 1427 | bug is in your code, or possibly to get no reply at all. The |
| 1428 | volunteers who maintain Perl are busy folks, so if your problem is |
| 1429 | an obvious bug in your own code, is difficult to understand or is |
| 1430 | a duplicate of an existing report, you may not receive a personal |
| 1431 | reply. |
| 1432 | |
| 1433 | If it is important to you that your bug be fixed, do monitor the |
| 1434 | issue tracker (you will be subscribed to notifications for issues you |
| 1435 | submit or comment on) and the commit logs to development |
| 1436 | versions of Perl, and encourage the maintainers with kind words or |
| 1437 | offers of frosty beverages. (Please do be kind to the maintainers. |
| 1438 | Harassing or flaming them is likely to have the opposite effect of the |
| 1439 | one you want.) |
| 1440 | |
| 1441 | Feel free to update the ticket about your bug on |
| 1442 | L<https://github.com/Perl/perl5/issues> |
| 1443 | if a new version of Perl is released and your bug is still present. |
| 1444 | |
| 1445 | =head1 OPTIONS |
| 1446 | |
| 1447 | =over 8 |
| 1448 | |
| 1449 | =item B<-a> |
| 1450 | |
| 1451 | Address to send the report to. Defaults to B<perlbug@perl.org>. |
| 1452 | |
| 1453 | =item B<-A> |
| 1454 | |
| 1455 | Don't send a bug received acknowledgement to the reply address. |
| 1456 | Generally it is only a sensible to use this option if you are a |
| 1457 | perl maintainer actively watching perl porters for your message to |
| 1458 | arrive. |
| 1459 | |
| 1460 | =item B<-b> |
| 1461 | |
| 1462 | Body of the report. If not included on the command line, or |
| 1463 | in a file with B<-f>, you will get a chance to edit the message. |
| 1464 | |
| 1465 | =item B<-C> |
| 1466 | |
| 1467 | Don't send copy to administrator. |
| 1468 | |
| 1469 | =item B<-c> |
| 1470 | |
| 1471 | Address to send copy of report to. Defaults to the address of the |
| 1472 | local perl administrator (recorded when perl was built). |
| 1473 | |
| 1474 | =item B<-d> |
| 1475 | |
| 1476 | Data mode (the default if you redirect or pipe output). This prints out |
| 1477 | your configuration data, without mailing anything. You can use this |
| 1478 | with B<-v> to get more complete data. |
| 1479 | |
| 1480 | =item B<-e> |
| 1481 | |
| 1482 | Editor to use. |
| 1483 | |
| 1484 | =item B<-f> |
| 1485 | |
| 1486 | File containing the body of the report. Use this to quickly send a |
| 1487 | prepared message. |
| 1488 | |
| 1489 | =item B<-F> |
| 1490 | |
| 1491 | File to output the results to instead of sending as an email. Useful |
| 1492 | particularly when running perlbug on a machine with no direct internet |
| 1493 | connection. |
| 1494 | |
| 1495 | =item B<-h> |
| 1496 | |
| 1497 | Prints a brief summary of the options. |
| 1498 | |
| 1499 | =item B<-ok> |
| 1500 | |
| 1501 | Report successful build on this system to perl porters. Forces B<-S> |
| 1502 | and B<-C>. Forces and supplies values for B<-s> and B<-b>. Only |
| 1503 | prompts for a return address if it cannot guess it (for use with |
| 1504 | B<make>). Honors return address specified with B<-r>. You can use this |
| 1505 | with B<-v> to get more complete data. Only makes a report if this |
| 1506 | system is less than 60 days old. |
| 1507 | |
| 1508 | =item B<-okay> |
| 1509 | |
| 1510 | As B<-ok> except it will report on older systems. |
| 1511 | |
| 1512 | =item B<-nok> |
| 1513 | |
| 1514 | Report unsuccessful build on this system. Forces B<-C>. Forces and |
| 1515 | supplies a value for B<-s>, then requires you to edit the report |
| 1516 | and say what went wrong. Alternatively, a prepared report may be |
| 1517 | supplied using B<-f>. Only prompts for a return address if it |
| 1518 | cannot guess it (for use with B<make>). Honors return address |
| 1519 | specified with B<-r>. You can use this with B<-v> to get more |
| 1520 | complete data. Only makes a report if this system is less than 60 |
| 1521 | days old. |
| 1522 | |
| 1523 | =item B<-nokay> |
| 1524 | |
| 1525 | As B<-nok> except it will report on older systems. |
| 1526 | |
| 1527 | =item B<-p> |
| 1528 | |
| 1529 | The names of one or more patch files or other text attachments to be |
| 1530 | included with the report. Multiple files must be separated with commas. |
| 1531 | |
| 1532 | =item B<-r> |
| 1533 | |
| 1534 | Your return address. The program will ask you to confirm its default |
| 1535 | if you don't use this option. |
| 1536 | |
| 1537 | =item B<-S> |
| 1538 | |
| 1539 | Send without asking for confirmation. |
| 1540 | |
| 1541 | =item B<-s> |
| 1542 | |
| 1543 | Subject to include with the message. You will be prompted if you don't |
| 1544 | supply one on the command line. |
| 1545 | |
| 1546 | =item B<-t> |
| 1547 | |
| 1548 | Test mode. The target address defaults to B<perlbug-test@perl.org>. |
| 1549 | Also makes it possible to command perlbug from a pipe or file, for |
| 1550 | testing purposes. |
| 1551 | |
| 1552 | =item B<-T> |
| 1553 | |
| 1554 | Send a thank-you note instead of a bug report. |
| 1555 | |
| 1556 | =item B<-v> |
| 1557 | |
| 1558 | Include verbose configuration data in the report. |
| 1559 | |
| 1560 | =back |
| 1561 | |
| 1562 | =head1 AUTHORS |
| 1563 | |
| 1564 | Kenneth Albanowski (E<lt>kjahds@kjahds.comE<gt>), subsequently |
| 1565 | I<doc>tored by Gurusamy Sarathy (E<lt>gsar@activestate.comE<gt>), |
| 1566 | Tom Christiansen (E<lt>tchrist@perl.comE<gt>), Nathan Torkington |
| 1567 | (E<lt>gnat@frii.comE<gt>), Charles F. Randall (E<lt>cfr@pobox.comE<gt>), |
| 1568 | Mike Guy (E<lt>mjtg@cam.ac.ukE<gt>), Dominic Dunlop |
| 1569 | (E<lt>domo@computer.orgE<gt>), Hugo van der Sanden (E<lt>hv@crypt.orgE<gt>), |
| 1570 | Jarkko Hietaniemi (E<lt>jhi@iki.fiE<gt>), Chris Nandor |
| 1571 | (E<lt>pudge@pobox.comE<gt>), Jon Orwant (E<lt>orwant@media.mit.eduE<gt>, |
| 1572 | Richard Foley (E<lt>richard.foley@rfi.netE<gt>), Jesse Vincent |
| 1573 | (E<lt>jesse@bestpractical.comE<gt>), and Craig A. Berry (E<lt>craigberry@mac.comE<gt>). |
| 1574 | |
| 1575 | =head1 SEE ALSO |
| 1576 | |
| 1577 | perl(1), perldebug(1), perldiag(1), perlport(1), perltrap(1), |
| 1578 | diff(1), patch(1), dbx(1), gdb(1) |
| 1579 | |
| 1580 | =head1 BUGS |
| 1581 | |
| 1582 | None known (guess what must have been used to report them?) |
| 1583 | |
| 1584 | =cut |
| 1585 | |
| 1586 | !NO!SUBS! |
| 1587 | |
| 1588 | close OUT or die "Can't close $file: $!"; |
| 1589 | chmod 0755, $file or die "Can't reset permissions for $file: $!\n"; |
| 1590 | exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':'; |
| 1591 | chdir $origdir; |