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