# critical region - only one code BLOCK runs at any one time sub lock_section (&@) { my ($cb, $old_file, $new_file, $next_file, $retry_cnt, $wait_time) = @_; defined($old_file) && defined($new_file) or die("lock_section(): Must define lock filenames as arguments"); # revert to old file if next file is not defined $next_file = $old_file unless defined($next_file); # set default wait $retry_cnt = -1 unless defined($retry_cnt); # -1 means never give up $wait_time = 10 unless defined($wait_time) && $wait_time > 0; # 10us before trying again require Time::HiRes; my $rename = sub { ! -e $_[1] && rename($_[0], $_[1]) && -e $_[1] }; # wait to acquire lock my $i = -1; while (! $rename->($old_file, $new_file)) { if (++$i >= $retry_cnt && $retry_cnt >= 0) { my $total_wait = $i * $wait_time * 1e-6; warn(<<"EOT"); lock_section(): Cannot re-acquire lock - giving up after $total_wait second(s) EOT return (); } Time::HiRes::usleep($wait_time); } # lock acquired { # run critical code my @ret = $cb->($next_file, $new_file, $old_file); # release lock $rename->($new_file, $next_file) or die(<<"EOT"); lock_section(): Cannot release lockfile '$new_file' as '$next_file' EOT # return may potentially be obsolete at this point return \@ret; } }