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     {
 210          # don't display the warnings from Mail::Address->parse
 211          local $SIG{__WARN__} = sub { };
 212          @{$_parsedaddrs{$addr}} = Mail::Address->parse($addr);
 213     }
 214     return wantarray?@{$_parsedaddrs{$addr}}:$_parsedaddrs{$addr}[0];
 215 }
 216
 217 our $_maintainer;
 218 our $_maintainer_rev;
 219 sub getmaintainers {
 220     return $_maintainer if $_maintainer;
 221     my %maintainer;
 222     my %maintainer_rev;
 223     for my $file (@config{qw(maintainer_file maintainer_file_override pseduo_maint_file)}) {
 224          next unless defined $file;
 225          my $maintfile = new IO::File $file,'r' or
 226               &quitcgi("Unable to open $file: $!");
 227          while(<$maintfile>) {
 228               next unless m/^(\S+)\s+(\S.*\S)\s*$/;
 229               ($a,$b)=($1,$2);
 230               $a =~ y/A-Z/a-z/;
 231               $maintainer{$a}= $b;
 232               for my $maint (map {lc($_->address)} getparsedaddrs($b)) {
 233                    push @{$maintainer_rev{$maint}},$a;
 234               }
 235          }
 236          close($maintfile);
 237     }
 238     $_maintainer = \%maintainer;
 239     $_maintainer_rev = \%maintainer_rev;
 240     return $_maintainer;
 241 }
 242 sub getmaintainers_reverse{
 243      return $_maintainer_rev if $_maintainer_rev;
 244      getmaintainers();
 245      return $_maintainer_rev;
 246 }
 247
 248 =head2 getpseudodesc
 249
 250      my $pseudopkgdesc = getpseudodesc(...);
 251
 252 Returns the entry for a pseudo package from the
 253 $config{pseudo_desc_file}. In cases where pseudo_desc_file is not
 254 defined, returns an empty arrayref.
 255
 256 This function can be used to see if a particular package is a
 257 pseudopackage or not.
 258
 259 =cut
 260
 261 our $_pseudodesc;
 262 sub getpseudodesc {
 263     return $_pseudodesc if $_pseudodesc;
 264     my %pseudodesc;
 265
 266     if (not defined $config{pseudo_desc_file}) {
 267          $_pseudodesc = {};
 268          return $_pseudodesc;
 269     }
 270     my $pseudo = IO::File->new($config{pseudo_desc_file},'r')
 271          or die "Unable to open $config{pseudo_desc_file}: $!";
 272     while(<$pseudo>) {
 273         next unless m/^(\S+)\s+(\S.*\S)\s*$/;
 274         $pseudodesc{lc $1} = $2;
 275     }
 276     close($pseudo);
 277     $_pseudodesc = \%pseudodesc;
 278     return $_pseudodesc;
 279 }
 280
 281
 282 =head1 DATE
 283
 284     my $english = secs_to_english($seconds);
 285     my ($days,$english) = secs_to_english($seconds);
 286
 287 XXX This should probably be changed to use Date::Calc
 288
 289 =cut
 290
 291 sub secs_to_english{
 292      my ($seconds) = @_;
 293
 294      my $days = int($seconds / 86400);
 295      my $years = int($days / 365);
 296      $days %= 365;
 297      my $result;
 298      my @age;
 299      push @age, "1 year" if ($years == 1);
 300      push @age, "$years years" if ($years > 1);
 301      push @age, "1 day" if ($days == 1);
 302      push @age, "$days days" if ($days > 1);
 303      $result .= join(" and ", @age);
 304
 305      return wantarray?(int($seconds/86400),$result):$result;
 306 }
 307
 308
 309 =head1 LOCK
 310
 311 These functions are exported with the :lock tag
 312
 313 =head2 filelock
 314
 315      filelock
 316
 317 FLOCKs the passed file. Use unfilelock to unlock it.
 318
 319 =cut
 320
 321 our @filelocks;
 322 our @cleanups;
 323
 324 sub filelock {
 325     # NB - NOT COMPATIBLE WITH `with-lock'
 326     my ($lockfile) = @_;
 327     if ($lockfile !~ m{^/}) {
 328          $lockfile = cwd().'/'.$lockfile;
 329     }
 330     my ($count,$errors);
 331     $count= 10; $errors= '';
 332     for (;;) {
 333         my $fh = eval {
 334              my $fh2 = IO::File->new($lockfile,'w')
 335                   or die "Unable to open $lockfile for writing: $!";
 336              flock($fh2,LOCK_EX|LOCK_NB)
 337                   or die "Unable to lock $lockfile $!";
 338              return $fh2;
 339         };
 340         if ($@) {
 341              $errors .= $@;
 342         }
 343         if ($fh) {
 344              push @filelocks, {fh => $fh, file => $lockfile};
 345              last;
 346         }
 347         if (--$count <=0) {
 348             $errors =~ s/\n+$//;
 349             &quit("failed to get lock on $lockfile -- $errors");
 350         }
 351         sleep 10;
 352     }
 353     push(@cleanups,\&unfilelock);
 354 }
 355
 356
 357 =head2 unfilelock
 358
 359      unfilelock()
 360
 361 Unlocks the file most recently locked.
 362
 363 Note that it is not currently possible to unlock a specific file
 364 locked with filelock.
 365
 366 =cut
 367
 368 sub unfilelock {
 369     if (@filelocks == 0) {
 370         warn "unfilelock called with no active filelocks!\n";
 371         return;
 372     }
 373     my %fl = %{pop(@filelocks)};
 374     pop(@cleanups);
 375     flock($fl{fh},LOCK_UN)
 376          or warn "Unable to unlock lockfile $fl{file}: $!";
 377     close($fl{fh})
 378          or warn "Unable to close lockfile $fl{file}: $!";
 379     unlink($fl{file})
 380          or warn "Unable to unlink lockfile $fl{file}: $!";
 381 }
 382
 383 =head2 lockpid
 384
 385       lockpid('/path/to/pidfile');
 386
 387 Creates a pidfile '/path/to/pidfile' if one doesn't exist or if the
 388 pid in the file does not respond to kill 0.
 389
 390 Returns 1 on success, false on failure; dies on unusual errors.
 391
 392 =cut
 393
 394 sub lockpid {
 395      my ($pidfile) = @_;
 396      if (-e $pidfile) {
 397           my $pidfh = IO::File->new($pidfile, 'r') or
 398                die "Unable to open pidfile $pidfile: $!";
 399           local $/;
 400           my $pid = <$pidfh>;
 401           ($pid) = $pid =~ /(\d+)/;
 402           if (defined $pid and kill(0,$pid)) {
 403                return 0;
 404           }
 405           close $pidfh;
 406           unlink $pidfile or
 407                die "Unable to unlink stale pidfile $pidfile $!";
 408      }
 409      my $pidfh = IO::File->new($pidfile,'w') or
 410           die "Unable to open $pidfile for writing: $!";
 411      print {$pidfh} $$ or die "Unable to write to $pidfile $!";
 412      close $pidfh or die "Unable to close $pidfile $!";
 413      return 1;
 414 }
 415
 416
 417 =head1 QUIT
 418
 419 These functions are exported with the :quit tag.
 420
 421 =head2 quit
 422
 423      quit()
 424
 425 Exits the program by calling die after running some cleanups.
 426
 427 This should be replaced with an END handler which runs the cleanups
 428 instead. (Or possibly a die handler, if the cleanups are important)
 429
 430 =cut
 431
 432 sub quit {
 433     print $DEBUG_FH "quitting >$_[0]<\n" if $DEBUG;
 434     my ($u);
 435     while ($u= $cleanups[$#cleanups]) { &$u; }
 436     die "*** $_[0]\n";
 437 }
 438
 439 =head1 MISC
 440
 441 These functions are exported with the :misc tag
 442
 443 =head2 make_list
 444
 445      LIST = make_list(@_);
 446
 447 Turns a scalar or an arrayref into a list; expands a list of arrayrefs
 448 into a list.
 449
 450 That is, make_list([qw(a b c)]); returns qw(a b c); make_list([qw(a
 451 b)],[qw(c d)] returns qw(a b c d);
 452
 453 =cut
 454
 455 sub make_list {
 456      return map {(ref($_) eq 'ARRAY')?@{$_}:$_} @_;
 457 }
 458
 459
 460
 461 1;
 462
 463 __END__