Beefy Boxes and Bandwidth Generously Provided by pair Networks
Syntactic Confectionery Delight

Comment on

( #3333=superdoc: print w/replies, xml ) Need Help??

A while ago I had a problem where some locking code (in Perl) wasn't working like I expected. I pulled the locking code out and tested it and eventually began to suspect that flock() was just broken under FreeBSD (this was not a suspicion I came to easily; it was a bit shocking to think that what I consider a high quality operating system might have gotten such an important basic item wrong).

So I implemented a flock() work-alike that used fcntl() locks under the covers. Using fcntl() locks made everything work the way I expected.

Anyway, I was reminded of this recently by a fellow monk and this is actually code that is used on the PerlMonks' back end. So I'm publishing it here in case someone can show me my mistake or verify my suspicion. I'll forward it to FreeBSD if it looks like a real bug.

Some details. According to, Perl was built using native flock() not flock() emulation:

$ perl -MConfig -le 'print $Config{d_flock}' define
A sample test run that shows the locks working via flock() (the bug is intermittent):
$ ./locktest & sleep 4; ./locktest [1] 64228 Using flock()... 64228 shares. 64228 owns 64228 shares Using flock()... 64233 shares. 64233 waiting for previous instance(s) to exit... 64228 leaving to allow new instance to run. 64233 owns Running... 64233 owns 64233 shares ^C
And a sample run that shows how things break (more often than they work):
$ ./locktest & sleep 4; ./locktest [1] 64308 Using flock()... 64308 shares. 64308 owns 64308 shares Using flock()... 64310 shares. 64310 waiting for previous instance(s) to exit... 64308 owns 64308 shares 64308 owns 64308 shares ^C $ kill %1
The important part is:
64310 shares. 64310 waiting for previous instance(s) to exit... 64308 owns
which shows process 64310 getting a shared lock (and holding it) and then the other process (64308) successfully getting an exclusive lock. You should not be able to get an exclusive lock if anyone else has a shared lock.

And here's how to run it with fcntl() locks instead (which, if it ever fails, certainly only does so extremely rarely):

$ ./locktest 1 & sleep 4; ./locktest 1 [1] 64442 Using fcntl() locks... 64442 shares. 64442 owns 64442 shares Using fcntl() locks... 64446 shares. 64446 waiting for previous instance(s) to exit... 64442 leaving to allow new instance to run. 64446 owns Running... 64446 owns 64446 shares ^C
And (just for completeness), here is a run showing what happens if you start the second instance at just the wrong time. This is just a case that I didn't want to handle in this sample code as it makes the code too complicated and doesn't really have anything to do with what I'm reporting except that I wanted to mention it so that no one would get distracted if they happened to run into it:
$ ( sleep 1; ./locktest 1 ) & sleep 8; ./locktest 1 [1] 64887 Using fcntl() locks... 64890 shares. 64890 owns 64890 shares 64890 owns Using fcntl() locks... 64891 can't lock self: Resource temporarily unavailable 64890 shares $ kill %1
and then the source code:
#!/usr/bin/perl -w # use strict; use Fcntl qw( LOCK_SH LOCK_EX LOCK_UN LOCK_NB ); # "./locktest" uses flock(), "./locktest 1" uses fcntl() locks. use constant FCNTL => 0<@ARGV; BEGIN { if( ! FCNTL ) { warn "Using flock()...\n"; } else { warn "Using fcntl() locks...\n"; require Fcntl; Fcntl->import( qw( F_GETLK F_SETLK F_SETLKW F_RDLCK F_UNLCK F_WRLCK ) ); eval 'use subs "flock"'; { my $f= *flock } # Don't warn about 'flock' only used once. *flock= sub { my( $fh, $mode )= @_; if( ! ref($fh) && $fh !~ /'|::/ ) { $fh= caller() . "::" . $fh; } my $nb= $mode & LOCK_NB(); my $lock; my $count= 0; $count++, $lock= F_RDLCK() if $mode & LOCK_SH(); $count++, $lock= F_WRLCK() if $mode & LOCK_EX(); $count++, $lock= F_UNLCK() if $mode & LOCK_UN(); if( 1 != $count ) { require Carp; Carp::croak( "$count of LOCK_SH, LOCK_EX, LOCK_UN set, + not 1" ) } # start, len, PID, type, whence: my $struct= pack( "LL LL I S S", 0,0, 0,0, 0, $lock, 0 ); my $op= $nb ? F_SETLK() : F_SETLKW(); return fcntl( $fh, $op, $struct ); }; } } open DATA, "+>lock" or warn "Can't open lock file: $!\n"; my %config= ( delay => 5 ); $|++; flock( \*DATA, LOCK_SH|LOCK_NB ) or die "$$ can't lock self: $!\n"; warn "$$ shares.\n"; if( ! flock( \*DATA, LOCK_EX|LOCK_NB ) ) { warn "$$ waiting for previous instance(s) to exit...\n"; select( undef, undef, undef, rand($config{delay}) ); my $start= time(); my $end; alarm( 5*$config{delay} ); my $oldSig= $SIG{ALRM}; $SIG{ALRM}= sub { warn "$$ previous instance(s) still running!\n"; warn "$$ tho, lock obtained ".localtime($end),$/ if $end; die "$$ ", localtime($start)." .. ".localtime(), $/; }; flock( \*DATA, LOCK_EX ); warn "$$ owns\n"; $end= time(); alarm( 0 ); $SIG{ALRM}= defined($oldSig) ? $oldSig : 'DEFAULT'; warn "Running...\n"; } # Will revert lock to shared below while (1) { if( ! flock( \*DATA, LOCK_EX|LOCK_NB ) ) { warn "$$ leaving to allow new instance to run.\n"; exit( 0 ); } warn "$$ owns\n"; sleep( 1 ); flock( \*DATA, LOCK_SH|LOCK_NB ) or die "$$ can't revert self lock to shared: $!\n"; warn "$$ shares\n"; sleep $config{delay}; } __END__

        - tye (but my friends call me "Tye")

In reply to flock() broken under FreeBSD? by tye

Use:  <p> text here (a paragraph) </p>
and:  <code> code here </code>
to format your post; it's "PerlMonks-approved HTML":

  • Posts are HTML formatted. Put <p> </p> tags around your paragraphs. Put <code> </code> tags around your code and data!
  • Titles consisting of a single word are discouraged, and in most cases are disallowed outright.
  • Read Where should I post X? if you're not absolutely sure you're posting in the right place.
  • Please read these before you post! —
  • Posts may use any of the Perl Monks Approved HTML tags:
    a, abbr, b, big, blockquote, br, caption, center, col, colgroup, dd, del, div, dl, dt, em, font, h1, h2, h3, h4, h5, h6, hr, i, ins, li, ol, p, pre, readmore, small, span, spoiler, strike, strong, sub, sup, table, tbody, td, tfoot, th, thead, tr, tt, u, ul, wbr
  • You may need to use entities for some characters, as follows. (Exception: Within code tags, you can put the characters literally.)
            For:     Use:
    & &amp;
    < &lt;
    > &gt;
    [ &#91;
    ] &#93;
  • Link using PerlMonks shortcuts! What shortcuts can I use for linking?
  • See Writeup Formatting Tips and other pages linked from there for more info.
  • Log In?

    What's my password?
    Create A New User
    [holli]: hessenrap...
    [holli]: love it :)
    [Corion]: acapella hessian rap, but they also do melodic stuff, like Shout (Tears for Fears)

    How do I use this? | Other CB clients
    Other Users?
    Others surveying the Monastery: (11)
    As of 2017-11-18 19:32 GMT
    Find Nodes?
      Voting Booth?
      In order to be able to say "I know Perl", you must have:

      Results (277 votes). Check out past polls.