X-Git-Url: https://git.donarmstrong.com/?p=debbugs.git;a=blobdiff_plain;f=Debbugs%2FCommon.pm;h=b135c42cd6c263cc37e4fd997b41b7ec1be9c13d;hp=732ac2e5bf2f6c02fcaa4b718cb2a7780e3bfc2b;hb=773c964cfcf6ac6ce095ba46b98455b6e4be5e7b;hpb=d4b9a1bfe03c6ec1451c8f9178bb5a7458e9ae3e diff --git a/Debbugs/Common.pm b/Debbugs/Common.pm index 732ac2e..b135c42 100644 --- a/Debbugs/Common.pm +++ b/Debbugs/Common.pm @@ -31,7 +31,8 @@ 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); +use v5.10; BEGIN{ $VERSION = 1.00; @@ -40,11 +41,14 @@ BEGIN{ @EXPORT = (); %EXPORT_TAGS = (util => [qw(getbugcomponent getbuglocation getlocationpath get_hashname), qw(appendfile overwritefile buglog getparsedaddrs getmaintainers), + qw(getsourcemaintainers getsourcemaintainers_reverse), qw(bug_status), qw(getmaintainers_reverse), qw(getpseudodesc), qw(package_maintainer), qw(sort_versions), + qw(open_compressed_file), + qw(walk_bugs), ], misc => [qw(make_list globify_scalar english_join checkpid), qw(cleanup_eval_fail), @@ -72,6 +76,11 @@ use Mail::Address; use Cwd qw(cwd); use Storable qw(dclone); use Time::HiRes qw(usleep); +use File::Path qw(mkpath); +use File::Basename qw(dirname); +use MLDBM qw(DB_File Storable); +$MLDBM::DumpMeth='portable'; +use List::AllUtils qw(natatime); use Params::Validate qw(validate_with :types); @@ -239,9 +248,153 @@ 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; +} + +=head2 walk_bugs + +Walk through directories of bugs, calling a subroutine with a list of bugs +found. + +C sub {print map {qq($_\n)} @_},dirs => [qw(db-h)];> + +=over + +=item callback -- CODEREF of a subroutine to call with a list of bugs + +=item dirs -- ARRAYREF of directories to get bugs from. Like C<[qw(db-h archive)]>. + +=item bugs -- ARRAYREF of bugs to walk through. If both C and C are +provided, both are walked through. + +=item bugs_per_call -- maximum number of bugs to provide to callback + +=item progress_bar -- optional L + +=item bug_file -- bug file to look for (generally C) + +=item logging -- optional filehandle to output logging information + +=back + +=cut + +sub walk_bugs { + state $spec = + {dirs => {type => ARRAYREF, + default => [], + }, + bugs => {type => ARRAYREF, + default => [], + }, + progress_bar => {type => OBJECT|UNDEF, + optional => 1, + }, + bug_file => {type => SCALAR, + default => 'summary', + }, + logging => {type => HANDLE, + optional => 1, + }, + callback => {type => CODEREF, + }, + bugs_per_call => {type => SCALAR, + default => 1, + }, + }; + my %param = validate_with(params => \@_, + spec => $spec + ); + my @dirs = @{$param{dirs}}; + my @initial_bugs = (); + if (@{$param{bugs}}) { + unshift @dirs,''; + @initial_bugs = @{$param{bugs}}; + } + my $tot_dirs = @dirs; + my $done_dirs = 0; + my $avg_subfiles = 0; + my $completed_files = 0; + my $dir; + while ($dir = shift @dirs or defined $dir) { + my @list; + my @subdirs; + if (not length $dir and @initial_bugs) { + push @list,@initial_bugs; + @initial_bugs = (); + } else { + printf {$param{verbose}} "Doing dir %s ...\n", $dir + if defined $param{verbose}; + opendir(my $DIR, "$dir/.") or + die "opendir $dir: $!"; + @subdirs = readdir($DIR) or + die "Unable to readdir $dir: $!"; + closedir($DIR) or + die "Unable to closedir $dir: $!"; + + @list = map { m/^(\d+)\.$param{bug_file}$/?($1):() } @subdirs; + } + $tot_dirs -= @dirs; + push @dirs, map { m/^(\d+)$/ && -d "$dir/$1"?("$dir/$1"):() } @subdirs; + $tot_dirs += @dirs; + if ($param{progress_bar}) { + if ($avg_subfiles == 0) { + $avg_subfiles = @list; + } + $param{progress_bar}-> + target($avg_subfiles*($tot_dirs-$done_dirs)+$completed_files+@list); + $avg_subfiles = ($avg_subfiles * $done_dirs + @list) / ($done_dirs+1); + $done_dirs += 1; + } + + my $it = natatime $param{bugs_per_call},@list; + while (my @bugs = $it->()) { + $param{callback}->(@bugs); + $completed_files += scalar @bugs; + if ($param{progress_bar}) { + $param{progress_bar}->update($completed_files) if $param{progress_bar}; + } + if ($completed_files % 100 == 0 and + defined $param{verbose}) { + print {$param{verbose}} "Up to $completed_files bugs...\n" + } + } + } + $param{progress_bar}->remove() if $param{progress_bar}; +} + =head2 getparsedaddrs @@ -299,6 +452,36 @@ sub getmaintainers_reverse{ return $_maintainer_rev; } +=head2 getsourcemaintainers + + my $maintainer = getsourcemaintainers()->{debbugs} + +Returns a hashref of src_package => maintainer pairs. + +=cut + +our $_source_maintainer = undef; +our $_source_maintainer_rev = undef; +sub getsourcemaintainers { + return $_source_maintainer if defined $_source_maintainer; + package_maintainer(rehash => 1); + return $_source_maintainer; +} + +=head2 getsourcemaintainers_reverse + + my @src_packages = @{getsourcemaintainers_reverse->{'don@debian.org'}||[]}; + +Returns a hashref of maintainer => [qw(list of source packages)] pairs. + +=cut + +sub getsourcemaintainers_reverse{ + return $_source_maintainer_rev if defined $_source_maintainer_rev; + package_maintainer(rehash => 1); + return $_source_maintainer_rev; +} + =head2 package_maintainer my @s = package_maintainer(source => [qw(foo bar baz)], @@ -314,18 +497,19 @@ maintainers for, defaults to the empty arrayref. maintainers for; automatically returns source package maintainer if the package name starts with 'src:', defaults to the empty arrayref. -=item reverse -- whether to return the source/binary packages a -maintainer maintains instead +=item maintainer -- scalar or arrayref of maintainers to return source packages +for. If given, binary and source cannot be given. =item rehash -- whether to reread the maintainer and source maintainer files; defaults to 0 +=item schema -- Debbugs::DB schema. If set, uses the database for maintainer +information. + =back =cut -our $_source_maintainer = undef; -our $_source_maintainer_rev = undef; sub package_maintainer { my %param = validate_with(params => \@_, spec => {source => {type => SCALAR|ARRAYREF, @@ -343,6 +527,9 @@ sub package_maintainer { reverse => {type => BOOLEAN, default => 0, }, + schema => {type => OBJECT, + optional => 1, + } }, ); my @binary = make_list($param{binary}); @@ -351,6 +538,53 @@ sub package_maintainer { if ((@binary or @source) and @maintainers) { croak "It is nonsensical to pass both maintainers and source or binary"; } + if (@binary) { + @source = grep {/^src:/} @binary; + @binary = grep {!/^src:/} @binary; + } + # remove leading src: from source package names + s/^src:// foreach @source; + if ($param{schema}) { + my $s = $param{schema}; + if (@maintainers) { + my $m_rs = $s->resultset('SrcPkg')-> + search({'correspondent.addr' => [@maintainers]}, + {join => {src_vers => + {maintainer => + 'correspondent'}, + }, + columns => ['pkg'], + group_by => [qw(me.pkg)], + }); + return $m_rs->get_column('pkg')->all(); + } elsif (@binary or @source) { + my $rs = $s->resultset('Maintainer'); + if (@binary) { + $rs = + $rs->search({'bin_pkg.pkg' => [@binary]}, + {join => {src_vers => + {bin_vers => 'bin_pkg'}, + }, + columns => ['name'], + group_by => [qw(me.name)], + } + ); + } + if (@source) { + $rs = + $rs->search({'src_pkg.pkg' => [@source]}, + {join => {src_vers => + 'src_pkg', + }, + columns => ['name'], + group_by => [qw(me.name)], + } + ); + } + return $rs->get_column('name')->all(); + } + return (); + } if ($param{rehash}) { $_source_maintainer = undef; $_source_maintainer_rev = undef; @@ -361,37 +595,63 @@ 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; for my $binary (@binary) { - if (not $param{reverse} and $binary =~ /^src:/) { + if ($binary =~ /^src:/) { push @source,$binary; next; } @@ -431,12 +691,12 @@ 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; - next unless m/^(\S+)\s+(\S.*\S)\s*$/; - my ($key,$value)=($1,$2); + next unless m/^(\S+)\s+(\S.*\S)\s*$/; + my ($key,$value)=($1,$2); $key = lc $key; $forward->{$key}= $value; if (defined $reverse) { @@ -471,7 +731,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; } @@ -728,6 +989,7 @@ sub lockpid { unlink $pidfile or die "Unable to unlink stale pidfile $pidfile $!"; } + mkpath(dirname($pidfile)); my $pidfh = IO::File->new($pidfile,O_CREAT|O_EXCL|O_WRONLY) or die "Unable to open $pidfile for writing: $!"; print {$pidfh} $$ or die "Unable to write to $pidfile $!"; @@ -878,6 +1140,8 @@ before. This appears to be a bug in the underlying modules. =cut +our $_NULL_HANDLE; + sub globify_scalar { my ($scalar) = @_; my $handle; @@ -902,8 +1166,15 @@ sub globify_scalar { else { carp "Given a non-scalar reference, non-glob to globify_scalar; returning /dev/null handle"; } + } + if (not defined $_NULL_HANDLE or + not $_NULL_HANDLE->opened() + ) { + $_NULL_HANDLE = + IO::File->new('/dev/null','>:encoding(UTF-8)') or + die "Unable to open /dev/null for writing: $!"; } - return IO::File->new('/dev/null','>:encoding(UTF-8)'); + return $_NULL_HANDLE; } =head2 cleanup_eval_fail() @@ -937,7 +1208,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/\.+$/\./;