#!/usr/bin/perl
# System V record locking demonstration
# Author: Mark Jason Dominus 20010503
# This program is in the public domain

use Fcntl qw(F_GETLK F_SETLK F_WRLCK F_RDLCK F_UNLCK );

my %type = map {&$_ => $_} qw(F_WRLCK F_RDLCK F_UNLCK);
my @whence = ('from beginning', 'from current position', 'from end');

# this is correct for my I386 linux box, but will be different 
# depending on your OS and hardwre
$struct_flock = "s s l l L";

$file = $0;
open F, "+< $file" or die "Couldn't open file $file: $!; aborting";

do_lock(0, 10, F_WRLCK);
if (fork()) { # parent
  wait;
} else {
  do_lock(9, 20, F_WRLCK);
}
exit;

# see make_lock for an explanation of the arguments
sub do_lock {
  my $lock_s = make_lock(@_);
  if (fcntl(F, F_SETLK, $lock_s)) {
    print "Got lock.\n";
  } else {
    print "Lock failed: $!\n\t", lock_struct_to_string($lock_s), "\n";
  }
}

sub lock_struct_to_string {
  my $s = shift;
  my @d = unpack $struct_flock, $s;
  my $type = $type{$d[0]} || '(unknown)';
  my $whence = $whence[$d[1]];
  my ($start, $len, $pid) = @d[2,3,4];
  my $end = $start + $len - 1;
  "$start-$end   [type: $type; whence: $whence; pid: $pid]";
}


# arguments: lock $length bytes of the file, starting at position $position
# $type should be F_WRLCK for a write lock, F_RDLCK for a read lock
# F_UNLCK releases the lock
sub make_lock {
  my ($position, $length, $type) = @_;
  $type = F_WRLCK unless defined $type;

  return pack $struct_flock, $type, 0, $position, $length, $$;
}