Debbugs/Common.pm

   1
   2 package Debbugs::Common;
   3
   4 =head1 NAME
   5
   6 Debbugs::Common -- Common routines for all of Debbugs
   7
   8 =head1 SYNOPSIS
   9
  10 use Debbugs::Common qw(:url :html);
  11
  12
  13 =head1 DESCRIPTION
  14
  15 This module is a replacement for the general parts of errorlib.pl.
  16 subroutines in errorlib.pl will be gradually phased out and replaced
  17 with equivalent (or better) functionality here.
  18
  19 =head1 FUNCTIONS
  20
  21 =cut
  22
  23 use warnings;
  24 use strict;
  25 use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT);
  26 use base qw(Exporter);
  27
  28 BEGIN{
  29      $VERSION = 1.00;
  30      $DEBUG = 0 unless defined $DEBUG;
  31
  32      @EXPORT = ();
  33      %EXPORT_TAGS = (util   => [qw(getbugcomponent getbuglocation getlocationpath get_hashname),
  34                                 qw(appendfile buglog getparsedaddrs getmaintainers),
  35                                 qw(getmaintainers_reverse)
  36                                ],
  37                      quit   => [qw(quit)],
  38                      lock   => [qw(filelock unfilelock @cleanups)],
  39                     );
  40      @EXPORT_OK = ();
  41      Exporter::export_ok_tags(qw(lock quit util));
  42      $EXPORT_TAGS{all} = [@EXPORT_OK];
  43 }
  44
  45 #use Debbugs::Config qw(:globals);
  46 use Debbugs::Config qw(:config);
  47 use IO::File;
  48 use Debbugs::MIME qw(decode_rfc1522);
  49 use Mail::Address;
  50 use Cwd qw(cwd);
  51
  52 use Fcntl qw(:flock);
  53
  54 our $DEBUG_FH = \*STDERR if not defined $DEBUG_FH;
  55
  56 =head1 UTILITIES
  57
  58 The following functions are exported by the C<:util> tag
  59
  60 =head2 getbugcomponent
  61
  62      my $file = getbugcomponent($bug_number,$extension,$location)
  63
  64 Returns the path to the bug file in location C<$location>, bug number
  65 C<$bugnumber> and extension C<$extension>
  66
  67 =cut
  68
  69 sub getbugcomponent {
  70     my ($bugnum, $ext, $location) = @_;
  71
  72     if (not defined $location) {
  73         $location = getbuglocation($bugnum, $ext);
  74         # Default to non-archived bugs only for now; CGI scripts want
  75         # archived bugs but most of the backend scripts don't. For now,
  76         # anything that is prepared to accept archived bugs should call
  77         # getbuglocation() directly first.
  78         return undef if defined $location and
  79                         ($location ne 'db' and $location ne 'db-h');
  80     }
  81     my $dir = getlocationpath($location);
  82     return undef if not defined $dir;
  83     if (defined $location and $location eq 'db') {
  84         return "$dir/$bugnum.$ext";
  85     } else {
  86         my $hash = get_hashname($bugnum);
  87         return "$dir/$hash/$bugnum.$ext";
  88     }
  89 }
  90
  91 =head2 getbuglocation
  92
  93      getbuglocation($bug_number,$extension)
  94
  95 Returns the the location in which a particular bug exists; valid
  96 locations returned currently are archive, db-h, or db. If the bug does
  97 not exist, returns undef.
  98
  99 =cut
 100
 101 sub getbuglocation {
 102     my ($bugnum, $ext) = @_;
 103     my $archdir = get_hashname($bugnum);
 104     return 'archive' if -r getlocationpath('archive')."/$archdir/$bugnum.$ext";
 105     return 'db-h' if -r getlocationpath('db-h')."/$archdir/$bugnum.$ext";
 106     return 'db' if -r getlocationpath('db')."/$bugnum.$ext";
 107     return undef;
 108 }
 109
 110
 111 =head2 getlocationpath
 112
 113      getlocationpath($location)
 114
 115 Returns the path to a specific location
 116
 117 =cut
 118
 119 sub getlocationpath {
 120      my ($location) = @_;
 121      if (defined $location and $location eq 'archive') {
 122           return "$config{spool_dir}/archive";
 123      } elsif (defined $location and $location eq 'db') {
 124           return "$config{spool_dir}/db";
 125      } else {
 126           return "$config{spool_dir}/db-h";
 127      }
 128 }
 129
 130
 131 =head2 get_hashname
 132
 133      get_hashname
 134
 135 Returns the hash of the bug which is the location within the archive
 136
 137 =cut
 138
 139 sub get_hashname {
 140     return "" if ( $_[ 0 ] < 0 );
 141     return sprintf "%02d", $_[ 0 ] % 100;
 142 }
 143
 144 =head2 buglog
 145
 146      buglog($bugnum);
 147
 148 Returns the path to the logfile corresponding to the bug.
 149
 150 =cut
 151
 152 sub buglog {
 153     my $bugnum = shift;
 154     my $location = getbuglocation($bugnum, 'log');
 155     return getbugcomponent($bugnum, 'log', $location) if ($location);
 156     $location = getbuglocation($bugnum, 'log.gz');
 157     return getbugcomponent($bugnum, 'log.gz', $location);
 158 }
 159
 160
 161 =head2 appendfile
 162
 163      appendfile($file,'data','to','append');
 164
 165 Opens a file for appending and writes data to it.
 166
 167 =cut
 168
 169 sub appendfile {
 170         my $file = shift;
 171         if (!open(AP,">>$file")) {
 172                 print $DEBUG_FH "failed open log<\n" if $DEBUG;
 173                 print $DEBUG_FH "failed open log err $!<\n" if $DEBUG;
 174                 &quit("opening $file (appendfile): $!");
 175         }
 176         print(AP @_) || &quit("writing $file (appendfile): $!");
 177         close(AP) || &quit("closing $file (appendfile): $!");
 178 }
 179
 180 =head2 getparsedaddrs
 181
 182      my $address = getparsedaddrs($address);
 183      my @address = getpasredaddrs($address);
 184
 185 Returns the output from Mail::Address->parse, or the cached output if
 186 this address has been parsed before. In SCALAR context returns the
 187 first address parsed.
 188
 189 =cut
 190
 191
 192 my %_parsedaddrs;
 193 sub getparsedaddrs {
 194     my $addr = shift;
 195     return () unless defined $addr;
 196     return wantarray?@{$_parsedaddrs{$addr}}:$_parsedaddrs{$addr}[0]
 197          if exists $_parsedaddrs{$addr};
 198     @{$_parsedaddrs{$addr}} = Mail::Address->parse($addr);
 199     return wantarray?@{$_parsedaddrs{$addr}}:$_parsedaddrs{$addr}[0];
 200 }
 201
 202 my $_maintainer;
 203 my $_maintainer_rev;
 204 sub getmaintainers {
 205     return $_maintainer if $_maintainer;
 206     my %maintainer;
 207     my %maintainer_rev;
 208     for my $file (@config{qw(maintainer_file maintainer_file_override)}) {
 209          next unless defined $file;
 210          my $maintfile = new IO::File $file,'r' or
 211               &quitcgi("Unable to open $file: $!");
 212          while(<$maintfile>) {
 213               next unless m/^(\S+)\s+(\S.*\S)\s*$/;
 214               ($a,$b)=($1,$2);
 215               $a =~ y/A-Z/a-z/;
 216               $maintainer{$a}= $b;
 217               for my $maint (map {lc($_->address)} getparsedaddrs($b)) {
 218                    push @{$maintainer_rev{$maint}},$a;
 219               }
 220          }
 221          close($maintfile);
 222     }
 223     $_maintainer = \%maintainer;
 224     $_maintainer_rev = \%maintainer_rev;
 225     return $_maintainer;
 226 }
 227 sub getmaintainers_reverse{
 228      return $_maintainer_rev if $_maintainer_rev;
 229      getmaintainers();
 230      return $_maintainer_rev;
 231 }
 232
 233
 234 =head1 LOCK
 235
 236 These functions are exported with the :lock tag
 237
 238 =head2 filelock
 239
 240      filelock
 241
 242 FLOCKs the passed file. Use unfilelock to unlock it.
 243
 244 =cut
 245
 246 my @filelocks;
 247 our @cleanups;
 248
 249 sub filelock {
 250     # NB - NOT COMPATIBLE WITH `with-lock'
 251     my ($lockfile) = @_;
 252     if ($lockfile !~ m{^/}) {
 253          $lockfile = cwd().'/'.$lockfile;
 254     }
 255     my ($count,$errors);
 256     $count= 10; $errors= '';
 257     for (;;) {
 258         my $fh = eval {
 259              my $fh2 = IO::File->new($lockfile,'w')
 260                   or die "Unable to open $lockfile for writing: $!";
 261              flock($fh2,LOCK_EX|LOCK_NB)
 262                   or die "Unable to lock $lockfile $!";
 263              return $fh2;
 264         };
 265         if ($@) {
 266              $errors .= $@;
 267         }
 268         if ($fh) {
 269              push @filelocks, {fh => $fh, file => $lockfile};
 270              last;
 271         }
 272         if (--$count <=0) {
 273             $errors =~ s/\n+$//;
 274             &quit("failed to get lock on $lockfile -- $errors");
 275         }
 276         sleep 10;
 277     }
 278     push(@cleanups,\&unfilelock);
 279 }
 280
 281
 282 =head2 unfilelock
 283
 284      unfilelock()
 285
 286 Unlocks the file most recently locked.
 287
 288 Note that it is not currently possible to unlock a specific file
 289 locked with filelock.
 290
 291 =cut
 292
 293 sub unfilelock {
 294     if (@filelocks == 0) {
 295         warn "unfilelock called with no active filelocks!\n";
 296         return;
 297     }
 298     my %fl = %{pop(@filelocks)};
 299     pop(@cleanups);
 300     flock($fl{fh},LOCK_UN)
 301          or warn "Unable to unlock lockfile $fl{file}: $!";
 302     close($fl{fh})
 303          or warn "Unable to close lockfile $fl{file}: $!";
 304     unlink($fl{file})
 305          or warn "Unable to unlink lockfile $fl{file}: $!";
 306 }
 307
 308
 309
 310 =head1 QUIT
 311
 312 These functions are exported with the :quit tag.
 313
 314 =head2 quit
 315
 316      quit()
 317
 318 Exits the program by calling die after running some cleanups.
 319
 320 This should be replaced with an END handler which runs the cleanups
 321 instead. (Or possibly a die handler, if the cleanups are important)
 322
 323 =cut
 324
 325 sub quit {
 326     print $DEBUG_FH "quitting >$_[0]<\n" if $DEBUG;
 327     my ($u);
 328     while ($u= $cleanups[$#cleanups]) { &$u; }
 329     die "*** $_[0]\n";
 330 }
 331
 332
 333
 334
 335 1;
 336
 337 __END__