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