PATCH: Make install-info use fcntl (via perl's flock) for locking

[Nathanael Nerode <neroden@fastmail.fm>]

tags 2531 +patch
thanks

This patch converts install-info to use perl's flock for locking.  I have been
told that this uses the system's fcntl in Debian's perl installation.  (It is
written to tolerate any implementation of flock which perl may supply, however.)

As part of this change, it now operates directly on the dir file rather than 
creating a new dir file and then relocating it.  (This is the cleanest way to 
make the locking actually work right.)  Accordingly the creation of the backup 
dir file is moved *before* the actual work rather than after it.

This has been tested (by hand-invocation).  It works.  

It *might* require that dpkg acquire a dependency on a version of perl-base newer 
than something or other.  I'm not sure because I'm not sure when exactly the 
necessary functionality arrived in perl.  I doubt that it requires such a 
dependency; I believe all the necessary functionality is present in 5.8.4 (which 
is in 'stable'); I'm just not 100% sure.

This is copyright-worthy content, so here's my copyright notice for debian/copyright
(should you choose to apply this patch):
Copyright 2006 Nathanael Nerode <neroden@gcc.gnu.org>

--- install-info.pl.orig	2006-06-07 00:58:26.000000000 -0400
+++ install-info.pl	2006-06-07 02:27:38.000000000 -0400
@@ -1,6 +1,8 @@
 #!/usr/bin/perl --
 
 use Text::Wrap;
+use Fcntl ':flock';
+use Fcntl ':seek';
 
 my $dpkglibdir = "."; # This line modified by Makefile
 push (@INC, $dpkglibdir);
@@ -301,18 +303,28 @@
     }
 }
 
-if (!$nowrite && !link($dirfile, "$dirfile.lock")) {
-    printf( STDERR _g("%s: failed to lock dir for editing! %s")."\n",
-	    $name, $! );
-    printf( STDERR _g("try deleting %s?")."\n", "$dirfile.lock")
-	if $!{EEXIST};
+# Handle (sort of) being run concurrently with older versions.
+if (!$nowrite && -e "$dirfile.lock") {
+    printf( STDERR _g("%s: old lockfile still present! ")."\n",
+	    $name);
+    printf( STDERR _g("try deleting %s?")."\n", "$dirfile.lock");
     exit 1;
 }
 
-open(OLD,$dirfile) || &ulquit(sprintf(_g("open %s: %s"), $dirfile, $!));
-@work= <OLD>;
-eof(OLD) || &ulquit(sprintf(_g("read %s: %s"), $dirfile, $!));
-close(OLD) || &ulquit(sprintf(_g("close %s after read: %s"), $dirfile, $!));
+if (!$nowrite) {
+    # Open for reading and writing, and lock it.
+    open(DIRFILE,"+<",$dirfile) || &ulquit(sprintf(_g("open %s: %s"), $dirfile, $!));
+    flock(DIRFILE, LOCK_EX);
+    # Back it up.  Since we'll be erasing the original, this is crucial.
+    unlink("$dirfile.old");
+    system ('cp', $dirfile, "$dirfile.old") &&
+	&ulquit(sprintf(_g("cannot backup old %s, giving up: %s"), $dirfile, $!));
+} else {
+    open(DIRFILE,"<",$dirfile) || &ulquit(sprintf(_g("open %s: %s"), $dirfile, $!));
+}
+
+@work= <DIRFILE>;
+eof(DIRFILE) || &ulquit(sprintf(_g("read %s: %s"), $dirfile, $!));
 
 while (($#work >= 0) && ($work[$#work] !~ m/\S/)) { $#work--; }
 
@@ -478,27 +490,18 @@
 }
 
 if (!$nowrite) {
-    open(NEW,"> $dirfile.new") || &ulquit(sprintf(_g("create %s: %s"), "$dirfile.new", $!));
-    print(NEW @head,join("\n",@newwork)) ||
-	&ulquit(sprintf(_g("write %s: %s"), "$dirfile.new", $!));
-    close(NEW) || &ulquit(sprintf(_g("close %s: %s"), "$dirfile.new", $!));
-
-    unlink("$dirfile.old");
-    link($dirfile, "$dirfile.old") ||
-	&ulquit(sprintf(_g("cannot backup old %s, giving up: %s"), $dirfile, $!));
-    rename("$dirfile.new", $dirfile) ||
-	&ulquit(sprintf(_g("install new %s: %s"), $dirfile, $!));
-
-    unlink("$dirfile.lock") ||
-	die sprintf(_g("%s: unlock %s: %s"), $name, $dirfile, $!)."\n";
-    system ('cp', $dirfile, $backup) &&
-	warn sprintf(_g("%s: couldn't backup %s in %s: %s"), $name, $dirfile, $backup, $!)."\n";
+    # Switch from reading to writing, still holding the same lock on the same file
+    seek(DIRFILE,0,SEEK_SET)
+      || &ulquit(sprintf(_g("seeking start of %s: %s"), $dirfile, $!));
+    truncate(DIRFILE, 0)
+      || &ulquit(sprintf(_g("truncating %s: %s"), $dirfile, $!));
+    print(DIRFILE @head,join("\n",@newwork)) ||
+	&ulquit(sprintf(_g("writing new %s: %s"), $dirfile, $!));
+    flock(DIRFILE, LOCK_UN);
 }
+close(DIRFILE) || &ulquit(sprintf(_g("close %s: %s"), $dirfile, $!));
 
 sub ulquit {
-    unlink("$dirfile.lock") ||
-	warn sprintf(_g("%s: warning - unable to unlock %s: %s"),
-		     $name, $dirfile, $!)."\n";
     die "$name: $_[0]\n";
 }
 

-- 
Nathanael Nerode  <neroden@fastmail.fm>

[Insert famous quote here]