Debbugs/Common.pm

   1 # This module is part of debbugs, and is released
   2 # under the terms of the GPL version 2, or any later
   3 # version at your option.
   4 # See the file README and COPYING for more information.
   5 #
   6 # [Other people have contributed to this file; their copyrights should
   7 # go here too.]
   8 # Copyright 2007 by Don Armstrong <don@donarmstrong.com>.
   9
  10 package Debbugs::Common;
  11
  12 =head1 NAME
  13
  14 Debbugs::Common -- Common routines for all of Debbugs
  15
  16 =head1 SYNOPSIS
  17
  18 use Debbugs::Common qw(:url :html);
  19
  20
  21 =head1 DESCRIPTION
  22
  23 This module is a replacement for the general parts of errorlib.pl.
  24 subroutines in errorlib.pl will be gradually phased out and replaced
  25 with equivalent (or better) functionality here.
  26
  27 =head1 FUNCTIONS
  28
  29 =cut
  30
  31 use warnings;
  32 use strict;
  33 use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT);
  34 use Exporter qw(import);
  35
  36 BEGIN{
  37      $VERSION = 1.00;
  38      $DEBUG = 0 unless defined $DEBUG;
  39
  40      @EXPORT = ();
  41      %EXPORT_TAGS = (util   => [qw(getbugcomponent getbuglocation getlocationpath get_hashname),
  42                                 qw(appendfile overwritefile buglog getparsedaddrs getmaintainers),
  43                                 qw(bug_status),
  44                                 qw(getmaintainers_reverse),
  45                                 qw(getpseudodesc),
  46                                 qw(package_maintainer),
  47                                 qw(sort_versions),
  48                                 qw(open_compressed_file),
  49                                ],
  50                      misc   => [qw(make_list globify_scalar english_join checkpid),
  51                                 qw(cleanup_eval_fail),
  52                                 qw(hash_slice),
  53                                ],
  54                      date   => [qw(secs_to_english)],
  55                      quit   => [qw(quit)],
  56                      lock   => [qw(filelock unfilelock lockpid simple_filelock simple_unlockfile)],
  57                     );
  58      @EXPORT_OK = ();
  59      Exporter::export_ok_tags(keys %EXPORT_TAGS);
  60      $EXPORT_TAGS{all} = [@EXPORT_OK];
  61 }
  62
  63 #use Debbugs::Config qw(:globals);
  64
  65 use Carp;
  66 $Carp::Verbose = 1;
  67
  68 use Debbugs::Config qw(:config);
  69 use IO::File;
  70 use IO::Scalar;
  71 use Debbugs::MIME qw(decode_rfc1522);
  72 use Mail::Address;
  73 use Cwd qw(cwd);
  74 use Storable qw(dclone);
  75 use Time::HiRes qw(usleep);
  76 use MLDBM qw(DB_File Storable);
  77 $MLDBM::DumpMeth='portable';
  78
  79 use Params::Validate qw(validate_with :types);
  80
  81 use Fcntl qw(:DEFAULT :flock);
  82 use Encode qw(is_utf8 decode_utf8);
  83
  84 our $DEBUG_FH = \*STDERR if not defined $DEBUG_FH;
  85
  86 =head1 UTILITIES
  87
  88 The following functions are exported by the C<:util> tag
  89
  90 =head2 getbugcomponent
  91
  92      my $file = getbugcomponent($bug_number,$extension,$location)
  93
  94 Returns the path to the bug file in location C<$location>, bug number
  95 C<$bugnumber> and extension C<$extension>
  96
  97 =cut
  98
  99 sub getbugcomponent {
 100     my ($bugnum, $ext, $location) = @_;
 101
 102     if (not defined $location) {
 103         $location = getbuglocation($bugnum, $ext);
 104         # Default to non-archived bugs only for now; CGI scripts want
 105         # archived bugs but most of the backend scripts don't. For now,
 106         # anything that is prepared to accept archived bugs should call
 107         # getbuglocation() directly first.
 108         return undef if defined $location and
 109                         ($location ne 'db' and $location ne 'db-h');
 110     }
 111     my $dir = getlocationpath($location);
 112     return undef if not defined $dir;
 113     if (defined $location and $location eq 'db') {
 114         return "$dir/$bugnum.$ext";
 115     } else {
 116         my $hash = get_hashname($bugnum);
 117         return "$dir/$hash/$bugnum.$ext";
 118     }
 119 }
 120
 121 =head2 getbuglocation
 122
 123      getbuglocation($bug_number,$extension)
 124
 125 Returns the the location in which a particular bug exists; valid
 126 locations returned currently are archive, db-h, or db. If the bug does
 127 not exist, returns undef.
 128
 129 =cut
 130
 131 sub getbuglocation {
 132     my ($bugnum, $ext) = @_;
 133     my $archdir = get_hashname($bugnum);
 134     return 'archive' if -r getlocationpath('archive')."/$archdir/$bugnum.$ext";
 135     return 'db-h' if -r getlocationpath('db-h')."/$archdir/$bugnum.$ext";
 136     return 'db' if -r getlocationpath('db')."/$bugnum.$ext";
 137     return undef;
 138 }
 139
 140
 141 =head2 getlocationpath
 142
 143      getlocationpath($location)
 144
 145 Returns the path to a specific location
 146
 147 =cut
 148
 149 sub getlocationpath {
 150      my ($location) = @_;
 151      if (defined $location and $location eq 'archive') {
 152           return "$config{spool_dir}/archive";
 153      } elsif (defined $location and $location eq 'db') {
 154           return "$config{spool_dir}/db";
 155      } else {
 156           return "$config{spool_dir}/db-h";
 157      }
 158 }
 159
 160
 161 =head2 get_hashname
 162
 163      get_hashname
 164
 165 Returns the hash of the bug which is the location within the archive
 166
 167 =cut
 168
 169 sub get_hashname {
 170     return "" if ( $_[ 0 ] < 0 );
 171     return sprintf "%02d", $_[ 0 ] % 100;
 172 }
 173
 174 =head2 buglog
 175
 176      buglog($bugnum);
 177
 178 Returns the path to the logfile corresponding to the bug.
 179
 180 Returns undef if the bug does not exist.
 181
 182 =cut
 183
 184 sub buglog {
 185     my $bugnum = shift;
 186     my $location = getbuglocation($bugnum, 'log');
 187     return getbugcomponent($bugnum, 'log', $location) if ($location);
 188     $location = getbuglocation($bugnum, 'log.gz');
 189     return getbugcomponent($bugnum, 'log.gz', $location) if ($location);
 190     return undef;
 191 }
 192
 193 =head2 bug_status
 194
 195      bug_status($bugnum)
 196
 197
 198 Returns the path to the summary file corresponding to the bug.
 199
 200 Returns undef if the bug does not exist.
 201
 202 =cut
 203
 204 sub bug_status{
 205     my ($bugnum) = @_;
 206     my $location = getbuglocation($bugnum, 'summary');
 207     return getbugcomponent($bugnum, 'summary', $location) if ($location);
 208     return undef;
 209 }
 210
 211 =head2 appendfile
 212
 213      appendfile($file,'data','to','append');
 214
 215 Opens a file for appending and writes data to it.
 216
 217 =cut
 218
 219 sub appendfile {
 220         my ($file,@data) = @_;
 221         my $fh = IO::File->new($file,'a') or
 222              die "Unable top open $file for appending: $!";
 223         print {$fh} @data or die "Unable to write to $file: $!";
 224         close $fh or die "Unable to close $file: $!";
 225 }
 226
 227 =head2 overwritefile
 228
 229      ovewritefile($file,'data','to','append');
 230
 231 Opens file.new, writes data to it, then moves file.new to file.
 232
 233 =cut
 234
 235 sub overwritefile {
 236         my ($file,@data) = @_;
 237         my $fh = IO::File->new("${file}.new",'w') or
 238              die "Unable top open ${file}.new for writing: $!";
 239         print {$fh} @data or die "Unable to write to ${file}.new: $!";
 240         close $fh or die "Unable to close ${file}.new: $!";
 241         rename("${file}.new",$file) or
 242             die "Unable to rename ${file}.new to $file: $!";
 243 }
 244
 245 =head2 open_compressed_file
 246
 247      my $fh = open_compressed_file('foo.gz') or
 248           die "Unable to open compressed file: $!";
 249
 250
 251 Opens a file; if the file ends in .gz, .xz, or .bz2, the appropriate
 252 decompression program is forked and output from it is read.
 253
 254 This routine by default opens the file with UTF-8 encoding; if you want some
 255 other encoding, specify it with the second option.
 256
 257 =cut
 258 sub open_compressed_file {
 259     my ($file,$encoding) = @_;
 260     $encoding //= ':encoding(UTF-8)';
 261     my $fh;
 262     my $mode = "<$encoding";
 263     my @opts;
 264     if ($file =~ /\.gz$/) {
 265         $mode = "-|$encoding";
 266         push @opts,'gzip','-dc';
 267     }
 268     if ($file =~ /\.xz$/) {
 269         $mode = "-|$encoding";
 270         push @opts,'xz','-dc';
 271     }
 272     if ($file =~ /\.bz2$/) {
 273         $mode = "-|$encoding";
 274         push @opts,'bzip2','-dc';
 275     }
 276     open($fh,$mode,@opts,$file);
 277     return $fh;
 278 }
 279
 280
 281
 282 =head2 getparsedaddrs
 283
 284      my $address = getparsedaddrs($address);
 285      my @address = getparsedaddrs($address);
 286
 287 Returns the output from Mail::Address->parse, or the cached output if
 288 this address has been parsed before. In SCALAR context returns the
 289 first address parsed.
 290
 291 =cut
 292
 293
 294 our %_parsedaddrs;
 295 sub getparsedaddrs {
 296     my $addr = shift;
 297     return () unless defined $addr;
 298     return wantarray?@{$_parsedaddrs{$addr}}:$_parsedaddrs{$addr}[0]
 299          if exists $_parsedaddrs{$addr};
 300     {
 301          # don't display the warnings from Mail::Address->parse
 302          local $SIG{__WARN__} = sub { };
 303          @{$_parsedaddrs{$addr}} = Mail::Address->parse($addr);
 304     }
 305     return wantarray?@{$_parsedaddrs{$addr}}:$_parsedaddrs{$addr}[0];
 306 }
 307
 308 =head2 getmaintainers
 309
 310      my $maintainer = getmaintainers()->{debbugs}
 311
 312 Returns a hashref of package => maintainer pairs.
 313
 314 =cut
 315
 316 our $_maintainer = undef;
 317 our $_maintainer_rev = undef;
 318 sub getmaintainers {
 319     return $_maintainer if defined $_maintainer;
 320     package_maintainer(rehash => 1);
 321     return $_maintainer;
 322 }
 323
 324 =head2 getmaintainers_reverse
 325
 326      my @packages = @{getmaintainers_reverse->{'don@debian.org'}||[]};
 327
 328 Returns a hashref of maintainer => [qw(list of packages)] pairs.
 329
 330 =cut
 331
 332 sub getmaintainers_reverse{
 333      return $_maintainer_rev if defined $_maintainer_rev;
 334      package_maintainer(rehash => 1);
 335      return $_maintainer_rev;
 336 }
 337
 338 =head2 package_maintainer
 339
 340      my @s = package_maintainer(source => [qw(foo bar baz)],
 341                                 binary => [qw(bleh blah)],
 342                                );
 343
 344 =over
 345
 346 =item source -- scalar or arrayref of source package names to return
 347 maintainers for, defaults to the empty arrayref.
 348
 349 =item binary -- scalar or arrayref of binary package names to return
 350 maintainers for; automatically returns source package maintainer if
 351 the package name starts with 'src:', defaults to the empty arrayref.
 352
 353 =item reverse -- whether to return the source/binary packages a
 354 maintainer maintains instead
 355
 356 =item rehash -- whether to reread the maintainer and source maintainer
 357 files; defaults to 0
 358
 359 =back
 360
 361 =cut
 362
 363 our $_source_maintainer = undef;
 364 our $_source_maintainer_rev = undef;
 365 sub package_maintainer {
 366     my %param = validate_with(params => \@_,
 367                               spec   => {source => {type => SCALAR|ARRAYREF,
 368                                                     default => [],
 369                                                    },
 370                                          binary => {type => SCALAR|ARRAYREF,
 371                                                     default => [],
 372                                                    },
 373                                          maintainer => {type => SCALAR|ARRAYREF,
 374                                                         default => [],
 375                                                        },
 376                                          rehash => {type => BOOLEAN,
 377                                                     default => 0,
 378                                                    },
 379                                          reverse => {type => BOOLEAN,
 380                                                      default => 0,
 381                                                     },
 382                                         },
 383                              );
 384     my @binary = make_list($param{binary});
 385     my @source = make_list($param{source});
 386     my @maintainers = make_list($param{maintainer});
 387     if ((@binary or @source) and @maintainers) {
 388         croak "It is nonsensical to pass both maintainers and source or binary";
 389     }
 390     if ($param{rehash}) {
 391         $_source_maintainer = undef;
 392         $_source_maintainer_rev = undef;
 393         $_maintainer = undef;
 394         $_maintainer_rev = undef;
 395     }
 396     if (not defined $_source_maintainer or
 397         not defined $_source_maintainer_rev) {
 398         $_source_maintainer = {};
 399         $_source_maintainer_rev = {};
 400         if (-e $config{spool_dir}.'/source_maintainers.idx' and
 401             -e $config{spool_dir}.'/source_maintainers_reverse.idx'
 402            ) {
 403             tie %{$_source_maintainer},
 404                 MLDBM => $config{spool_dir}.'/source_maintainers.idx',
 405                 O_RDONLY or
 406                 die "Unable to tie source maintainers: $!";
 407             tie %{$_source_maintainer_rev},
 408                 MLDBM => $config{spool_dir}.'/source_maintainers_reverse.idx',
 409                 O_RDONLY or
 410                 die "Unable to tie source maintainers reverse: $!";
 411         } else {
 412             for my $fn (@config{('source_maintainer_file',
 413                                  'source_maintainer_file_override',
 414                                  'pseudo_maint_file')}) {
 415                 next unless defined $fn and length $fn;
 416                 if (not -e $fn) {
 417                     warn "Missing source maintainer file '$fn'";
 418                     next;
 419                 }
 420                 __add_to_hash($fn,$_source_maintainer,
 421                               $_source_maintainer_rev);
 422             }
 423         }
 424     }
 425     if (not defined $_maintainer or
 426         not defined $_maintainer_rev) {
 427         $_maintainer = {};
 428         $_maintainer_rev = {};
 429         if (-e $config{spool_dir}.'/maintainers.idx' and
 430             -e $config{spool_dir}.'/maintainers_reverse.idx'
 431            ) {
 432             tie %{$_maintainer},
 433                 MLDBM => $config{spool_dir}.'/binary_maintainers.idx',
 434                 O_RDONLY or
 435                 die "Unable to tie binary maintainers: $!";
 436             tie %{$_maintainer_rev},
 437                 MLDBM => $config{spool_dir}.'/binary_maintainers_reverse.idx',
 438                 O_RDONLY or
 439                 die "Unable to binary maintainers reverse: $!";
 440         } else {
 441             for my $fn (@config{('maintainer_file',
 442                                  'maintainer_file_override',
 443                                  'pseudo_maint_file')}) {
 444                 next unless defined $fn and length $fn;
 445                 if (not -e $fn) {
 446                     warn "Missing maintainer file '$fn'";
 447                     next;
 448                 }
 449                 __add_to_hash($fn,$_maintainer,
 450                               $_maintainer_rev);
 451             }
 452         }
 453     }
 454     my @return;
 455     for my $binary (@binary) {
 456         if (not $param{reverse} and $binary =~ /^src:/) {
 457             push @source,$binary;
 458             next;
 459         }
 460         push @return,grep {defined $_} make_list($_maintainer->{$binary});
 461     }
 462     for my $source (@source) {
 463         $source =~ s/^src://;
 464         push @return,grep {defined $_} make_list($_source_maintainer->{$source});
 465     }
 466     for my $maintainer (grep {defined $_} @maintainers) {
 467         push @return,grep {defined $_}
 468             make_list($_maintainer_rev->{$maintainer});
 469         push @return,map {$_ !~ /^src:/?'src:'.$_:$_}
 470             grep {defined $_}
 471                 make_list($_source_maintainer_rev->{$maintainer});
 472     }
 473     return @return;
 474 }
 475
 476 #=head2 __add_to_hash
 477 #
 478 #     __add_to_hash($file,$forward_hash,$reverse_hash,'address');
 479 #
 480 # Reads a maintainer/source maintainer/pseudo desc file and adds the
 481 # maintainers from it to the forward and reverse hashref; assumes that
 482 # the forward is unique; makes no assumptions of the reverse.
 483 #
 484 #=cut
 485
 486 sub __add_to_hash {
 487     my ($fn,$forward,$reverse,$type) = @_;
 488     if (ref($forward) ne 'HASH') {
 489         croak "__add_to_hash must be passed a hashref for the forward";
 490     }
 491     if (defined $reverse and not ref($reverse) eq 'HASH') {
 492         croak "if reverse is passed to __add_to_hash, it must be a hashref";
 493     }
 494     $type //= 'address';
 495     my $fh = IO::File->new($fn,'r') or
 496         croak "Unable to open $fn for reading: $!";
 497     binmode($fh,':encoding(UTF-8)');
 498     while (<$fh>) {
 499         chomp;
 500         my @elements = split /\t/;
 501         next unless @elements >=2;
 502         # we do this because the source maintainer file contains the
 503         # archive location, which we don't care about
 504         my ($key,$value)=($elements[0],$elements[-1]);
 505         $key = lc $key;
 506         $forward->{$key}= $value;
 507         if (defined $reverse) {
 508             if ($type eq 'address') {
 509                 for my $m (map {lc($_->address)} (getparsedaddrs($value))) {
 510                     push @{$reverse->{$m}},$key;
 511                 }
 512             }
 513             else {
 514                 push @{$reverse->{$value}}, $key;
 515             }
 516         }
 517     }
 518 }
 519
 520
 521 =head2 getpseudodesc
 522
 523      my $pseudopkgdesc = getpseudodesc(...);
 524
 525 Returns the entry for a pseudo package from the
 526 $config{pseudo_desc_file}. In cases where pseudo_desc_file is not
 527 defined, returns an empty arrayref.
 528
 529 This function can be used to see if a particular package is a
 530 pseudopackage or not.
 531
 532 =cut
 533
 534 our $_pseudodesc = undef;
 535 sub getpseudodesc {
 536     return $_pseudodesc if defined $_pseudodesc;
 537     $_pseudodesc = {};
 538     __add_to_hash($config{pseudo_desc_file},$_pseudodesc) if
 539         defined $config{pseudo_desc_file} and
 540         length $config{pseudo_desc_file};
 541     return $_pseudodesc;
 542 }
 543
 544 =head2 sort_versions
 545
 546      sort_versions('1.0-2','1.1-2');
 547
 548 Sorts versions using AptPkg::Versions::compare if it is available, or
 549 Debbugs::Versions::Dpkg::vercmp if it isn't.
 550
 551 =cut
 552
 553 our $vercmp;
 554 BEGIN{
 555     use Debbugs::Versions::Dpkg;
 556     $vercmp=\&Debbugs::Versions::Dpkg::vercmp;
 557
 558 # eventually we'll use AptPkg:::Version or similar, but the current
 559 # implementation makes this *super* difficult.
 560
 561 #     eval {
 562 #       use AptPkg::Version;
 563 #       $vercmp=\&AptPkg::Version::compare;
 564 #     };
 565 }
 566
 567 sub sort_versions{
 568     return sort {$vercmp->($a,$b)} @_;
 569 }
 570
 571
 572 =head1 DATE
 573
 574     my $english = secs_to_english($seconds);
 575     my ($days,$english) = secs_to_english($seconds);
 576
 577 XXX This should probably be changed to use Date::Calc
 578
 579 =cut
 580
 581 sub secs_to_english{
 582      my ($seconds) = @_;
 583
 584      my $days = int($seconds / 86400);
 585      my $years = int($days / 365);
 586      $days %= 365;
 587      my $result;
 588      my @age;
 589      push @age, "1 year" if ($years == 1);
 590      push @age, "$years years" if ($years > 1);
 591      push @age, "1 day" if ($days == 1);
 592      push @age, "$days days" if ($days > 1);
 593      $result .= join(" and ", @age);
 594
 595      return wantarray?(int($seconds/86400),$result):$result;
 596 }
 597
 598
 599 =head1 LOCK
 600
 601 These functions are exported with the :lock tag
 602
 603 =head2 filelock
 604
 605      filelock($lockfile);
 606      filelock($lockfile,$locks);
 607
 608 FLOCKs the passed file. Use unfilelock to unlock it.
 609
 610 Can be passed an optional $locks hashref, which is used to track which
 611 files are locked (and how many times they have been locked) to allow
 612 for cooperative locking.
 613
 614 =cut
 615
 616 our @filelocks;
 617
 618 use Carp qw(cluck);
 619
 620 sub filelock {
 621     # NB - NOT COMPATIBLE WITH `with-lock'
 622     my ($lockfile,$locks) = @_;
 623     if ($lockfile !~ m{^/}) {
 624          $lockfile = cwd().'/'.$lockfile;
 625     }
 626     # This is only here to allow for relocking bugs inside of
 627     # Debbugs::Control. Nothing else should be using it.
 628     if (defined $locks and exists $locks->{locks}{$lockfile} and
 629         $locks->{locks}{$lockfile} >= 1) {
 630         if (exists $locks->{relockable} and
 631             exists $locks->{relockable}{$lockfile}) {
 632             $locks->{locks}{$lockfile}++;
 633             # indicate that the bug for this lockfile needs to be reread
 634             $locks->{relockable}{$lockfile} = 1;
 635             push @{$locks->{lockorder}},$lockfile;
 636             return;
 637         }
 638         else {
 639             use Data::Dumper;
 640             confess "Locking already locked file: $lockfile\n".Data::Dumper->Dump([$lockfile,$locks],[qw(lockfile locks)]);
 641         }
 642     }
 643     my ($fh,$t_lockfile,$errors) =
 644         simple_filelock($lockfile,10,1);
 645     if ($fh) {
 646         push @filelocks, {fh => $fh, file => $lockfile};
 647         if (defined $locks) {
 648             $locks->{locks}{$lockfile}++;
 649             push @{$locks->{lockorder}},$lockfile;
 650         }
 651     } else {
 652         use Data::Dumper;
 653         croak "failed to get lock on $lockfile -- $errors".
 654             (defined $locks?Data::Dumper->Dump([$locks],[qw(locks)]):'');
 655     }
 656 }
 657
 658 =head2 simple_filelock
 659
 660     my ($fh,$t_lockfile,$errors) =
 661         simple_filelock($lockfile,$count,$wait);
 662
 663 Does a flock of lockfile. If C<$count> is zero, does a blocking lock.
 664 Otherwise, does a non-blocking lock C<$count> times, waiting C<$wait>
 665 seconds in between.
 666
 667 In list context, returns the lockfile filehandle, lockfile name, and
 668 any errors which occured.
 669
 670 When the lockfile filehandle is undef, locking failed.
 671
 672 These lockfiles must be unlocked manually at process end.
 673
 674
 675 =cut
 676
 677 sub simple_filelock {
 678     my ($lockfile,$count,$wait) = @_;
 679     if (not defined $count) {
 680         $count = 10;
 681     }
 682     if ($count < 0) {
 683         $count = 0;
 684     }
 685     if (not defined $wait) {
 686         $wait = 1;
 687     }
 688     my $errors= '';
 689     my $fh;
 690     while (1) {
 691         $fh = eval {
 692              my $fh2 = IO::File->new($lockfile,'w')
 693                   or die "Unable to open $lockfile for writing: $!";
 694              # Do a blocking lock if count is zero
 695              flock($fh2,LOCK_EX|($count == 0?0:LOCK_NB))
 696                   or die "Unable to lock $lockfile $!";
 697              return $fh2;
 698         };
 699         if ($@) {
 700              $errors .= $@;
 701         }
 702         if ($fh) {
 703             last;
 704         }
 705         # use usleep for fractional wait seconds
 706         usleep($wait * 1_000_000);
 707     } continue {
 708         last unless (--$count > 0);
 709     }
 710     if ($fh) {
 711         return wantarray?($fh,$lockfile,$errors):$fh
 712     }
 713     return wantarray?(undef,$lockfile,$errors):undef;
 714 }
 715
 716 # clean up all outstanding locks at end time
 717 END {
 718      while (@filelocks) {
 719           unfilelock();
 720      }
 721 }
 722
 723 =head2 simple_unlockfile
 724
 725      simple_unlockfile($fh,$lockfile);
 726
 727
 728 =cut
 729
 730 sub simple_unlockfile {
 731     my ($fh,$lockfile) = @_;
 732     flock($fh,LOCK_UN)
 733         or warn "Unable to unlock lockfile $lockfile: $!";
 734     close($fh)
 735         or warn "Unable to close lockfile $lockfile: $!";
 736     unlink($lockfile)
 737         or warn "Unable to unlink lockfile $lockfile: $!";
 738 }
 739
 740
 741 =head2 unfilelock
 742
 743      unfilelock()
 744      unfilelock($locks);
 745
 746 Unlocks the file most recently locked.
 747
 748 Note that it is not currently possible to unlock a specific file
 749 locked with filelock.
 750
 751 =cut
 752
 753 sub unfilelock {
 754     my ($locks) = @_;
 755     if (@filelocks == 0) {
 756         carp "unfilelock called with no active filelocks!\n";
 757         return;
 758     }
 759     if (defined $locks and ref($locks) ne 'HASH') {
 760         croak "hash not passsed to unfilelock";
 761     }
 762     if (defined $locks and exists $locks->{lockorder} and
 763         @{$locks->{lockorder}} and
 764         exists $locks->{locks}{$locks->{lockorder}[-1]}) {
 765         my $lockfile = pop @{$locks->{lockorder}};
 766         $locks->{locks}{$lockfile}--;
 767         if ($locks->{locks}{$lockfile} > 0) {
 768             return
 769         }
 770         delete $locks->{locks}{$lockfile};
 771     }
 772     my %fl = %{pop(@filelocks)};
 773     simple_unlockfile($fl{fh},$fl{file});
 774 }
 775
 776
 777 =head2 lockpid
 778
 779       lockpid('/path/to/pidfile');
 780
 781 Creates a pidfile '/path/to/pidfile' if one doesn't exist or if the
 782 pid in the file does not respond to kill 0.
 783
 784 Returns 1 on success, false on failure; dies on unusual errors.
 785
 786 =cut
 787
 788 sub lockpid {
 789      my ($pidfile) = @_;
 790      if (-e $pidfile) {
 791           my $pid = checkpid($pidfile);
 792           die "Unable to read pidfile $pidfile: $!" if not defined $pid;
 793           return 0 if $pid != 0;
 794           unlink $pidfile or
 795                die "Unable to unlink stale pidfile $pidfile $!";
 796      }
 797      my $pidfh = IO::File->new($pidfile,O_CREAT|O_EXCL|O_WRONLY) or
 798           die "Unable to open $pidfile for writing: $!";
 799      print {$pidfh} $$ or die "Unable to write to $pidfile $!";
 800      close $pidfh or die "Unable to close $pidfile $!";
 801      return 1;
 802 }
 803
 804 =head2 checkpid
 805
 806      checkpid('/path/to/pidfile');
 807
 808 Checks a pid file and determines if the process listed in the pidfile
 809 is still running. Returns the pid if it is, 0 if it isn't running, and
 810 undef if the pidfile doesn't exist or cannot be read.
 811
 812 =cut
 813
 814 sub checkpid{
 815      my ($pidfile) = @_;
 816      if (-e $pidfile) {
 817           my $pidfh = IO::File->new($pidfile, 'r') or
 818                return undef;
 819           local $/;
 820           my $pid = <$pidfh>;
 821           close $pidfh;
 822           ($pid) = $pid =~ /(\d+)/;
 823           if (defined $pid and kill(0,$pid)) {
 824                return $pid;
 825           }
 826           return 0;
 827      }
 828      else {
 829           return undef;
 830      }
 831 }
 832
 833
 834 =head1 QUIT
 835
 836 These functions are exported with the :quit tag.
 837
 838 =head2 quit
 839
 840      quit()
 841
 842 Exits the program by calling die.
 843
 844 Usage of quit is deprecated; just call die instead.
 845
 846 =cut
 847
 848 sub quit {
 849      print {$DEBUG_FH} "quitting >$_[0]<\n" if $DEBUG;
 850      carp "quit() is deprecated; call die directly instead";
 851 }
 852
 853
 854 =head1 MISC
 855
 856 These functions are exported with the :misc tag
 857
 858 =head2 make_list
 859
 860      LIST = make_list(@_);
 861
 862 Turns a scalar or an arrayref into a list; expands a list of arrayrefs
 863 into a list.
 864
 865 That is, make_list([qw(a b c)]); returns qw(a b c); make_list([qw(a
 866 b)],[qw(c d)] returns qw(a b c d);
 867
 868 =cut
 869
 870 sub make_list {
 871      return map {(ref($_) eq 'ARRAY')?@{$_}:$_} @_;
 872 }
 873
 874
 875 =head2 english_join
 876
 877      print english_join(list => \@list);
 878      print english_join(\@list);
 879
 880 Joins list properly to make an english phrase.
 881
 882 =over
 883
 884 =item normal -- how to separate most values; defaults to ', '
 885
 886 =item last -- how to separate the last two values; defaults to ', and '
 887
 888 =item only_two -- how to separate only two values; defaults to ' and '
 889
 890 =item list -- ARRAYREF values to join; if the first argument is an
 891 ARRAYREF, it's assumed to be the list of values to join
 892
 893 =back
 894
 895 In cases where C<list> is empty, returns ''; when there is only one
 896 element, returns that element.
 897
 898 =cut
 899
 900 sub english_join {
 901     if (ref $_[0] eq 'ARRAY') {
 902         return english_join(list=>$_[0]);
 903     }
 904     my %param = validate_with(params => \@_,
 905                               spec  => {normal => {type => SCALAR,
 906                                                    default => ', ',
 907                                                   },
 908                                         last   => {type => SCALAR,
 909                                                    default => ', and ',
 910                                                   },
 911                                         only_two => {type => SCALAR,
 912                                                      default => ' and ',
 913                                                     },
 914                                         list     => {type => ARRAYREF,
 915                                                     },
 916                                        },
 917                              );
 918     my @list = @{$param{list}};
 919     if (@list <= 1) {
 920         return @list?$list[0]:'';
 921     }
 922     elsif (@list == 2) {
 923         return join($param{only_two},@list);
 924     }
 925     my $ret = $param{last} . pop(@list);
 926     return join($param{normal},@list) . $ret;
 927 }
 928
 929
 930 =head2 globify_scalar
 931
 932      my $handle = globify_scalar(\$foo);
 933
 934 if $foo isn't already a glob or a globref, turn it into one using
 935 IO::Scalar. Gives a new handle to /dev/null if $foo isn't defined.
 936
 937 Will carp if given a scalar which isn't a scalarref or a glob (or
 938 globref), and return /dev/null. May return undef if IO::Scalar or
 939 IO::File fails. (Check $!)
 940
 941 The scalar will fill with octets, not perl's internal encoding, so you
 942 must use decode_utf8() after on the scalar, and encode_utf8() on it
 943 before. This appears to be a bug in the underlying modules.
 944
 945 =cut
 946
 947 sub globify_scalar {
 948      my ($scalar) = @_;
 949      my $handle;
 950      if (defined $scalar) {
 951           if (defined ref($scalar)) {
 952                if (ref($scalar) eq 'SCALAR' and
 953                    not UNIVERSAL::isa($scalar,'GLOB')) {
 954                    if (is_utf8(${$scalar})) {
 955                        ${$scalar} = decode_utf8(${$scalar});
 956                        carp(q(\$scalar must not be in perl's internal encoding));
 957                    }
 958                     open $handle, '>:scalar:utf8', $scalar;
 959                     return $handle;
 960                }
 961                else {
 962                     return $scalar;
 963                }
 964           }
 965           elsif (UNIVERSAL::isa(\$scalar,'GLOB')) {
 966                return $scalar;
 967           }
 968           else {
 969                carp "Given a non-scalar reference, non-glob to globify_scalar; returning /dev/null handle";
 970           }
 971      }
 972      return IO::File->new('/dev/null','>:encoding(UTF-8)');
 973 }
 974
 975 =head2 cleanup_eval_fail()
 976
 977      print "Something failed with: ".cleanup_eval_fail($@);
 978
 979 Does various bits of cleanup on the failure message from an eval (or
 980 any other die message)
 981
 982 Takes at most two options; the first is the actual failure message
 983 (usually $@ and defaults to $@), the second is the debug level
 984 (defaults to $DEBUG).
 985
 986 If debug is non-zero, the code at which the failure occured is output.
 987
 988 =cut
 989
 990 sub cleanup_eval_fail {
 991     my ($error,$debug) = @_;
 992     if (not defined $error or not @_) {
 993         $error = $@ // 'unknown reason';
 994     }
 995     if (@_ <= 1) {
 996         $debug = $DEBUG // 0;
 997     }
 998     $debug = 0 if not defined $debug;
 999
1000     if ($debug > 0) {
1001         return $error;
1002     }
1003     # ditch the "at foo/bar/baz.pm line 5"
1004     $error =~ s/\sat\s\S+\sline\s\d+//;
1005     # ditch croak messages
1006     $error =~ s/^\t+.+\n?//mg;
1007     # ditch trailing multiple periods in case there was a cascade of
1008     # die messages.
1009     $error =~ s/\.+$/\./;
1010     return $error;
1011 }
1012
1013 =head2 hash_slice
1014
1015      hash_slice(%hash,qw(key1 key2 key3))
1016
1017 For each key, returns matching values and keys of the hash if they exist
1018
1019 =cut
1020
1021
1022 # NB: We use prototypes here SPECIFICALLY so that we can be passed a
1023 # hash without uselessly making a reference to first. DO NOT USE
1024 # PROTOTYPES USELESSLY ELSEWHERE.
1025 sub hash_slice(\%@) {
1026     my ($hashref,@keys) = @_;
1027     return map {exists $hashref->{$_}?($_,$hashref->{$_}):()} @keys;
1028 }
1029
1030
1031 1;
1032
1033 __END__