X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=Debbugs%2FCommon.pm;h=87b355924458444536aff9a27c2a1d3a52ee593e;hb=1117f33d9daf5069ad51693ebc5bd3df0250f269;hp=bb42bf8b207c171f240c48779a3c18b680124ddc;hpb=aad288b69b12b43446b8bf5ec53c617475bd1e91;p=debbugs.git diff --git a/Debbugs/Common.pm b/Debbugs/Common.pm index bb42bf8..87b3559 100644 --- a/Debbugs/Common.pm +++ b/Debbugs/Common.pm @@ -43,10 +43,10 @@ BEGIN{ qw(getmaintainers_reverse), qw(getpseudodesc), ], - misc => [qw(make_list)], + misc => [qw(make_list globify_scalar english_join checkpid)], 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)); @@ -54,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); @@ -158,6 +162,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 { @@ -165,7 +171,8 @@ 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; } @@ -178,14 +185,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 @@ -214,6 +218,14 @@ sub getparsedaddrs { 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 { @@ -222,8 +234,8 @@ sub getmaintainers { my %maintainer_rev; 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); @@ -239,6 +251,15 @@ 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(); @@ -319,7 +340,6 @@ FLOCKs the passed file. Use unfilelock to unlock it. =cut our @filelocks; -our @cleanups; sub filelock { # NB - NOT COMPATIBLE WITH `with-lock' @@ -346,11 +366,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(); + } } @@ -371,7 +397,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}) @@ -380,6 +405,7 @@ sub unfilelock { or warn "Unable to unlink lockfile $fl{file}: $!"; } + =head2 lockpid lockpid('/path/to/pidfile'); @@ -394,15 +420,9 @@ 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 $!"; } @@ -413,6 +433,35 @@ sub lockpid { 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 @@ -422,20 +471,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 @@ -457,6 +504,63 @@ sub make_list { } +=head2 english_join + + print english_join(', ',' and ',@list); + +Joins list properly to make an english phrase. + + + +=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; +} + + +=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;