X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=Debbugs%2FCommon.pm;h=2bc3e0dfe3280143f0243b6ae8df189376ead1a7;hb=1f81df46999fc3699ce73aeba95af5095a5a413a;hp=cf53b07e0e35344c35823496315585cd958df8ca;hpb=e26e4c2c8243d3e6f9f461f5b59e4abb3b761f84;p=debbugs.git

diff --git a/Debbugs/Common.pm b/Debbugs/Common.pm
index cf53b07..2bc3e0d 100644
--- a/Debbugs/Common.pm
+++ b/Debbugs/Common.pm
@@ -31,7 +31,7 @@ with equivalent (or better) functionality here.
 use warnings;
 use strict;
 use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT);
-use base qw(Exporter);
+use Exporter qw(import);
 
 BEGIN{
      $VERSION = 1.00;
@@ -52,7 +52,7 @@ BEGIN{
 			       ],
 		     date   => [qw(secs_to_english)],
 		     quit   => [qw(quit)],
-		     lock   => [qw(filelock unfilelock lockpid)],
+		     lock   => [qw(filelock unfilelock lockpid simple_filelock simple_unlockfile)],
 		    );
      @EXPORT_OK = ();
      Exporter::export_ok_tags(keys %EXPORT_TAGS);
@@ -71,6 +71,7 @@ use Debbugs::MIME qw(decode_rfc1522);
 use Mail::Address;
 use Cwd qw(cwd);
 use Storable qw(dclone);
+use Time::HiRes qw(usleep);
 
 use Params::Validate qw(validate_with :types);
 
@@ -434,8 +435,8 @@ sub __add_to_hash {
     binmode($fh,':encoding(UTF-8)');
     while (<$fh>) {
 	chomp;
-	next unless m/^(\S+)\s+(\S.*\S)\s*$/;
-	my ($key,$value)=($1,$2);
+        next unless m/^(\S+)\s+(\S.*\S)\s*$/;
+        my ($key,$value)=($1,$2);
 	$key = lc $key;
 	$forward->{$key}= $value;
 	if (defined $reverse) {
@@ -573,35 +574,77 @@ sub filelock {
 	    confess "Locking already locked file: $lockfile\n".Data::Dumper->Dump([$lockfile,$locks],[qw(lockfile locks)]);
 	}
     }
-    my ($count,$errors);
-    $count= 10; $errors= '';
-    for (;;) {
-	my $fh = eval {
+    my ($fh,$t_lockfile,$errors) =
+        simple_filelock($lockfile,10,1);
+    if ($fh) {
+        push @filelocks, {fh => $fh, file => $lockfile};
+        if (defined $locks) {
+            $locks->{locks}{$lockfile}++;
+            push @{$locks->{lockorder}},$lockfile;
+        }
+    } else {
+        use Data::Dumper;
+        croak "failed to get lock on $lockfile -- $errors".
+            (defined $locks?Data::Dumper->Dump([$locks],[qw(locks)]):'');
+    }
+}
+
+=head2 simple_filelock
+
+    my ($fh,$t_lockfile,$errors) =
+        simple_filelock($lockfile,$count,$wait);
+
+Does a flock of lockfile. If C<$count> is zero, does a blocking lock.
+Otherwise, does a non-blocking lock C<$count> times, waiting C<$wait>
+seconds in between.
+
+In list context, returns the lockfile filehandle, lockfile name, and
+any errors which occured.
+
+When the lockfile filehandle is undef, locking failed.
+
+These lockfiles must be unlocked manually at process end.
+
+
+=cut
+
+sub simple_filelock {
+    my ($lockfile,$count,$wait) = @_;
+    if (not defined $count) {
+        $count = 10;
+    }
+    if ($count < 0) {
+        $count = 0;
+    }
+    if (not defined $wait) {
+        $wait = 1;
+    }
+    my $errors= '';
+    my $fh;
+    while (1) {
+        $fh = eval {
 	     my $fh2 = IO::File->new($lockfile,'w')
 		  or die "Unable to open $lockfile for writing: $!";
-	     flock($fh2,LOCK_EX|LOCK_NB)
+             # Do a blocking lock if count is zero
+	     flock($fh2,LOCK_EX|($count == 0?0:LOCK_NB))
 		  or die "Unable to lock $lockfile $!";
 	     return $fh2;
 	};
 	if ($@) {
 	     $errors .= $@;
 	}
-	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+$//;
-	    use Data::Dumper;
-            croak "failed to get lock on $lockfile -- $errors".
-		(defined $locks?Data::Dumper->Dump([$locks],[qw(locks)]):'');
+        if ($fh) {
+            last;
         }
-#        sleep 10;
+        # use usleep for fractional wait seconds
+        usleep($wait * 1_000_000);
+    } continue {
+        last unless (--$count > 0);
+    } 
+    if ($fh) {
+        return wantarray?($fh,$lockfile,$errors):$fh
     }
+    return wantarray?(undef,$lockfile,$errors):undef;
 }
 
 # clean up all outstanding locks at end time
@@ -611,6 +654,23 @@ END {
      }
 }
 
+=head2 simple_unlockfile
+
+     simple_unlockfile($fh,$lockfile);
+
+
+=cut
+
+sub simple_unlockfile {
+    my ($fh,$lockfile) = @_;
+    flock($fh,LOCK_UN)
+        or warn "Unable to unlock lockfile $lockfile: $!";
+    close($fh)
+        or warn "Unable to close lockfile $lockfile: $!";
+    unlink($lockfile)
+        or warn "Unable to unlink lockfile $lockfile: $!";
+}
+
 
 =head2 unfilelock
 
@@ -644,12 +704,7 @@ sub unfilelock {
 	delete $locks->{locks}{$lockfile};
     }
     my %fl = %{pop(@filelocks)};
-    flock($fl{fh},LOCK_UN)
-	 or warn "Unable to unlock lockfile $fl{file}: $!";
-    close($fl{fh})
-	 or warn "Unable to close lockfile $fl{file}: $!";
-    unlink($fl{file})
-	 or warn "Unable to unlink lockfile $fl{file}: $!";
+    simple_unlockfile($fl{fh},$fl{file});
 }
 
 
@@ -882,7 +937,7 @@ sub cleanup_eval_fail {
     # ditch the "at foo/bar/baz.pm line 5"
     $error =~ s/\sat\s\S+\sline\s\d+//;
     # ditch croak messages
-    $error =~ s/^\t+.+\n?//g;
+    $error =~ s/^\t+.+\n?//mg;
     # ditch trailing multiple periods in case there was a cascade of
     # die messages.
     $error =~ s/\.+$/\./;