allow for tracking locks and relocking

[debbugs.git] / Debbugs / Common.pm

diff --git a/Debbugs/Common.pm b/Debbugs/Common.pm
index ab51dbacf5c86f5ab20ce9da4ff22f96a150f4b5..ae3c844936dcf26c09293d80e0a2bd3a77ac2074 100644 (file)
--- a/Debbugs/Common.pm
+++ b/Debbugs/Common.pm
@@ -62,6 +62,7 @@ BEGIN{
 #use Debbugs::Config qw(:globals);
 
 use Carp;
+$Carp::Verbose = 1;
 
 use Debbugs::Config qw(:config);
 use IO::File;
@@ -72,7 +73,7 @@ use Cwd qw(cwd);
 
 use Params::Validate qw(validate_with :types);
 
-use Fcntl qw(:flock);
+use Fcntl qw(:DEFAULT :flock);
 
 our $DEBUG_FH = \*STDERR if not defined $DEBUG_FH;
 
@@ -509,20 +510,44 @@ These functions are exported with the :lock tag
 
 =head2 filelock
 
-     filelock
+     filelock($lockfile);
+     filelock($lockfile,$locks);
 
 FLOCKs the passed file. Use unfilelock to unlock it.
 
+Can be passed an optional $locks hashref, which is used to track which
+files are locked (and how many times they have been locked) to allow
+for cooperative locking.
+
 =cut
 
 our @filelocks;
 
+use Carp qw(cluck);
+
 sub filelock {
     # NB - NOT COMPATIBLE WITH `with-lock'
-    my ($lockfile) = @_;
+    my ($lockfile,$locks) = @_;
     if ($lockfile !~ m{^/}) {
         $lockfile = cwd().'/'.$lockfile;
     }
+    # This is only here to allow for relocking bugs inside of
+    # Debbugs::Control. Nothing else should be using it.
+    if (defined $locks and exists $locks->{locks}{$lockfile} and
+       $locks->{locks}{$lockfile} >= 1) {
+       if (exists $locks->{relockable} and
+           exists $locks->{relockable}{$lockfile}) {
+           $locks->{locks}{$lockfile}++;
+           # indicate that the bug for this lockfile needs to be reread
+           $locks->{relockable}{$lockfile} = 1;
+           push @{$locks->{lockorder}},$lockfile;
+           return;
+       }
+       else {
+           use Data::Dumper;
+           confess "Locking already locked file: $lockfile\n".Data::Dumper->Dump([$lockfile,$locks],[qw(lockfile locks)]);
+       }
+    }
     my ($count,$errors);
     $count= 10; $errors= '';
     for (;;) {
@@ -538,13 +563,19 @@ sub filelock {
        }
        if ($fh) {
             push @filelocks, {fh => $fh, file => $lockfile};
+            if (defined $locks) {
+                $locks->{locks}{$lockfile}++;
+                push @{$locks->{lockorder}},$lockfile;
+            }
             last;
        }
         if (--$count <=0) {
             $errors =~ s/\n+$//;
-            die "failed to get lock on $lockfile -- $errors";
+           use Data::Dumper;
+            croak "failed to get lock on $lockfile -- $errors".
+               (defined $locks?Data::Dumper->Dump([$locks],[qw(locks)]):'');
         }
-        sleep 10;
+#        sleep 10;
     }
 }
 
@@ -559,6 +590,7 @@ END {
 =head2 unfilelock
 
      unfilelock()
+     unfilelock($locks);
 
 Unlocks the file most recently locked.
 
@@ -568,10 +600,24 @@ locked with filelock.
 =cut
 
 sub unfilelock {
+    my ($locks) = @_;
     if (@filelocks == 0) {
-        warn "unfilelock called with no active filelocks!\n";
+        carp "unfilelock called with no active filelocks!\n";
         return;
     }
+    if (defined $locks and ref($locks) ne 'HASH') {
+       croak "hash not passsed to unfilelock";
+    }
+    if (defined $locks and exists $locks->{lockorder} and
+       @{$locks->{lockorder}} and
+       exists $locks->{locks}{$locks->{lockorder}[-1]}) {
+       my $lockfile = pop @{$locks->{lockorder}};
+       $locks->{locks}{$lockfile}--;
+       if ($locks->{locks}{$lockfile} > 0) {
+           return
+       }
+       delete $locks->{locks}{$lockfile};
+    }
     my %fl = %{pop(@filelocks)};
     flock($fl{fh},LOCK_UN)
         or warn "Unable to unlock lockfile $fl{file}: $!";
@@ -602,7 +648,7 @@ sub lockpid {
          unlink $pidfile or
               die "Unable to unlink stale pidfile $pidfile $!";
      }
-     my $pidfh = IO::File->new($pidfile,'w') or
+     my $pidfh = IO::File->new($pidfile,O_CREAT|O_EXCL|O_WRONLY) or
          die "Unable to open $pidfile for writing: $!";
      print {$pidfh} $$ or die "Unable to write to $pidfile $!";
      close $pidfh or die "Unable to close $pidfile $!";