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),
  35                                ],
  36                      quit   => [qw(quit)],
  37                      lock   => [qw(filelock unfilelock)],
  38                     );
  39      @EXPORT_OK = ();
  40      Exporter::export_ok_tags(qw(lock quit util));
  41      $EXPORT_TAGS{all} = [@EXPORT_OK];
  42 }
  43
  44 #use Debbugs::Config qw(:globals);
  45 use Debbugs::Config qw(:config);
  46 use IO::File;
  47 use Debbugs::MIME qw(decode_rfc1522);
  48
  49 use Fcntl qw(:flock);
  50
  51 =head1 UTILITIES
  52
  53 The following functions are exported by the C<:util> tag
  54
  55 =head2 getbugcomponent
  56
  57      my $file = getbugcomponent($bug_number,$extension,$location)
  58
  59 Returns the path to the bug file in location C<$location>, bug number
  60 C<$bugnumber> and extension C<$extension>
  61
  62 =cut
  63
  64 sub getbugcomponent {
  65     my ($bugnum, $ext, $location) = @_;
  66
  67     if (not defined $location) {
  68         $location = getbuglocation($bugnum, $ext);
  69         # Default to non-archived bugs only for now; CGI scripts want
  70         # archived bugs but most of the backend scripts don't. For now,
  71         # anything that is prepared to accept archived bugs should call
  72         # getbuglocation() directly first.
  73         return undef if defined $location and
  74                         ($location ne 'db' and $location ne 'db-h');
  75     }
  76     return undef if not defined $location;
  77     my $dir = getlocationpath($location);
  78     return undef if not defined $dir;
  79     if ($location eq 'db') {
  80         return "$dir/$bugnum.$ext";
  81     } else {
  82         my $hash = get_hashname($bugnum);
  83         return "$dir/$hash/$bugnum.$ext";
  84     }
  85 }
  86
  87 =head2 getbuglocation
  88
  89      getbuglocation($bug_number,$extension)
  90
  91 Returns the the location in which a particular bug exists; valid
  92 locations returned currently are archive, db-h, or db. If the bug does
  93 not exist, returns undef.
  94
  95 =cut
  96
  97 sub getbuglocation {
  98     my ($bugnum, $ext) = @_;
  99     my $archdir = get_hashname($bugnum);
 100     return 'archive' if -r getlocationpath('archive')."/$archdir/$bugnum.$ext";
 101     return 'db-h' if -r getlocationpath('db-h')."/$archdir/$bugnum.$ext";
 102     return 'db' if -r getlocationpath('db')."/$bugnum.$ext";
 103     return undef;
 104 }
 105
 106
 107 =head2 getlocationpath
 108
 109      getlocationpath($location)
 110
 111 Returns the path to a specific location
 112
 113 =cut
 114
 115 sub getlocationpath {
 116      my ($location) = @_;
 117      if (defined $location and $location eq 'archive') {
 118           return "$config{spool_dir}/archive";
 119      } elsif (defined $location and $location eq 'db') {
 120           return "$config{spool_dir}/db";
 121      } else {
 122           return "$config{spool_dir}/db-h";
 123      }
 124 }
 125
 126
 127 =head2 get_hashname
 128
 129      get_hashname
 130
 131 Returns the hash of the bug which is the location within the archive
 132
 133 =cut
 134
 135 sub get_hashname {
 136     return "" if ( $_[ 0 ] < 0 );
 137     return sprintf "%02d", $_[ 0 ] % 100;
 138 }
 139
 140 =head2 buglog
 141
 142      buglog($bugnum);
 143
 144 Returns the path to the logfile corresponding to the bug.
 145
 146 =cut
 147
 148 sub buglog {
 149     my $bugnum = shift;
 150     my $location = getbuglocation($bugnum, 'log');
 151     return getbugcomponent($bugnum, 'log', $location) if ($location);
 152     $location = getbuglocation($bugnum, 'log.gz');
 153     return getbugcomponent($bugnum, 'log.gz', $location);
 154 }
 155
 156
 157 =head2 appendfile
 158
 159      appendfile($file,'data','to','append');
 160
 161 Opens a file for appending and writes data to it.
 162
 163 =cut
 164
 165 sub appendfile {
 166         my $file = shift;
 167         if (!open(AP,">>$file")) {
 168                 print DEBUG "failed open log<\n";
 169                 print DEBUG "failed open log err $!<\n";
 170                 &quit("opening $file (appendfile): $!");
 171         }
 172         print(AP @_) || &quit("writing $file (appendfile): $!");
 173         close(AP) || &quit("closing $file (appendfile): $!");
 174 }
 175
 176 =head1 LOCK
 177
 178 These functions are exported with the :lock tag
 179
 180 =head2 filelock
 181
 182      filelock
 183
 184 FLOCKs the passed file. Use unfilelock to unlock it.
 185
 186 =cut
 187
 188 my @filelocks;
 189 my @cleanups;
 190
 191 sub filelock {
 192     # NB - NOT COMPATIBLE WITH `with-lock'
 193     my ($lockfile) = @_;
 194     my ($count,$errors) = @_;
 195     $count= 10; $errors= '';
 196     for (;;) {
 197         my $fh = eval {
 198              my $fh = new IO::File $lockfile,'w'
 199                   or die "Unable to open $lockfile for writing: $!";
 200              flock($fh,LOCK_EX|LOCK_NB)
 201                   or die "Unable to lock $lockfile $!";
 202              return $fh;
 203         };
 204         if ($@) {
 205              $errors .= $@;
 206         }
 207         if ($fh) {
 208              push @filelocks, {fh => $fh, file => $lockfile};
 209              last;
 210         }
 211         if (--$count <=0) {
 212             $errors =~ s/\n+$//;
 213             &quit("failed to get lock on $lockfile -- $errors");
 214         }
 215         sleep 10;
 216     }
 217     push(@cleanups,\&unfilelock);
 218 }
 219
 220
 221 =head2 unfilelock
 222
 223      unfilelock()
 224
 225 Unlocks the file most recently locked.
 226
 227 Note that it is not currently possible to unlock a specific file
 228 locked with filelock.
 229
 230 =cut
 231
 232 sub unfilelock {
 233     if (@filelocks == 0) {
 234         warn "unfilelock called with no active filelocks!\n";
 235         return;
 236     }
 237     my %fl = %{pop(@filelocks)};
 238     pop(@cleanups);
 239     flock($fl{fh},LOCK_UN)
 240          or warn "Unable to unlock lockfile $fl{file}: $!";
 241     close($fl{fh})
 242          or warn "Unable to close lockfile $fl{file}: $!";
 243     unlink($fl{file})
 244          or warn "Unable to unlink locfile $fl{file}: $!";
 245 }
 246
 247
 248
 249 =head1 QUIT
 250
 251 These functions are exported with the :quit tag.
 252
 253 =head2 quit
 254
 255      quit()
 256
 257 Exits the program by calling die after running some cleanups.
 258
 259 This should be replaced with an END handler which runs the cleanups
 260 instead. (Or possibly a die handler, if the cleanups are important)
 261
 262 =cut
 263
 264 sub quit {
 265     print DEBUG "quitting >$_[0]<\n";
 266     my ($u);
 267     while ($u= $cleanups[$#cleanups]) { &$u; }
 268     die "*** $_[0]\n";
 269 }
 270
 271
 272
 273
 274 1;
 275
 276 __END__