Debbugs/Common.pm

   1 # This module is part of debbugs, and is released
   2 # under the terms of the GPL version 2, or any later
   3 # version at your option.
   4 # See the file README and COPYING for more information.
   5 #
   6 # [Other people have contributed to this file; their copyrights should
   7 # go here too.]
   8 # Copyright 2007 by Don Armstrong <don@donarmstrong.com>.
   9
  10 package Debbugs::Common;
  11
  12 =head1 NAME
  13
  14 Debbugs::Common -- Common routines for all of Debbugs
  15
  16 =head1 SYNOPSIS
  17
  18 use Debbugs::Common qw(:url :html);
  19
  20
  21 =head1 DESCRIPTION
  22
  23 This module is a replacement for the general parts of errorlib.pl.
  24 subroutines in errorlib.pl will be gradually phased out and replaced
  25 with equivalent (or better) functionality here.
  26
  27 =head1 FUNCTIONS
  28
  29 =cut
  30
  31 use warnings;
  32 use strict;
  33 use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT);
  34 use Exporter qw(import);
  35
  36 BEGIN{
  37      $VERSION = 1.00;
  38      $DEBUG = 0 unless defined $DEBUG;
  39
  40      @EXPORT = ();
  41      %EXPORT_TAGS = (util   => [qw(getbugcomponent getbuglocation getlocationpath get_hashname),
  42                                 qw(appendfile overwritefile buglog getparsedaddrs getmaintainers),
  43                                 qw(bug_status),
  44                                 qw(getmaintainers_reverse),
  45                                 qw(getpseudodesc),
  46                                 qw(package_maintainer),
  47                                 qw(sort_versions),
  48                                ],
  49                      misc   => [qw(make_list globify_scalar english_join checkpid),
  50                                 qw(cleanup_eval_fail),
  51                                 qw(hash_slice),
  52                                ],
  53                      date   => [qw(secs_to_english)],
  54                      quit   => [qw(quit)],
  55                      lock   => [qw(filelock unfilelock lockpid simple_filelock simple_unlockfile)],
  56                     );
  57      @EXPORT_OK = ();
  58      Exporter::export_ok_tags(keys %EXPORT_TAGS);
  59      $EXPORT_TAGS{all} = [@EXPORT_OK];
  60 }
  61
  62 #use Debbugs::Config qw(:globals);
  63
  64 use Carp;
  65 $Carp::Verbose = 1;
  66
  67 use Debbugs::Config qw(:config);
  68 use IO::File;
  69 use IO::Scalar;
  70 use Debbugs::MIME qw(decode_rfc1522);
  71 use Mail::Address;
  72 use Cwd qw(cwd);
  73 use Storable qw(dclone);
  74 use Time::HiRes qw(usleep);
  75
  76 use Params::Validate qw(validate_with :types);
  77
  78 use Fcntl qw(:DEFAULT :flock);
  79 use Encode qw(is_utf8 decode_utf8);
  80
  81 our $DEBUG_FH = \*STDERR if not defined $DEBUG_FH;
  82
  83 =head1 UTILITIES
  84
  85 The following functions are exported by the C<:util> tag
  86
  87 =head2 getbugcomponent
  88
  89      my $file = getbugcomponent($bug_number,$extension,$location)
  90
  91 Returns the path to the bug file in location C<$location>, bug number
  92 C<$bugnumber> and extension C<$extension>
  93
  94 =cut
  95
  96 sub getbugcomponent {
  97     my ($bugnum, $ext, $location) = @_;
  98
  99     if (not defined $location) {
 100         $location = getbuglocation($bugnum, $ext);
 101         # Default to non-archived bugs only for now; CGI scripts want
 102         # archived bugs but most of the backend scripts don't. For now,
 103         # anything that is prepared to accept archived bugs should call
 104         # getbuglocation() directly first.
 105         return undef if defined $location and
 106                         ($location ne 'db' and $location ne 'db-h');
 107     }
 108     my $dir = getlocationpath($location);
 109     return undef if not defined $dir;
 110     if (defined $location and $location eq 'db') {
 111         return "$dir/$bugnum.$ext";
 112     } else {
 113         my $hash = get_hashname($bugnum);
 114         return "$dir/$hash/$bugnum.$ext";
 115     }
 116 }
 117
 118 =head2 getbuglocation
 119
 120      getbuglocation($bug_number,$extension)
 121
 122 Returns the the location in which a particular bug exists; valid
 123 locations returned currently are archive, db-h, or db. If the bug does
 124 not exist, returns undef.
 125
 126 =cut
 127
 128 sub getbuglocation {
 129     my ($bugnum, $ext) = @_;
 130     my $archdir = get_hashname($bugnum);
 131     return 'archive' if -r getlocationpath('archive')."/$archdir/$bugnum.$ext";
 132     return 'db-h' if -r getlocationpath('db-h')."/$archdir/$bugnum.$ext";
 133     return 'db' if -r getlocationpath('db')."/$bugnum.$ext";
 134     return undef;
 135 }
 136
 137
 138 =head2 getlocationpath
 139
 140      getlocationpath($location)
 141
 142 Returns the path to a specific location
 143
 144 =cut
 145
 146 sub getlocationpath {
 147      my ($location) = @_;
 148      if (defined $location and $location eq 'archive') {
 149           return "$config{spool_dir}/archive";
 150      } elsif (defined $location and $location eq 'db') {
 151           return "$config{spool_dir}/db";
 152      } else {
 153           return "$config{spool_dir}/db-h";
 154      }
 155 }
 156
 157
 158 =head2 get_hashname
 159
 160      get_hashname
 161
 162 Returns the hash of the bug which is the location within the archive
 163
 164 =cut
 165
 166 sub get_hashname {
 167     return "" if ( $_[ 0 ] < 0 );
 168     return sprintf "%02d", $_[ 0 ] % 100;
 169 }
 170
 171 =head2 buglog
 172
 173      buglog($bugnum);
 174
 175 Returns the path to the logfile corresponding to the bug.
 176
 177 Returns undef if the bug does not exist.
 178
 179 =cut
 180
 181 sub buglog {
 182     my $bugnum = shift;
 183     my $location = getbuglocation($bugnum, 'log');
 184     return getbugcomponent($bugnum, 'log', $location) if ($location);
 185     $location = getbuglocation($bugnum, 'log.gz');
 186     return getbugcomponent($bugnum, 'log.gz', $location) if ($location);
 187     return undef;
 188 }
 189
 190 =head2 bug_status
 191
 192      bug_status($bugnum)
 193
 194
 195 Returns the path to the summary file corresponding to the bug.
 196
 197 Returns undef if the bug does not exist.
 198
 199 =cut
 200
 201 sub bug_status{
 202     my ($bugnum) = @_;
 203     my $location = getbuglocation($bugnum, 'summary');
 204     return getbugcomponent($bugnum, 'summary', $location) if ($location);
 205     return undef;
 206 }
 207
 208 =head2 appendfile
 209
 210      appendfile($file,'data','to','append');
 211
 212 Opens a file for appending and writes data to it.
 213
 214 =cut
 215
 216 sub appendfile {
 217         my ($file,@data) = @_;
 218         my $fh = IO::File->new($file,'a') or
 219              die "Unable top open $file for appending: $!";
 220         print {$fh} @data or die "Unable to write to $file: $!";
 221         close $fh or die "Unable to close $file: $!";
 222 }
 223
 224 =head2 overwritefile
 225
 226      ovewritefile($file,'data','to','append');
 227
 228 Opens file.new, writes data to it, then moves file.new to file.
 229
 230 =cut
 231
 232 sub overwritefile {
 233         my ($file,@data) = @_;
 234         my $fh = IO::File->new("${file}.new",'w') or
 235              die "Unable top open ${file}.new for writing: $!";
 236         print {$fh} @data or die "Unable to write to ${file}.new: $!";
 237         close $fh or die "Unable to close ${file}.new: $!";
 238         rename("${file}.new",$file) or
 239             die "Unable to rename ${file}.new to $file: $!";
 240 }
 241
 242
 243
 244
 245
 246 =head2 getparsedaddrs
 247
 248      my $address = getparsedaddrs($address);
 249      my @address = getparsedaddrs($address);
 250
 251 Returns the output from Mail::Address->parse, or the cached output if
 252 this address has been parsed before. In SCALAR context returns the
 253 first address parsed.
 254
 255 =cut
 256
 257
 258 our %_parsedaddrs;
 259 sub getparsedaddrs {
 260     my $addr = shift;
 261     return () unless defined $addr;
 262     return wantarray?@{$_parsedaddrs{$addr}}:$_parsedaddrs{$addr}[0]
 263          if exists $_parsedaddrs{$addr};
 264     {
 265          # don't display the warnings from Mail::Address->parse
 266          local $SIG{__WARN__} = sub { };
 267          @{$_parsedaddrs{$addr}} = Mail::Address->parse($addr);
 268     }
 269     return wantarray?@{$_parsedaddrs{$addr}}:$_parsedaddrs{$addr}[0];
 270 }
 271
 272 =head2 getmaintainers
 273
 274      my $maintainer = getmaintainers()->{debbugs}
 275
 276 Returns a hashref of package => maintainer pairs.
 277
 278 =cut
 279
 280 our $_maintainer = undef;
 281 our $_maintainer_rev = undef;
 282 sub getmaintainers {
 283     return $_maintainer if defined $_maintainer;
 284     package_maintainer(rehash => 1);
 285     return $_maintainer;
 286 }
 287
 288 =head2 getmaintainers_reverse
 289
 290      my @packages = @{getmaintainers_reverse->{'don@debian.org'}||[]};
 291
 292 Returns a hashref of maintainer => [qw(list of packages)] pairs.
 293
 294 =cut
 295
 296 sub getmaintainers_reverse{
 297      return $_maintainer_rev if defined $_maintainer_rev;
 298      package_maintainer(rehash => 1);
 299      return $_maintainer_rev;
 300 }
 301
 302 =head2 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 and length $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 and length $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} and
 475         length $config{pseudo_desc_file};
 476     return $_pseudodesc;
 477 }
 478
 479 =head2 sort_versions
 480
 481      sort_versions('1.0-2','1.1-2');
 482
 483 Sorts versions using AptPkg::Versions::compare if it is available, or
 484 Debbugs::Versions::Dpkg::vercmp if it isn't.
 485
 486 =cut
 487
 488 our $vercmp;
 489 BEGIN{
 490     use Debbugs::Versions::Dpkg;
 491     $vercmp=\&Debbugs::Versions::Dpkg::vercmp;
 492
 493 # eventually we'll use AptPkg:::Version or similar, but the current
 494 # implementation makes this *super* difficult.
 495
 496 #     eval {
 497 #       use AptPkg::Version;
 498 #       $vercmp=\&AptPkg::Version::compare;
 499 #     };
 500 }
 501
 502 sub sort_versions{
 503     return sort {$vercmp->($a,$b)} @_;
 504 }
 505
 506
 507 =head1 DATE
 508
 509     my $english = secs_to_english($seconds);
 510     my ($days,$english) = secs_to_english($seconds);
 511
 512 XXX This should probably be changed to use Date::Calc
 513
 514 =cut
 515
 516 sub secs_to_english{
 517      my ($seconds) = @_;
 518
 519      my $days = int($seconds / 86400);
 520      my $years = int($days / 365);
 521      $days %= 365;
 522      my $result;
 523      my @age;
 524      push @age, "1 year" if ($years == 1);
 525      push @age, "$years years" if ($years > 1);
 526      push @age, "1 day" if ($days == 1);
 527      push @age, "$days days" if ($days > 1);
 528      $result .= join(" and ", @age);
 529
 530      return wantarray?(int($seconds/86400),$result):$result;
 531 }
 532
 533
 534 =head1 LOCK
 535
 536 These functions are exported with the :lock tag
 537
 538 =head2 filelock
 539
 540      filelock($lockfile);
 541      filelock($lockfile,$locks);
 542
 543 FLOCKs the passed file. Use unfilelock to unlock it.
 544
 545 Can be passed an optional $locks hashref, which is used to track which
 546 files are locked (and how many times they have been locked) to allow
 547 for cooperative locking.
 548
 549 =cut
 550
 551 our @filelocks;
 552
 553 use Carp qw(cluck);
 554
 555 sub filelock {
 556     # NB - NOT COMPATIBLE WITH `with-lock'
 557     my ($lockfile,$locks) = @_;
 558     if ($lockfile !~ m{^/}) {
 559          $lockfile = cwd().'/'.$lockfile;
 560     }
 561     # This is only here to allow for relocking bugs inside of
 562     # Debbugs::Control. Nothing else should be using it.
 563     if (defined $locks and exists $locks->{locks}{$lockfile} and
 564         $locks->{locks}{$lockfile} >= 1) {
 565         if (exists $locks->{relockable} and
 566             exists $locks->{relockable}{$lockfile}) {
 567             $locks->{locks}{$lockfile}++;
 568             # indicate that the bug for this lockfile needs to be reread
 569             $locks->{relockable}{$lockfile} = 1;
 570             push @{$locks->{lockorder}},$lockfile;
 571             return;
 572         }
 573         else {
 574             use Data::Dumper;
 575             confess "Locking already locked file: $lockfile\n".Data::Dumper->Dump([$lockfile,$locks],[qw(lockfile locks)]);
 576         }
 577     }
 578     my ($fh,$t_lockfile,$errors) =
 579         simple_filelock($lockfile,10,1);
 580     if ($fh) {
 581         push @filelocks, {fh => $fh, file => $lockfile};
 582         if (defined $locks) {
 583             $locks->{locks}{$lockfile}++;
 584             push @{$locks->{lockorder}},$lockfile;
 585         }
 586     } else {
 587         use Data::Dumper;
 588         croak "failed to get lock on $lockfile -- $errors".
 589             (defined $locks?Data::Dumper->Dump([$locks],[qw(locks)]):'');
 590     }
 591 }
 592
 593 =head2 simple_filelock
 594
 595     my ($fh,$t_lockfile,$errors) =
 596         simple_filelock($lockfile,$count,$wait);
 597
 598 Does a flock of lockfile. If C<$count> is zero, does a blocking lock.
 599 Otherwise, does a non-blocking lock C<$count> times, waiting C<$wait>
 600 seconds in between.
 601
 602 In list context, returns the lockfile filehandle, lockfile name, and
 603 any errors which occured.
 604
 605 When the lockfile filehandle is undef, locking failed.
 606
 607 These lockfiles must be unlocked manually at process end.
 608
 609
 610 =cut
 611
 612 sub simple_filelock {
 613     my ($lockfile,$count,$wait) = @_;
 614     if (not defined $count) {
 615         $count = 10;
 616     }
 617     if ($count < 0) {
 618         $count = 0;
 619     }
 620     if (not defined $wait) {
 621         $wait = 1;
 622     }
 623     my $errors= '';
 624     my $fh;
 625     while (1) {
 626         $fh = eval {
 627              my $fh2 = IO::File->new($lockfile,'w')
 628                   or die "Unable to open $lockfile for writing: $!";
 629              # Do a blocking lock if count is zero
 630              flock($fh2,LOCK_EX|($count == 0?0:LOCK_NB))
 631                   or die "Unable to lock $lockfile $!";
 632              return $fh2;
 633         };
 634         if ($@) {
 635              $errors .= $@;
 636         }
 637         if ($fh) {
 638             last;
 639         }
 640         # use usleep for fractional wait seconds
 641         usleep($wait * 1_000_000);
 642     } continue {
 643         last unless (--$count > 0);
 644     }
 645     if ($fh) {
 646         return wantarray?($fh,$lockfile,$errors):$fh
 647     }
 648     return wantarray?(undef,$lockfile,$errors):undef;
 649 }
 650
 651 # clean up all outstanding locks at end time
 652 END {
 653      while (@filelocks) {
 654           unfilelock();
 655      }
 656 }
 657
 658 =head2 simple_unlockfile
 659
 660      simple_unlockfile($fh,$lockfile);
 661
 662
 663 =cut
 664
 665 sub simple_unlockfile {
 666     my ($fh,$lockfile) = @_;
 667     flock($fh,LOCK_UN)
 668         or warn "Unable to unlock lockfile $lockfile: $!";
 669     close($fh)
 670         or warn "Unable to close lockfile $lockfile: $!";
 671     unlink($lockfile)
 672         or warn "Unable to unlink lockfile $lockfile: $!";
 673 }
 674
 675
 676 =head2 unfilelock
 677
 678      unfilelock()
 679      unfilelock($locks);
 680
 681 Unlocks the file most recently locked.
 682
 683 Note that it is not currently possible to unlock a specific file
 684 locked with filelock.
 685
 686 =cut
 687
 688 sub unfilelock {
 689     my ($locks) = @_;
 690     if (@filelocks == 0) {
 691         carp "unfilelock called with no active filelocks!\n";
 692         return;
 693     }
 694     if (defined $locks and ref($locks) ne 'HASH') {
 695         croak "hash not passsed to unfilelock";
 696     }
 697     if (defined $locks and exists $locks->{lockorder} and
 698         @{$locks->{lockorder}} and
 699         exists $locks->{locks}{$locks->{lockorder}[-1]}) {
 700         my $lockfile = pop @{$locks->{lockorder}};
 701         $locks->{locks}{$lockfile}--;
 702         if ($locks->{locks}{$lockfile} > 0) {
 703             return
 704         }
 705         delete $locks->{locks}{$lockfile};
 706     }
 707     my %fl = %{pop(@filelocks)};
 708     simple_unlockfile($fl{fh},$fl{file});
 709 }
 710
 711
 712 =head2 lockpid
 713
 714       lockpid('/path/to/pidfile');
 715
 716 Creates a pidfile '/path/to/pidfile' if one doesn't exist or if the
 717 pid in the file does not respond to kill 0.
 718
 719 Returns 1 on success, false on failure; dies on unusual errors.
 720
 721 =cut
 722
 723 sub lockpid {
 724      my ($pidfile) = @_;
 725      if (-e $pidfile) {
 726           my $pid = checkpid($pidfile);
 727           die "Unable to read pidfile $pidfile: $!" if not defined $pid;
 728           return 0 if $pid != 0;
 729           unlink $pidfile or
 730                die "Unable to unlink stale pidfile $pidfile $!";
 731      }
 732      my $pidfh = IO::File->new($pidfile,O_CREAT|O_EXCL|O_WRONLY) or
 733           die "Unable to open $pidfile for writing: $!";
 734      print {$pidfh} $$ or die "Unable to write to $pidfile $!";
 735      close $pidfh or die "Unable to close $pidfile $!";
 736      return 1;
 737 }
 738
 739 =head2 checkpid
 740
 741      checkpid('/path/to/pidfile');
 742
 743 Checks a pid file and determines if the process listed in the pidfile
 744 is still running. Returns the pid if it is, 0 if it isn't running, and
 745 undef if the pidfile doesn't exist or cannot be read.
 746
 747 =cut
 748
 749 sub checkpid{
 750      my ($pidfile) = @_;
 751      if (-e $pidfile) {
 752           my $pidfh = IO::File->new($pidfile, 'r') or
 753                return undef;
 754           local $/;
 755           my $pid = <$pidfh>;
 756           close $pidfh;
 757           ($pid) = $pid =~ /(\d+)/;
 758           if (defined $pid and kill(0,$pid)) {
 759                return $pid;
 760           }
 761           return 0;
 762      }
 763      else {
 764           return undef;
 765      }
 766 }
 767
 768
 769 =head1 QUIT
 770
 771 These functions are exported with the :quit tag.
 772
 773 =head2 quit
 774
 775      quit()
 776
 777 Exits the program by calling die.
 778
 779 Usage of quit is deprecated; just call die instead.
 780
 781 =cut
 782
 783 sub quit {
 784      print {$DEBUG_FH} "quitting >$_[0]<\n" if $DEBUG;
 785      carp "quit() is deprecated; call die directly instead";
 786 }
 787
 788
 789 =head1 MISC
 790
 791 These functions are exported with the :misc tag
 792
 793 =head2 make_list
 794
 795      LIST = make_list(@_);
 796
 797 Turns a scalar or an arrayref into a list; expands a list of arrayrefs
 798 into a list.
 799
 800 That is, make_list([qw(a b c)]); returns qw(a b c); make_list([qw(a
 801 b)],[qw(c d)] returns qw(a b c d);
 802
 803 =cut
 804
 805 sub make_list {
 806      return map {(ref($_) eq 'ARRAY')?@{$_}:$_} @_;
 807 }
 808
 809
 810 =head2 english_join
 811
 812      print english_join(list => \@list);
 813      print english_join(\@list);
 814
 815 Joins list properly to make an english phrase.
 816
 817 =over
 818
 819 =item normal -- how to separate most values; defaults to ', '
 820
 821 =item last -- how to separate the last two values; defaults to ', and '
 822
 823 =item only_two -- how to separate only two values; defaults to ' and '
 824
 825 =item list -- ARRAYREF values to join; if the first argument is an
 826 ARRAYREF, it's assumed to be the list of values to join
 827
 828 =back
 829
 830 In cases where C<list> is empty, returns ''; when there is only one
 831 element, returns that element.
 832
 833 =cut
 834
 835 sub english_join {
 836     if (ref $_[0] eq 'ARRAY') {
 837         return english_join(list=>$_[0]);
 838     }
 839     my %param = validate_with(params => \@_,
 840                               spec  => {normal => {type => SCALAR,
 841                                                    default => ', ',
 842                                                   },
 843                                         last   => {type => SCALAR,
 844                                                    default => ', and ',
 845                                                   },
 846                                         only_two => {type => SCALAR,
 847                                                      default => ' and ',
 848                                                     },
 849                                         list     => {type => ARRAYREF,
 850                                                     },
 851                                        },
 852                              );
 853     my @list = @{$param{list}};
 854     if (@list <= 1) {
 855         return @list?$list[0]:'';
 856     }
 857     elsif (@list == 2) {
 858         return join($param{only_two},@list);
 859     }
 860     my $ret = $param{last} . pop(@list);
 861     return join($param{normal},@list) . $ret;
 862 }
 863
 864
 865 =head2 globify_scalar
 866
 867      my $handle = globify_scalar(\$foo);
 868
 869 if $foo isn't already a glob or a globref, turn it into one using
 870 IO::Scalar. Gives a new handle to /dev/null if $foo isn't defined.
 871
 872 Will carp if given a scalar which isn't a scalarref or a glob (or
 873 globref), and return /dev/null. May return undef if IO::Scalar or
 874 IO::File fails. (Check $!)
 875
 876 The scalar will fill with octets, not perl's internal encoding, so you
 877 must use decode_utf8() after on the scalar, and encode_utf8() on it
 878 before. This appears to be a bug in the underlying modules.
 879
 880 =cut
 881
 882 sub globify_scalar {
 883      my ($scalar) = @_;
 884      my $handle;
 885      if (defined $scalar) {
 886           if (defined ref($scalar)) {
 887                if (ref($scalar) eq 'SCALAR' and
 888                    not UNIVERSAL::isa($scalar,'GLOB')) {
 889                    if (is_utf8(${$scalar})) {
 890                        ${$scalar} = decode_utf8(${$scalar});
 891                        carp(q(\$scalar must not be in perl's internal encoding));
 892                    }
 893                     open $handle, '>:scalar:utf8', $scalar;
 894                     return $handle;
 895                }
 896                else {
 897                     return $scalar;
 898                }
 899           }
 900           elsif (UNIVERSAL::isa(\$scalar,'GLOB')) {
 901                return $scalar;
 902           }
 903           else {
 904                carp "Given a non-scalar reference, non-glob to globify_scalar; returning /dev/null handle";
 905           }
 906      }
 907      return IO::File->new('/dev/null','>:encoding(UTF-8)');
 908 }
 909
 910 =head2 cleanup_eval_fail()
 911
 912      print "Something failed with: ".cleanup_eval_fail($@);
 913
 914 Does various bits of cleanup on the failure message from an eval (or
 915 any other die message)
 916
 917 Takes at most two options; the first is the actual failure message
 918 (usually $@ and defaults to $@), the second is the debug level
 919 (defaults to $DEBUG).
 920
 921 If debug is non-zero, the code at which the failure occured is output.
 922
 923 =cut
 924
 925 sub cleanup_eval_fail {
 926     my ($error,$debug) = @_;
 927     if (not defined $error or not @_) {
 928         $error = $@ // 'unknown reason';
 929     }
 930     if (@_ <= 1) {
 931         $debug = $DEBUG // 0;
 932     }
 933     $debug = 0 if not defined $debug;
 934
 935     if ($debug > 0) {
 936         return $error;
 937     }
 938     # ditch the "at foo/bar/baz.pm line 5"
 939     $error =~ s/\sat\s\S+\sline\s\d+//;
 940     # ditch croak messages
 941     $error =~ s/^\t+.+\n?//mg;
 942     # ditch trailing multiple periods in case there was a cascade of
 943     # die messages.
 944     $error =~ s/\.+$/\./;
 945     return $error;
 946 }
 947
 948 =head2 hash_slice
 949
 950      hash_slice(%hash,qw(key1 key2 key3))
 951
 952 For each key, returns matching values and keys of the hash if they exist
 953
 954 =cut
 955
 956
 957 # NB: We use prototypes here SPECIFICALLY so that we can be passed a
 958 # hash without uselessly making a reference to first. DO NOT USE
 959 # PROTOTYPES USELESSLY ELSEWHERE.
 960 sub hash_slice(\%@) {
 961     my ($hashref,@keys) = @_;
 962     return map {exists $hashref->{$_}?($_,$hashref->{$_}):()} @keys;
 963 }
 964
 965
 966 1;
 967
 968 __END__