X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=Debbugs%2FCommon.pm;h=b135c42cd6c263cc37e4fd997b41b7ec1be9c13d;hb=773c964cfcf6ac6ce095ba46b98455b6e4be5e7b;hp=9317d880ca6f683eae00bffafe0ce73d17bf71a9;hpb=6ba5d808b76cdb736795d99500c61d61d1da78ab;p=debbugs.git diff --git a/Debbugs/Common.pm b/Debbugs/Common.pm index 9317d88..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; @@ -39,28 +40,52 @@ BEGIN{ @EXPORT = (); %EXPORT_TAGS = (util => [qw(getbugcomponent getbuglocation getlocationpath get_hashname), - qw(appendfile buglog getparsedaddrs getmaintainers), + 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), + qw(hash_slice), ], - misc => [qw(make_list)], date => [qw(secs_to_english)], quit => [qw(quit)], - lock => [qw(filelock unfilelock @cleanups lockpid)], + lock => [qw(filelock unfilelock lockpid simple_filelock simple_unlockfile)], ); @EXPORT_OK = (); - Exporter::export_ok_tags(qw(lock quit date util misc)); + Exporter::export_ok_tags(keys %EXPORT_TAGS); $EXPORT_TAGS{all} = [@EXPORT_OK]; } #use Debbugs::Config qw(:globals); + +use Carp; +$Carp::Verbose = 1; + 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 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); -use Fcntl qw(:flock); +use Fcntl qw(:DEFAULT :flock); +use Encode qw(is_utf8 decode_utf8); our $DEBUG_FH = \*STDERR if not defined $DEBUG_FH; @@ -158,6 +183,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,9 +192,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 @@ -178,16 +223,179 @@ 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): $!"); + 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 overwritefile + + ovewritefile($file,'data','to','append'); + +Opens file.new, writes data to it, then moves file.new to file. + +=cut + +sub overwritefile { + my ($file,@data) = @_; + my $fh = IO::File->new("${file}.new",'w') or + die "Unable top open ${file}.new for writing: $!"; + print {$fh} @data or die "Unable to write to ${file}.new: $!"; + close $fh or die "Unable to close ${file}.new: $!"; + rename("${file}.new",$file) or + 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; } - print(AP @_) || &quit("writing $file (appendfile): $!"); - close(AP) || &quit("closing $file (appendfile): $!"); + + 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 my $address = getparsedaddrs($address); @@ -206,41 +414,305 @@ 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 pseduo_maint_file)}) { - 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 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)], + 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 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 + +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, + }, + schema => {type => OBJECT, + optional => 1, + } + }, + ); + 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 (@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; + $_maintainer = undef; + $_maintainer_rev = undef; + } + if (not defined $_source_maintainer or + not defined $_source_maintainer_rev) { + $_source_maintainer = {}; + $_source_maintainer_rev = {}; + 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); + } + } + } + if (not defined $_maintainer or + not defined $_maintainer_rev) { + $_maintainer = {}; + $_maintainer_rev = {}; + 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 ($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 + 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); + $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(...); @@ -254,26 +726,43 @@ 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} and + length $config{pseudo_desc_file}; return $_pseudodesc; } +=head2 sort_versions + + sort_versions('1.0-2','1.1-2'); + +Sorts versions using AptPkg::Versions::compare if it is available, or +Debbugs::Versions::Dpkg::vercmp if it isn't. + +=cut + +our $vercmp; +BEGIN{ + use Debbugs::Versions::Dpkg; + $vercmp=\&Debbugs::Versions::Dpkg::vercmp; + +# eventually we'll use AptPkg:::Version or similar, but the current +# implementation makes this *super* difficult. + +# eval { +# use AptPkg::Version; +# $vercmp=\&AptPkg::Version::compare; +# }; +} + +sub sort_versions{ + return sort {$vercmp->($a,$b)} @_; +} + =head1 DATE @@ -308,51 +797,146 @@ These functions are exported with the :lock tag =head2 filelock - filelock + filelock($lockfile); + filelock($lockfile,$locks); FLOCKs the passed file. Use unfilelock to unlock it. +Can be passed an optional $locks hashref, which is used to track which +files are locked (and how many times they have been locked) to allow +for cooperative locking. + =cut our @filelocks; -our @cleanups; + +use Carp qw(cluck); sub filelock { # NB - NOT COMPATIBLE WITH `with-lock' - my ($lockfile) = @_; + my ($lockfile,$locks) = @_; if ($lockfile !~ m{^/}) { $lockfile = cwd().'/'.$lockfile; } - my ($count,$errors); - $count= 10; $errors= ''; - for (;;) { - my $fh = eval { + # This is only here to allow for relocking bugs inside of + # Debbugs::Control. Nothing else should be using it. + if (defined $locks and exists $locks->{locks}{$lockfile} and + $locks->{locks}{$lockfile} >= 1) { + if (exists $locks->{relockable} and + exists $locks->{relockable}{$lockfile}) { + $locks->{locks}{$lockfile}++; + # indicate that the bug for this lockfile needs to be reread + $locks->{relockable}{$lockfile} = 1; + push @{$locks->{lockorder}},$lockfile; + return; + } + else { + use Data::Dumper; + confess "Locking already locked file: $lockfile\n".Data::Dumper->Dump([$lockfile,$locks],[qw(lockfile locks)]); + } + } + my ($fh,$t_lockfile,$errors) = + simple_filelock($lockfile,10,1); + if ($fh) { + push @filelocks, {fh => $fh, file => $lockfile}; + if (defined $locks) { + $locks->{locks}{$lockfile}++; + push @{$locks->{lockorder}},$lockfile; + } + } else { + use Data::Dumper; + croak "failed to get lock on $lockfile -- $errors". + (defined $locks?Data::Dumper->Dump([$locks],[qw(locks)]):''); + } +} + +=head2 simple_filelock + + my ($fh,$t_lockfile,$errors) = + simple_filelock($lockfile,$count,$wait); + +Does a flock of lockfile. If C<$count> is zero, does a blocking lock. +Otherwise, does a non-blocking lock C<$count> times, waiting C<$wait> +seconds in between. + +In list context, returns the lockfile filehandle, lockfile name, and +any errors which occured. + +When the lockfile filehandle is undef, locking failed. + +These lockfiles must be unlocked manually at process end. + + +=cut + +sub simple_filelock { + my ($lockfile,$count,$wait) = @_; + if (not defined $count) { + $count = 10; + } + if ($count < 0) { + $count = 0; + } + if (not defined $wait) { + $wait = 1; + } + my $errors= ''; + my $fh; + while (1) { + $fh = eval { my $fh2 = IO::File->new($lockfile,'w') or die "Unable to open $lockfile for writing: $!"; - flock($fh2,LOCK_EX|LOCK_NB) + # Do a blocking lock if count is zero + flock($fh2,LOCK_EX|($count == 0?0:LOCK_NB)) or die "Unable to lock $lockfile $!"; return $fh2; }; if ($@) { $errors .= $@; } - if ($fh) { - push @filelocks, {fh => $fh, file => $lockfile}; - last; - } - if (--$count <=0) { - $errors =~ s/\n+$//; - &quit("failed to get lock on $lockfile -- $errors"); + if ($fh) { + last; } - sleep 10; + # use usleep for fractional wait seconds + usleep($wait * 1_000_000); + } continue { + last unless (--$count > 0); + } + if ($fh) { + return wantarray?($fh,$lockfile,$errors):$fh } - push(@cleanups,\&unfilelock); + return wantarray?(undef,$lockfile,$errors):undef; +} + +# clean up all outstanding locks at end time +END { + while (@filelocks) { + unfilelock(); + } +} + +=head2 simple_unlockfile + + simple_unlockfile($fh,$lockfile); + + +=cut + +sub simple_unlockfile { + my ($fh,$lockfile) = @_; + flock($fh,LOCK_UN) + or warn "Unable to unlock lockfile $lockfile: $!"; + close($fh) + or warn "Unable to close lockfile $lockfile: $!"; + unlink($lockfile) + or warn "Unable to unlink lockfile $lockfile: $!"; } =head2 unfilelock unfilelock() + unfilelock($locks); Unlocks the file most recently locked. @@ -362,20 +946,29 @@ locked with filelock. =cut sub unfilelock { + my ($locks) = @_; if (@filelocks == 0) { - warn "unfilelock called with no active filelocks!\n"; + carp "unfilelock called with no active filelocks!\n"; return; } + if (defined $locks and ref($locks) ne 'HASH') { + croak "hash not passsed to unfilelock"; + } + if (defined $locks and exists $locks->{lockorder} and + @{$locks->{lockorder}} and + exists $locks->{locks}{$locks->{lockorder}[-1]}) { + my $lockfile = pop @{$locks->{lockorder}}; + $locks->{locks}{$lockfile}--; + if ($locks->{locks}{$lockfile} > 0) { + return + } + delete $locks->{locks}{$lockfile}; + } my %fl = %{pop(@filelocks)}; - pop(@cleanups); - flock($fl{fh},LOCK_UN) - or warn "Unable to unlock lockfile $fl{file}: $!"; - close($fl{fh}) - or warn "Unable to close lockfile $fl{file}: $!"; - unlink($fl{file}) - or warn "Unable to unlink lockfile $fl{file}: $!"; + simple_unlockfile($fl{fh},$fl{file}); } + =head2 lockpid lockpid('/path/to/pidfile'); @@ -390,25 +983,49 @@ 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 + 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 $!"; 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 @@ -418,20 +1035,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 @@ -453,6 +1068,170 @@ 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 $!) + +The scalar will fill with octets, not perl's internal encoding, so you +must use decode_utf8() after on the scalar, and encode_utf8() on it +before. This appears to be a bug in the underlying modules. + +=cut + +our $_NULL_HANDLE; + +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')) { + if (is_utf8(${$scalar})) { + ${$scalar} = decode_utf8(${$scalar}); + carp(q(\$scalar must not be in perl's internal encoding)); + } + open $handle, '>:scalar:utf8', $scalar; + return $handle; + } + 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"; + } + } + 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 $_NULL_HANDLE; +} + +=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 croak messages + $error =~ s/^\t+.+\n?//mg; + # ditch trailing multiple periods in case there was a cascade of + # die messages. + $error =~ s/\.+$/\./; + return $error; +} + +=head2 hash_slice + + hash_slice(%hash,qw(key1 key2 key3)) + +For each key, returns matching values and keys of the hash if they exist + +=cut + + +# NB: We use prototypes here SPECIFICALLY so that we can be passed a +# hash without uselessly making a reference to first. DO NOT USE +# PROTOTYPES USELESSLY ELSEWHERE. +sub hash_slice(\%@) { + my ($hashref,@keys) = @_; + return map {exists $hashref->{$_}?($_,$hashref->{$_}):()} @keys; +} + 1;