X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=Debbugs%2FCommon.pm;h=2e5132d677eb9bc4ac82c46de37e3772498a4ff2;hb=refs%2Fheads%2Fdebian;hp=abc98dc6efe6f5d65191ae3f012004c4ff8891f1;hpb=593feb86562b711efd71e4d03239e188ddeea051;p=debbugs.git

diff --git a/Debbugs/Common.pm b/Debbugs/Common.pm
index abc98dc..2e5132d 100644
--- a/Debbugs/Common.pm
+++ b/Debbugs/Common.pm
@@ -31,7 +31,7 @@ with equivalent (or better) functionality here.
 use warnings;
 use strict;
 use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT);
-use base qw(Exporter);
+use Exporter qw(import);
 
 BEGIN{
      $VERSION = 1.00;
@@ -45,6 +45,7 @@ BEGIN{
 				qw(getpseudodesc),
 				qw(package_maintainer),
 				qw(sort_versions),
+				qw(open_compressed_file),
 			       ],
 		     misc   => [qw(make_list globify_scalar english_join checkpid),
 				qw(cleanup_eval_fail),
@@ -72,6 +73,8 @@ use Mail::Address;
 use Cwd qw(cwd);
 use Storable qw(dclone);
 use Time::HiRes qw(usleep);
+use MLDBM qw(DB_File Storable);
+$MLDBM::DumpMeth='portable';
 
 use Params::Validate qw(validate_with :types);
 
@@ -239,7 +242,40 @@ sub overwritefile {
 	    die "Unable to rename ${file}.new to $file: $!";
 }
 
+=head2 open_compressed_file
 
+     my $fh = open_compressed_file('foo.gz') or
+          die "Unable to open compressed file: $!";
+
+
+Opens a file; if the file ends in .gz, .xz, or .bz2, the appropriate
+decompression program is forked and output from it is read.
+
+This routine by default opens the file with UTF-8 encoding; if you want some
+other encoding, specify it with the second option.
+
+=cut
+sub open_compressed_file {
+    my ($file,$encoding) = @_;
+    $encoding //= ':encoding(UTF-8)';
+    my $fh;
+    my $mode = "<$encoding";
+    my @opts;
+    if ($file =~ /\.gz$/) {
+	$mode = "-|$encoding";
+	push @opts,'gzip','-dc';
+    }
+    if ($file =~ /\.xz$/) {
+	$mode = "-|$encoding";
+	push @opts,'xz','-dc';
+    }
+    if ($file =~ /\.bz2$/) {
+	$mode = "-|$encoding";
+	push @opts,'bzip2','-dc';
+    }
+    open($fh,$mode,@opts,$file);
+    return $fh;
+}
 
 
 
@@ -361,32 +397,58 @@ sub package_maintainer {
 	not defined $_source_maintainer_rev) {
 	$_source_maintainer = {};
 	$_source_maintainer_rev = {};
-	for my $fn (@config{('source_maintainer_file',
-			     'source_maintainer_file_override',
-			     'pseudo_maint_file')}) {
-	    next unless defined $fn;
-	    if (not -e $fn) {
-		warn "Missing source maintainer file '$fn'";
-		next;
+	if (-e $config{spool_dir}.'/source_maintainers.idx' and
+	    -e $config{spool_dir}.'/source_maintainers_reverse.idx'
+	   ) {
+	    tie %{$_source_maintainer},
+		MLDBM => $config{spool_dir}.'/source_maintainers.idx',
+		O_RDONLY or
+		die "Unable to tie source maintainers: $!";
+	    tie %{$_source_maintainer_rev},
+		MLDBM => $config{spool_dir}.'/source_maintainers_reverse.idx',
+		O_RDONLY or
+		die "Unable to tie source maintainers reverse: $!";
+	} else {
+	    for my $fn (@config{('source_maintainer_file',
+				 'source_maintainer_file_override',
+				 'pseudo_maint_file')}) {
+		next unless defined $fn and length $fn;
+		if (not -e $fn) {
+		    warn "Missing source maintainer file '$fn'";
+		    next;
+		}
+		__add_to_hash($fn,$_source_maintainer,
+			      $_source_maintainer_rev);
 	    }
-	    __add_to_hash($fn,$_source_maintainer,
-			  $_source_maintainer_rev);
 	}
     }
     if (not defined $_maintainer or
 	not defined $_maintainer_rev) {
 	$_maintainer = {};
 	$_maintainer_rev = {};
-	for my $fn (@config{('maintainer_file',
-			     'maintainer_file_override',
-			     'pseudo_maint_file')}) {
-	    next unless defined $fn;
-	    if (not -e $fn) {
-		warn "Missing maintainer file '$fn'";
-		next;
-	    }
-	    __add_to_hash($fn,$_maintainer,
+	if (-e $config{spool_dir}.'/maintainers.idx' and
+	    -e $config{spool_dir}.'/maintainers_reverse.idx'
+	   ) {
+	    tie %{$_maintainer},
+		MLDBM => $config{spool_dir}.'/binary_maintainers.idx',
+		O_RDONLY or
+		die "Unable to tie binary maintainers: $!";
+	    tie %{$_maintainer_rev},
+		MLDBM => $config{spool_dir}.'/binary_maintainers_reverse.idx',
+		O_RDONLY or
+		die "Unable to binary maintainers reverse: $!";
+	} else {
+	    for my $fn (@config{('maintainer_file',
+				 'maintainer_file_override',
+				 'pseudo_maint_file')}) {
+		next unless defined $fn and length $fn;
+		if (not -e $fn) {
+		    warn "Missing maintainer file '$fn'";
+		    next;
+		}
+		__add_to_hash($fn,$_maintainer,
 			      $_maintainer_rev);
+	    }
 	}
     }
     my @return;
@@ -431,7 +493,7 @@ sub __add_to_hash {
     }
     $type //= 'address';
     my $fh = IO::File->new($fn,'r') or
-	die "Unable to open $fn for reading: $!";
+	croak "Unable to open $fn for reading: $!";
     binmode($fh,':encoding(UTF-8)');
     while (<$fh>) {
 	chomp;
@@ -474,7 +536,8 @@ sub getpseudodesc {
     return $_pseudodesc if defined $_pseudodesc;
     $_pseudodesc = {};
     __add_to_hash($config{pseudo_desc_file},$_pseudodesc) if
-	defined $config{pseudo_desc_file};
+	defined $config{pseudo_desc_file} and
+	length $config{pseudo_desc_file};
     return $_pseudodesc;
 }
 
@@ -940,7 +1003,7 @@ sub cleanup_eval_fail {
     # ditch the "at foo/bar/baz.pm line 5"
     $error =~ s/\sat\s\S+\sline\s\d+//;
     # ditch croak messages
-    $error =~ s/^\t+.+\n?//g;
+    $error =~ s/^\t+.+\n?//mg;
     # ditch trailing multiple periods in case there was a cascade of
     # die messages.
     $error =~ s/\.+$/\./;