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