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         next unless m/^(\S+)\s+(\S.*\S)\s*$/;
 501         my ($key,$value)=($1,$2);
 502         $key = lc $key;
 503         $forward->{$key}= $value;
 504         if (defined $reverse) {
 505             if ($type eq 'address') {
 506                 for my $m (map {lc($_->address)} (getparsedaddrs($value))) {
 507                     push @{$reverse->{$m}},$key;
 508                 }
 509             }
 510             else {
 511                 push @{$reverse->{$value}}, $key;
 512             }
 513         }
 514     }
 515 }
 516
 517
 518 =head2 getpseudodesc
 519
 520      my $pseudopkgdesc = getpseudodesc(...);
 521
 522 Returns the entry for a pseudo package from the
 523 $config{pseudo_desc_file}. In cases where pseudo_desc_file is not
 524 defined, returns an empty arrayref.
 525
 526 This function can be used to see if a particular package is a
 527 pseudopackage or not.
 528
 529 =cut
 530
 531 our $_pseudodesc = undef;
 532 sub getpseudodesc {
 533     return $_pseudodesc if defined $_pseudodesc;
 534     $_pseudodesc = {};
 535     __add_to_hash($config{pseudo_desc_file},$_pseudodesc) if
 536         defined $config{pseudo_desc_file} and
 537         length $config{pseudo_desc_file};
 538     return $_pseudodesc;
 539 }
 540
 541 =head2 sort_versions
 542
 543      sort_versions('1.0-2','1.1-2');
 544
 545 Sorts versions using AptPkg::Versions::compare if it is available, or
 546 Debbugs::Versions::Dpkg::vercmp if it isn't.
 547
 548 =cut
 549
 550 our $vercmp;
 551 BEGIN{
 552     use Debbugs::Versions::Dpkg;
 553     $vercmp=\&Debbugs::Versions::Dpkg::vercmp;
 554
 555 # eventually we'll use AptPkg:::Version or similar, but the current
 556 # implementation makes this *super* difficult.
 557
 558 #     eval {
 559 #       use AptPkg::Version;
 560 #       $vercmp=\&AptPkg::Version::compare;
 561 #     };
 562 }
 563
 564 sub sort_versions{
 565     return sort {$vercmp->($a,$b)} @_;
 566 }
 567
 568
 569 =head1 DATE
 570
 571     my $english = secs_to_english($seconds);
 572     my ($days,$english) = secs_to_english($seconds);
 573
 574 XXX This should probably be changed to use Date::Calc
 575
 576 =cut
 577
 578 sub secs_to_english{
 579      my ($seconds) = @_;
 580
 581      my $days = int($seconds / 86400);
 582      my $years = int($days / 365);
 583      $days %= 365;
 584      my $result;
 585      my @age;
 586      push @age, "1 year" if ($years == 1);
 587      push @age, "$years years" if ($years > 1);
 588      push @age, "1 day" if ($days == 1);
 589      push @age, "$days days" if ($days > 1);
 590      $result .= join(" and ", @age);
 591
 592      return wantarray?(int($seconds/86400),$result):$result;
 593 }
 594
 595
 596 =head1 LOCK
 597
 598 These functions are exported with the :lock tag
 599
 600 =head2 filelock
 601
 602      filelock($lockfile);
 603      filelock($lockfile,$locks);
 604
 605 FLOCKs the passed file. Use unfilelock to unlock it.
 606
 607 Can be passed an optional $locks hashref, which is used to track which
 608 files are locked (and how many times they have been locked) to allow
 609 for cooperative locking.
 610
 611 =cut
 612
 613 our @filelocks;
 614
 615 use Carp qw(cluck);
 616
 617 sub filelock {
 618     # NB - NOT COMPATIBLE WITH `with-lock'
 619     my ($lockfile,$locks) = @_;
 620     if ($lockfile !~ m{^/}) {
 621          $lockfile = cwd().'/'.$lockfile;
 622     }
 623     # This is only here to allow for relocking bugs inside of
 624     # Debbugs::Control. Nothing else should be using it.
 625     if (defined $locks and exists $locks->{locks}{$lockfile} and
 626         $locks->{locks}{$lockfile} >= 1) {
 627         if (exists $locks->{relockable} and
 628             exists $locks->{relockable}{$lockfile}) {
 629             $locks->{locks}{$lockfile}++;
 630             # indicate that the bug for this lockfile needs to be reread
 631             $locks->{relockable}{$lockfile} = 1;
 632             push @{$locks->{lockorder}},$lockfile;
 633             return;
 634         }
 635         else {
 636             use Data::Dumper;
 637             confess "Locking already locked file: $lockfile\n".Data::Dumper->Dump([$lockfile,$locks],[qw(lockfile locks)]);
 638         }
 639     }
 640     my ($fh,$t_lockfile,$errors) =
 641         simple_filelock($lockfile,10,1);
 642     if ($fh) {
 643         push @filelocks, {fh => $fh, file => $lockfile};
 644         if (defined $locks) {
 645             $locks->{locks}{$lockfile}++;
 646             push @{$locks->{lockorder}},$lockfile;
 647         }
 648     } else {
 649         use Data::Dumper;
 650         croak "failed to get lock on $lockfile -- $errors".
 651             (defined $locks?Data::Dumper->Dump([$locks],[qw(locks)]):'');
 652     }
 653 }
 654
 655 =head2 simple_filelock
 656
 657     my ($fh,$t_lockfile,$errors) =
 658         simple_filelock($lockfile,$count,$wait);
 659
 660 Does a flock of lockfile. If C<$count> is zero, does a blocking lock.
 661 Otherwise, does a non-blocking lock C<$count> times, waiting C<$wait>
 662 seconds in between.
 663
 664 In list context, returns the lockfile filehandle, lockfile name, and
 665 any errors which occured.
 666
 667 When the lockfile filehandle is undef, locking failed.
 668
 669 These lockfiles must be unlocked manually at process end.
 670
 671
 672 =cut
 673
 674 sub simple_filelock {
 675     my ($lockfile,$count,$wait) = @_;
 676     if (not defined $count) {
 677         $count = 10;
 678     }
 679     if ($count < 0) {
 680         $count = 0;
 681     }
 682     if (not defined $wait) {
 683         $wait = 1;
 684     }
 685     my $errors= '';
 686     my $fh;
 687     while (1) {
 688         $fh = eval {
 689              my $fh2 = IO::File->new($lockfile,'w')
 690                   or die "Unable to open $lockfile for writing: $!";
 691              # Do a blocking lock if count is zero
 692              flock($fh2,LOCK_EX|($count == 0?0:LOCK_NB))
 693                   or die "Unable to lock $lockfile $!";
 694              return $fh2;
 695         };
 696         if ($@) {
 697              $errors .= $@;
 698         }
 699         if ($fh) {
 700             last;
 701         }
 702         # use usleep for fractional wait seconds
 703         usleep($wait * 1_000_000);
 704     } continue {
 705         last unless (--$count > 0);
 706     }
 707     if ($fh) {
 708         return wantarray?($fh,$lockfile,$errors):$fh
 709     }
 710     return wantarray?(undef,$lockfile,$errors):undef;
 711 }
 712
 713 # clean up all outstanding locks at end time
 714 END {
 715      while (@filelocks) {
 716           unfilelock();
 717      }
 718 }
 719
 720 =head2 simple_unlockfile
 721
 722      simple_unlockfile($fh,$lockfile);
 723
 724
 725 =cut
 726
 727 sub simple_unlockfile {
 728     my ($fh,$lockfile) = @_;
 729     flock($fh,LOCK_UN)
 730         or warn "Unable to unlock lockfile $lockfile: $!";
 731     close($fh)
 732         or warn "Unable to close lockfile $lockfile: $!";
 733     unlink($lockfile)
 734         or warn "Unable to unlink lockfile $lockfile: $!";
 735 }
 736
 737
 738 =head2 unfilelock
 739
 740      unfilelock()
 741      unfilelock($locks);
 742
 743 Unlocks the file most recently locked.
 744
 745 Note that it is not currently possible to unlock a specific file
 746 locked with filelock.
 747
 748 =cut
 749
 750 sub unfilelock {
 751     my ($locks) = @_;
 752     if (@filelocks == 0) {
 753         carp "unfilelock called with no active filelocks!\n";
 754         return;
 755     }
 756     if (defined $locks and ref($locks) ne 'HASH') {
 757         croak "hash not passsed to unfilelock";
 758     }
 759     if (defined $locks and exists $locks->{lockorder} and
 760         @{$locks->{lockorder}} and
 761         exists $locks->{locks}{$locks->{lockorder}[-1]}) {
 762         my $lockfile = pop @{$locks->{lockorder}};
 763         $locks->{locks}{$lockfile}--;
 764         if ($locks->{locks}{$lockfile} > 0) {
 765             return
 766         }
 767         delete $locks->{locks}{$lockfile};
 768     }
 769     my %fl = %{pop(@filelocks)};
 770     simple_unlockfile($fl{fh},$fl{file});
 771 }
 772
 773
 774 =head2 lockpid
 775
 776       lockpid('/path/to/pidfile');
 777
 778 Creates a pidfile '/path/to/pidfile' if one doesn't exist or if the
 779 pid in the file does not respond to kill 0.
 780
 781 Returns 1 on success, false on failure; dies on unusual errors.
 782
 783 =cut
 784
 785 sub lockpid {
 786      my ($pidfile) = @_;
 787      if (-e $pidfile) {
 788           my $pid = checkpid($pidfile);
 789           die "Unable to read pidfile $pidfile: $!" if not defined $pid;
 790           return 0 if $pid != 0;
 791           unlink $pidfile or
 792                die "Unable to unlink stale pidfile $pidfile $!";
 793      }
 794      my $pidfh = IO::File->new($pidfile,O_CREAT|O_EXCL|O_WRONLY) or
 795           die "Unable to open $pidfile for writing: $!";
 796      print {$pidfh} $$ or die "Unable to write to $pidfile $!";
 797      close $pidfh or die "Unable to close $pidfile $!";
 798      return 1;
 799 }
 800
 801 =head2 checkpid
 802
 803      checkpid('/path/to/pidfile');
 804
 805 Checks a pid file and determines if the process listed in the pidfile
 806 is still running. Returns the pid if it is, 0 if it isn't running, and
 807 undef if the pidfile doesn't exist or cannot be read.
 808
 809 =cut
 810
 811 sub checkpid{
 812      my ($pidfile) = @_;
 813      if (-e $pidfile) {
 814           my $pidfh = IO::File->new($pidfile, 'r') or
 815                return undef;
 816           local $/;
 817           my $pid = <$pidfh>;
 818           close $pidfh;
 819           ($pid) = $pid =~ /(\d+)/;
 820           if (defined $pid and kill(0,$pid)) {
 821                return $pid;
 822           }
 823           return 0;
 824      }
 825      else {
 826           return undef;
 827      }
 828 }
 829
 830
 831 =head1 QUIT
 832
 833 These functions are exported with the :quit tag.
 834
 835 =head2 quit
 836
 837      quit()
 838
 839 Exits the program by calling die.
 840
 841 Usage of quit is deprecated; just call die instead.
 842
 843 =cut
 844
 845 sub quit {
 846      print {$DEBUG_FH} "quitting >$_[0]<\n" if $DEBUG;
 847      carp "quit() is deprecated; call die directly instead";
 848 }
 849
 850
 851 =head1 MISC
 852
 853 These functions are exported with the :misc tag
 854
 855 =head2 make_list
 856
 857      LIST = make_list(@_);
 858
 859 Turns a scalar or an arrayref into a list; expands a list of arrayrefs
 860 into a list.
 861
 862 That is, make_list([qw(a b c)]); returns qw(a b c); make_list([qw(a
 863 b)],[qw(c d)] returns qw(a b c d);
 864
 865 =cut
 866
 867 sub make_list {
 868      return map {(ref($_) eq 'ARRAY')?@{$_}:$_} @_;
 869 }
 870
 871
 872 =head2 english_join
 873
 874      print english_join(list => \@list);
 875      print english_join(\@list);
 876
 877 Joins list properly to make an english phrase.
 878
 879 =over
 880
 881 =item normal -- how to separate most values; defaults to ', '
 882
 883 =item last -- how to separate the last two values; defaults to ', and '
 884
 885 =item only_two -- how to separate only two values; defaults to ' and '
 886
 887 =item list -- ARRAYREF values to join; if the first argument is an
 888 ARRAYREF, it's assumed to be the list of values to join
 889
 890 =back
 891
 892 In cases where C<list> is empty, returns ''; when there is only one
 893 element, returns that element.
 894
 895 =cut
 896
 897 sub english_join {
 898     if (ref $_[0] eq 'ARRAY') {
 899         return english_join(list=>$_[0]);
 900     }
 901     my %param = validate_with(params => \@_,
 902                               spec  => {normal => {type => SCALAR,
 903                                                    default => ', ',
 904                                                   },
 905                                         last   => {type => SCALAR,
 906                                                    default => ', and ',
 907                                                   },
 908                                         only_two => {type => SCALAR,
 909                                                      default => ' and ',
 910                                                     },
 911                                         list     => {type => ARRAYREF,
 912                                                     },
 913                                        },
 914                              );
 915     my @list = @{$param{list}};
 916     if (@list <= 1) {
 917         return @list?$list[0]:'';
 918     }
 919     elsif (@list == 2) {
 920         return join($param{only_two},@list);
 921     }
 922     my $ret = $param{last} . pop(@list);
 923     return join($param{normal},@list) . $ret;
 924 }
 925
 926
 927 =head2 globify_scalar
 928
 929      my $handle = globify_scalar(\$foo);
 930
 931 if $foo isn't already a glob or a globref, turn it into one using
 932 IO::Scalar. Gives a new handle to /dev/null if $foo isn't defined.
 933
 934 Will carp if given a scalar which isn't a scalarref or a glob (or
 935 globref), and return /dev/null. May return undef if IO::Scalar or
 936 IO::File fails. (Check $!)
 937
 938 The scalar will fill with octets, not perl's internal encoding, so you
 939 must use decode_utf8() after on the scalar, and encode_utf8() on it
 940 before. This appears to be a bug in the underlying modules.
 941
 942 =cut
 943
 944 sub globify_scalar {
 945      my ($scalar) = @_;
 946      my $handle;
 947      if (defined $scalar) {
 948           if (defined ref($scalar)) {
 949                if (ref($scalar) eq 'SCALAR' and
 950                    not UNIVERSAL::isa($scalar,'GLOB')) {
 951                    if (is_utf8(${$scalar})) {
 952                        ${$scalar} = decode_utf8(${$scalar});
 953                        carp(q(\$scalar must not be in perl's internal encoding));
 954                    }
 955                     open $handle, '>:scalar:utf8', $scalar;
 956                     return $handle;
 957                }
 958                else {
 959                     return $scalar;
 960                }
 961           }
 962           elsif (UNIVERSAL::isa(\$scalar,'GLOB')) {
 963                return $scalar;
 964           }
 965           else {
 966                carp "Given a non-scalar reference, non-glob to globify_scalar; returning /dev/null handle";
 967           }
 968      }
 969      return IO::File->new('/dev/null','>:encoding(UTF-8)');
 970 }
 971
 972 =head2 cleanup_eval_fail()
 973
 974      print "Something failed with: ".cleanup_eval_fail($@);
 975
 976 Does various bits of cleanup on the failure message from an eval (or
 977 any other die message)
 978
 979 Takes at most two options; the first is the actual failure message
 980 (usually $@ and defaults to $@), the second is the debug level
 981 (defaults to $DEBUG).
 982
 983 If debug is non-zero, the code at which the failure occured is output.
 984
 985 =cut
 986
 987 sub cleanup_eval_fail {
 988     my ($error,$debug) = @_;
 989     if (not defined $error or not @_) {
 990         $error = $@ // 'unknown reason';
 991     }
 992     if (@_ <= 1) {
 993         $debug = $DEBUG // 0;
 994     }
 995     $debug = 0 if not defined $debug;
 996
 997     if ($debug > 0) {
 998         return $error;
 999     }
1000     # ditch the "at foo/bar/baz.pm line 5"
1001     $error =~ s/\sat\s\S+\sline\s\d+//;
1002     # ditch croak messages
1003     $error =~ s/^\t+.+\n?//mg;
1004     # ditch trailing multiple periods in case there was a cascade of
1005     # die messages.
1006     $error =~ s/\.+$/\./;
1007     return $error;
1008 }
1009
1010 =head2 hash_slice
1011
1012      hash_slice(%hash,qw(key1 key2 key3))
1013
1014 For each key, returns matching values and keys of the hash if they exist
1015
1016 =cut
1017
1018
1019 # NB: We use prototypes here SPECIFICALLY so that we can be passed a
1020 # hash without uselessly making a reference to first. DO NOT USE
1021 # PROTOTYPES USELESSLY ELSEWHERE.
1022 sub hash_slice(\%@) {
1023     my ($hashref,@keys) = @_;
1024     return map {exists $hashref->{$_}?($_,$hashref->{$_}):()} @keys;
1025 }
1026
1027
1028 1;
1029
1030 __END__