bin/quidi-test-unlinklockfile.pl

   1 #!/usr/bin/perl
   2
   3 =pod
   4
   5
   6 This is a short test script that compares several locking solutions
   7 that also guarantee atomicity on file reads. Strange that I could not
   8 find a module on CPAN for this. Probably because the answer is too simple.
   9
  10
  11 rev 3421 works but leaves a lock file around forever which cannot be
  12 deleted.
  13
  14 rev 3422 worked without a permanent lockfile. It has a lockfile that
  15 is removed after the other file is written. Must not use another
  16 process like "|sort > ...". When I tried this the other process was
  17 usually not yet finished. May be slow on deadlock-like conditions
  18 because it uses more and more time and rand. This needs to go away.
  19
  20 rev 3424 works very well. I doesn't need a permanent lockfile. Instead
  21 each process creates a temporary file with the process ID while
  22 waiting for the lock. When the work is done nothings is left over.
  23
  24 rev 3429 is taken from the Cookbook chapter 7.21, page 264 "Program
  25 netlock" and needs less code and less temporary files.
  26
  27 This guy sums it up very nicely:
  28 http://utcc.utoronto.ca/~cks/space/blog/unix/ShellScriptLocking
  29
  30
  31 =cut
  32
  33 use strict;
  34 use warnings;
  35
  36 use File::Temp; # only used for our test file, not for the locking operation
  37 use IO::Handle;
  38 use Time::HiRes qw(sleep);
  39
  40 my($xfh,$rfile) = File::Temp::tempfile("qtulf-XXXX", DIR => "/tmp", CLEANUP => 0, SUFFIX => ".test");
  41 close $xfh;
  42
  43 for my $i (0..99) {
  44   my $pid = fork;
  45   if (defined $pid) {
  46     if ($pid) {
  47       next;
  48     } else {
  49       my $slept = sleep rand $i/1000;
  50       my $locked;
  51       while (!$locked) {
  52         sleep 0.05;
  53         $locked = mkdir "$rfile.lock";
  54       }
  55       my $content = do { open my $tfh, $rfile or die $!; local $/; <$tfh> };
  56       $content .= "$$ $slept\n";
  57       open my $nfh, ">", "$rfile.new" or die "Couldn't open: $!";
  58       print $nfh $content;
  59       close $nfh or die "Could not close '> $rfile.new': $!";
  60       rename "$rfile.new", $rfile or die "Could not rename to '$rfile': $!";
  61       rmdir "$rfile.lock";
  62       exit;
  63    }
  64   } else {
  65     die "fork test failed completely: $!";
  66   }
  67 }
  68 1 while wait > 0;
  69 system 'wc', '-l', $rfile;