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