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                                ],
  45                      misc   => [qw(make_list)],
  46                      date   => [qw(secs_to_english)],
  47                      quit   => [qw(quit)],
  48                      lock   => [qw(filelock unfilelock @cleanups lockpid)],
  49                     );
  50      @EXPORT_OK = ();
  51      Exporter::export_ok_tags(qw(lock quit date util misc));
  52      $EXPORT_TAGS{all} = [@EXPORT_OK];
  53 }
  54
  55 #use Debbugs::Config qw(:globals);
  56 use Debbugs::Config qw(:config);
  57 use IO::File;
  58 use Debbugs::MIME qw(decode_rfc1522);
  59 use Mail::Address;
  60 use Cwd qw(cwd);
  61
  62 use Fcntl qw(:flock);
  63
  64 our $DEBUG_FH = \*STDERR if not defined $DEBUG_FH;
  65
  66 =head1 UTILITIES
  67
  68 The following functions are exported by the C<:util> tag
  69
  70 =head2 getbugcomponent
  71
  72      my $file = getbugcomponent($bug_number,$extension,$location)
  73
  74 Returns the path to the bug file in location C<$location>, bug number
  75 C<$bugnumber> and extension C<$extension>
  76
  77 =cut
  78
  79 sub getbugcomponent {
  80     my ($bugnum, $ext, $location) = @_;
  81
  82     if (not defined $location) {
  83         $location = getbuglocation($bugnum, $ext);
  84         # Default to non-archived bugs only for now; CGI scripts want
  85         # archived bugs but most of the backend scripts don't. For now,
  86         # anything that is prepared to accept archived bugs should call
  87         # getbuglocation() directly first.
  88         return undef if defined $location and
  89                         ($location ne 'db' and $location ne 'db-h');
  90     }
  91     my $dir = getlocationpath($location);
  92     return undef if not defined $dir;
  93     if (defined $location and $location eq 'db') {
  94         return "$dir/$bugnum.$ext";
  95     } else {
  96         my $hash = get_hashname($bugnum);
  97         return "$dir/$hash/$bugnum.$ext";
  98     }
  99 }
 100
 101 =head2 getbuglocation
 102
 103      getbuglocation($bug_number,$extension)
 104
 105 Returns the the location in which a particular bug exists; valid
 106 locations returned currently are archive, db-h, or db. If the bug does
 107 not exist, returns undef.
 108
 109 =cut
 110
 111 sub getbuglocation {
 112     my ($bugnum, $ext) = @_;
 113     my $archdir = get_hashname($bugnum);
 114     return 'archive' if -r getlocationpath('archive')."/$archdir/$bugnum.$ext";
 115     return 'db-h' if -r getlocationpath('db-h')."/$archdir/$bugnum.$ext";
 116     return 'db' if -r getlocationpath('db')."/$bugnum.$ext";
 117     return undef;
 118 }
 119
 120
 121 =head2 getlocationpath
 122
 123      getlocationpath($location)
 124
 125 Returns the path to a specific location
 126
 127 =cut
 128
 129 sub getlocationpath {
 130      my ($location) = @_;
 131      if (defined $location and $location eq 'archive') {
 132           return "$config{spool_dir}/archive";
 133      } elsif (defined $location and $location eq 'db') {
 134           return "$config{spool_dir}/db";
 135      } else {
 136           return "$config{spool_dir}/db-h";
 137      }
 138 }
 139
 140
 141 =head2 get_hashname
 142
 143      get_hashname
 144
 145 Returns the hash of the bug which is the location within the archive
 146
 147 =cut
 148
 149 sub get_hashname {
 150     return "" if ( $_[ 0 ] < 0 );
 151     return sprintf "%02d", $_[ 0 ] % 100;
 152 }
 153
 154 =head2 buglog
 155
 156      buglog($bugnum);
 157
 158 Returns the path to the logfile corresponding to the bug.
 159
 160 =cut
 161
 162 sub buglog {
 163     my $bugnum = shift;
 164     my $location = getbuglocation($bugnum, 'log');
 165     return getbugcomponent($bugnum, 'log', $location) if ($location);
 166     $location = getbuglocation($bugnum, 'log.gz');
 167     return getbugcomponent($bugnum, 'log.gz', $location);
 168 }
 169
 170
 171 =head2 appendfile
 172
 173      appendfile($file,'data','to','append');
 174
 175 Opens a file for appending and writes data to it.
 176
 177 =cut
 178
 179 sub appendfile {
 180         my $file = shift;
 181         if (!open(AP,">>$file")) {
 182                 print $DEBUG_FH "failed open log<\n" if $DEBUG;
 183                 print $DEBUG_FH "failed open log err $!<\n" if $DEBUG;
 184                 &quit("opening $file (appendfile): $!");
 185         }
 186         print(AP @_) || &quit("writing $file (appendfile): $!");
 187         close(AP) || &quit("closing $file (appendfile): $!");
 188 }
 189
 190 =head2 getparsedaddrs
 191
 192      my $address = getparsedaddrs($address);
 193      my @address = getparsedaddrs($address);
 194
 195 Returns the output from Mail::Address->parse, or the cached output if
 196 this address has been parsed before. In SCALAR context returns the
 197 first address parsed.
 198
 199 =cut
 200
 201
 202 our %_parsedaddrs;
 203 sub getparsedaddrs {
 204     my $addr = shift;
 205     return () unless defined $addr;
 206     return wantarray?@{$_parsedaddrs{$addr}}:$_parsedaddrs{$addr}[0]
 207          if exists $_parsedaddrs{$addr};
 208     @{$_parsedaddrs{$addr}} = Mail::Address->parse($addr);
 209     return wantarray?@{$_parsedaddrs{$addr}}:$_parsedaddrs{$addr}[0];
 210 }
 211
 212 our $_maintainer;
 213 our $_maintainer_rev;
 214 sub getmaintainers {
 215     return $_maintainer if $_maintainer;
 216     my %maintainer;
 217     my %maintainer_rev;
 218     for my $file (@config{qw(maintainer_file maintainer_file_override)}) {
 219          next unless defined $file;
 220          my $maintfile = new IO::File $file,'r' or
 221               &quitcgi("Unable to open $file: $!");
 222          while(<$maintfile>) {
 223               next unless m/^(\S+)\s+(\S.*\S)\s*$/;
 224               ($a,$b)=($1,$2);
 225               $a =~ y/A-Z/a-z/;
 226               $maintainer{$a}= $b;
 227               for my $maint (map {lc($_->address)} getparsedaddrs($b)) {
 228                    push @{$maintainer_rev{$maint}},$a;
 229               }
 230          }
 231          close($maintfile);
 232     }
 233     $_maintainer = \%maintainer;
 234     $_maintainer_rev = \%maintainer_rev;
 235     return $_maintainer;
 236 }
 237 sub getmaintainers_reverse{
 238      return $_maintainer_rev if $_maintainer_rev;
 239      getmaintainers();
 240      return $_maintainer_rev;
 241 }
 242
 243 =head1 DATE
 244
 245     my $english = secs_to_english($seconds);
 246     my ($days,$english) = secs_to_english($seconds);
 247
 248 XXX This should probably be changed to use Date::Calc
 249
 250 =cut
 251
 252 sub secs_to_english{
 253      my ($seconds) = @_;
 254
 255      my $days = int($seconds / 86400);
 256      my $years = int($days / 365);
 257      $days %= 365;
 258      my $result;
 259      my @age;
 260      push @age, "1 year" if ($years == 1);
 261      push @age, "$years years" if ($years > 1);
 262      push @age, "1 day" if ($days == 1);
 263      push @age, "$days days" if ($days > 1);
 264      $result .= join(" and ", @age);
 265
 266      return wantarray?(int($seconds/86400),$result):$result;
 267 }
 268
 269
 270 =head1 LOCK
 271
 272 These functions are exported with the :lock tag
 273
 274 =head2 filelock
 275
 276      filelock
 277
 278 FLOCKs the passed file. Use unfilelock to unlock it.
 279
 280 =cut
 281
 282 our @filelocks;
 283 our @cleanups;
 284
 285 sub filelock {
 286     # NB - NOT COMPATIBLE WITH `with-lock'
 287     my ($lockfile) = @_;
 288     if ($lockfile !~ m{^/}) {
 289          $lockfile = cwd().'/'.$lockfile;
 290     }
 291     my ($count,$errors);
 292     $count= 10; $errors= '';
 293     for (;;) {
 294         my $fh = eval {
 295              my $fh2 = IO::File->new($lockfile,'w')
 296                   or die "Unable to open $lockfile for writing: $!";
 297              flock($fh2,LOCK_EX|LOCK_NB)
 298                   or die "Unable to lock $lockfile $!";
 299              return $fh2;
 300         };
 301         if ($@) {
 302              $errors .= $@;
 303         }
 304         if ($fh) {
 305              push @filelocks, {fh => $fh, file => $lockfile};
 306              last;
 307         }
 308         if (--$count <=0) {
 309             $errors =~ s/\n+$//;
 310             &quit("failed to get lock on $lockfile -- $errors");
 311         }
 312         sleep 10;
 313     }
 314     push(@cleanups,\&unfilelock);
 315 }
 316
 317
 318 =head2 unfilelock
 319
 320      unfilelock()
 321
 322 Unlocks the file most recently locked.
 323
 324 Note that it is not currently possible to unlock a specific file
 325 locked with filelock.
 326
 327 =cut
 328
 329 sub unfilelock {
 330     if (@filelocks == 0) {
 331         warn "unfilelock called with no active filelocks!\n";
 332         return;
 333     }
 334     my %fl = %{pop(@filelocks)};
 335     pop(@cleanups);
 336     flock($fl{fh},LOCK_UN)
 337          or warn "Unable to unlock lockfile $fl{file}: $!";
 338     close($fl{fh})
 339          or warn "Unable to close lockfile $fl{file}: $!";
 340     unlink($fl{file})
 341          or warn "Unable to unlink lockfile $fl{file}: $!";
 342 }
 343
 344 =head2 lockpid
 345
 346       lockpid('/path/to/pidfile');
 347
 348 Creates a pidfile '/path/to/pidfile' if one doesn't exist or if the
 349 pid in the file does not respond to kill 0.
 350
 351 Returns 1 on success, false on failure; dies on unusual errors.
 352
 353 =cut
 354
 355 sub lockpid {
 356      my ($pidfile) = @_;
 357      if (-e $pidfile) {
 358           my $pidfh = IO::File->new($pidfile, 'r') or
 359                die "Unable to open pidfile $pidfile: $!";
 360           local $/;
 361           my $pid = <$pidfh>;
 362           ($pid) = $pid =~ /(\d+)/;
 363           if (defined $pid and kill(0,$pid)) {
 364                return 0;
 365           }
 366           close $pidfh;
 367           unlink $pidfile or
 368                die "Unable to unlink stale pidfile $pidfile $!";
 369      }
 370      my $pidfh = IO::File->new($pidfile,'w') or
 371           die "Unable to open $pidfile for writing: $!";
 372      print {$pidfh} $$ or die "Unable to write to $pidfile $!";
 373      close $pidfh or die "Unable to close $pidfile $!";
 374      return 1;
 375 }
 376
 377
 378 =head1 QUIT
 379
 380 These functions are exported with the :quit tag.
 381
 382 =head2 quit
 383
 384      quit()
 385
 386 Exits the program by calling die after running some cleanups.
 387
 388 This should be replaced with an END handler which runs the cleanups
 389 instead. (Or possibly a die handler, if the cleanups are important)
 390
 391 =cut
 392
 393 sub quit {
 394     print $DEBUG_FH "quitting >$_[0]<\n" if $DEBUG;
 395     my ($u);
 396     while ($u= $cleanups[$#cleanups]) { &$u; }
 397     die "*** $_[0]\n";
 398 }
 399
 400 =head1 MISC
 401
 402 These functions are exported with the :misc tag
 403
 404 =head2 make_list
 405
 406      LIST = make_list(@_);
 407
 408 Turns a scalar or an arrayref into a list; expands a list of arrayrefs
 409 into a list.
 410
 411 That is, make_list([qw(a b c)]); returns qw(a b c); make_list([qw(a
 412 b)],[qw(c d)] returns qw(a b c d);
 413
 414 =cut
 415
 416 sub make_list {
 417      return map {(ref($_) eq 'ARRAY')?@{$_}:$_} @_;
 418 }
 419
 420
 421
 422 1;
 423
 424 __END__