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