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