* src/pmc/multisub.pmc:
[parrot.git] / parrotbug
blob260ef5a9c96e329a12f29bf135cb98b25ab0290e
1 #!/usr/bin/perl
3 # Copyright (C) 2004-2007, The Perl Foundation.
4 # $Id$
7 eval 'exec perl -w -S $0 ${1+"$@"}'
8 if $running_under_some_shell;
10 use strict;
11 use warnings;
13 use Config;
14 use File::Spec;
15 use Getopt::Long;
18 my $VERSION = "0.6.1";
20 # These are the standard addresses for reporting bugs.
21 my %std_to =
22 ( bug => 'parrotbug@parrotcode.org',
23 ok => 'parrotstatus-ok@parrotcode.org',
24 nok => 'parrotstatus-nok@parrotcode.org',
27 my $parrotdir = File::Spec->curdir();
28 my ( %opts, %parrot, %report );
29 my ( $editor, $user, $domain, $msgid, $tmpfile );
30 my ( $is_linux, $is_macos, $is_mswin32, $is_os2, $is_vms );
31 my @categories = qw[ core docs install library utilities languages ];
32 my @severities = qw[ critical high medium low wishlist none ];
35 #------------------------------------------------------------#
36 # Main program. #
38 init();
39 help() if $opts{help};
40 version() if $opts{version};
41 explain_parrotbug() unless $opts{quiet};
42 query_missing_info();
43 what_next();
44 unlink $tmpfile;
45 exit;
49 # Explain what C<parrotbug> is.
50 sub explain_parrotbug {
51 print <<EOT;
53 This program provides an easy way to create a message reporting a bug
54 in parrot, and e-mail it to the parrot developers.
56 It is *NOT* intended for:
57 - sending test messages,
58 - or reporting bugs in languages targetting parrot,
59 - or reporting bugs in some library bindings for parrot,
60 - or simply verifying that parrot works.
62 It is *ONLY* a mean of reporting verifiable problems with the core
63 parrot distribution, and any solutions to such problems, to parrot
64 developers.
66 If you're just looking for help with parrot, subscribe to the parrot
67 mailing list, parrot-porters<at>perl.org.
71 EOT
77 #------------------------------------------------------------#
78 # Utils subs. #
80 # Generate random filename to edit report.
81 sub generate_filename {
82 my $dir = File::Spec->tmpdir();
83 my $filename = "bugrep0$$";
84 $filename++ while -e File::Spec->catfile($dir, $filename);
85 $filename = File::Spec->catfile($dir, $filename);
86 return $filename;
90 # Check whether a subject is trivial. A subject is not considered trivial
91 # if it's an ok or a nok report.
92 # Return 1 if trivial, 0 otherwise (subject acceptable).
93 sub trivial_subject {
94 my $subject = shift;
96 return 0 if $opts{ok} || $opts{nok};
97 if ( $subject =~
98 /^(y(es)?|no?|help|parrot( (bug|problem))?|bug|problem)$/i ||
99 length($subject) < 4 ||
100 $subject !~ /\s/ ) {
101 return 1;
103 else {
104 return 0;
111 #------------------------------------------------------------#
112 # Init subs. #
114 # Initialize the program.
116 # Get parrot information, process the options, create the message
117 # information (subject, to, body, etc.) depending on the type of report
118 # (ok, nok or bug report).
119 sub init {
120 $is_linux = lc($^O) eq 'linux';
121 $is_mswin32 = $^O eq 'MSWin32';
122 $is_os2 = $^O eq 'os2';
123 $is_vms = $^O eq 'VMS';
126 ## Fetch Parrot information.
129 # Get parrot version.
130 # There will always be an up-to-date $parrot/VERSION
131 my $filename = File::Spec->catfile($parrotdir, "VERSION");
132 open(VERSION, "<$filename") or die "Cannot open '$filename': $!";
133 $parrot{version} = <VERSION>;
134 chomp $parrot{version};
135 close(VERSION) or die "Cannot close '$filename': $!";
137 # Get parrot configuration, stored in $parrot/myconfig
138 $filename = File::Spec->catfile($parrotdir, "myconfig");
139 open(MYCONFIG, "<$filename") or die "Cannot open '$filename': $!";
141 local $/;
142 $parrot{myconfig} = <MYCONFIG>;
144 close(MYCONFIG) or die "Cannot close '$filename': $!";
148 ## Process options.
150 Getopt::Long::Configure("no_bundling", "no_ignore_case", "auto_abbrev");
151 help() unless GetOptions
152 ( \%opts,
153 "help|h", "version|V",
154 "send", "dump", "save",
155 "from|f=s", "to|test|t=s", "editor|e=s",
156 "subject|s=s", "category|C=s", "severity|S=s",
157 "input|input-file|i=s", "output|output-file|o=s",
158 "ok", "nok", "ack!", "quiet|q!" );
161 ## Report to be sent.
163 sw: {
164 ok_report: {
165 last ok_report unless defined $opts{ok};
167 # This is an ok report, woohoo!
168 $report{to} = $std_to{ok};
169 $report{subject} = "OK: parrot $parrot{version} "
170 . "on $Config{archname} $Config{osvers}";
171 $report{body} = "Parrot reported to build OK on this system.\n";
172 $report{category} = "install";
173 $report{severity} = "none";
174 $report{body} = "";
175 last sw;
178 # Ok reports do not need body, but nok and bug reports do need
179 # a body.
180 if ( $opts{input} ) {
181 # Report was pre-written, slurp it.
182 open BODY, "<$opts{input}" or die "Can't open '$opts{input}': $!";
183 local $/;
184 $report{body} = <BODY>;
185 close BODY or die "Can't close '$opts{input}': $!";
187 else {
188 # No file provided...
189 $report{body} = "";
192 nok_report: {
193 last nok_report unless defined $opts{nok};
195 # This a nok report, how sad... :-(
196 $report{to} = $std_to{nok};
197 $report{subject} = "Not OK: parrot $parrot{version} "
198 . "on $Config{archname} $Config{osvers}";
199 $report{category} = "install";
200 $report{severity} = "none";
201 last sw;
204 # Neither an ok nor a nok.
205 $report{to} = $std_to{bug};
206 $report{subject} = $opts{subject} || "";
207 $report{category} = $opts{category} || "";
208 $report{severity} = $opts{severity} || "";
211 # Test message, shortcuting recipent.
212 $report{to} = $opts{to} if $opts{to};
215 ## User information.
218 # Username.
219 $user = $is_mswin32 ? $ENV{USERNAME}
220 : $is_os2 ? $ENV{USER} || $ENV{LOGNAME}
221 : $is_macos ? $ENV{USER}
222 : eval { getpwuid($<) }; # May be missing
224 # User address, used in message and in Reply-To header.
225 $report{from} = $opts{from} || "";
227 # Editor
228 $editor = $ENV{VISUAL} || $ENV{EDITOR} || $ENV{EDIT}
229 || ( $is_vms && "edit/tpu" )
230 || ( $is_mswin32 && "notepad" )
231 || ( $is_macos && "" )
232 || "vi";
236 ## Mail information.
239 # Message-Id.
240 eval "use Mail::Util;";
241 if ( $@ eq "" ) {
242 $domain = Mail::Util::maildomain();
244 elsif ($is_mswin32) {
245 $domain = $ENV{USERDOMAIN};
247 else {
248 require Sys::Hostname;
249 $domain = Sys::Hostname::hostname();
251 $msgid = "<parrotbug_${VERSION}_${$}_".time."\@$domain>";
256 #------------------------------------------------------------#
257 # Querying subs. #
259 # Query missing information in order to have a complete report.
260 sub query_missing_info {
261 $report{subject} = "" if trivial_subject( $report{subject} );
262 $report{subject} = ask_for_subject() unless $report{subject};
263 $report{category} = ask_for_alternative( "category", \@categories)
264 unless $report{category};
265 $report{severity} = ask_for_alternative( "severity", \@severities)
266 unless $report{severity};
267 $report{from} = ask_for_return_address() unless $report{from};
268 $report{body} = ask_for_body() unless $report{body};
272 # Prompt for alternatives from a set of choices.
274 # The arguments are: the name of alternative, the choices (as an array
275 # ref), and the default answer. (first element if undef)
277 # Return the lowercased alternative chosen.
279 # Die if more than 5 wrong answers.
280 sub ask_for_alternative {
281 my ( $what, $choices, $default ) = @_;
283 print <<EOT unless $opts{quiet};
284 Please pick a $what from the following:
285 @{$choices}
289 $default ||= $choices->[0];
290 my $alt;
291 my $err = 0;
292 do {
293 die "Invalid $alt: aborting.\n" if $err++ > 5;
294 print "Please enter a $what [$default]: ";
295 $alt = <STDIN>;
296 chomp $alt;
297 $alt = $default if $alt =~ /^\s*$/;
298 } until ( ($alt) = grep /^$alt/i, @$choices );
300 print "\n\n\n";
301 return lc $alt;
305 # Prompt for a body, through an external editor.
306 sub ask_for_body {
307 unless ( $opts{quiet} ) {
308 print <<EOT;
309 Now you need to supply the bug report. Try to make the report concise
310 but descriptive. Include any relevant detail. If you are reporting
311 something that does not work as you think it should, please try to
312 include example of both the actual result, and what you expected.
314 Some information about your local parrot configuration will
315 automatically be included at the end of the report. If you are using
316 any unusual version of parrot, please try and confirm exactly which
317 versions are relevant.
321 print "Press 'Enter' to continue...\n";
322 scalar <STDIN>;
325 # Prompt for editor to use if none supplied.
326 if ( $opts{editor} ) {
327 $editor = $opts{editor};
330 else {
331 ask_for_editor($opts{quiet} ? "" : <<EOT);
332 You will probably want to use an editor to enter the report. If the
333 default editor proposed below is the editor you want to use, then just
334 press the 'Enter' key, otherwise type in the name of the editor you
335 would like to use.
339 # Launch editor.
340 $tmpfile = generate_filename();
341 my $body = "";
342 my $err = 0;
343 do {
344 edit_bug_report( $tmpfile );
345 # Slurp bug report.
346 open BODY, "<$tmpfile" or die "Can't open '$tmpfile': $!";
348 local $/;
349 $body = <BODY>;
351 close BODY or die "Can't close '$tmpfile': $!";
352 unless ( $body ) {
353 print "\nYou provided an empty bug report!\n";
354 print "Press 'Enter' to continue...\n";
355 scalar <STDIN>;
357 die "Aborting.\n" if $err++ == 5;
358 } until ( $body );
360 return $body;
364 # Prompt for editor to use.
365 sub ask_for_editor {
366 print shift() . "Editor [$editor]: ";
367 my $entry = <STDIN>;
368 chomp $entry;
369 $editor = $entry if $entry ne "";
370 $opts{editor} = $editor;
374 # Prompt for return address, return it.
375 sub ask_for_return_address {
376 print <<EOT unless $opts{quiet};
377 Your e-mail address will be useful if you need to be contacted. If the
378 default shown below is not your full internet e-mail address, please
379 correct it.
382 # Try and guess return address
383 my ($from, $guess);
384 $guess = $ENV{'REPLY-TO'} || $ENV{REPLYTO} || "";
386 if ( ! $guess ) {
387 # Use $domain if we can.
388 if ( $domain ) {
389 $guess = $is_vms && !$Config{d_socket} ?
390 "$domain\:\:$user" : "$user\@$domain";
394 # Verify our guess.
395 print "Your address [$guess]: ";
396 $from = <STDIN>;
397 chomp $from;
398 $from = $guess if $from eq "";
399 print "\n\n\n";
400 return $from;
404 # Prompt for subject of message.
406 # Return the subject chosen.
408 # Die if more than 5 wrong subjects.
409 sub ask_for_subject {
410 print <<EOT unless $opts{quiet};
411 First of all, please provide a subject for the message. It should be a
412 concise description of the bug or problem. "parrot bug" or "parrot
413 problem" is not a concise description.
417 my $subject;
418 my $err = 0;
419 do {
420 $err and print "\nThat doesn't look like a good subject. "
421 . "Please be more verbose.\n";
422 print "Subject: ";
423 $subject = <STDIN>;
424 $subject = q{} unless defined $subject;
425 chomp $subject;
426 die "Aborting.\n" if $err++ == 5;
427 } while ( trivial_subject($subject) );
428 print "\n\n\n";
429 return $subject;
433 # Launch an editor in which to edit the bug report.
434 sub edit_bug_report {
435 my $filename = shift;
437 # Launch editor.
438 my $retval;
439 $retval = system("$editor $filename");
441 # Check whether editor run was successful.
442 die <<EOT if $retval;
443 The editor you chose ('$editor') could apparently not be run! Did you
444 mistype the name of your editor?
452 #------------------------------------------------------------#
453 # Action subs. #
456 # Display everything collected.
457 sub dump_report {
458 print "==> Dumping message...\n";
459 print format_message();
463 # Last chance to edit report.
464 sub edit_report {
465 # Prompt for editor to use if none supplied.
466 unless ( $opts{editor} ) {
467 ask_for_editor(<<EOT);
468 You will probably want to use an editor to modify the report. If the
469 default editor proposed below is the editor you want to use, then just
470 press the 'Enter' key, otherwise type in the name of the editor you
471 would like to use.
475 $tmpfile ||= $opts{input};
476 my $err = 0;
477 my $body;
478 do {
479 edit_bug_report( $tmpfile );
480 # Slurp bug report.
481 open BODY, "<$tmpfile" or die "Can't open '$tmpfile': $!";
483 local $/;
484 $body = <BODY>;
486 close BODY or die "Can't close '$tmpfile': $!";
487 unless ( $body ) {
488 print "\nYou provided an empty bug report!\n";
489 print "Press 'Enter' to continue...\n";
490 scalar <STDIN>;
492 die "Aborting.\n" if $err++ == 5;
493 } until ( $body );
495 $report{body} = $body;
499 # Format the message with everything collected and return it.
500 sub format_message {
501 my $report = "";
503 # OS, arch, compiler...
504 $report .= <<EOT;
506 osname= $Config{osname}
507 osvers= $Config{osvers}
508 arch= $Config{archname}
511 my $cc = $Config{cc};
512 #$report .= "cc= $cc $Config{${cc}.'version'}\n";
513 $report .= "cc= $cc\n";
516 # ... flags...
517 $report .= <<EOT;
519 Flags:
520 category=$report{category}
521 severity=$report{severity}
523 $report .= " ack=no\n" if ! $opts{ack};
525 # ... bug report ...
526 $report .= "---\n$report{body}\n";
528 # ... myconfig ...
529 $report .= "---\n$parrot{myconfig}\n---\n";
531 # ... and environment.
532 $report .= "Environment:\n";
533 my @env = qw[ PATH LD_LIBRARY_PATH LANG SHELL HOME LOGDIR LANGUAGE ];
534 push @env, $Config{ldlibpthname} if $Config{ldlibpthname} ne '';
535 push @env, grep /^(?:PERL|LC_|LANG|CYGWIN)/, keys %ENV;
536 my %env;
537 @env{@env} = @env;
538 for my $env (sort keys %env) {
539 my $env_value = exists $ENV{$env} ? "=$ENV{$env}\n" : " (unset)\n";
540 $report .= " $env $env_value";
543 return $report;
547 # Print synopsis + help message and exit.
548 sub help {
549 print <<EOT;
551 A program to help generate bug reports about parrot, and mail them.
552 It is designed to be used interactively. Normally no arguments will
553 be needed.
555 Simplest usage: run '$0', and follow the prompts.
556 Usage: $0 [OPTIONS] [ACTIONS]
558 Options:
559 --ok Report successful build on this system to parrot
560 developers. Only use --ok if *everything* was ok:
561 if there were *any* problems at all, use --nok.
562 --nok Report unsuccessful build on this system.
563 --subject <subject> Subject to include with the message.
564 --category <category> Category of the bug report.
565 --severity <severity> Severity of the bug report.
566 --from <address> Your email address.
567 --editor <editor> Editor to use for editing the bug report.
568 --ack, --noack Don't send a bug received acknowledgement.
569 --input-file File containing the body of the report. Use this
570 to quickly send a prepared message.
571 --output-file File where parrotbug will save its bug report.
572 --to <address> Email address to send report to. (testing only)
574 Note: you will be prompted if the program miss some information.
576 Actions:
577 --dump Dump message.
578 --save Save message.
579 --send Send message.
580 --help Print this help message and exit.
581 --version Print version information and exit.
584 exit;
588 # Save message to file.
589 sub save_report {
590 print "\n==> Saving message to file...\n";
591 if ( ! $opts{output} ) {
592 print "Enter filename to save bug report: ";
593 $opts{output} = <STDIN>;
596 open OUTPUT, ">$opts{output}" or die "Cannot open '$opts{output}': $!";
597 print OUTPUT format_message();
598 close OUTPUT or die "Cannot open '$opts{output}': $!";
600 print "Message saved.\n";
604 # Send message to final recipient.
605 sub send_report {
606 print "==> Sending message to recipient...\n";
608 # On linux certain mail implementations won't accept the subject
609 # as "~s subject" and thus the Subject header will be corrupted
610 # so don't use Mail::Send to be safe
611 eval "require Mail::Send";
612 if ( $@ eq "" && !$is_linux) {
613 my $msg = new Mail::Send Subject => $report{subject}, To => $report{to};
614 $msg->add( "Reply-To", $report{from} );
616 my $fh = $msg->open;
617 print $fh format_message();
618 $fh->close;
620 print "\nMessage sent.\n";
623 else {
624 my $sendmail = "";
625 for ( qw[ /usr/lib/sendmail /usr/sbin/sendmail
626 /usr/ucblib/sendmail /var/qmail/bin/sendmail ] ) {
627 $sendmail = $_, last if -e $_;
630 die <<EOT if $sendmail eq "";
631 I am terribly sorry, but I cannot find sendmail, or a close
632 equivalent, and the perl package Mail::Send has not been installed, so
633 I can't send your bug report. We apologize for the inconvenience.
635 So you may attempt to find some way of sending your message, it has
636 been left in the file '$tmpfile'.
639 open(SENDMAIL, "|$sendmail -t -oi") || die "'|$sendmail -t -oi' failed: $!";
641 print SENDMAIL <<EOT;
642 To: $report{to}
643 Subject: $report{subject}
644 Reply-To: $report{from}
645 Message-Id: $msgid
649 print SENDMAIL format_message();
650 if (close(SENDMAIL)) {
651 printf "\nMessage sent.\n";
653 else {
654 warn "\nSendmail returned status '", $? >> 8, "'\n";
660 # Print version information (of the parrotbug program) and exit.
661 sub version {
662 print <<"EOT";
664 This is $0, version $VERSION.
667 exit;
671 # Check whether actions have been provided on comand-line, otherwise
672 # prompt for what to do with bug report.
673 sub what_next {
674 dump_report() if $opts{dump};
675 save_report() if $opts{save};
676 send_report() if $opts{send};
678 return if $opts{dump} || $opts{save} || $opts{send};
680 # No actions provided on command-line, prompt for action.
682 my $action;
683 do {
684 print "Action (send,display,edit,save,quit): ";
685 $action = <STDIN>;
686 sw: for ($action) {
687 dump_report(), last sw if /^d/i;
688 edit_report(), last sw if /^e/i;
689 save_report(), last sw if /^sa/i;
690 send_report(), last sw if /^se/i;
691 print "Uh?\n" unless /^q/i;
693 } until ( $action =~ /^q/i );
697 __END__
699 =head1 NAME
701 parrotbug - Parrot Bug Reporter
703 =head1 SYNOPSIS
705 % ./parrotbug [options] [actions]
707 =head1 DESCRIPTION
709 A program to help generate bug reports about parrot, and mail them.
710 It is designed to be used interactively. Normally no arguments will
711 be needed.
714 =head1 COMMAND-LINE SWITCHES
717 =head2 Options
719 Note: you will be prompted if the program miss some information.
721 =over 4
723 =item B<--nok>
725 Report unsuccessful build on this system to parrot developers.
727 =item B<--ok>
729 Report successful build on this system to parrot developers Only use
730 C<--ok> if B<everything> was ok; if there were B<any> problems at all,
731 use C<--nok>.
733 =item B<--subject>
735 Subject of the report. You will be prompted if you don't supply one on
736 the command-line.
738 =item B<--category>
740 Category of the bug report. You will be prompted if you don't supply
741 one on the command-line.
743 =item B<--severity>
745 Severity of the bug report. You will be prompted if you don't supply
746 one on the command-line.
748 =item B<--address>
750 Your email address. The program will try to guess one if you don't
751 provide one, but you'll still need to validate it.
753 =item B<--editor>
755 Editor to use for editing the bug report.
757 =item B<--ack>, B<--noack>
759 Don't send a bug received acknowledgement.
761 =item B<--input-file>
763 File containing the body of the report. Use this to quickly send a
764 prepared message.
766 =item B<--output-file>
768 File where parrotbug will save its bug report, if you ask it to do so.
770 =item B<--to>
772 Email address to send report to. (for testing purposes only)
774 =back
777 =head2 Actions
779 You can provide more than one action on the command-line. If none is
780 supplied, then you will be prompted for what to do.
782 =over 4
784 =item B<--dump>
786 Dump formatted report on standard output.
788 =item B<--save>
790 Save message to a file, in order for you to send it later from your
791 own. See C<--output> flag.
793 =item B<--send>
795 Try to send a mail with the report.
797 =item B<--help>
799 Print a short synopsis and exit.
801 =item B<--version>
803 Print version information and exit.
805 =back
808 =head1 AUTHORS
810 Jerome Quelin (E<lt>jquelin@cpan.orgE<gt>), with lots of good stuff taken from perlbug.
813 =head1 SEE ALSO
815 perlbug(1), parrot(1), diff(1), patch(1)
817 =cut
819 # Local Variables:
820 # mode: cperl
821 # cperl-indent-level: 4
822 # fill-column: 100
823 # End:
824 # vim: expandtab shiftwidth=4: