$ perl -MConfig -le 'print $Config{d_flock}' define #### $ ./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 #### $ ./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 #### 64310 shares. 64310 waiting for previous instance(s) to exit... 64308 owns #### $ ./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 #### $ ( 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 #### #!/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__