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),
  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
 141 =head2 appendfile
 142
 143      appendfile($file,'data','to','append');
 144
 145 Opens a file for appending and writes data to it.
 146
 147 =cut
 148
 149 sub appendfile {
 150         my $file = shift;
 151         if (!open(AP,">>$file")) {
 152                 print DEBUG "failed open log<\n";
 153                 print DEBUG "failed open log err $!<\n";
 154                 &quit("opening $file (appendfile): $!");
 155         }
 156         print(AP @_) || &quit("writing $file (appendfile): $!");
 157         close(AP) || &quit("closing $file (appendfile): $!");
 158 }
 159
 160 =head1 LOCK
 161
 162 These functions are exported with the :lock tag
 163
 164 =head2 filelock
 165
 166      filelock
 167
 168 FLOCKs the passed file. Use unfilelock to unlock it.
 169
 170 =cut
 171
 172 my @filelocks;
 173 my @cleanups;
 174
 175 sub filelock {
 176     # NB - NOT COMPATIBLE WITH `with-lock'
 177     my ($lockfile) = @_;
 178     my ($count,$errors) = @_;
 179     $count= 10; $errors= '';
 180     for (;;) {
 181         my $fh = eval {
 182              my $fh = new IO::File $lockfile,'w'
 183                   or die "Unable to open $lockfile for writing: $!";
 184              flock($fh,LOCK_EX|LOCK_NB)
 185                   or die "Unable to lock $lockfile $!";
 186              return $fh;
 187         };
 188         if ($@) {
 189              $errors .= $@;
 190         }
 191         if ($fh) {
 192              push @filelocks, {fh => $fh, file => $lockfile};
 193              last;
 194         }
 195         if (--$count <=0) {
 196             $errors =~ s/\n+$//;
 197             &quit("failed to get lock on $lockfile -- $errors");
 198         }
 199         sleep 10;
 200     }
 201     push(@cleanups,\&unfilelock);
 202 }
 203
 204
 205 =head2 unfilelock
 206
 207      unfilelock()
 208
 209 Unlocks the file most recently locked.
 210
 211 Note that it is not currently possible to unlock a specific file
 212 locked with filelock.
 213
 214 =cut
 215
 216 sub unfilelock {
 217     if (@filelocks == 0) {
 218         warn "unfilelock called with no active filelocks!\n";
 219         return;
 220     }
 221     my %fl = %{pop(@filelocks)};
 222     pop(@cleanups);
 223     flock($fl{fh},LOCK_UN)
 224          or warn "Unable to unlock lockfile $fl{file}: $!";
 225     close($fl{fh})
 226          or warn "Unable to close lockfile $fl{file}: $!";
 227     unlink($fl{file})
 228          or warn "Unable to unlink locfile $fl{file}: $!";
 229 }
 230
 231
 232
 233 =head1 QUIT
 234
 235 These functions are exported with the :quit tag.
 236
 237 =head2 quit
 238
 239      quit()
 240
 241 Exits the program by calling die after running some cleanups.
 242
 243 This should be replaced with an END handler which runs the cleanups
 244 instead. (Or possibly a die handler, if the cleanups are important)
 245
 246 =cut
 247
 248 sub quit {
 249     print DEBUG "quitting >$_[0]<\n";
 250     my ($u);
 251     while ($u= $cleanups[$#cleanups]) { &$u; }
 252     die "*** $_[0]\n";
 253 }
 254
 255
 256
 257
 258 1;
 259
 260 __END__