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