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