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