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         $source =~ s/^src://;
 360         push @return,grep {defined $_} make_list($s->{$source});
 361     }
 362     return @return;
 363 }
 364
 365 #=head2 __add_to_hash
 366 #
 367 #     __add_to_hash($file,$forward_hash,$reverse_hash,'address');
 368 #
 369 # Reads a maintainer/source maintainer/pseudo desc file and adds the
 370 # maintainers from it to the forward and reverse hashref; assumes that
 371 # the forward is unique; makes no assumptions of the reverse.
 372 #
 373 #=cut
 374
 375 sub __add_to_hash {
 376     my ($fn,$forward,$reverse,$type) = @_;
 377     if (ref($forward) ne 'HASH') {
 378         croak "__add_to_hash must be passed a hashref for the forward";
 379     }
 380     if (defined $reverse and not ref($reverse) eq 'HASH') {
 381         croak "if reverse is passed to __add_to_hash, it must be a hashref";
 382     }
 383     $type //= 'address';
 384     my $fh = IO::File->new($fn,'r') or
 385         die "Unable to open $fn for reading: $!";
 386     while (<$fh>) {
 387         chomp;
 388         next unless m/^(\S+)\s+(\S.*\S)\s*$/;
 389         my ($key,$value)=($1,$2);
 390         $key = lc $key;
 391         $forward->{$key}= $value;
 392         if (defined $reverse) {
 393             if ($type eq 'address') {
 394                 for my $m (map {lc($_->address)} (getparsedaddrs($value))) {
 395                     push @{$reverse->{$m}},$key;
 396                 }
 397             }
 398             else {
 399                 push @{$reverse->{$value}}, $key;
 400             }
 401         }
 402     }
 403 }
 404
 405
 406 =head2 getpseudodesc
 407
 408      my $pseudopkgdesc = getpseudodesc(...);
 409
 410 Returns the entry for a pseudo package from the
 411 $config{pseudo_desc_file}. In cases where pseudo_desc_file is not
 412 defined, returns an empty arrayref.
 413
 414 This function can be used to see if a particular package is a
 415 pseudopackage or not.
 416
 417 =cut
 418
 419 our $_pseudodesc = undef;
 420 sub getpseudodesc {
 421     return $_pseudodesc if defined $_pseudodesc;
 422     $_pseudodesc = {};
 423     __add_to_hash($config{pseudo_desc_file},$_pseudodesc) if
 424         defined $config{pseudo_desc_file};
 425     return $_pseudodesc;
 426 }
 427
 428
 429 =head1 DATE
 430
 431     my $english = secs_to_english($seconds);
 432     my ($days,$english) = secs_to_english($seconds);
 433
 434 XXX This should probably be changed to use Date::Calc
 435
 436 =cut
 437
 438 sub secs_to_english{
 439      my ($seconds) = @_;
 440
 441      my $days = int($seconds / 86400);
 442      my $years = int($days / 365);
 443      $days %= 365;
 444      my $result;
 445      my @age;
 446      push @age, "1 year" if ($years == 1);
 447      push @age, "$years years" if ($years > 1);
 448      push @age, "1 day" if ($days == 1);
 449      push @age, "$days days" if ($days > 1);
 450      $result .= join(" and ", @age);
 451
 452      return wantarray?(int($seconds/86400),$result):$result;
 453 }
 454
 455
 456 =head1 LOCK
 457
 458 These functions are exported with the :lock tag
 459
 460 =head2 filelock
 461
 462      filelock
 463
 464 FLOCKs the passed file. Use unfilelock to unlock it.
 465
 466 =cut
 467
 468 our @filelocks;
 469
 470 sub filelock {
 471     # NB - NOT COMPATIBLE WITH `with-lock'
 472     my ($lockfile) = @_;
 473     if ($lockfile !~ m{^/}) {
 474          $lockfile = cwd().'/'.$lockfile;
 475     }
 476     my ($count,$errors);
 477     $count= 10; $errors= '';
 478     for (;;) {
 479         my $fh = eval {
 480              my $fh2 = IO::File->new($lockfile,'w')
 481                   or die "Unable to open $lockfile for writing: $!";
 482              flock($fh2,LOCK_EX|LOCK_NB)
 483                   or die "Unable to lock $lockfile $!";
 484              return $fh2;
 485         };
 486         if ($@) {
 487              $errors .= $@;
 488         }
 489         if ($fh) {
 490              push @filelocks, {fh => $fh, file => $lockfile};
 491              last;
 492         }
 493         if (--$count <=0) {
 494             $errors =~ s/\n+$//;
 495             die "failed to get lock on $lockfile -- $errors";
 496         }
 497         sleep 10;
 498     }
 499 }
 500
 501 # clean up all outstanding locks at end time
 502 END {
 503      while (@filelocks) {
 504           unfilelock();
 505      }
 506 }
 507
 508
 509 =head2 unfilelock
 510
 511      unfilelock()
 512
 513 Unlocks the file most recently locked.
 514
 515 Note that it is not currently possible to unlock a specific file
 516 locked with filelock.
 517
 518 =cut
 519
 520 sub unfilelock {
 521     if (@filelocks == 0) {
 522         warn "unfilelock called with no active filelocks!\n";
 523         return;
 524     }
 525     my %fl = %{pop(@filelocks)};
 526     flock($fl{fh},LOCK_UN)
 527          or warn "Unable to unlock lockfile $fl{file}: $!";
 528     close($fl{fh})
 529          or warn "Unable to close lockfile $fl{file}: $!";
 530     unlink($fl{file})
 531          or warn "Unable to unlink lockfile $fl{file}: $!";
 532 }
 533
 534
 535 =head2 lockpid
 536
 537       lockpid('/path/to/pidfile');
 538
 539 Creates a pidfile '/path/to/pidfile' if one doesn't exist or if the
 540 pid in the file does not respond to kill 0.
 541
 542 Returns 1 on success, false on failure; dies on unusual errors.
 543
 544 =cut
 545
 546 sub lockpid {
 547      my ($pidfile) = @_;
 548      if (-e $pidfile) {
 549           my $pid = checkpid($pidfile);
 550           die "Unable to read pidfile $pidfile: $!" if not defined $pid;
 551           return 0 if $pid != 0;
 552           unlink $pidfile or
 553                die "Unable to unlink stale pidfile $pidfile $!";
 554      }
 555      my $pidfh = IO::File->new($pidfile,'w') or
 556           die "Unable to open $pidfile for writing: $!";
 557      print {$pidfh} $$ or die "Unable to write to $pidfile $!";
 558      close $pidfh or die "Unable to close $pidfile $!";
 559      return 1;
 560 }
 561
 562 =head2 checkpid
 563
 564      checkpid('/path/to/pidfile');
 565
 566 Checks a pid file and determines if the process listed in the pidfile
 567 is still running. Returns the pid if it is, 0 if it isn't running, and
 568 undef if the pidfile doesn't exist or cannot be read.
 569
 570 =cut
 571
 572 sub checkpid{
 573      my ($pidfile) = @_;
 574      if (-e $pidfile) {
 575           my $pidfh = IO::File->new($pidfile, 'r') or
 576                return undef;
 577           local $/;
 578           my $pid = <$pidfh>;
 579           close $pidfh;
 580           ($pid) = $pid =~ /(\d+)/;
 581           if (defined $pid and kill(0,$pid)) {
 582                return $pid;
 583           }
 584           return 0;
 585      }
 586      else {
 587           return undef;
 588      }
 589 }
 590
 591
 592 =head1 QUIT
 593
 594 These functions are exported with the :quit tag.
 595
 596 =head2 quit
 597
 598      quit()
 599
 600 Exits the program by calling die.
 601
 602 Usage of quit is deprecated; just call die instead.
 603
 604 =cut
 605
 606 sub quit {
 607      print {$DEBUG_FH} "quitting >$_[0]<\n" if $DEBUG;
 608      carp "quit() is deprecated; call die directly instead";
 609 }
 610
 611
 612 =head1 MISC
 613
 614 These functions are exported with the :misc tag
 615
 616 =head2 make_list
 617
 618      LIST = make_list(@_);
 619
 620 Turns a scalar or an arrayref into a list; expands a list of arrayrefs
 621 into a list.
 622
 623 That is, make_list([qw(a b c)]); returns qw(a b c); make_list([qw(a
 624 b)],[qw(c d)] returns qw(a b c d);
 625
 626 =cut
 627
 628 sub make_list {
 629      return map {(ref($_) eq 'ARRAY')?@{$_}:$_} @_;
 630 }
 631
 632
 633 =head2 english_join
 634
 635      print english_join(list => \@list);
 636      print english_join(\@list);
 637
 638 Joins list properly to make an english phrase.
 639
 640 =over
 641
 642 =item normal -- how to separate most values; defaults to ', '
 643
 644 =item last -- how to separate the last two values; defaults to ', and '
 645
 646 =item only_two -- how to separate only two values; defaults to ' and '
 647
 648 =item list -- ARRAYREF values to join; if the first argument is an
 649 ARRAYREF, it's assumed to be the list of values to join
 650
 651 =back
 652
 653 In cases where C<list> is empty, returns ''; when there is only one
 654 element, returns that element.
 655
 656 =cut
 657
 658 sub english_join {
 659     if (ref $_[0] eq 'ARRAY') {
 660         return english_join(list=>$_[0]);
 661     }
 662     my %param = validate_with(params => \@_,
 663                               spec  => {normal => {type => SCALAR,
 664                                                    default => ', ',
 665                                                   },
 666                                         last   => {type => SCALAR,
 667                                                    default => ', and ',
 668                                                   },
 669                                         only_two => {type => SCALAR,
 670                                                      default => ' and ',
 671                                                     },
 672                                         list     => {type => ARRAYREF,
 673                                                     },
 674                                        },
 675                              );
 676     my @list = @{$param{list}};
 677     if (@list <= 1) {
 678         return @list?$list[0]:'';
 679     }
 680     elsif (@list == 2) {
 681         return join($param{only_two},@list);
 682     }
 683     my $ret = $param{last} . pop(@list);
 684     return join($param{normal},@list) . $ret;
 685 }
 686
 687
 688 =head2 globify_scalar
 689
 690      my $handle = globify_scalar(\$foo);
 691
 692 if $foo isn't already a glob or a globref, turn it into one using
 693 IO::Scalar. Gives a new handle to /dev/null if $foo isn't defined.
 694
 695 Will carp if given a scalar which isn't a scalarref or a glob (or
 696 globref), and return /dev/null. May return undef if IO::Scalar or
 697 IO::File fails. (Check $!)
 698
 699 =cut
 700
 701 sub globify_scalar {
 702      my ($scalar) = @_;
 703      my $handle;
 704      if (defined $scalar) {
 705           if (defined ref($scalar)) {
 706                if (ref($scalar) eq 'SCALAR' and
 707                    not UNIVERSAL::isa($scalar,'GLOB')) {
 708                     return IO::Scalar->new($scalar);
 709                }
 710                else {
 711                     return $scalar;
 712                }
 713           }
 714           elsif (UNIVERSAL::isa(\$scalar,'GLOB')) {
 715                return $scalar;
 716           }
 717           else {
 718                carp "Given a non-scalar reference, non-glob to globify_scalar; returning /dev/null handle";
 719           }
 720      }
 721      return IO::File->new('/dev/null','w');
 722 }
 723
 724 =head2 cleanup_eval_fail()
 725
 726      print "Something failed with: ".cleanup_eval_fail($@);
 727
 728 Does various bits of cleanup on the failure message from an eval (or
 729 any other die message)
 730
 731 Takes at most two options; the first is the actual failure message
 732 (usually $@ and defaults to $@), the second is the debug level
 733 (defaults to $DEBUG).
 734
 735 If debug is non-zero, the code at which the failure occured is output.
 736
 737 =cut
 738
 739 sub cleanup_eval_fail {
 740     my ($error,$debug) = @_;
 741     if (not defined $error or not @_) {
 742         $error = $@ // 'unknown reason';
 743     }
 744     if (@_ <= 1) {
 745         $debug = $DEBUG // 0;
 746     }
 747     $debug = 0 if not defined $debug;
 748
 749     if ($debug > 0) {
 750         return $error;
 751     }
 752     # ditch the "at foo/bar/baz.pm line 5"
 753     $error =~ s/\sat\s\S+\sline\s\d+//;
 754     # ditch trailing multiple periods in case there was a cascade of
 755     # die messages.
 756     $error =~ s/\.+$/\./;
 757     return $error;
 758 }
 759
 760
 761 1;
 762
 763 __END__