لطفا منتظر باشید ...
 |  |
7.25. 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 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 that line only,
and then 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, then when the lock is finally
granted, that line is updated with a message telling which process
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 of 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);
use Errno;
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} = \&infanticide;
} 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 = lockplace(*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
unlockplace(*FH, $place, $COLS);
sleep $SLEEP if $SLEEP;
}
die "NOT REACHED"; # just in case
# lock($handle, $offset, $timeout) - get an fcntl lock
sub lockplace {
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 unlockplace {
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 infanticide {
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 { &infanticide }
|  | |
| 7.24. Program: netlock |  | 8. File Contents |
Copyright © 2003 O'Reilly & Associates. All rights reserved.
