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 base qw(Exporter);
  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 buglog getparsedaddrs getmaintainers),
  43                                 qw(bug_status),
  44                                 qw(getmaintainers_reverse),
  45                                 qw(getpseudodesc),
  46                                 qw(package_maintainer),
  47                                ],
  48                      misc   => [qw(make_list globify_scalar english_join checkpid),
  49                                 qw(cleanup_eval_fail),
  50                                ],
  51                      date   => [qw(secs_to_english)],
  52                      quit   => [qw(quit)],
  53                      lock   => [qw(filelock unfilelock lockpid)],
  54                     );
  55      @EXPORT_OK = ();
  56      Exporter::export_ok_tags(qw(lock quit date util misc));
  57      $EXPORT_TAGS{all} = [@EXPORT_OK];
  58 }
  59
  60 #use Debbugs::Config qw(:globals);
  61
  62 use Carp;
  63
  64 use Debbugs::Config qw(:config);
  65 use IO::File;
  66 use IO::Scalar;
  67 use Debbugs::MIME qw(decode_rfc1522);
  68 use Mail::Address;
  69 use Cwd qw(cwd);
  70
  71 use Params::Validate qw(validate_with :types);
  72
  73 use Fcntl qw(:flock);
  74
  75 our $DEBUG_FH = \*STDERR if not defined $DEBUG_FH;
  76
  77 =head1 UTILITIES
  78
  79 The following functions are exported by the C<:util> tag
  80
  81 =head2 getbugcomponent
  82
  83      my $file = getbugcomponent($bug_number,$extension,$location)
  84
  85 Returns the path to the bug file in location C<$location>, bug number
  86 C<$bugnumber> and extension C<$extension>
  87
  88 =cut
  89
  90 sub getbugcomponent {
  91     my ($bugnum, $ext, $location) = @_;
  92
  93     if (not defined $location) {
  94         $location = getbuglocation($bugnum, $ext);
  95         # Default to non-archived bugs only for now; CGI scripts want
  96         # archived bugs but most of the backend scripts don't. For now,
  97         # anything that is prepared to accept archived bugs should call
  98         # getbuglocation() directly first.
  99         return undef if defined $location and
 100                         ($location ne 'db' and $location ne 'db-h');
 101     }
 102     my $dir = getlocationpath($location);
 103     return undef if not defined $dir;
 104     if (defined $location and $location eq 'db') {
 105         return "$dir/$bugnum.$ext";
 106     } else {
 107         my $hash = get_hashname($bugnum);
 108         return "$dir/$hash/$bugnum.$ext";
 109     }
 110 }
 111
 112 =head2 getbuglocation
 113
 114      getbuglocation($bug_number,$extension)
 115
 116 Returns the the location in which a particular bug exists; valid
 117 locations returned currently are archive, db-h, or db. If the bug does
 118 not exist, returns undef.
 119
 120 =cut
 121
 122 sub getbuglocation {
 123     my ($bugnum, $ext) = @_;
 124     my $archdir = get_hashname($bugnum);
 125     return 'archive' if -r getlocationpath('archive')."/$archdir/$bugnum.$ext";
 126     return 'db-h' if -r getlocationpath('db-h')."/$archdir/$bugnum.$ext";
 127     return 'db' if -r getlocationpath('db')."/$bugnum.$ext";
 128     return undef;
 129 }
 130
 131
 132 =head2 getlocationpath
 133
 134      getlocationpath($location)
 135
 136 Returns the path to a specific location
 137
 138 =cut
 139
 140 sub getlocationpath {
 141      my ($location) = @_;
 142      if (defined $location and $location eq 'archive') {
 143           return "$config{spool_dir}/archive";
 144      } elsif (defined $location and $location eq 'db') {
 145           return "$config{spool_dir}/db";
 146      } else {
 147           return "$config{spool_dir}/db-h";
 148      }
 149 }
 150
 151
 152 =head2 get_hashname
 153
 154      get_hashname
 155
 156 Returns the hash of the bug which is the location within the archive
 157
 158 =cut
 159
 160 sub get_hashname {
 161     return "" if ( $_[ 0 ] < 0 );
 162     return sprintf "%02d", $_[ 0 ] % 100;
 163 }
 164
 165 =head2 buglog
 166
 167      buglog($bugnum);
 168
 169 Returns the path to the logfile corresponding to the bug.
 170
 171 Returns undef if the bug does not exist.
 172
 173 =cut
 174
 175 sub buglog {
 176     my $bugnum = shift;
 177     my $location = getbuglocation($bugnum, 'log');
 178     return getbugcomponent($bugnum, 'log', $location) if ($location);
 179     $location = getbuglocation($bugnum, 'log.gz');
 180     return getbugcomponent($bugnum, 'log.gz', $location) if ($location);
 181     return undef;
 182 }
 183
 184 =head2 bug_status
 185
 186      bug_status($bugnum)
 187
 188
 189 Returns the path to the summary file corresponding to the bug.
 190
 191 Returns undef if the bug does not exist.
 192
 193 =cut
 194
 195 sub bug_status{
 196     my ($bugnum) = @_;
 197     my $location = getbuglocation($bugnum, 'summary');
 198     return getbugcomponent($bugnum, 'summary', $location) if ($location);
 199     return undef;
 200 }
 201
 202 =head2 appendfile
 203
 204      appendfile($file,'data','to','append');
 205
 206 Opens a file for appending and writes data to it.
 207
 208 =cut
 209
 210 sub appendfile {
 211         my ($file,@data) = @_;
 212         my $fh = IO::File->new($file,'a') or
 213              die "Unable top open $file for appending: $!";
 214         print {$fh} @data or die "Unable to write to $file: $!";
 215         close $fh or die "Unable to close $file: $!";
 216 }
 217
 218 =head2 getparsedaddrs
 219
 220      my $address = getparsedaddrs($address);
 221      my @address = getparsedaddrs($address);
 222
 223 Returns the output from Mail::Address->parse, or the cached output if
 224 this address has been parsed before. In SCALAR context returns the
 225 first address parsed.
 226
 227 =cut
 228
 229
 230 our %_parsedaddrs;
 231 sub getparsedaddrs {
 232     my $addr = shift;
 233     return () unless defined $addr;
 234     return wantarray?@{$_parsedaddrs{$addr}}:$_parsedaddrs{$addr}[0]
 235          if exists $_parsedaddrs{$addr};
 236     {
 237          # don't display the warnings from Mail::Address->parse
 238          local $SIG{__WARN__} = sub { };
 239          @{$_parsedaddrs{$addr}} = Mail::Address->parse($addr);
 240     }
 241     return wantarray?@{$_parsedaddrs{$addr}}:$_parsedaddrs{$addr}[0];
 242 }
 243
 244 =head2 getmaintainers
 245
 246      my $maintainer = getmaintainers()->{debbugs}
 247
 248 Returns a hashref of package => maintainer pairs.
 249
 250 =cut
 251
 252 our $_maintainer = undef;
 253 our $_maintainer_rev = undef;
 254 sub getmaintainers {
 255     return $_maintainer if defined $_maintainer;
 256     package_maintainer(rehash => 1);
 257     return $_maintainer;
 258 }
 259
 260 =head2 getmaintainers_reverse
 261
 262      my @packages = @{getmaintainers_reverse->{'don@debian.org'}||[]};
 263
 264 Returns a hashref of maintainer => [qw(list of packages)] pairs.
 265
 266 =cut
 267
 268 sub getmaintainers_reverse{
 269      return $_maintainer_rev if defined $_maintainer_rev;
 270      package_maintainer(rehash => 1);
 271      return $_maintainer_rev;
 272 }
 273
 274 =head2 package_maintainer
 275
 276      my @s = package_maintainer(source => [qw(foo bar baz)],
 277                                 binary => [qw(bleh blah)],
 278                                );
 279
 280 =over
 281
 282 =item source -- scalar or arrayref of source package names to return
 283 maintainers for, defaults to the empty arrayref.
 284
 285 =item binary -- scalar or arrayref of binary package names to return
 286 maintainers for; automatically returns source package maintainer if
 287 the package name starts with 'src:', defaults to the empty arrayref.
 288
 289 =item reverse -- whether to return the source/binary packages a
 290 maintainer maintains instead
 291
 292 =item rehash -- whether to reread the maintainer and source maintainer
 293 files; defaults to 0
 294
 295 =back
 296
 297 =cut
 298
 299 our $_source_maintainer = undef;
 300 our $_source_maintainer_rev = undef;
 301 sub package_maintainer {
 302     my %param = validate_with(params => \@_,
 303                               spec   => {source => {type => SCALAR|ARRAYREF,
 304                                                     default => [],
 305                                                    },
 306                                          binary => {type => SCALAR|ARRAYREF,
 307                                                     default => [],
 308                                                    },
 309                                          rehash => {type => BOOLEAN,
 310                                                     default => 0,
 311                                                    },
 312                                          reverse => {type => BOOLEAN,
 313                                                      default => 0,
 314                                                     },
 315                                         },
 316                              );
 317     if ($param{rehash}) {
 318         $_source_maintainer = undef;
 319         $_source_maintainer_rev = undef;
 320         $_maintainer = undef;
 321         $_maintainer_rev = undef;
 322     }
 323     if (not defined $_source_maintainer or
 324         not defined $_source_maintainer_rev) {
 325         $_source_maintainer = {};
 326         $_source_maintainer_rev = {};
 327         for my $fn (@config{('source_maintainer_file',
 328                              'source_maintainer_file_override',
 329                              'pseduo_maint_file')}) {
 330             next unless defined $fn;
 331             __add_to_hash($fn,$_source_maintainer,
 332                           $_source_maintainer_rev);
 333         }
 334     }
 335     if (not defined $_maintainer or
 336         not defined $_maintainer_rev) {
 337         $_maintainer = {};
 338         $_maintainer_rev = {};
 339         for my $fn (@config{('maintainer_file',
 340                              'maintainer_file_override',
 341                              'pseduo_maint_file')}) {
 342             next unless defined $fn;
 343             __add_to_hash($fn,$_maintainer,
 344                               $_maintainer_rev);
 345         }
 346     }
 347     my @return;
 348     my @extra_source;
 349     my $b = $param{reverse}?$_maintainer_rev:$_maintainer;
 350     for my $binary (make_list($param{binary})) {
 351         if (not $param{reverse} and $binary =~ /^src:/) {
 352             push @extra_source,$binary;
 353             next;
 354         }
 355         push @return,grep {defined $_} make_list($b->{$binary});
 356     }
 357     my $s = $param{reverse}?$_source_maintainer_rev:$_source_maintainer;
 358     for my $source (make_list($param{source},@extra_source)) {
 359         push @return,grep {defined $_} make_list($s->{$source});
 360     }
 361     return @return;
 362 }
 363
 364 #=head2 __add_to_hash
 365 #
 366 #     __add_to_hash($file,$forward_hash,$reverse_hash,'address');
 367 #
 368 # Reads a maintainer/source maintainer/pseudo desc file and adds the
 369 # maintainers from it to the forward and reverse hashref; assumes that
 370 # the forward is unique; makes no assumptions of the reverse.
 371 #
 372 #=cut
 373
 374 sub __add_to_hash {
 375     my ($fn,$forward,$reverse,$type) = @_;
 376     if (ref($forward) ne 'HASH') {
 377         croak "__add_to_hash must be passed a hashref for the forward";
 378     }
 379     if (defined $reverse and not ref($reverse) eq 'HASH') {
 380         croak "if reverse is passed to __add_to_hash, it must be a hashref";
 381     }
 382     $type //= 'address';
 383     my $fh = IO::File->new($fn,'r') or
 384         die "Unable to open $fn for reading: $!";
 385     while (<$fh>) {
 386         chomp;
 387         next unless m/^(\S+)\s+(\S.*\S)\s*$/;
 388         my ($key,$value)=($1,$2);
 389         $key = lc $key;
 390         $forward->{$key}= $value;
 391         if (defined $reverse) {
 392             if ($type eq 'address') {
 393                 for my $m (map {lc($_->address)} (getparsedaddrs($value))) {
 394                     push @{$reverse->{$m}},$key;
 395                 }
 396             }
 397             else {
 398                 push @{$reverse->{$value}}, $key;
 399             }
 400         }
 401     }
 402 }
 403
 404
 405 =head2 getpseudodesc
 406
 407      my $pseudopkgdesc = getpseudodesc(...);
 408
 409 Returns the entry for a pseudo package from the
 410 $config{pseudo_desc_file}. In cases where pseudo_desc_file is not
 411 defined, returns an empty arrayref.
 412
 413 This function can be used to see if a particular package is a
 414 pseudopackage or not.
 415
 416 =cut
 417
 418 our $_pseudodesc = undef;
 419 sub getpseudodesc {
 420     return $_pseudodesc if defined $_pseudodesc;
 421     $_pseudodesc = {};
 422     __add_to_hash($config{pseudo_desc_file},$_pseudodesc) if
 423         defined $config{pseudo_desc_file};
 424     return $_pseudodesc;
 425 }
 426
 427
 428 =head1 DATE
 429
 430     my $english = secs_to_english($seconds);
 431     my ($days,$english) = secs_to_english($seconds);
 432
 433 XXX This should probably be changed to use Date::Calc
 434
 435 =cut
 436
 437 sub secs_to_english{
 438      my ($seconds) = @_;
 439
 440      my $days = int($seconds / 86400);
 441      my $years = int($days / 365);
 442      $days %= 365;
 443      my $result;
 444      my @age;
 445      push @age, "1 year" if ($years == 1);
 446      push @age, "$years years" if ($years > 1);
 447      push @age, "1 day" if ($days == 1);
 448      push @age, "$days days" if ($days > 1);
 449      $result .= join(" and ", @age);
 450
 451      return wantarray?(int($seconds/86400),$result):$result;
 452 }
 453
 454
 455 =head1 LOCK
 456
 457 These functions are exported with the :lock tag
 458
 459 =head2 filelock
 460
 461      filelock
 462
 463 FLOCKs the passed file. Use unfilelock to unlock it.
 464
 465 =cut
 466
 467 our @filelocks;
 468
 469 sub filelock {
 470     # NB - NOT COMPATIBLE WITH `with-lock'
 471     my ($lockfile) = @_;
 472     if ($lockfile !~ m{^/}) {
 473          $lockfile = cwd().'/'.$lockfile;
 474     }
 475     my ($count,$errors);
 476     $count= 10; $errors= '';
 477     for (;;) {
 478         my $fh = eval {
 479              my $fh2 = IO::File->new($lockfile,'w')
 480                   or die "Unable to open $lockfile for writing: $!";
 481              flock($fh2,LOCK_EX|LOCK_NB)
 482                   or die "Unable to lock $lockfile $!";
 483              return $fh2;
 484         };
 485         if ($@) {
 486              $errors .= $@;
 487         }
 488         if ($fh) {
 489              push @filelocks, {fh => $fh, file => $lockfile};
 490              last;
 491         }
 492         if (--$count <=0) {
 493             $errors =~ s/\n+$//;
 494             die "failed to get lock on $lockfile -- $errors";
 495         }
 496         sleep 10;
 497     }
 498 }
 499
 500 # clean up all outstanding locks at end time
 501 END {
 502      while (@filelocks) {
 503           unfilelock();
 504      }
 505 }
 506
 507
 508 =head2 unfilelock
 509
 510      unfilelock()
 511
 512 Unlocks the file most recently locked.
 513
 514 Note that it is not currently possible to unlock a specific file
 515 locked with filelock.
 516
 517 =cut
 518
 519 sub unfilelock {
 520     if (@filelocks == 0) {
 521         warn "unfilelock called with no active filelocks!\n";
 522         return;
 523     }
 524     my %fl = %{pop(@filelocks)};
 525     flock($fl{fh},LOCK_UN)
 526          or warn "Unable to unlock lockfile $fl{file}: $!";
 527     close($fl{fh})
 528          or warn "Unable to close lockfile $fl{file}: $!";
 529     unlink($fl{file})
 530          or warn "Unable to unlink lockfile $fl{file}: $!";
 531 }
 532
 533
 534 =head2 lockpid
 535
 536       lockpid('/path/to/pidfile');
 537
 538 Creates a pidfile '/path/to/pidfile' if one doesn't exist or if the
 539 pid in the file does not respond to kill 0.
 540
 541 Returns 1 on success, false on failure; dies on unusual errors.
 542
 543 =cut
 544
 545 sub lockpid {
 546      my ($pidfile) = @_;
 547      if (-e $pidfile) {
 548           my $pid = checkpid($pidfile);
 549           die "Unable to read pidfile $pidfile: $!" if not defined $pid;
 550           return 0 if $pid != 0;
 551           unlink $pidfile or
 552                die "Unable to unlink stale pidfile $pidfile $!";
 553      }
 554      my $pidfh = IO::File->new($pidfile,'w') or
 555           die "Unable to open $pidfile for writing: $!";
 556      print {$pidfh} $$ or die "Unable to write to $pidfile $!";
 557      close $pidfh or die "Unable to close $pidfile $!";
 558      return 1;
 559 }
 560
 561 =head2 checkpid
 562
 563      checkpid('/path/to/pidfile');
 564
 565 Checks a pid file and determines if the process listed in the pidfile
 566 is still running. Returns the pid if it is, 0 if it isn't running, and
 567 undef if the pidfile doesn't exist or cannot be read.
 568
 569 =cut
 570
 571 sub checkpid{
 572      my ($pidfile) = @_;
 573      if (-e $pidfile) {
 574           my $pidfh = IO::File->new($pidfile, 'r') or
 575                return undef;
 576           local $/;
 577           my $pid = <$pidfh>;
 578           close $pidfh;
 579           ($pid) = $pid =~ /(\d+)/;
 580           if (defined $pid and kill(0,$pid)) {
 581                return $pid;
 582           }
 583           return 0;
 584      }
 585      else {
 586           return undef;
 587      }
 588 }
 589
 590
 591 =head1 QUIT
 592
 593 These functions are exported with the :quit tag.
 594
 595 =head2 quit
 596
 597      quit()
 598
 599 Exits the program by calling die.
 600
 601 Usage of quit is deprecated; just call die instead.
 602
 603 =cut
 604
 605 sub quit {
 606      print {$DEBUG_FH} "quitting >$_[0]<\n" if $DEBUG;
 607      carp "quit() is deprecated; call die directly instead";
 608 }
 609
 610
 611 =head1 MISC
 612
 613 These functions are exported with the :misc tag
 614
 615 =head2 make_list
 616
 617      LIST = make_list(@_);
 618
 619 Turns a scalar or an arrayref into a list; expands a list of arrayrefs
 620 into a list.
 621
 622 That is, make_list([qw(a b c)]); returns qw(a b c); make_list([qw(a
 623 b)],[qw(c d)] returns qw(a b c d);
 624
 625 =cut
 626
 627 sub make_list {
 628      return map {(ref($_) eq 'ARRAY')?@{$_}:$_} @_;
 629 }
 630
 631
 632 =head2 english_join
 633
 634      print english_join(list => \@list);
 635      print english_join(\@list);
 636
 637 Joins list properly to make an english phrase.
 638
 639 =over
 640
 641 =item normal -- how to separate most values; defaults to ', '
 642
 643 =item last -- how to separate the last two values; defaults to ', and '
 644
 645 =item only_two -- how to separate only two values; defaults to ' and '
 646
 647 =item list -- ARRAYREF values to join; if the first argument is an
 648 ARRAYREF, it's assumed to be the list of values to join
 649
 650 =back
 651
 652 In cases where C<list> is empty, returns ''; when there is only one
 653 element, returns that element.
 654
 655 =cut
 656
 657 sub english_join {
 658     if (ref $_[0] eq 'ARRAY') {
 659         return english_join(list=>$_[0]);
 660     }
 661     my %param = validate_with(params => \@_,
 662                               spec  => {normal => {type => SCALAR,
 663                                                    default => ', ',
 664                                                   },
 665                                         last   => {type => SCALAR,
 666                                                    default => ', and ',
 667                                                   },
 668                                         only_two => {type => SCALAR,
 669                                                      default => ' and ',
 670                                                     },
 671                                         list     => {type => ARRAYREF,
 672                                                     },
 673                                        },
 674                              );
 675     my @list = @{$param{list}};
 676     if (@list <= 1) {
 677         return @list?$list[0]:'';
 678     }
 679     elsif (@list == 2) {
 680         return join($param{only_two},@list);
 681     }
 682     my $ret = $param{last} . pop(@list);
 683     return join($param{normal},@list) . $ret;
 684 }
 685
 686
 687 =head2 globify_scalar
 688
 689      my $handle = globify_scalar(\$foo);
 690
 691 if $foo isn't already a glob or a globref, turn it into one using
 692 IO::Scalar. Gives a new handle to /dev/null if $foo isn't defined.
 693
 694 Will carp if given a scalar which isn't a scalarref or a glob (or
 695 globref), and return /dev/null. May return undef if IO::Scalar or
 696 IO::File fails. (Check $!)
 697
 698 =cut
 699
 700 sub globify_scalar {
 701      my ($scalar) = @_;
 702      my $handle;
 703      if (defined $scalar) {
 704           if (defined ref($scalar)) {
 705                if (ref($scalar) eq 'SCALAR' and
 706                    not UNIVERSAL::isa($scalar,'GLOB')) {
 707                     return IO::Scalar->new($scalar);
 708                }
 709                else {
 710                     return $scalar;
 711                }
 712           }
 713           elsif (UNIVERSAL::isa(\$scalar,'GLOB')) {
 714                return $scalar;
 715           }
 716           else {
 717                carp "Given a non-scalar reference, non-glob to globify_scalar; returning /dev/null handle";
 718           }
 719      }
 720      return IO::File->new('/dev/null','w');
 721 }
 722
 723 =head2 cleanup_eval_fail()
 724
 725      print "Something failed with: ".cleanup_eval_fail($@);
 726
 727 Does various bits of cleanup on the failure message from an eval (or
 728 any other die message)
 729
 730 Takes at most two options; the first is the actual failure message
 731 (usually $@ and defaults to $@), the second is the debug level
 732 (defaults to $DEBUG).
 733
 734 If debug is non-zero, the code at which the failure occured is output.
 735
 736 =cut
 737
 738 sub cleanup_eval_fail {
 739     my ($error,$debug) = @_;
 740     if (not defined $error or not @_) {
 741         $error = $@ // 'unknown reason';
 742     }
 743     if (@_ <= 1) {
 744         $debug = $DEBUG // 0;
 745     }
 746     $debug = 0 if not defined $debug;
 747
 748     if ($debug > 0) {
 749         return $error;
 750     }
 751     # ditch the "at foo/bar/baz.pm line 5"
 752     $error =~ s/\sat\s\S+\sline\s\d+//;
 753     # ditch trailing multiple periods in case there was a cascade of
 754     # die messages.
 755     $error =~ s/\.+$/\./;
 756     return $error;
 757 }
 758
 759
 760 1;
 761
 762 __END__