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