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