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