Version 5 of Serializing things via file locks

Updated 2005-12-23 09:30:31

namespace eval lock {

    variable timeout 250; # 250ms standard-time to wait for lock and do locked operations; 0=no time limit
    variable lockfile [file join $::env(temp) "[pid].lock"]
    variable wait

    proc acquireLock [list "timeout $timeout" "lockfile $lockfile"] {

       set trystart [clock clicks -milliseconds]
       while {[clock clicks -milliseconds] - $trystart < $timeout || $timeout == 0} {
          if {![catch {open $lockfile {WRONLY CREAT EXCL}} rc]} {
             puts  $rc "locked by pid [pid] at [clock format [clock seconds]]"
             flush $rc
             return [list $rc $lockfile]
          }
          after 10 set lock::wait 1
          vwait lock::wait
       }
       return -code error "Error: timeout after $timeout ms"
    }

    proc releaseLock {info} {
       if {![catch {fconfigure [lindex $info 0]}]} {
          if {![catch {
             close [lindex $info 0]
             file delete -force [lindex $info 1]
             # only after file is deleted, a new open...WRONLY CREAT EXCL is possible!
          } rc]} {
             return ""
          } else {
             return -code error "Error releasing lockfile: '$rc'"
          }
       } else {
          return "kein gültiger Lock, ignoriert"
       }
    }

    proc withLock {code} {
       # standard options take place, use ::vars to change behaviour
       if {![catch {acquireLock} rc]} {
          catch {
             uplevel $code
             releaseLock $rc
          }
       }
    }

 }

A few quick'n'dirty Tests

 set globalVar 1
 lock::withLock {
    puts "Dies"
    puts "ist"
    puts "ein Test: $globalVar"
    parray env
 }
 exit

 set t [lock::acquireLock 5000 ./hugo.lock]
 puts "(test):$t"
 # lock::releaseLock $t
 set t [lock::acquireLock 0 ./hugo.lock]

 set h [lock::acquireLock]
 puts ---$h
 after 600 [list lock::releaseLock "$h"]
 while 1 {
    if {![catch {lock::acquireLock 200} h]} {
       set x $h
       after 5000 {lock::releaseLock "$x"; exit}
    }
    puts -+-$h
    after 50
    update
 }

ulis, 2005-12-23. As I said in Semaphores, 2003-05-31, this is THE portable manner to lock. Almost all OSes ensure that {open $lockfile {WRONLY CREAT EXCL} is an atomic operation based on a Test and Set operation.

See How do I manage lock files in a cross platform manner in Tcl for the NFS exception.

When available, system semaphores are more efficient.