Generic Lock Server

This is a quick and dirty (and incomplete) example of a lock server for general resources. It doesn't implement the actual locking of the resources but can be used to (begin to) answer the question How do I manage lock files in a cross platform manner in Tcl.

You lock a resource by sending "L:resource_name\n". You unlock a resource with "U:resource_name\n". Once you acquire the lock, you get back a message: "LOCKED". If you do not immediately acquire the lock you are placed in a queue until your turn (no message is sent until then).

Disconnecting from the server immediately releases any locks and any pending locks you may have.

-- Todd Coram

 variable port 6700

 # lock(resource) -> chan ..
 # First chan int the list has the lock, the rest are queued.
 array set lock [list]

 # client(chan) -> resource
 array set client [list]

 # If you own the lock, return 1 else remove chan from queue and return 0 
 #
 proc unlock {chan res} {
    global lock client
    if {[lindex $lock($res) 0] == $chan} {
        set lock($res) [lrange $lock($res) 1 end]
        set idx [lsearch -exact $client($chan) $res]
        set client($chan) [lreplace $client($chan) $idx $idx]
        # Notify the next in line
        if {[llength $lock($res)] != 0}  {
           puts [lindex $lock($res) 0] "LOCKED $res"
        }
        return 1
    }
    set idx [lsearch -exact $lock($res) $chan]
    if {$idx != -1} {
        set lock($res) [lreplace $lock($res) $idx $idx]
    }
    return 0
 }

 # You will either aquire the lock (return 1) or be queued (return 0).
 #
 proc lock {chan res} {
    global lock client
    lappend lock($res) $chan
    lappend client($chan) $res
    return [locked? $chan $res]
 }

 proc locked? {chan res} {
    global lock
    if {[info exists lock($res)] && [lindex $lock($res) 0 ] == $chan} {
        return 1
    }
    return 0
 }


 proc accept {chan addr port} {
    global client
    fconfigure $chan -buffering none
    fileevent $chan readable [list handle_req $chan]
    set client($chan) [list]
 }

 proc handle_req chan {
    global client lock
    if {[eof $chan]} {
        # Unlock resources
        foreach res $client($chan) {
            unlock $chan $res
        }
        unset client($chan)
        close $chan
        return
    }
    set str [gets $chan]
    foreach {req res} [split $str :] {
        switch -- $req {
            L { 
                puts stderr "($chan) Locking $res"
                if {[lock $chan $res]}  { puts $chan "LOCKED $res" }
            }
            U {
                if {![info exists lock($res)]} { 
                    puts $chan "NOLOCKS $res"
                    break
                }
                if {[unlock $chan $res]} {
                    puts $chan "UNLOCK $res"
                } else {
                    puts $chan "DEQUEUED $res"
                }
            }
            default {
                puts $chan {HUH? Usage: L:resource or U:resource}
            }
            
        }
    }
 }

 socket -server [list accept] $port
 vwait forever

Category Uncategorized