X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=utils%2Fperlbug.PL;h=d9389ce7d14ee6d66e9ddf43ceba65dd86c5943f;hb=aaa68c4a88ea4a62f62819baf4cacc0ca679c5fa;hp=97f8d867da17a48df18bafefa8922ffb419c011e;hpb=cb50131aab68ac6dda048612c6e853b8cb08701e;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/utils/perlbug.PL b/utils/perlbug.PL
index 97f8d86..d9389ce 100644
--- a/utils/perlbug.PL
+++ b/utils/perlbug.PL
@@ -37,15 +37,15 @@ my @patches;
 while (<PATCH_LEVEL>) {
     last if /^\s*}/;
     chomp;
-    s/^\s+,?"?//;
-    s/"?,?$//;
+    s/^\s+,?\s*"?//;
+    s/"?\s*,?$//;
     s/(['\\])/\\$1/g;
     push @patches, $_ unless $_ eq 'NULL';
 }
 my $patch_desc = "'" . join("',\n    '", @patches) . "'";
 my $patch_tags = join "", map /(\S+)/ ? "+$1 " : (), @patches;
 
-close PATCH_LEVEL;
+close(PATCH_LEVEL) or die "Error closing patchlevel.h: $!";
 
 # TO DO (prehaps): store/embed $Config::config_sh into perlbug. When perlbug is
 # used, compare $Config::config_sh with the stored version. If they differ then
@@ -57,7 +57,7 @@ print "Extracting $file (with variable substitutions)\n";
 # In this section, perl variables will be expanded during extraction.
 # You can use $Config{...} to use Configure variables.
 
-my $extract_version = sprintf("v%v", $^V);
+my $extract_version = sprintf("v%vd", $^V);
 
 print OUT <<"!GROK!THIS!";
 $Config{startperl}
@@ -91,7 +91,7 @@ BEGIN {
     $::HaveUtil = ($@ eq "");
 };
 
-my $Version = "1.27";
+my $Version = "1.31";
 
 # Changed in 1.06 to skip Mail::Send and Mail::Util if not available.
 # Changed in 1.07 to see more sendmail execs, and added pipe output.
@@ -123,6 +123,10 @@ my $Version = "1.27";
 # Changed in 1.25 Warn on failure to open save file. HVDS 98-07-12
 # Changed in 1.26 Don't require -t STDIN for -ok. HVDS 98-07-15
 # Changed in 1.27 Added Mac OS and File::Spec support CNANDOR 99-07-27
+# Changed in 1.28 Additional questions for Perlbugtron RFOLEY 20.03.2000
+# Changed in 1.29 Perlbug(tron): auto(-ok), short prompts RFOLEY 05-05-2000
+# Changed in 1.30 Added warnings on failure to open files MSTEVENS 13-07-2000
+# Changed in 1.31 Add checks on close().Fix my $var unless. TJENNESS 26-07-2000
 
 # TODO: - Allow the user to re-name the file on mail failure, and
 #       make sure failure (transmission-wise) of Mail::Send is
@@ -130,10 +134,10 @@ my $Version = "1.27";
 #       - Test -b option
 
 my( $file, $usefile, $cc, $address, $perlbug, $testaddress, $filename,
-    $subject, $from, $verbose, $ed, $outfile, $Is_MacOS,
+    $subject, $from, $verbose, $ed, $outfile, $Is_MacOS, $category, $severity, 
     $fh, $me, $Is_MSWin32, $Is_VMS, $msg, $body, $andcc, %REP, $ok);
 
-my $perl_version = $^V ? sprintf("v%v", $^V) : $];
+my $perl_version = $^V ? sprintf("v%vd", $^V) : $];
 
 my $config_tag2 = "$perl_version - $Config{cf_time}";
 
@@ -157,6 +161,48 @@ Send();
 
 exit;
 
+sub ask_for_alternatives { # (category|severity)
+    my $name = shift;
+    my %alts = (
+	'category' => {
+	    'default' => 'core',
+	    'ok'      => 'install',
+	    'opts'    => [qw(core docs install library utilities)], # patch, notabug
+	},
+	'severity' => {
+	    'default' => 'low',
+	    'ok'      => 'none',
+	    'opts'    => [qw(critical high medium low wishlist none)], # zero
+	}, 	
+    );
+    die "Invalid alternative($name) requested\n" unless grep(/^$name$/, keys %alts); 
+    my $alt = "";
+    if ($ok) {
+	$alt = $alts{$name}{'ok'};
+    } else {
+ 	my @alts = @{$alts{$name}{'opts'}};
+	paraprint <<EOF;
+Please pick a \u$name from the following:
+
+    @alts
+
+EOF
+	my $err = 0;
+	do {
+	    if ($err++ > 5) {
+		die "Invalid $name: aborting.\n";
+	    }
+	    print "Please enter a \u$name [$alts{$name}{'default'}]: ";
+	    $alt = <>;
+	    chomp $alt;
+	    if ($alt =~ /^\s*$/) {
+		$alt = $alts{$name}{'default'};
+	    }
+	} while !((($alt) = grep(/^$alt/i, @alts)));
+    }
+    lc $alt;
+}
+
 sub Init {
     # -------- Setup --------
 
@@ -437,6 +483,12 @@ EOF
 	}
     }
 
+    # Prompt for category of bug
+    $category ||= ask_for_alternatives('category');
+
+    # Prompt for severity of bug
+    $severity ||= ask_for_alternatives('severity');
+
     # Generate scratch file to edit report in
     $filename = filename();
 
@@ -469,7 +521,7 @@ EOF
     }
 
     # Generate report
-    open(REP,">$filename");
+    open(REP,">$filename") or die "Unable to create report file `$filename': $!\n";
     my $reptype = !$ok ? "bug" : $::opt_n ? "build failure" : "success";
 
     print REP <<EOF;
@@ -486,7 +538,7 @@ EOF
 	while (<F>) {
 	    print REP $_
 	}
-	close(F);
+	close(F) or die "Error closing `$file': $!";
     } else {
 	print REP <<EOF;
 
@@ -500,24 +552,30 @@ EOF
 EOF
     }
     Dump(*REP);
-    close(REP);
+    close(REP) or die "Error closing report file: $!";
 
     # read in the report template once so that
     # we can track whether the user does any editing.
     # yes, *all* whitespace is ignored.
-    open(REP, "<$filename");
+    open(REP, "<$filename") or die "Unable to open report file `$filename': $!\n";
     while (<REP>) {
 	s/\s+//g;
 	$REP{$_}++;
     }
-    close(REP);
+    close(REP) or die "Error closing report file `$filename': $!";
 } # sub Query
 
 sub Dump {
     local(*OUT) = @_;
 
-    print REP "\n---\n";
-    print REP "This perlbug was built using Perl $config_tag1\n",
+    print OUT <<EFF;
+---
+Flags:
+    category=$category
+    severity=$severity
+---
+EFF
+    print OUT "This perlbug was built using Perl $config_tag1\n",
 	    "It is being executed now by  Perl $config_tag2.\n\n"
 	if $config_tag2 ne $config_tag1;
 
@@ -584,7 +642,8 @@ EOF
     }
 
 tryagain:
-    my $sts = system("$ed $filename") unless $Is_MacOS;
+    my $sts;
+    $sts = system("$ed $filename") unless $Is_MacOS;
     if ($Is_MacOS) {
         require ExtUtils::MakeMaker;
         ExtUtils::MM_MacOS::launch_file($filename);
@@ -618,7 +677,7 @@ EOF
     # Check that we have a report that has some, eh, report in it.
     my $unseen = 0;
 
-    open(REP, "<$filename");
+    open(REP, "<$filename") or die "Couldn't open `$filename': $!\n";
     # a strange way to check whether any significant editing
     # have been done: check whether any new non-empty lines
     # have been added. Yes, the below code ignores *any* space
@@ -673,22 +732,22 @@ EOF
 		    print "\nError opening $file: $!\n\n";
 		    goto retry;
 		}
-		open(REP, "<$filename");
+		open(REP, "<$filename") or die "Couldn't open file `$filename': $!\n";
 		print FILE "To: $address\nSubject: $subject\n";
 		print FILE "Cc: $cc\n" if $cc;
 		print FILE "Reply-To: $from\n" if $from;
 		print FILE "\n";
 		while (<REP>) { print FILE }
-		close(REP);
-		close(FILE);
+		close(REP) or die "Error closing report file `$filename': $!";
+		close(FILE) or die "Error closing $file: $!";
 
 		print "\nMessage saved in `$file'.\n";
 		exit;
 	    } elsif ($action =~ /^(d|l|sh)/i ) { # <D>isplay, <L>ist, <Sh>ow
 		# Display the message
-		open(REP, "<$filename");
+		open(REP, "<$filename") or die "Couldn't open file `$filename': $!\n";
 		while (<REP>) { print $_ }
-		close(REP);
+		close(REP) or die "Error closing report file `$filename': $!";
 	    } elsif ($action =~ /^se/i) { # <S>end
 		# Send the message
 		print "Are you certain you want to send this message?\n"
@@ -730,9 +789,9 @@ sub Send {
 	$msg->add("Reply-To",$from) if $from;
 
 	$fh = $msg->open;
-	open(REP, "<$filename");
+	open(REP, "<$filename") or die "Couldn't open `$filename': $!\n";
 	while (<REP>) { print $fh $_ }
-	close(REP);
+	close(REP) or die "Error closing $filename: $!";
 	$fh->close;
 
 	print "\nMessage sent.\n";
@@ -784,9 +843,9 @@ sendout:
 	print SENDMAIL "Cc: $cc\n" if $cc;
 	print SENDMAIL "Reply-To: $from\n" if $from;
 	print SENDMAIL "\n\n";
-	open(REP, "<$filename");
+	open(REP, "<$filename") or die "Couldn't open `$filename': $!\n";
 	while (<REP>) { print SENDMAIL $_ }
-	close(REP);
+	close(REP) or die "Error closing $filename: $!";
 
 	if (close(SENDMAIL)) {
 	    printf "\nMessage %s.\n", $outfile ? "saved" : "sent";
@@ -1130,8 +1189,9 @@ by Gurusamy Sarathy (E<lt>gsar@activestate.comE<gt>), Tom Christiansen
 Charles F. Randall (E<lt>cfr@pobox.comE<gt>), Mike Guy
 (E<lt>mjtg@cam.a.ukE<gt>), Dominic Dunlop (E<lt>domo@computer.orgE<gt>),
 Hugo van der Sanden (E<lt>hv@crypt0.demon.co.ukE<gt>),
-Jarkko Hietaniemi (E<lt>jhi@iki.fiE<gt>), hris Nandor
-(E<lt>pudge@pobox.comE<gt>), and Jon Orwant (E<lt>orwant@media.mit.eduE<gt>).
+Jarkko Hietaniemi (E<lt>jhi@iki.fiE<gt>), Chris Nandor
+(E<lt>pudge@pobox.comE<gt>), Jon Orwant (E<lt>orwant@media.mit.eduE<gt>,
+and Richard Foley (E<lt>richard@rfi.netE<gt>).
 
 =head1 SEE ALSO