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