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