Recipe 7.22. Program: lockarea (Perl Cookbook)

7.22. Program: lockarea

Perl's flock function only locks complete files, not regions of the file. Although fcntl supports locking of a file's regions, this is difficult to access from Perl, largely because no one has written an XS module that portably packs up the necessary structure.

The program in Example 7.11 implements fcntl , but only for the three architectures it already knows about: SunOS, BSD, and Linux. If you're running something else, you'll have to figure out the layout of the flock structure. We did this by eyeballing the C-language sys/fcntl.h #include file - and running the c2ph program to figure out alignment and typing. This program, while included with Perl, only works on systems with a strong Berkeley heritage, like those listed above. As with Unix - or Perl itself - you don't have to use c2ph , but it sure makes life easier if you can.

The struct_flock function in the lockarea program packs and unpacks in the proper format for the current architectures by consulting the $^O variable, which contains your current operating system name. There is no struct_flock function declaration. It's just aliased to the architecture-specific version. Function aliasing is discussed in Recipe 10.14 .

The lockarea program opens a temporary file, clobbering any existing contents and writing a screenful (80 by 23) of blanks. Each line is the same length.

The program then forks one or more times and lets all the child processes try to update the file at the same time. The first argument, N , is the number of times to fork to produce 2 ** N processes. So lockarea 1 makes two children, lockarea 2 makes four, lockarea 3 makes eight, lockarea 4 makes sixteen, etc. The more kids, the more contention for the locks.

Each process picks a random line in the file, locks just that line, and updates it. It writes its process ID into the line, prepended with a count of how many times the line has been updated:

4: 18584 was just here

If the line was already locked, when the lock is finally granted, the line is updated with a message indicating the process that was in the way of this process:

29: 24652 ZAPPED 24656

A fun demo is to run the lockarea program in the background and the rep program from Chapter 15 watching the file change. Think of it as a video game for systems programmers.

% lockarea 5 &
% rep -1 'cat /tmp/lkscreen'

When you interrupt the original parent, usually with Ctrl-C or by sending it a SIGINT from the command line, it kills all its children by sending its entire process group a signal.

Example 7.11: lockarea

#!/usr/bin/perl -w
# lockarea - demo record locking with fcntl

use strict;

my $FORKS = shift || 1;
my $SLEEP = shift || 1;

use Fcntl;
use POSIX qw(:unistd_h :errno_h);

my $COLS = 80;
my $ROWS = 23;

# when's the last time you saw *this* mode used correctly?
open(FH, "+> /tmp/lkscreen")            or  die $!;

select(FH);
$| = 1;
select STDOUT;

# clear screen
for (1 .. $ROWS) {
        print FH " " x $COLS, "\n";
}

my $progenitor = $$;
fork while $FORKS-- > 0;

print "hello from $$\n";

if ($progenitor == $$) {
        $SIG{INT} = \&genocide;
} else {
        $SIG{INT} = sub { die "goodbye from $$" };
}

while (1) {
        my $line_num = int rand($ROWS);
        my $line;
        my $n;

        # move to line
        seek(FH, $n = $line_num * ($COLS+1), SEEK_SET)              or next;

        # get lock
        my $place = tell(FH);
        my $him;
        next unless defined($him = lock(*FH, $place, $COLS));

        # read line
        read(FH, $line, $COLS) == $COLS                             or next;
        my $count = ($line =~ /(\d+)/) ? $1 : 0;
        $count++;

        # update line
        seek(FH, $place, 0)                                         or die $!;
        my $update = sprintf($him
                            ? "%6d: %d ZAPPED %d"
                            : "%6d: %d was just here",
                        $count, $$, $him);
        my $start = int(rand($COLS - length($update)));
        die "XXX" if $start + length($update) > $COLS;
        printf FH "%*.*s\n", -$COLS, $COLS, " " x $start . $update;

        # release lock and go to sleep
        unlock(*FH, $place, $COLS);
        sleep $SLEEP if $SLEEP;
}
die "NOT REACHED";                              # just in case

# lock($handle, $offset, $timeout) - get an fcntl lock
sub lock {
        my ($fh, $start, $till) = @_;
        ##print "$$: Locking $start, $till\n";
        my $lock = struct_flock(F_WRLCK, SEEK_SET, $start, $till, 0);
        my $blocker = 0;
        unless (fcntl($fh, F_SETLK, $lock)) {
            die "F_SETLK $$ @_: $!" unless $! == EAGAIN || $! == EDEADLK;
            fcntl($fh, F_GETLK, $lock)          or die "F_GETLK $$ @_: $!";
            $blocker = (struct_flock($lock))[-1];
            ##print "lock $$ @_: waiting for $blocker\n";
            $lock = struct_flock(F_WRLCK, SEEK_SET, $start, $till, 0);
            unless (fcntl($fh, F_SETLKW, $lock)) {
                warn "F_SETLKW $$ @_: $!\n";
                return;  # undef
            }
        }
        return $blocker;
}

# unlock($handle, $offset, $timeout) - release an fcntl lock
sub unlock {
        my ($fh, $start, $till) = @_;
        ##print "$$: Unlocking $start, $till\n";
        my $lock = struct_flock(F_UNLCK, SEEK_SET, $start, $till, 0);
        fcntl($fh, F_SETLK, $lock) or die "F_UNLCK $$ @_: $!";
}

# OS-dependent flock structures

# Linux struct flock
#   short l_type;
#   short l_whence;
#   off_t l_start;
#   off_t l_len;
#   pid_t l_pid;
BEGIN {
        # c2ph says: typedef='s2 l2 i', sizeof=16
        my $FLOCK_STRUCT = 's s l l i';

        sub linux_flock {
            if (wantarray) {
                my ($type, $whence, $start, $len, $pid) =
                    unpack($FLOCK_STRUCT, $_[0]);
                return ($type, $whence, $start, $len, $pid);
            } else {
                my ($type, $whence, $start, $len, $pid) = @_;
                return pack($FLOCK_STRUCT,
                        $type, $whence, $start, $len, $pid);
            }
        }

}

# SunOS struct flock:
#   short   l_type;         /* F_RDLCK, F_WRLCK, or F_UNLCK */
#   short   l_whence;       /* flag to choose starting offset */
#   long    l_start;        /* relative offset, in bytes */
#   long    l_len;          /* length, in bytes; 0 means lock to EOF */
#   short   l_pid;          /* returned with F_GETLK */
#   short   l_xxx;          /* reserved for future use */
BEGIN {
        # c2ph says: typedef='s2 l2 s2', sizeof=16
        my $FLOCK_STRUCT = 's s l l s s';

        sub sunos_flock {
            if (wantarray) {
                my ($type, $whence, $start, $len, $pid, $xxx) =
                    unpack($FLOCK_STRUCT, $_[0]);
                return ($type, $whence, $start, $len, $pid);
            } else {
                my ($type, $whence, $start, $len, $pid) = @_;
                return pack($FLOCK_STRUCT,
                        $type, $whence, $start, $len, $pid, 0);
            }
        }

}

# (Free)BSD struct flock:
#   off_t   l_start;        /* starting offset */
#   off_t   l_len;          /* len = 0 means until end of file */
#   pid_t   l_pid;          /* lock owner */
#   short   l_type;         /* lock type: read/write, etc. */
#   short   l_whence;       /* type of l_start */
BEGIN {
        # c2ph says: typedef="q2 i s2", size=24
        my $FLOCK_STRUCT = 'll ll i s s';   # XXX: q is ll

        sub bsd_flock {
            if (wantarray) {
                my ($xxstart, $start, $xxlen, $len, $pid, $type, $whence) =
                    unpack($FLOCK_STRUCT, $_[0]);
                return ($type, $whence, $start, $len, $pid);
            } else {
                my ($type, $whence, $start, $len, $pid) = @_;
                my ($xxstart, $xxlen) = (0,0);
                return pack($FLOCK_STRUCT,
                    $xxstart, $start, $xxlen, $len, $pid, $type, $whence);
            }
        }
}

# alias the fcntl structure at compile time
BEGIN {
        for ($^O) {
            *struct_flock =                do                           {

                                    /bsd/  &&  \&bsd_flock
                                           ||
                                /linux/    &&    \&linux_flock
                                           ||
                              /sunos/      &&      \&sunos_flock
                                           ||
                      die "unknown operating system $^O, bailing out";
            };
        }
}

# install signal handler for children
BEGIN {
        my $called = 0;

        sub genocide {
            exit if $called++;
            print "$$: Time to die, kiddies.\n" if $$ == $progenitor;
            my $job = getpgrp();
            $SIG{INT} = 'IGNORE';
            kill -2, $job if $job;  # killpg(SIGINT, job)
            1 while wait > 0;
            print "$$: My turn\n" if $$ == $progenitor;
            exit;
        }

}

END { &genocide }