System V IPC (Programming Perl)

16.4. System V IPC

Everyone hates System V IPC. It's slower than paper tape, carves out insidious little namespaces completely unrelated to the filesystem, uses human-hostile numbers to name its objects, and is constantly losing track of its own mind. Every so often, your sysadmin has to go on a search-and-destroy mission to hunt down these lost SysV IPC objects with ipcs(1) and kill them with ipcrm(1), hopefully before the system runs out of memory.

Despite all this pain, ancient SysV IPC still has a few valid uses. The three kinds of IPC objects are shared memory, semaphores, and messages. For message passing, sockets are the preferred mechanisms these days, and they're a lot more portable, too. For simple uses of semaphores, the filesystem tends to get used. As for shared memory--well, now there's a problem for you. If you have it, the more modern mmap(2) syscall fits the bill,[11] but the quality of the implementation varies from system to system. It also requires a bit of care to avoid letting Perl reallocate your strings from where mmap(2) put them. But when programmers look into using mmap(2), they hear these incoherent mumbles from the resident wizards about how it suffers from dodgy cache coherency issues on systems without something called a "unified buffer cache"--or maybe it was a "flycatcher unibus"--and, figuring the devil they know is better than the one they don't, run quickly back to the SysV IPC they know and hate for all their shared memory needs.

[11]There's even an Mmap module on CPAN.

Here's a little program that demonstrates controlled access to a shared memory buffer by a brood of sibling processes. SysV IPC objects can also be shared among unrelated processes on the same computer, but then you have to figure out how they're going to find each other. To mediate safe access, we'll create a semaphore per piece.[12]

[12]It would be more realistic to create a pair of semaphores for each bit of shared memory, one for reading and the other for writing, and in fact, that's what the IPC::Shareable module on CPAN does. But we're trying to keep things simple here. It's worth admitting, though, that with a couple of semaphores, you could then make use of pretty much the only redeeming feature of SysV IPC: you could perform atomic operations on entire sets of semaphores as one unit, which is occasionally useful.

Every time you want to get or put a new value into the shared memory, you have to go through the semaphore first. This can get pretty tedious, so we'll wrap access in an object class. IPC::Shareable goes one step further, wrapping its object class in a tie interface.

This program runs until you interrupt it with a Control-C or equivalent:

#!/usr/bin/perl -w
use v5.6.0;   # or better
use strict;
use sigtrap qw(die INT TERM HUP QUIT);
my $PROGENY = shift(@ARGV) || 3;
eval { main() };   # see DESTROY below for why
die if $@ && $@ !~ /^Caught a SIG/;
print "\nDone.\n";
exit;

sub main {
    my $mem = ShMem->alloc("Original Creation at " . localtime);
    my(@kids, $child);
    $SIG{CHLD} = 'IGNORE';
    for (my $unborn = $PROGENY; $unborn > 0; $unborn--) {
        if ($child = fork) {
            print "$$ begat $child\n";
            next;
        }
        die "cannot fork: $!" unless defined $child;
        eval {
            while (1) {
                $mem->lock();
                $mem->poke("$$ " . localtime) 
                    unless $mem->peek =~ /^$$\b/o;
                $mem->unlock();
            }
        };

        die if $@ && $@ !~ /^Caught a SIG/;
        exit;  # child death

    }
    while (1) {
        print "Buffer is ", $mem->get, "\n";
        sleep 1;
    }
}

And here's the ShMem package, which that program uses. You can just tack it on to the end of the program, or put it in its own file (with a "1;" at the end) and require it from the main program. (The two IPC modules it uses in turn are found in the standard Perl distribution.)

package ShMem;
use IPC::SysV qw(IPC_PRIVATE IPC_RMID IPC_CREAT S_IRWXU);
use IPC::Semaphore;
sub MAXBUF() { 2000 }

sub alloc {    # constructor method
    my $class = shift;
    my $value = @_ ? shift : '';

    my $key = shmget(IPC_PRIVATE, MAXBUF, S_IRWXU) or die "shmget: $!";
    my $sem = IPC::Semaphore->new(IPC_PRIVATE, 1, S_IRWXU | IPC_CREAT)
                         or die "IPC::Semaphore->new: $!";
    $sem->setval(0,1)    or die "sem setval: $!";

    my $self = bless {
        OWNER   => $$,
        SHMKEY  => $key,
        SEMA    => $sem,
    } => $class;

    $self->put($value);
    return $self;
}

Now for the fetch and store methods. The get and put methods lock the buffer, but peek and poke don't, so the latter two should be used only while the object is manually locked--which you have to do when you want to retrieve an old value and store back a modified version, all under the same lock. The demo program does this in its while (1) loop. The entire transaction must occur under the same lock, or the testing and setting wouldn't be atomic and might bomb.

sub get {
    my $self = shift;
    $self->lock;
    my $value = $self->peek(@_);
    $self->unlock;
    return $value;
}
sub peek {
    my $self = shift;
    shmread($self->{SHMKEY}, my $buff='', 0, MAXBUF) or die "shmread: $!";
    substr($buff, index($buff, "\0")) = '';
    return $buff;
}
sub put {
    my $self = shift;
    $self->lock;
    $self->poke(@_);
    $self->unlock;
}
sub poke {
    my($self,$msg) = @_;
    shmwrite($self->{SHMKEY}, $msg, 0, MAXBUF) or die "shmwrite: $!";
}
sub lock {
    my $self = shift;
    $self->{SEMA}->op(0,-1,0) or die "semop: $!";
}
sub unlock {
    my $self = shift;
    $self->{SEMA}->op(0,1,0) or die "semop: $!";
}

Finally, the class needs a destructor so that when the object goes away, we can manually deallocate the shared memory and the semaphore stored inside the object. Otherwise, they'll outlive their creator, and you'll have to resort to ipcs and ipcrm (or a sysadmin) to get rid of them. That's why we went through the elaborate wrappers in the main program to convert signals into exceptions: it that all destructors get run, SysV IPC objects get deallocated, and sysadmins get off our case.

sub DESTROY {
    my $self = shift;
    return unless $self->{OWNER} == $$;  # avoid dup dealloc
    shmctl($self->{SHMKEY}, IPC_RMID, 0)    or warn "shmctl RMID: $!";
    $self->{SEMA}->remove()                 or warn "sema->remove: $!";
}