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