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