X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=Debbugs%2FCommon.pm;h=0875fabdeedf621dd44a24e358063d37b00ed2bc;hb=1635a052c1837d0c4ba20e85cdda070b683f808f;hp=f88a2f475091a174c8a0d3d8de0591b55e5ba5a2;hpb=ba16531a071635cea1d31d5c72c2ae8ce3716803;p=debbugs.git diff --git a/Debbugs/Common.pm b/Debbugs/Common.pm index f88a2f4..0875fab 100644 --- a/Debbugs/Common.pm +++ b/Debbugs/Common.pm @@ -40,12 +40,13 @@ BEGIN{ @EXPORT = (); %EXPORT_TAGS = (util => [qw(getbugcomponent getbuglocation getlocationpath get_hashname), qw(appendfile buglog getparsedaddrs getmaintainers), - qw(getmaintainers_reverse) + qw(getmaintainers_reverse), + qw(getpseudodesc), ], - misc => [qw(make_list)], + misc => [qw(make_list globify_scalar)], date => [qw(secs_to_english)], quit => [qw(quit)], - lock => [qw(filelock unfilelock @cleanups)], + lock => [qw(filelock unfilelock @cleanups lockpid)], ); @EXPORT_OK = (); Exporter::export_ok_tags(qw(lock quit date util misc)); @@ -53,8 +54,12 @@ 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); @@ -177,14 +182,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,20 +207,32 @@ 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]; } +=head2 getmaintainers + + my $maintainer = getmaintainers()->{debbugs} + +Returns a hashref of package => maintainer pairs. + +=cut + our $_maintainer; our $_maintainer_rev; sub getmaintainers { return $_maintainer if $_maintainer; my %maintainer; my %maintainer_rev; - for my $file (@config{qw(maintainer_file maintainer_file_override)}) { + for my $file (@config{qw(maintainer_file maintainer_file_override pseduo_maint_file)}) { next unless defined $file; - my $maintfile = new IO::File $file,'r' or - &quitcgi("Unable to open $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); @@ -234,12 +248,55 @@ sub getmaintainers { $_maintainer_rev = \%maintainer_rev; 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; } +=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; +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; +} + + =head1 DATE my $english = secs_to_english($seconds); @@ -280,7 +337,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 +363,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 +394,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}) @@ -342,6 +403,39 @@ sub unfilelock { } +=head2 lockpid + + lockpid('/path/to/pidfile'); + +Creates a pidfile '/path/to/pidfile' if one doesn't exist or if the +pid in the file does not respond to kill 0. + +Returns 1 on success, false on failure; dies on unusual errors. + +=cut + +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; + unlink $pidfile or + die "Unable to unlink stale pidfile $pidfile $!"; + } + 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; +} + =head1 QUIT @@ -351,20 +445,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 @@ -386,6 +478,42 @@ sub make_list { } +=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'); +} + 1;