X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=Debbugs%2FCommon.pm;h=abc98dc6efe6f5d65191ae3f012004c4ff8891f1;hb=593feb86562b711efd71e4d03239e188ddeea051;hp=1331ac003cb8108a4b3f46b8564b334162f37e84;hpb=04265c83beff7e1ccb28a88ff7257fe36b2fc45d;p=debbugs.git

diff --git a/Debbugs/Common.pm b/Debbugs/Common.pm
index 1331ac0..abc98dc 100644
--- a/Debbugs/Common.pm
+++ b/Debbugs/Common.pm
@@ -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,10 +71,12 @@ 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);
 
 use Fcntl qw(:DEFAULT :flock);
+use Encode qw(is_utf8 decode_utf8);
 
 our $DEBUG_FH = \*STDERR if not defined $DEBUG_FH;
 
@@ -433,8 +435,11 @@ 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);
+        my @elements = split /\t/;
+        next unless @elements >=2;
+        # we do this because the source maintainer file contains the
+        # archive location, which we don't care about
+        my ($key,$value)=($elements[0],$elements[-1]);
 	$key = lc $key;
 	$forward->{$key}= $value;
 	if (defined $reverse) {
@@ -572,35 +577,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
@@ -610,6 +657,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
 
@@ -643,12 +707,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});
 }
 
 
@@ -816,6 +875,10 @@ Will carp if given a scalar which isn't a scalarref or a glob (or
 globref), and return /dev/null. May return undef if IO::Scalar or
 IO::File fails. (Check $!)
 
+The scalar will fill with octets, not perl's internal encoding, so you
+must use decode_utf8() after on the scalar, and encode_utf8() on it
+before. This appears to be a bug in the underlying modules.
+
 =cut
 
 sub globify_scalar {
@@ -825,7 +888,11 @@ sub globify_scalar {
 	  if (defined ref($scalar)) {
 	       if (ref($scalar) eq 'SCALAR' and
 		   not UNIVERSAL::isa($scalar,'GLOB')) {
-		    open $handle, '>:scalar:encoding(UTF-8)', $scalar;
+                   if (is_utf8(${$scalar})) {
+                       ${$scalar} = decode_utf8(${$scalar});
+                       carp(q(\$scalar must not be in perl's internal encoding));
+                   }
+		    open $handle, '>:scalar:utf8', $scalar;
 		    return $handle;
 	       }
 	       else {