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(getmaintainers_reverse),
  44                                 qw(getpseudodesc),
  45                                ],
  46                      misc   => [qw(make_list globify_scalar english_join checkpid)],
  47                      date   => [qw(secs_to_english)],
  48                      quit   => [qw(quit)],
  49                      lock   => [qw(filelock unfilelock lockpid)],
  50                     );
  51      @EXPORT_OK = ();
  52      Exporter::export_ok_tags(qw(lock quit date util misc));
  53      $EXPORT_TAGS{all} = [@EXPORT_OK];
  54 }
  55
  56 #use Debbugs::Config qw(:globals);
  57
  58 use Carp;
  59
  60 use Debbugs::Config qw(:config);
  61 use IO::File;
  62 use IO::Scalar;
  63 use Debbugs::MIME qw(decode_rfc1522);
  64 use Mail::Address;
  65 use Cwd qw(cwd);
  66
  67 use Fcntl qw(:flock);
  68
  69 our $DEBUG_FH = \*STDERR if not defined $DEBUG_FH;
  70
  71 =head1 UTILITIES
  72
  73 The following functions are exported by the C<:util> tag
  74
  75 =head2 getbugcomponent
  76
  77      my $file = getbugcomponent($bug_number,$extension,$location)
  78
  79 Returns the path to the bug file in location C<$location>, bug number
  80 C<$bugnumber> and extension C<$extension>
  81
  82 =cut
  83
  84 sub getbugcomponent {
  85     my ($bugnum, $ext, $location) = @_;
  86
  87     if (not defined $location) {
  88         $location = getbuglocation($bugnum, $ext);
  89         # Default to non-archived bugs only for now; CGI scripts want
  90         # archived bugs but most of the backend scripts don't. For now,
  91         # anything that is prepared to accept archived bugs should call
  92         # getbuglocation() directly first.
  93         return undef if defined $location and
  94                         ($location ne 'db' and $location ne 'db-h');
  95     }
  96     my $dir = getlocationpath($location);
  97     return undef if not defined $dir;
  98     if (defined $location and $location eq 'db') {
  99         return "$dir/$bugnum.$ext";
 100     } else {
 101         my $hash = get_hashname($bugnum);
 102         return "$dir/$hash/$bugnum.$ext";
 103     }
 104 }
 105
 106 =head2 getbuglocation
 107
 108      getbuglocation($bug_number,$extension)
 109
 110 Returns the the location in which a particular bug exists; valid
 111 locations returned currently are archive, db-h, or db. If the bug does
 112 not exist, returns undef.
 113
 114 =cut
 115
 116 sub getbuglocation {
 117     my ($bugnum, $ext) = @_;
 118     my $archdir = get_hashname($bugnum);
 119     return 'archive' if -r getlocationpath('archive')."/$archdir/$bugnum.$ext";
 120     return 'db-h' if -r getlocationpath('db-h')."/$archdir/$bugnum.$ext";
 121     return 'db' if -r getlocationpath('db')."/$bugnum.$ext";
 122     return undef;
 123 }
 124
 125
 126 =head2 getlocationpath
 127
 128      getlocationpath($location)
 129
 130 Returns the path to a specific location
 131
 132 =cut
 133
 134 sub getlocationpath {
 135      my ($location) = @_;
 136      if (defined $location and $location eq 'archive') {
 137           return "$config{spool_dir}/archive";
 138      } elsif (defined $location and $location eq 'db') {
 139           return "$config{spool_dir}/db";
 140      } else {
 141           return "$config{spool_dir}/db-h";
 142      }
 143 }
 144
 145
 146 =head2 get_hashname
 147
 148      get_hashname
 149
 150 Returns the hash of the bug which is the location within the archive
 151
 152 =cut
 153
 154 sub get_hashname {
 155     return "" if ( $_[ 0 ] < 0 );
 156     return sprintf "%02d", $_[ 0 ] % 100;
 157 }
 158
 159 =head2 buglog
 160
 161      buglog($bugnum);
 162
 163 Returns the path to the logfile corresponding to the bug.
 164
 165 Returns undef if the bug does not exist.
 166
 167 =cut
 168
 169 sub buglog {
 170     my $bugnum = shift;
 171     my $location = getbuglocation($bugnum, 'log');
 172     return getbugcomponent($bugnum, 'log', $location) if ($location);
 173     $location = getbuglocation($bugnum, 'log.gz');
 174     return getbugcomponent($bugnum, 'log.gz', $location) if ($location);
 175     return undef;
 176 }
 177
 178
 179 =head2 appendfile
 180
 181      appendfile($file,'data','to','append');
 182
 183 Opens a file for appending and writes data to it.
 184
 185 =cut
 186
 187 sub appendfile {
 188         my ($file,@data) = @_;
 189         my $fh = IO::File->new($file,'a') or
 190              die "Unable top open $file for appending: $!";
 191         print {$fh} @data or die "Unable to write to $file: $!";
 192         close $fh or die "Unable to close $file: $!";
 193 }
 194
 195 =head2 getparsedaddrs
 196
 197      my $address = getparsedaddrs($address);
 198      my @address = getparsedaddrs($address);
 199
 200 Returns the output from Mail::Address->parse, or the cached output if
 201 this address has been parsed before. In SCALAR context returns the
 202 first address parsed.
 203
 204 =cut
 205
 206
 207 our %_parsedaddrs;
 208 sub getparsedaddrs {
 209     my $addr = shift;
 210     return () unless defined $addr;
 211     return wantarray?@{$_parsedaddrs{$addr}}:$_parsedaddrs{$addr}[0]
 212          if exists $_parsedaddrs{$addr};
 213     {
 214          # don't display the warnings from Mail::Address->parse
 215          local $SIG{__WARN__} = sub { };
 216          @{$_parsedaddrs{$addr}} = Mail::Address->parse($addr);
 217     }
 218     return wantarray?@{$_parsedaddrs{$addr}}:$_parsedaddrs{$addr}[0];
 219 }
 220
 221 =head2 getmaintainers
 222
 223      my $maintainer = getmaintainers()->{debbugs}
 224
 225 Returns a hashref of package => maintainer pairs.
 226
 227 =cut
 228
 229 our $_maintainer;
 230 our $_maintainer_rev;
 231 sub getmaintainers {
 232     return $_maintainer if $_maintainer;
 233     my %maintainer;
 234     my %maintainer_rev;
 235     for my $file (@config{qw(maintainer_file maintainer_file_override pseduo_maint_file)}) {
 236          next unless defined $file;
 237          my $maintfile = IO::File->new($file,'r') or
 238               die "Unable to open maintainer file $file: $!";
 239          while(<$maintfile>) {
 240               next unless m/^(\S+)\s+(\S.*\S)\s*$/;
 241               ($a,$b)=($1,$2);
 242               $a =~ y/A-Z/a-z/;
 243               $maintainer{$a}= $b;
 244               for my $maint (map {lc($_->address)} getparsedaddrs($b)) {
 245                    push @{$maintainer_rev{$maint}},$a;
 246               }
 247          }
 248          close($maintfile);
 249     }
 250     $_maintainer = \%maintainer;
 251     $_maintainer_rev = \%maintainer_rev;
 252     return $_maintainer;
 253 }
 254
 255 =head2 getmaintainers_reverse
 256
 257      my @packages = @{getmaintainers_reverse->{'don@debian.org'}||[]};
 258
 259 Returns a hashref of maintainer => [qw(list of packages)] pairs.
 260
 261 =cut
 262
 263 sub getmaintainers_reverse{
 264      return $_maintainer_rev if $_maintainer_rev;
 265      getmaintainers();
 266      return $_maintainer_rev;
 267 }
 268
 269 =head2 getpseudodesc
 270
 271      my $pseudopkgdesc = getpseudodesc(...);
 272
 273 Returns the entry for a pseudo package from the
 274 $config{pseudo_desc_file}. In cases where pseudo_desc_file is not
 275 defined, returns an empty arrayref.
 276
 277 This function can be used to see if a particular package is a
 278 pseudopackage or not.
 279
 280 =cut
 281
 282 our $_pseudodesc;
 283 sub getpseudodesc {
 284     return $_pseudodesc if $_pseudodesc;
 285     my %pseudodesc;
 286
 287     if (not defined $config{pseudo_desc_file}) {
 288          $_pseudodesc = {};
 289          return $_pseudodesc;
 290     }
 291     my $pseudo = IO::File->new($config{pseudo_desc_file},'r')
 292          or die "Unable to open $config{pseudo_desc_file}: $!";
 293     while(<$pseudo>) {
 294         next unless m/^(\S+)\s+(\S.*\S)\s*$/;
 295         $pseudodesc{lc $1} = $2;
 296     }
 297     close($pseudo);
 298     $_pseudodesc = \%pseudodesc;
 299     return $_pseudodesc;
 300 }
 301
 302
 303 =head1 DATE
 304
 305     my $english = secs_to_english($seconds);
 306     my ($days,$english) = secs_to_english($seconds);
 307
 308 XXX This should probably be changed to use Date::Calc
 309
 310 =cut
 311
 312 sub secs_to_english{
 313      my ($seconds) = @_;
 314
 315      my $days = int($seconds / 86400);
 316      my $years = int($days / 365);
 317      $days %= 365;
 318      my $result;
 319      my @age;
 320      push @age, "1 year" if ($years == 1);
 321      push @age, "$years years" if ($years > 1);
 322      push @age, "1 day" if ($days == 1);
 323      push @age, "$days days" if ($days > 1);
 324      $result .= join(" and ", @age);
 325
 326      return wantarray?(int($seconds/86400),$result):$result;
 327 }
 328
 329
 330 =head1 LOCK
 331
 332 These functions are exported with the :lock tag
 333
 334 =head2 filelock
 335
 336      filelock
 337
 338 FLOCKs the passed file. Use unfilelock to unlock it.
 339
 340 =cut
 341
 342 our @filelocks;
 343
 344 sub filelock {
 345     # NB - NOT COMPATIBLE WITH `with-lock'
 346     my ($lockfile) = @_;
 347     if ($lockfile !~ m{^/}) {
 348          $lockfile = cwd().'/'.$lockfile;
 349     }
 350     my ($count,$errors);
 351     $count= 10; $errors= '';
 352     for (;;) {
 353         my $fh = eval {
 354              my $fh2 = IO::File->new($lockfile,'w')
 355                   or die "Unable to open $lockfile for writing: $!";
 356              flock($fh2,LOCK_EX|LOCK_NB)
 357                   or die "Unable to lock $lockfile $!";
 358              return $fh2;
 359         };
 360         if ($@) {
 361              $errors .= $@;
 362         }
 363         if ($fh) {
 364              push @filelocks, {fh => $fh, file => $lockfile};
 365              last;
 366         }
 367         if (--$count <=0) {
 368             $errors =~ s/\n+$//;
 369             die "failed to get lock on $lockfile -- $errors";
 370         }
 371         sleep 10;
 372     }
 373 }
 374
 375 # clean up all outstanding locks at end time
 376 END {
 377      while (@filelocks) {
 378           unfilelock();
 379      }
 380 }
 381
 382
 383 =head2 unfilelock
 384
 385      unfilelock()
 386
 387 Unlocks the file most recently locked.
 388
 389 Note that it is not currently possible to unlock a specific file
 390 locked with filelock.
 391
 392 =cut
 393
 394 sub unfilelock {
 395     if (@filelocks == 0) {
 396         warn "unfilelock called with no active filelocks!\n";
 397         return;
 398     }
 399     my %fl = %{pop(@filelocks)};
 400     flock($fl{fh},LOCK_UN)
 401          or warn "Unable to unlock lockfile $fl{file}: $!";
 402     close($fl{fh})
 403          or warn "Unable to close lockfile $fl{file}: $!";
 404     unlink($fl{file})
 405          or warn "Unable to unlink lockfile $fl{file}: $!";
 406 }
 407
 408
 409 =head2 lockpid
 410
 411       lockpid('/path/to/pidfile');
 412
 413 Creates a pidfile '/path/to/pidfile' if one doesn't exist or if the
 414 pid in the file does not respond to kill 0.
 415
 416 Returns 1 on success, false on failure; dies on unusual errors.
 417
 418 =cut
 419
 420 sub lockpid {
 421      my ($pidfile) = @_;
 422      if (-e $pidfile) {
 423           my $pid = checkpid($pidfile);
 424           die "Unable to read pidfile $pidfile: $!" if not defined $pid;
 425           return 0 if $pid != 0;
 426           unlink $pidfile or
 427                die "Unable to unlink stale pidfile $pidfile $!";
 428      }
 429      my $pidfh = IO::File->new($pidfile,'w') or
 430           die "Unable to open $pidfile for writing: $!";
 431      print {$pidfh} $$ or die "Unable to write to $pidfile $!";
 432      close $pidfh or die "Unable to close $pidfile $!";
 433      return 1;
 434 }
 435
 436 =head2 checkpid
 437
 438      checkpid('/path/to/pidfile');
 439
 440 Checks a pid file and determines if the process listed in the pidfile
 441 is still running. Returns the pid if it is, 0 if it isn't running, and
 442 undef if the pidfile doesn't exist or cannot be read.
 443
 444 =cut
 445
 446 sub checkpid{
 447      my ($pidfile) = @_;
 448      if (-e $pidfile) {
 449           my $pidfh = IO::File->new($pidfile, 'r') or
 450                return undef;
 451           local $/;
 452           my $pid = <$pidfh>;
 453           close $pidfh;
 454           ($pid) = $pid =~ /(\d+)/;
 455           if (defined $pid and kill(0,$pid)) {
 456                return $pid;
 457           }
 458           return 0;
 459      }
 460      else {
 461           return undef;
 462      }
 463 }
 464
 465
 466 =head1 QUIT
 467
 468 These functions are exported with the :quit tag.
 469
 470 =head2 quit
 471
 472      quit()
 473
 474 Exits the program by calling die.
 475
 476 Usage of quit is deprecated; just call die instead.
 477
 478 =cut
 479
 480 sub quit {
 481      print {$DEBUG_FH} "quitting >$_[0]<\n" if $DEBUG;
 482      carp "quit() is deprecated; call die directly instead";
 483 }
 484
 485
 486 =head1 MISC
 487
 488 These functions are exported with the :misc tag
 489
 490 =head2 make_list
 491
 492      LIST = make_list(@_);
 493
 494 Turns a scalar or an arrayref into a list; expands a list of arrayrefs
 495 into a list.
 496
 497 That is, make_list([qw(a b c)]); returns qw(a b c); make_list([qw(a
 498 b)],[qw(c d)] returns qw(a b c d);
 499
 500 =cut
 501
 502 sub make_list {
 503      return map {(ref($_) eq 'ARRAY')?@{$_}:$_} @_;
 504 }
 505
 506
 507 =head2 english_join
 508
 509      print english_join(', ',' and ',@list);
 510
 511 Joins list properly to make an english phrase.
 512
 513
 514
 515 =cut
 516
 517 sub english_join {
 518      my ($normal,$last,@list) = @_;
 519      if (@list <= 1) {
 520           return @list?$list[0]:'';
 521      }
 522      my $ret = $last . pop(@list);
 523      $ret = join($normal,@list) . $ret;
 524      return $ret;
 525 }
 526
 527
 528 =head2 globify_scalar
 529
 530      my $handle = globify_scalar(\$foo);
 531
 532 if $foo isn't already a glob or a globref, turn it into one using
 533 IO::Scalar. Gives a new handle to /dev/null if $foo isn't defined.
 534
 535 Will carp if given a scalar which isn't a scalarref or a glob (or
 536 globref), and return /dev/null. May return undef if IO::Scalar or
 537 IO::File fails. (Check $!)
 538
 539 =cut
 540
 541 sub globify_scalar {
 542      my ($scalar) = @_;
 543      my $handle;
 544      if (defined $scalar) {
 545           if (defined ref($scalar)) {
 546                if (ref($scalar) eq 'SCALAR' and
 547                    not UNIVERSAL::isa($scalar,'GLOB')) {
 548                     return IO::Scalar->new($scalar);
 549                }
 550                else {
 551                     return $scalar;
 552                }
 553           }
 554           elsif (UNIVERSAL::isa(\$scalar,'GLOB')) {
 555                return $scalar;
 556           }
 557           else {
 558                carp "Given a non-scalar reference, non-glob to globify_scalar; returning /dev/null handle";
 559           }
 560      }
 561      return IO::File->new('/dev/null','w');
 562 }
 563
 564
 565 1;
 566
 567 __END__