|
Chapter 7 File Access |
|
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.
#!/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 }
|
|
|
|
| 7.21. Program: netlock |
|
8. File Contents |