----

 ###############################################################################
 # Package: lock.tcl
 # Author:  M.Hoffmann 2005-2006
 # Purpose: Guarantee atomic operations using a LOCKFILE, wrapper functions
 # Remarks: For intERprocess coordination, each process must specify THE SAME
 #          LOCKFILE. It's up to the programer to choose a name.-  We can let
 #          the module determine a name only if used within one program. Take
 #          care of the timeout: it depends on the type of the locked code and
 #          number of processes competing for the lock. The default is to wait
 #          only 1/4s for a lock to become available. Specifying a timeout of 0
 #          means to wait forever for a lock.
 # History:
 #  v0.1 2005/12/26
 #   - First release.
 #  v0.2 2006/02/25
 #   - New procs timeout and lockfile superseed the corresponding vars which
 #     are no longer availabe - they are used to query (and optionaly set new)
 #     defaults.
 #   - With v0.1 it wasn't possible to permanently overwrite the built-in
 #     defaults. [withLock] and [incrCounter] ALWAYS used these defaults because
 #     they where arg-less.
 #   - Additional proc defaults which restores timeout and lockfile to the
 #     original state.
 #   - Reworked withLock: errorState and results are given back to the caller.
 #   - withLock and incrCounter accepts optional args to pass timeout and lock-
 #     file on to acquireLock.
 #   - Added username to lockfile (perhaps usefull in search for bugs).
 #   - Addes namespace export *.
 #   - New and redesigned testproc(s) - some of them never worked right...
 ###############################################################################

 package provide lock 0.2

 namespace eval lock {

    variable defto 250; # 250ms default time to acquire/use a lock; 0 = infinite
    variable curto $defto
    variable deflf [file join $::env(temp) [pid].lock]; # default lockfile
    variable curlf $deflf
    variable wait

    namespace export *

    # Query (and optionally set) the default timeout. Returns (new) value.
    #  Attention: no arg-checking!
    proc timeout args {
       variable curto
       return [expr {[llength $args]==1?[set curto $args]:$curto}]
    }

    # Query (and optionally set) the default lockfile. Returns (new) value.
    #  Attention: no arg-checking!
    proc lockfile args {
       variable curlf
       return [expr {[llength $args]==1?[set curlf $args]:$curlf}]
    }

    # Restore the original defaults
    proc defaults {} {
       variable defto
       variable deflf
       variable curto $defto
       variable curlf $deflf
    }

    # Problem: defaults through arglists are static. But user can change the
    # defaults through procs. So special code is required.
    proc acquireLock args {
       variable curto
       variable curlf
       # these (private) values are for now not accessible from outside
       set timeout  [expr {[lindex $args 0]==""?$curto:[lindex $args 0]}]
       set lockfile [expr {[lindex $args 1]==""?$curlf:[lindex $args 1]}]
       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] from $::tcl_platform(user)\
                        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]
             # another OPEN ... EXCL only will succeed if the file is gone
          } rc]} {
             return ""
          } else {
             return -code error "Error releasing lockfile: '$rc'"
          }
       } else {
          return "invalid lock, ignored"
       }
    }

    # Abstraction layer upon acquire/release to perform code which is protected
    # from running in parallel through a lockfile. Usefull e.g. to update a file
    # which is in use by many systems. Optionally specify timeout and lockfile
    # which are passed through to acquireLock (eval is therefore required).
    # To handle errors in this routine, use catch {withLock {...}}
    proc withLock {code args} {
       if {![catch {eval acquireLock $args} rc]} {
          set urc [catch {uplevel 1 $code} ret]
          releaseLock $rc; # report errors the the caller, no CATCHing here
          return -code $urc $ret; # give original results back, including errors
       } else {
          return -code error $rc; # cannot get lock
       }
    }

    # Abstraction layer upon withLock, to maintain a file with a counter in it.
    # The counter is incremented with each access, to maintain a unique id.
    # Optionally specify timeout and lockfile which are passed over
    # wihtLock to acquireLock.
    # Let errors raise up to the main proc.
    proc incrCounter {ctrFile args} {
       set cmd {
          if {[file exists $ctrFile]} {
             set hCntr [open $ctrFile r]; # a+ not possible in VFS::MK4...
             set counter [gets $hCntr]
             incr counter
             close $hCntr
          } else {
             set counter 0
          }
          set hCntr [open $ctrFile w]; # a+ not possible in VFS::MK4...
          puts $hCntr $counter
          close $hCntr
       }
       eval withLock [list $cmd] $args; # notice eval and list are required!
       return $counter
    }
 }

----
'''A few quick'n'dirty Tests''' to prove the routines work right

 # lock_test0.tcl, 25.02.2006
 # basic test(suite)
 lappend auto_path [pwd]
 puts "result of \[package require lock 0.2\] should be 0.2:\t[package require lock 0.2]"
 puts "\[lock::timeout\] should give the default timeout right after loading:\t[lock::timeout]"
 puts "\[lock::lockfile\] should give the default lockfile right after loading:\n\t[lock::lockfile]"
 puts "calling \[lock::timeout 1000\] returnes:\t[lock::timeout 1000]"
 puts "calling \[lock::lockfile hugo.dat\] returns:\n\t[lock::lockfile hugo.dat]"
 puts "\[lock::timeout\] without args should now reflect the new value:\t[lock::timeout]"
 puts "\[lock::lockfile\] without args should now reflect the new value:\n\t[lock::lockfile]"
 puts "\[lock::defaults\] should restore the original defaults (gives nothing):\t[lock::defaults]"
 puts "\[lock::timeout\] now gives back:\t[lock::timeout]"
 puts "\[lock::lockfile\] now gives back:\n\t[lock::lockfile]"
 puts "Performing \[namespace import lock::*\]:\t[namespace import lock::*]"
 puts "1st \[acquireLock]\ returns:\n\t[set lockHandle [acquireLock]]"
 puts "2nd \[acquireLock]\ withOut releasing the lock (correctly) returns an error:"
 catch {set lockHandle [acquireLock]} rc
 puts $rc
 puts "1st \[releaseLock $lockHandle]\ returns:\t[releaseLock $lockHandle]"
 puts "2nd \[releaseLock $lockHandle]\ returns:\t[releaseLock $lockHandle]"
 puts "\[acquireLock 2000]\ returns:\n\t[set lockHandle [acquireLock 2000]]"
 puts "\[releaseLock $lockHandle]\ returns:\t[releaseLock $lockHandle]"
 puts "\[acquireLock 2000 lock.file]\ returns:\n\t[set lockHandle [acquireLock 2000 lock.file]]"
 puts "\[releaseLock $lockHandle]\ returns:\t[releaseLock $lockHandle]"
 puts -nonewline "\[withLock {puts \[lock::timeout\]}\] returns:\t"
 puts -nonewline "[withLock {puts [lock::timeout]}]"
 puts "calling \[lock::timeout 500\] returnes:\t[lock::timeout 500]"
 puts -nonewline "Now \[withLock {puts \[lock::timeout\]}\] returns:\t"
 puts -nonewline "[withLock {puts [lock::timeout]}]"
 puts -nonewline "\[withLock {puts \[lock::timeout\]} 2000\] returns:\t"
 puts -nonewline "[withLock {puts [lock::timeout]}]"
 puts "(global Default is not affected, 2000 is just an overwrite for this call an cannot be queried)"
 puts "Performing \[incrCounter ctr1.dat\] three times:"
 puts "[incrCounter ctr1.dat] [incrCounter ctr1.dat] [incrCounter ctr1.dat]"
 puts "Performing \[incrCounter ctr1.dat 5000\] returns:\t[incrCounter ctr1.dat 5000]"
 puts "Performing \[incrCounter ctr1.dat 5000 lock.file\] returns:\t[incrCounter ctr1.dat 5000 lock.file]"
 file delete ctr1.dat

----

 # lock_test1.tcl, 25.02.2006
 # starting 10 independet process in the background
 catch {file delete ./counter1.dat}
 catch {file delete ./lockfile.shr}
 set start [expr {[clock seconds]+10}]
 for {set i 1} {$i < 11} {incr i} {
     puts $i
     exec -- [auto_execok tclsh] lock_test1sub.tcl $start &
 }
 puts "soon starting processes, please stand by..."
 puts "after all processes have finished, press RETURN to see the cmd prompt (MS-Win)"
 puts "The counter should be: 99"

----

 # lock_test1sub.tcl, 25.02.2006
 lappend auto_path [pwd]
 package require lock 0.2
 # make shure all process are starting in the same moment
 while {[clock seconds] < "$argv"} {}
 for {set i 1} {$i < 11} {incr i} {
     # incrCounter uses withLock internally
     puts "$i [pid]:=[lock::incrCounter ./counter1.dat 500 ./lockfile.shr]"
 }

----

 # lock_test3.tcl, 25.02.2006

 lappend auto_path [pwd]
 package require lock 0.2

 # use a different lockfile and timeout-value
 set t [lock::acquireLock 5000 ./test.lock]
 puts "t:=$t"
 after 8000 {lock::releaseLock $t}
 after 8500 {set ready 1}
 set u [lock::acquireLock 10000 ./test.lock]
 puts "u:$u"
 lock::releaseLock $u

 vwait ready

----

 # lock_test4.tcl, 25.02.2006

 lappend auto_path [pwd]
 package require lock 0.2

 set h [lock::acquireLock]
 puts ---$h
 after 600 [list lock::releaseLock "$h"]
 while 1 {
    if {![catch {lock::acquireLock 200} h]} {
       set x $h
       after 2000 {lock::releaseLock "$x"}
    }
    puts -+-$h
    after 50
    update
 }
----
And now, forget ablout the complicated test stuff above. All you ever need is almost always the following:

 package require lock
 lock::withLock {
    #
    # put the code for which you want to assure that it only runs at one single time here
    #
 } msec lockfile

Where
   * msec is the period that a seconds instance that want to perform the same code waits for the lock to be released.
   * lockfile is the file used to be as a flag (you need write access to the directory, of course). 

That's it!
----
[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.