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