X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=Debbugs%2FCommon.pm;h=9760912a6445e1a2e0c848e7b0509cab790e0c0e;hb=b11165fffd765926da3c558caac71fc664276487;hp=a444a469d432a258556c8c9cf7436d406f94593a;hpb=20055761efef4215fc55c7708d5240bedeaacc44;p=debbugs.git diff --git a/Debbugs/Common.pm b/Debbugs/Common.pm index a444a46..9760912 100644 --- a/Debbugs/Common.pm +++ b/Debbugs/Common.pm @@ -40,10 +40,14 @@ BEGIN{ @EXPORT = (); %EXPORT_TAGS = (util => [qw(getbugcomponent getbuglocation getlocationpath get_hashname), qw(appendfile buglog getparsedaddrs getmaintainers), + qw(bug_status), qw(getmaintainers_reverse), qw(getpseudodesc), + qw(package_maintainer), + ], + misc => [qw(make_list globify_scalar english_join checkpid), + qw(cleanup_eval_fail), ], - misc => [qw(make_list globify_scalar english_join checkpid)], date => [qw(secs_to_english)], quit => [qw(quit)], lock => [qw(filelock unfilelock lockpid)], @@ -64,6 +68,8 @@ use Debbugs::MIME qw(decode_rfc1522); use Mail::Address; use Cwd qw(cwd); +use Params::Validate qw(validate_with :types); + use Fcntl qw(:flock); our $DEBUG_FH = \*STDERR if not defined $DEBUG_FH; @@ -162,6 +168,8 @@ sub get_hashname { Returns the path to the logfile corresponding to the bug. +Returns undef if the bug does not exist. + =cut sub buglog { @@ -169,9 +177,27 @@ sub buglog { my $location = getbuglocation($bugnum, 'log'); return getbugcomponent($bugnum, 'log', $location) if ($location); $location = getbuglocation($bugnum, 'log.gz'); - return getbugcomponent($bugnum, 'log.gz', $location); + return getbugcomponent($bugnum, 'log.gz', $location) if ($location); + return undef; } +=head2 bug_status + + bug_status($bugnum) + + +Returns the path to the summary file corresponding to the bug. + +Returns undef if the bug does not exist. + +=cut + +sub bug_status{ + my ($bugnum) = @_; + my $location = getbuglocation($bugnum, 'summary'); + return getbugcomponent($bugnum, 'summary', $location) if ($location); + return undef; +} =head2 appendfile @@ -223,29 +249,11 @@ Returns a hashref of package => maintainer pairs. =cut -our $_maintainer; -our $_maintainer_rev; +our $_maintainer = undef; +our $_maintainer_rev = undef; sub getmaintainers { - return $_maintainer if $_maintainer; - my %maintainer; - my %maintainer_rev; - for my $file (@config{qw(maintainer_file maintainer_file_override pseduo_maint_file)}) { - next unless defined $file; - my $maintfile = IO::File->new($file,'r') or - die "Unable to open maintainer file $file: $!"; - while(<$maintfile>) { - next unless m/^(\S+)\s+(\S.*\S)\s*$/; - ($a,$b)=($1,$2); - $a =~ y/A-Z/a-z/; - $maintainer{$a}= $b; - for my $maint (map {lc($_->address)} getparsedaddrs($b)) { - push @{$maintainer_rev{$maint}},$a; - } - } - close($maintfile); - } - $_maintainer = \%maintainer; - $_maintainer_rev = \%maintainer_rev; + return $_maintainer if defined $_maintainer; + package_maintainer(rehash => 1); return $_maintainer; } @@ -258,11 +266,164 @@ Returns a hashref of maintainer => [qw(list of packages)] pairs. =cut sub getmaintainers_reverse{ - return $_maintainer_rev if $_maintainer_rev; - getmaintainers(); + return $_maintainer_rev if defined $_maintainer_rev; + package_maintainer(rehash => 1); return $_maintainer_rev; } +=head2 package_maintainer + + my @s = package_maintainer(source => [qw(foo bar baz)], + binary => [qw(bleh blah)], + ); + +=over + +=item source -- scalar or arrayref of source package names to return +maintainers for, defaults to the empty arrayref. + +=item binary -- scalar or arrayref of binary package names to return +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 rehash -- whether to reread the maintainer and source maintainer +files; defaults to 0 + +=back + +=cut + +our $_source_maintainer = undef; +our $_source_maintainer_rev = undef; +sub package_maintainer { + my %param = validate_with(params => \@_, + spec => {source => {type => SCALAR|ARRAYREF, + default => [], + }, + binary => {type => SCALAR|ARRAYREF, + default => [], + }, + maintainer => {type => SCALAR|ARRAYREF, + default => [], + }, + rehash => {type => BOOLEAN, + default => 0, + }, + reverse => {type => BOOLEAN, + default => 0, + }, + }, + ); + my @binary = make_list($param{binary}); + my @source = make_list($param{source}); + my @maintainers = make_list($param{maintainer}); + if ((@binary or @source) and @maintainers) { + croak "It is nonsensical to pass both maintainers and source or binary"; + } + if ($param{rehash}) { + $_source_maintainer = undef; + $_source_maintainer_rev = undef; + $_maintainer = undef; + $_maintainer_rev = undef; + } + if (not defined $_source_maintainer or + 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; + } + __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, + $_maintainer_rev); + } + } + my @return; + for my $binary (@binary) { + if (not $param{reverse} and $binary =~ /^src:/) { + push @source,$binary; + next; + } + push @return,grep {defined $_} make_list($_maintainer->{$binary}); + } + for my $source (@source) { + $source =~ s/^src://; + push @return,grep {defined $_} make_list($_source_maintainer->{$source}); + } + for my $maintainer (grep {defined $_} @maintainers) { + push @return,grep {defined $_} + make_list($_maintainer_rev->{$maintainer}); + push @return,map {$_ !~ /^src:/?'src:'.$_:$_} + grep {defined $_} + make_list($_source_maintainer_rev->{$maintainer}); + } + return @return; +} + +#=head2 __add_to_hash +# +# __add_to_hash($file,$forward_hash,$reverse_hash,'address'); +# +# Reads a maintainer/source maintainer/pseudo desc file and adds the +# maintainers from it to the forward and reverse hashref; assumes that +# the forward is unique; makes no assumptions of the reverse. +# +#=cut + +sub __add_to_hash { + my ($fn,$forward,$reverse,$type) = @_; + if (ref($forward) ne 'HASH') { + croak "__add_to_hash must be passed a hashref for the forward"; + } + if (defined $reverse and not ref($reverse) eq 'HASH') { + croak "if reverse is passed to __add_to_hash, it must be a hashref"; + } + $type //= 'address'; + my $fh = IO::File->new($fn,'r') or + die "Unable to open $fn for reading: $!"; + while (<$fh>) { + chomp; + next unless m/^(\S+)\s+(\S.*\S)\s*$/; + my ($key,$value)=($1,$2); + $key = lc $key; + $forward->{$key}= $value; + if (defined $reverse) { + if ($type eq 'address') { + for my $m (map {lc($_->address)} (getparsedaddrs($value))) { + push @{$reverse->{$m}},$key; + } + } + else { + push @{$reverse->{$value}}, $key; + } + } + } +} + + =head2 getpseudodesc my $pseudopkgdesc = getpseudodesc(...); @@ -276,23 +437,12 @@ pseudopackage or not. =cut -our $_pseudodesc; +our $_pseudodesc = undef; sub getpseudodesc { - return $_pseudodesc if $_pseudodesc; - my %pseudodesc; - - if (not defined $config{pseudo_desc_file}) { - $_pseudodesc = {}; - return $_pseudodesc; - } - my $pseudo = IO::File->new($config{pseudo_desc_file},'r') - or die "Unable to open $config{pseudo_desc_file}: $!"; - while(<$pseudo>) { - next unless m/^(\S+)\s+(\S.*\S)\s*$/; - $pseudodesc{lc $1} = $2; - } - close($pseudo); - $_pseudodesc = \%pseudodesc; + return $_pseudodesc if defined $_pseudodesc; + $_pseudodesc = {}; + __add_to_hash($config{pseudo_desc_file},$_pseudodesc) if + defined $config{pseudo_desc_file}; return $_pseudodesc; } @@ -503,22 +653,56 @@ sub make_list { =head2 english_join - print english_join(', ',' and ',@list); + print english_join(list => \@list); + print english_join(\@list); Joins list properly to make an english phrase. +=over + +=item normal -- how to separate most values; defaults to ', ' + +=item last -- how to separate the last two values; defaults to ', and ' + +=item only_two -- how to separate only two values; defaults to ' and ' + +=item list -- ARRAYREF values to join; if the first argument is an +ARRAYREF, it's assumed to be the list of values to join +=back + +In cases where C is empty, returns ''; when there is only one +element, returns that element. =cut sub english_join { - my ($normal,$last,@list) = @_; - if (@list <= 1) { - return @list?$list[0]:''; - } - my $ret = $last . pop(@list); - $ret = join($normal,@list) . $ret; - return $ret; + if (ref $_[0] eq 'ARRAY') { + return english_join(list=>$_[0]); + } + my %param = validate_with(params => \@_, + spec => {normal => {type => SCALAR, + default => ', ', + }, + last => {type => SCALAR, + default => ', and ', + }, + only_two => {type => SCALAR, + default => ' and ', + }, + list => {type => ARRAYREF, + }, + }, + ); + my @list = @{$param{list}}; + if (@list <= 1) { + return @list?$list[0]:''; + } + elsif (@list == 2) { + return join($param{only_two},@list); + } + my $ret = $param{last} . pop(@list); + return join($param{normal},@list) . $ret; } @@ -558,6 +742,42 @@ sub globify_scalar { return IO::File->new('/dev/null','w'); } +=head2 cleanup_eval_fail() + + print "Something failed with: ".cleanup_eval_fail($@); + +Does various bits of cleanup on the failure message from an eval (or +any other die message) + +Takes at most two options; the first is the actual failure message +(usually $@ and defaults to $@), the second is the debug level +(defaults to $DEBUG). + +If debug is non-zero, the code at which the failure occured is output. + +=cut + +sub cleanup_eval_fail { + my ($error,$debug) = @_; + if (not defined $error or not @_) { + $error = $@ // 'unknown reason'; + } + if (@_ <= 1) { + $debug = $DEBUG // 0; + } + $debug = 0 if not defined $debug; + + if ($debug > 0) { + return $error; + } + # ditch the "at foo/bar/baz.pm line 5" + $error =~ s/\sat\s\S+\sline\s\d+//; + # ditch trailing multiple periods in case there was a cascade of + # die messages. + $error =~ s/\.+$/\./; + return $error; +} + 1;