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