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