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