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 maintainer -- scalar or arrayref of maintainers to return source packages
 501 for. If given, binary and source cannot be given.
 502
 503 =item rehash -- whether to reread the maintainer and source maintainer
 504 files; defaults to 0
 505
 506 =item schema -- Debbugs::DB schema. If set, uses the database for maintainer
 507 information.
 508
 509 =back
 510
 511 =cut
 512
 513 sub package_maintainer {
 514     my %param = validate_with(params => \@_,
 515                               spec   => {source => {type => SCALAR|ARRAYREF,
 516                                                     default => [],
 517                                                    },
 518                                          binary => {type => SCALAR|ARRAYREF,
 519                                                     default => [],
 520                                                    },
 521                                          maintainer => {type => SCALAR|ARRAYREF,
 522                                                         default => [],
 523                                                        },
 524                                          rehash => {type => BOOLEAN,
 525                                                     default => 0,
 526                                                    },
 527                                          reverse => {type => BOOLEAN,
 528                                                      default => 0,
 529                                                     },
 530                                          schema => {type => OBJECT,
 531                                                     optional => 1,
 532                                                    }
 533                                         },
 534                              );
 535     my @binary = make_list($param{binary});
 536     my @source = make_list($param{source});
 537     my @maintainers = make_list($param{maintainer});
 538     if ((@binary or @source) and @maintainers) {
 539         croak "It is nonsensical to pass both maintainers and source or binary";
 540     }
 541     if (@binary) {
 542         @source = grep {/^src:/} @binary;
 543         @binary = grep {!/^src:/} @binary;
 544     }
 545     # remove leading src: from source package names
 546     s/^src:// foreach @source;
 547     if ($param{schema}) {
 548         my $s = $param{schema};
 549         if (@maintainers) {
 550             my $m_rs = $s->resultset('SrcPkg')->
 551                 search({'correspondent.addr' => [@maintainers]},
 552                       {join => {src_vers =>
 553                                {maintainer =>
 554                                 'correspondent'},
 555                                },
 556                        columns => ['pkg'],
 557                        group_by => [qw(me.pkg)],
 558                        });
 559             return $m_rs->get_column('pkg')->all();
 560         } elsif (@binary or @source) {
 561             my $rs = $s->resultset('Maintainer');
 562             if (@binary) {
 563                 $rs =
 564                     $rs->search({'bin_pkg.pkg' => [@binary]},
 565                                {join => {src_vers =>
 566                                         {bin_vers => 'bin_pkg'},
 567                                         },
 568                                 columns => ['name'],
 569                                 group_by => [qw(me.name)],
 570                                }
 571                                );
 572             }
 573             if (@source) {
 574                 $rs =
 575                     $rs->search({'src_pkg.pkg' => [@source]},
 576                                {join => {src_vers =>
 577                                          'src_pkg',
 578                                         },
 579                                 columns => ['name'],
 580                                 group_by => [qw(me.name)],
 581                                }
 582                                );
 583             }
 584             return $rs->get_column('name')->all();
 585         }
 586         return ();
 587     }
 588     if ($param{rehash}) {
 589         $_source_maintainer = undef;
 590         $_source_maintainer_rev = undef;
 591         $_maintainer = undef;
 592         $_maintainer_rev = undef;
 593     }
 594     if (not defined $_source_maintainer or
 595         not defined $_source_maintainer_rev) {
 596         $_source_maintainer = {};
 597         $_source_maintainer_rev = {};
 598         if (-e $config{spool_dir}.'/source_maintainers.idx' and
 599             -e $config{spool_dir}.'/source_maintainers_reverse.idx'
 600            ) {
 601             tie %{$_source_maintainer},
 602                 MLDBM => $config{spool_dir}.'/source_maintainers.idx',
 603                 O_RDONLY or
 604                 die "Unable to tie source maintainers: $!";
 605             tie %{$_source_maintainer_rev},
 606                 MLDBM => $config{spool_dir}.'/source_maintainers_reverse.idx',
 607                 O_RDONLY or
 608                 die "Unable to tie source maintainers reverse: $!";
 609         } else {
 610             for my $fn (@config{('source_maintainer_file',
 611                                  'source_maintainer_file_override',
 612                                  'pseudo_maint_file')}) {
 613                 next unless defined $fn and length $fn;
 614                 if (not -e $fn) {
 615                     warn "Missing source maintainer file '$fn'";
 616                     next;
 617                 }
 618                 __add_to_hash($fn,$_source_maintainer,
 619                               $_source_maintainer_rev);
 620             }
 621         }
 622     }
 623     if (not defined $_maintainer or
 624         not defined $_maintainer_rev) {
 625         $_maintainer = {};
 626         $_maintainer_rev = {};
 627         if (-e $config{spool_dir}.'/maintainers.idx' and
 628             -e $config{spool_dir}.'/maintainers_reverse.idx'
 629            ) {
 630             tie %{$_maintainer},
 631                 MLDBM => $config{spool_dir}.'/binary_maintainers.idx',
 632                 O_RDONLY or
 633                 die "Unable to tie binary maintainers: $!";
 634             tie %{$_maintainer_rev},
 635                 MLDBM => $config{spool_dir}.'/binary_maintainers_reverse.idx',
 636                 O_RDONLY or
 637                 die "Unable to binary maintainers reverse: $!";
 638         } else {
 639             for my $fn (@config{('maintainer_file',
 640                                  'maintainer_file_override',
 641                                  'pseudo_maint_file')}) {
 642                 next unless defined $fn and length $fn;
 643                 if (not -e $fn) {
 644                     warn "Missing maintainer file '$fn'";
 645                     next;
 646                 }
 647                 __add_to_hash($fn,$_maintainer,
 648                               $_maintainer_rev);
 649             }
 650         }
 651     }
 652     my @return;
 653     for my $binary (@binary) {
 654         if ($binary =~ /^src:/) {
 655             push @source,$binary;
 656             next;
 657         }
 658         push @return,grep {defined $_} make_list($_maintainer->{$binary});
 659     }
 660     for my $source (@source) {
 661         $source =~ s/^src://;
 662         push @return,grep {defined $_} make_list($_source_maintainer->{$source});
 663     }
 664     for my $maintainer (grep {defined $_} @maintainers) {
 665         push @return,grep {defined $_}
 666             make_list($_maintainer_rev->{$maintainer});
 667         push @return,map {$_ !~ /^src:/?'src:'.$_:$_}
 668             grep {defined $_}
 669                 make_list($_source_maintainer_rev->{$maintainer});
 670     }
 671     return @return;
 672 }
 673
 674 #=head2 __add_to_hash
 675 #
 676 #     __add_to_hash($file,$forward_hash,$reverse_hash,'address');
 677 #
 678 # Reads a maintainer/source maintainer/pseudo desc file and adds the
 679 # maintainers from it to the forward and reverse hashref; assumes that
 680 # the forward is unique; makes no assumptions of the reverse.
 681 #
 682 #=cut
 683
 684 sub __add_to_hash {
 685     my ($fn,$forward,$reverse,$type) = @_;
 686     if (ref($forward) ne 'HASH') {
 687         croak "__add_to_hash must be passed a hashref for the forward";
 688     }
 689     if (defined $reverse and not ref($reverse) eq 'HASH') {
 690         croak "if reverse is passed to __add_to_hash, it must be a hashref";
 691     }
 692     $type //= 'address';
 693     my $fh = IO::File->new($fn,'r') or
 694         croak "Unable to open $fn for reading: $!";
 695     binmode($fh,':encoding(UTF-8)');
 696     while (<$fh>) {
 697         chomp;
 698         next unless m/^(\S+)\s+(\S.*\S)\s*$/;
 699         my ($key,$value)=($1,$2);
 700         $key = lc $key;
 701         $forward->{$key}= $value;
 702         if (defined $reverse) {
 703             if ($type eq 'address') {
 704                 for my $m (map {lc($_->address)} (getparsedaddrs($value))) {
 705                     push @{$reverse->{$m}},$key;
 706                 }
 707             }
 708             else {
 709                 push @{$reverse->{$value}}, $key;
 710             }
 711         }
 712     }
 713 }
 714
 715
 716 =head2 getpseudodesc
 717
 718      my $pseudopkgdesc = getpseudodesc(...);
 719
 720 Returns the entry for a pseudo package from the
 721 $config{pseudo_desc_file}. In cases where pseudo_desc_file is not
 722 defined, returns an empty arrayref.
 723
 724 This function can be used to see if a particular package is a
 725 pseudopackage or not.
 726
 727 =cut
 728
 729 our $_pseudodesc = undef;
 730 sub getpseudodesc {
 731     return $_pseudodesc if defined $_pseudodesc;
 732     $_pseudodesc = {};
 733     __add_to_hash($config{pseudo_desc_file},$_pseudodesc) if
 734         defined $config{pseudo_desc_file} and
 735         length $config{pseudo_desc_file};
 736     return $_pseudodesc;
 737 }
 738
 739 =head2 sort_versions
 740
 741      sort_versions('1.0-2','1.1-2');
 742
 743 Sorts versions using AptPkg::Versions::compare if it is available, or
 744 Debbugs::Versions::Dpkg::vercmp if it isn't.
 745
 746 =cut
 747
 748 our $vercmp;
 749 BEGIN{
 750     use Debbugs::Versions::Dpkg;
 751     $vercmp=\&Debbugs::Versions::Dpkg::vercmp;
 752
 753 # eventually we'll use AptPkg:::Version or similar, but the current
 754 # implementation makes this *super* difficult.
 755
 756 #     eval {
 757 #       use AptPkg::Version;
 758 #       $vercmp=\&AptPkg::Version::compare;
 759 #     };
 760 }
 761
 762 sub sort_versions{
 763     return sort {$vercmp->($a,$b)} @_;
 764 }
 765
 766
 767 =head1 DATE
 768
 769     my $english = secs_to_english($seconds);
 770     my ($days,$english) = secs_to_english($seconds);
 771
 772 XXX This should probably be changed to use Date::Calc
 773
 774 =cut
 775
 776 sub secs_to_english{
 777      my ($seconds) = @_;
 778
 779      my $days = int($seconds / 86400);
 780      my $years = int($days / 365);
 781      $days %= 365;
 782      my $result;
 783      my @age;
 784      push @age, "1 year" if ($years == 1);
 785      push @age, "$years years" if ($years > 1);
 786      push @age, "1 day" if ($days == 1);
 787      push @age, "$days days" if ($days > 1);
 788      $result .= join(" and ", @age);
 789
 790      return wantarray?(int($seconds/86400),$result):$result;
 791 }
 792
 793
 794 =head1 LOCK
 795
 796 These functions are exported with the :lock tag
 797
 798 =head2 filelock
 799
 800      filelock($lockfile);
 801      filelock($lockfile,$locks);
 802
 803 FLOCKs the passed file. Use unfilelock to unlock it.
 804
 805 Can be passed an optional $locks hashref, which is used to track which
 806 files are locked (and how many times they have been locked) to allow
 807 for cooperative locking.
 808
 809 =cut
 810
 811 our @filelocks;
 812
 813 use Carp qw(cluck);
 814
 815 sub filelock {
 816     # NB - NOT COMPATIBLE WITH `with-lock'
 817     my ($lockfile,$locks) = @_;
 818     if ($lockfile !~ m{^/}) {
 819          $lockfile = cwd().'/'.$lockfile;
 820     }
 821     # This is only here to allow for relocking bugs inside of
 822     # Debbugs::Control. Nothing else should be using it.
 823     if (defined $locks and exists $locks->{locks}{$lockfile} and
 824         $locks->{locks}{$lockfile} >= 1) {
 825         if (exists $locks->{relockable} and
 826             exists $locks->{relockable}{$lockfile}) {
 827             $locks->{locks}{$lockfile}++;
 828             # indicate that the bug for this lockfile needs to be reread
 829             $locks->{relockable}{$lockfile} = 1;
 830             push @{$locks->{lockorder}},$lockfile;
 831             return;
 832         }
 833         else {
 834             use Data::Dumper;
 835             confess "Locking already locked file: $lockfile\n".Data::Dumper->Dump([$lockfile,$locks],[qw(lockfile locks)]);
 836         }
 837     }
 838     my ($fh,$t_lockfile,$errors) =
 839         simple_filelock($lockfile,10,1);
 840     if ($fh) {
 841         push @filelocks, {fh => $fh, file => $lockfile};
 842         if (defined $locks) {
 843             $locks->{locks}{$lockfile}++;
 844             push @{$locks->{lockorder}},$lockfile;
 845         }
 846     } else {
 847         use Data::Dumper;
 848         croak "failed to get lock on $lockfile -- $errors".
 849             (defined $locks?Data::Dumper->Dump([$locks],[qw(locks)]):'');
 850     }
 851 }
 852
 853 =head2 simple_filelock
 854
 855     my ($fh,$t_lockfile,$errors) =
 856         simple_filelock($lockfile,$count,$wait);
 857
 858 Does a flock of lockfile. If C<$count> is zero, does a blocking lock.
 859 Otherwise, does a non-blocking lock C<$count> times, waiting C<$wait>
 860 seconds in between.
 861
 862 In list context, returns the lockfile filehandle, lockfile name, and
 863 any errors which occured.
 864
 865 When the lockfile filehandle is undef, locking failed.
 866
 867 These lockfiles must be unlocked manually at process end.
 868
 869
 870 =cut
 871
 872 sub simple_filelock {
 873     my ($lockfile,$count,$wait) = @_;
 874     if (not defined $count) {
 875         $count = 10;
 876     }
 877     if ($count < 0) {
 878         $count = 0;
 879     }
 880     if (not defined $wait) {
 881         $wait = 1;
 882     }
 883     my $errors= '';
 884     my $fh;
 885     while (1) {
 886         $fh = eval {
 887              my $fh2 = IO::File->new($lockfile,'w')
 888                   or die "Unable to open $lockfile for writing: $!";
 889              # Do a blocking lock if count is zero
 890              flock($fh2,LOCK_EX|($count == 0?0:LOCK_NB))
 891                   or die "Unable to lock $lockfile $!";
 892              return $fh2;
 893         };
 894         if ($@) {
 895              $errors .= $@;
 896         }
 897         if ($fh) {
 898             last;
 899         }
 900         # use usleep for fractional wait seconds
 901         usleep($wait * 1_000_000);
 902     } continue {
 903         last unless (--$count > 0);
 904     }
 905     if ($fh) {
 906         return wantarray?($fh,$lockfile,$errors):$fh
 907     }
 908     return wantarray?(undef,$lockfile,$errors):undef;
 909 }
 910
 911 # clean up all outstanding locks at end time
 912 END {
 913      while (@filelocks) {
 914           unfilelock();
 915      }
 916 }
 917
 918 =head2 simple_unlockfile
 919
 920      simple_unlockfile($fh,$lockfile);
 921
 922
 923 =cut
 924
 925 sub simple_unlockfile {
 926     my ($fh,$lockfile) = @_;
 927     flock($fh,LOCK_UN)
 928         or warn "Unable to unlock lockfile $lockfile: $!";
 929     close($fh)
 930         or warn "Unable to close lockfile $lockfile: $!";
 931     unlink($lockfile)
 932         or warn "Unable to unlink lockfile $lockfile: $!";
 933 }
 934
 935
 936 =head2 unfilelock
 937
 938      unfilelock()
 939      unfilelock($locks);
 940
 941 Unlocks the file most recently locked.
 942
 943 Note that it is not currently possible to unlock a specific file
 944 locked with filelock.
 945
 946 =cut
 947
 948 sub unfilelock {
 949     my ($locks) = @_;
 950     if (@filelocks == 0) {
 951         carp "unfilelock called with no active filelocks!\n";
 952         return;
 953     }
 954     if (defined $locks and ref($locks) ne 'HASH') {
 955         croak "hash not passsed to unfilelock";
 956     }
 957     if (defined $locks and exists $locks->{lockorder} and
 958         @{$locks->{lockorder}} and
 959         exists $locks->{locks}{$locks->{lockorder}[-1]}) {
 960         my $lockfile = pop @{$locks->{lockorder}};
 961         $locks->{locks}{$lockfile}--;
 962         if ($locks->{locks}{$lockfile} > 0) {
 963             return
 964         }
 965         delete $locks->{locks}{$lockfile};
 966     }
 967     my %fl = %{pop(@filelocks)};
 968     simple_unlockfile($fl{fh},$fl{file});
 969 }
 970
 971
 972 =head2 lockpid
 973
 974       lockpid('/path/to/pidfile');
 975
 976 Creates a pidfile '/path/to/pidfile' if one doesn't exist or if the
 977 pid in the file does not respond to kill 0.
 978
 979 Returns 1 on success, false on failure; dies on unusual errors.
 980
 981 =cut
 982
 983 sub lockpid {
 984      my ($pidfile) = @_;
 985      if (-e $pidfile) {
 986           my $pid = checkpid($pidfile);
 987           die "Unable to read pidfile $pidfile: $!" if not defined $pid;
 988           return 0 if $pid != 0;
 989           unlink $pidfile or
 990                die "Unable to unlink stale pidfile $pidfile $!";
 991      }
 992      mkpath(dirname($pidfile));
 993      my $pidfh = IO::File->new($pidfile,O_CREAT|O_EXCL|O_WRONLY) or
 994           die "Unable to open $pidfile for writing: $!";
 995      print {$pidfh} $$ or die "Unable to write to $pidfile $!";
 996      close $pidfh or die "Unable to close $pidfile $!";
 997      return 1;
 998 }
 999
1000 =head2 checkpid
1001
1002      checkpid('/path/to/pidfile');
1003
1004 Checks a pid file and determines if the process listed in the pidfile
1005 is still running. Returns the pid if it is, 0 if it isn't running, and
1006 undef if the pidfile doesn't exist or cannot be read.
1007
1008 =cut
1009
1010 sub checkpid{
1011      my ($pidfile) = @_;
1012      if (-e $pidfile) {
1013           my $pidfh = IO::File->new($pidfile, 'r') or
1014                return undef;
1015           local $/;
1016           my $pid = <$pidfh>;
1017           close $pidfh;
1018           ($pid) = $pid =~ /(\d+)/;
1019           if (defined $pid and kill(0,$pid)) {
1020                return $pid;
1021           }
1022           return 0;
1023      }
1024      else {
1025           return undef;
1026      }
1027 }
1028
1029
1030 =head1 QUIT
1031
1032 These functions are exported with the :quit tag.
1033
1034 =head2 quit
1035
1036      quit()
1037
1038 Exits the program by calling die.
1039
1040 Usage of quit is deprecated; just call die instead.
1041
1042 =cut
1043
1044 sub quit {
1045      print {$DEBUG_FH} "quitting >$_[0]<\n" if $DEBUG;
1046      carp "quit() is deprecated; call die directly instead";
1047 }
1048
1049
1050 =head1 MISC
1051
1052 These functions are exported with the :misc tag
1053
1054 =head2 make_list
1055
1056      LIST = make_list(@_);
1057
1058 Turns a scalar or an arrayref into a list; expands a list of arrayrefs
1059 into a list.
1060
1061 That is, make_list([qw(a b c)]); returns qw(a b c); make_list([qw(a
1062 b)],[qw(c d)] returns qw(a b c d);
1063
1064 =cut
1065
1066 sub make_list {
1067      return map {(ref($_) eq 'ARRAY')?@{$_}:$_} @_;
1068 }
1069
1070
1071 =head2 english_join
1072
1073      print english_join(list => \@list);
1074      print english_join(\@list);
1075
1076 Joins list properly to make an english phrase.
1077
1078 =over
1079
1080 =item normal -- how to separate most values; defaults to ', '
1081
1082 =item last -- how to separate the last two values; defaults to ', and '
1083
1084 =item only_two -- how to separate only two values; defaults to ' and '
1085
1086 =item list -- ARRAYREF values to join; if the first argument is an
1087 ARRAYREF, it's assumed to be the list of values to join
1088
1089 =back
1090
1091 In cases where C<list> is empty, returns ''; when there is only one
1092 element, returns that element.
1093
1094 =cut
1095
1096 sub english_join {
1097     if (ref $_[0] eq 'ARRAY') {
1098         return english_join(list=>$_[0]);
1099     }
1100     my %param = validate_with(params => \@_,
1101                               spec  => {normal => {type => SCALAR,
1102                                                    default => ', ',
1103                                                   },
1104                                         last   => {type => SCALAR,
1105                                                    default => ', and ',
1106                                                   },
1107                                         only_two => {type => SCALAR,
1108                                                      default => ' and ',
1109                                                     },
1110                                         list     => {type => ARRAYREF,
1111                                                     },
1112                                        },
1113                              );
1114     my @list = @{$param{list}};
1115     if (@list <= 1) {
1116         return @list?$list[0]:'';
1117     }
1118     elsif (@list == 2) {
1119         return join($param{only_two},@list);
1120     }
1121     my $ret = $param{last} . pop(@list);
1122     return join($param{normal},@list) . $ret;
1123 }
1124
1125
1126 =head2 globify_scalar
1127
1128      my $handle = globify_scalar(\$foo);
1129
1130 if $foo isn't already a glob or a globref, turn it into one using
1131 IO::Scalar. Gives a new handle to /dev/null if $foo isn't defined.
1132
1133 Will carp if given a scalar which isn't a scalarref or a glob (or
1134 globref), and return /dev/null. May return undef if IO::Scalar or
1135 IO::File fails. (Check $!)
1136
1137 The scalar will fill with octets, not perl's internal encoding, so you
1138 must use decode_utf8() after on the scalar, and encode_utf8() on it
1139 before. This appears to be a bug in the underlying modules.
1140
1141 =cut
1142
1143 our $_NULL_HANDLE;
1144
1145 sub globify_scalar {
1146      my ($scalar) = @_;
1147      my $handle;
1148      if (defined $scalar) {
1149           if (defined ref($scalar)) {
1150                if (ref($scalar) eq 'SCALAR' and
1151                    not UNIVERSAL::isa($scalar,'GLOB')) {
1152                    if (is_utf8(${$scalar})) {
1153                        ${$scalar} = decode_utf8(${$scalar});
1154                        carp(q(\$scalar must not be in perl's internal encoding));
1155                    }
1156                     open $handle, '>:scalar:utf8', $scalar;
1157                     return $handle;
1158                }
1159                else {
1160                     return $scalar;
1161                }
1162           }
1163           elsif (UNIVERSAL::isa(\$scalar,'GLOB')) {
1164                return $scalar;
1165           }
1166           else {
1167                carp "Given a non-scalar reference, non-glob to globify_scalar; returning /dev/null handle";
1168           }
1169       }
1170      if (not defined $_NULL_HANDLE or
1171          not $_NULL_HANDLE->opened()
1172         ) {
1173          $_NULL_HANDLE =
1174              IO::File->new('/dev/null','>:encoding(UTF-8)') or
1175                  die "Unable to open /dev/null for writing: $!";
1176      }
1177      return $_NULL_HANDLE;
1178 }
1179
1180 =head2 cleanup_eval_fail()
1181
1182      print "Something failed with: ".cleanup_eval_fail($@);
1183
1184 Does various bits of cleanup on the failure message from an eval (or
1185 any other die message)
1186
1187 Takes at most two options; the first is the actual failure message
1188 (usually $@ and defaults to $@), the second is the debug level
1189 (defaults to $DEBUG).
1190
1191 If debug is non-zero, the code at which the failure occured is output.
1192
1193 =cut
1194
1195 sub cleanup_eval_fail {
1196     my ($error,$debug) = @_;
1197     if (not defined $error or not @_) {
1198         $error = $@ // 'unknown reason';
1199     }
1200     if (@_ <= 1) {
1201         $debug = $DEBUG // 0;
1202     }
1203     $debug = 0 if not defined $debug;
1204
1205     if ($debug > 0) {
1206         return $error;
1207     }
1208     # ditch the "at foo/bar/baz.pm line 5"
1209     $error =~ s/\sat\s\S+\sline\s\d+//;
1210     # ditch croak messages
1211     $error =~ s/^\t+.+\n?//mg;
1212     # ditch trailing multiple periods in case there was a cascade of
1213     # die messages.
1214     $error =~ s/\.+$/\./;
1215     return $error;
1216 }
1217
1218 =head2 hash_slice
1219
1220      hash_slice(%hash,qw(key1 key2 key3))
1221
1222 For each key, returns matching values and keys of the hash if they exist
1223
1224 =cut
1225
1226
1227 # NB: We use prototypes here SPECIFICALLY so that we can be passed a
1228 # hash without uselessly making a reference to first. DO NOT USE
1229 # PROTOTYPES USELESSLY ELSEWHERE.
1230 sub hash_slice(\%@) {
1231     my ($hashref,@keys) = @_;
1232     return map {exists $hashref->{$_}?($_,$hashref->{$_}):()} @keys;
1233 }
1234
1235
1236 1;
1237
1238 __END__