X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=Debbugs%2FCommon.pm;h=9760912a6445e1a2e0c848e7b0509cab790e0c0e;hb=86591f1c9de1a37cfa9da585a6dfafc3962a258c;hp=4f36cb1c5f27e05d8891e433e833124ff0860065;hpb=00ee0147756121b6feeff5fa9d067d03e987e73e;p=debbugs.git diff --git a/Debbugs/Common.pm b/Debbugs/Common.pm index 4f36cb1..9760912 100644 --- a/Debbugs/Common.pm +++ b/Debbugs/Common.pm @@ -40,12 +40,17 @@ BEGIN{ @EXPORT = (); %EXPORT_TAGS = (util => [qw(getbugcomponent getbuglocation getlocationpath get_hashname), qw(appendfile buglog getparsedaddrs getmaintainers), - qw(getmaintainers_reverse) + 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)], date => [qw(secs_to_english)], quit => [qw(quit)], - lock => [qw(filelock unfilelock @cleanups lockpid)], + lock => [qw(filelock unfilelock lockpid)], ); @EXPORT_OK = (); Exporter::export_ok_tags(qw(lock quit date util misc)); @@ -53,12 +58,18 @@ BEGIN{ } #use Debbugs::Config qw(:globals); + +use Carp; + use Debbugs::Config qw(:config); use IO::File; +use IO::Scalar; 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; @@ -157,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 { @@ -164,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 @@ -177,14 +208,11 @@ Opens a file for appending and writes data to it. =cut sub appendfile { - my $file = shift; - if (!open(AP,">>$file")) { - print $DEBUG_FH "failed open log<\n" if $DEBUG; - print $DEBUG_FH "failed open log err $!<\n" if $DEBUG; - &quit("opening $file (appendfile): $!"); - } - print(AP @_) || &quit("writing $file (appendfile): $!"); - close(AP) || &quit("closing $file (appendfile): $!"); + my ($file,@data) = @_; + my $fh = IO::File->new($file,'a') or + die "Unable top open $file for appending: $!"; + print {$fh} @data or die "Unable to write to $file: $!"; + close $fh or die "Unable to close $file: $!"; } =head2 getparsedaddrs @@ -205,41 +233,220 @@ sub getparsedaddrs { return () unless defined $addr; return wantarray?@{$_parsedaddrs{$addr}}:$_parsedaddrs{$addr}[0] if exists $_parsedaddrs{$addr}; - @{$_parsedaddrs{$addr}} = Mail::Address->parse($addr); + { + # don't display the warnings from Mail::Address->parse + local $SIG{__WARN__} = sub { }; + @{$_parsedaddrs{$addr}} = Mail::Address->parse($addr); + } return wantarray?@{$_parsedaddrs{$addr}}:$_parsedaddrs{$addr}[0]; } -our $_maintainer; -our $_maintainer_rev; +=head2 getmaintainers + + my $maintainer = getmaintainers()->{debbugs} + +Returns a hashref of package => maintainer pairs. + +=cut + +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)}) { - next unless defined $file; - my $maintfile = new IO::File $file,'r' or - &quitcgi("Unable to open $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; } + +=head2 getmaintainers_reverse + + my @packages = @{getmaintainers_reverse->{'don@debian.org'}||[]}; + +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(...); + +Returns the entry for a pseudo package from the +$config{pseudo_desc_file}. In cases where pseudo_desc_file is not +defined, returns an empty arrayref. + +This function can be used to see if a particular package is a +pseudopackage or not. + +=cut + +our $_pseudodesc = undef; +sub getpseudodesc { + return $_pseudodesc if defined $_pseudodesc; + $_pseudodesc = {}; + __add_to_hash($config{pseudo_desc_file},$_pseudodesc) if + defined $config{pseudo_desc_file}; + return $_pseudodesc; +} + + =head1 DATE my $english = secs_to_english($seconds); @@ -280,7 +487,6 @@ FLOCKs the passed file. Use unfilelock to unlock it. =cut our @filelocks; -our @cleanups; sub filelock { # NB - NOT COMPATIBLE WITH `with-lock' @@ -307,11 +513,17 @@ sub filelock { } if (--$count <=0) { $errors =~ s/\n+$//; - &quit("failed to get lock on $lockfile -- $errors"); + die "failed to get lock on $lockfile -- $errors"; } sleep 10; } - push(@cleanups,\&unfilelock); +} + +# clean up all outstanding locks at end time +END { + while (@filelocks) { + unfilelock(); + } } @@ -332,7 +544,6 @@ sub unfilelock { return; } my %fl = %{pop(@filelocks)}; - pop(@cleanups); flock($fl{fh},LOCK_UN) or warn "Unable to unlock lockfile $fl{file}: $!"; close($fl{fh}) @@ -341,6 +552,7 @@ sub unfilelock { or warn "Unable to unlink lockfile $fl{file}: $!"; } + =head2 lockpid lockpid('/path/to/pidfile'); @@ -355,25 +567,48 @@ Returns 1 on success, false on failure; dies on unusual errors. sub lockpid { my ($pidfile) = @_; if (-e $pidfile) { - my $pidfh = IO::File->new($pidfile, 'r') or - die "Unable to open pidfile $pidfile: $!"; - local $/; - my $pid = <$pidfh>; - ($pid) = $pid =~ /(\d+)/; - if (defined $pid and kill(0,$pid)) { - return 0; - } - close $pidfh; + my $pid = checkpid($pidfile); + die "Unable to read pidfile $pidfile: $!" if not defined $pid; + return 0 if $pid != 0; unlink $pidfile or die "Unable to unlink stale pidfile $pidfile $!"; } - my $pidfh = IO::File->new($pidfile), 'w' or + my $pidfh = IO::File->new($pidfile,'w') or die "Unable to open $pidfile for writing: $!"; print {$pidfh} $$ or die "Unable to write to $pidfile $!"; close $pidfh or die "Unable to close $pidfile $!"; return 1; } +=head2 checkpid + + checkpid('/path/to/pidfile'); + +Checks a pid file and determines if the process listed in the pidfile +is still running. Returns the pid if it is, 0 if it isn't running, and +undef if the pidfile doesn't exist or cannot be read. + +=cut + +sub checkpid{ + my ($pidfile) = @_; + if (-e $pidfile) { + my $pidfh = IO::File->new($pidfile, 'r') or + return undef; + local $/; + my $pid = <$pidfh>; + close $pidfh; + ($pid) = $pid =~ /(\d+)/; + if (defined $pid and kill(0,$pid)) { + return $pid; + } + return 0; + } + else { + return undef; + } +} + =head1 QUIT @@ -383,20 +618,18 @@ These functions are exported with the :quit tag. quit() -Exits the program by calling die after running some cleanups. +Exits the program by calling die. -This should be replaced with an END handler which runs the cleanups -instead. (Or possibly a die handler, if the cleanups are important) +Usage of quit is deprecated; just call die instead. =cut sub quit { - print $DEBUG_FH "quitting >$_[0]<\n" if $DEBUG; - my ($u); - while ($u= $cleanups[$#cleanups]) { &$u; } - die "*** $_[0]\n"; + print {$DEBUG_FH} "quitting >$_[0]<\n" if $DEBUG; + carp "quit() is deprecated; call die directly instead"; } + =head1 MISC These functions are exported with the :misc tag @@ -418,6 +651,133 @@ sub make_list { } +=head2 english_join + + 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 { + 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; +} + + +=head2 globify_scalar + + my $handle = globify_scalar(\$foo); + +if $foo isn't already a glob or a globref, turn it into one using +IO::Scalar. Gives a new handle to /dev/null if $foo isn't defined. + +Will carp if given a scalar which isn't a scalarref or a glob (or +globref), and return /dev/null. May return undef if IO::Scalar or +IO::File fails. (Check $!) + +=cut + +sub globify_scalar { + my ($scalar) = @_; + my $handle; + if (defined $scalar) { + if (defined ref($scalar)) { + if (ref($scalar) eq 'SCALAR' and + not UNIVERSAL::isa($scalar,'GLOB')) { + return IO::Scalar->new($scalar); + } + else { + return $scalar; + } + } + elsif (UNIVERSAL::isa(\$scalar,'GLOB')) { + return $scalar; + } + else { + carp "Given a non-scalar reference, non-glob to globify_scalar; returning /dev/null handle"; + } + } + 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;