################################################################################
 # Module   : palloc.tcl 2003-2007
 # Date     : 03.07.2007
 # Purpose  : Implements a persistent pool of handles. Originally developed for
 #            the management of tcp ports in a given range across multiple pcs.
 #            No precautions yet for keeping pool consistent.
 # Author   : M.Hoffmann
 # Notes    : - Could make use of tie, a db or bitstrings.
 #            - A avail-query could be implemented (perhaps via statearray).
 # Wiki     : http://wiki.tcl.tk/19673
 # History  :
 # 03072007 2.0 - everything rewritten using 'lock', partially incompatible api.
 #
 ################################################################################

 package require lock       ; # see http://wiki.tcl.tk/15173
 package provide palloc 2.0 ; #

 namespace eval palloc {
 }

 #-------------------------------------------------------------------------------
 # -- init
 # Initialize a persistent pool of `poolSize` bytes in the file 'dbName'. Each
 # char position in the poolfile (later implementations may use individual bits)
 # represents a handle, where the char value '0' means 'free/available', and '1'
 # means 'used/not available'. The file must not exist (EXCL) and therefore can
 # no longer be resized by this method, compared to previous versions. Returns
 # an empty string or raises an error. Att: No precautions for conflicts here.
 #
 proc palloc::init {dbName poolSize} {
      set h [open $dbName {WRONLY CREAT EXCL}]
      puts -nonewline $h [string repeat 0 $poolSize]
      close $h
      return ""
 }

 #-------------------------------------------------------------------------------
 # --alloc
 # Abstraction layer upon lock::withLock, to retrieve 'count' free handles
 # (default count: 1) from the pool 'dbName', which have to exist (see 'init').
 # 'timeout' is passed over via 'withLock' to 'acquireLock'.
 # Eventually returning less handles then requested, or an empty list if no more
 # handles are availabe at all. Attention: if called in a loop, competing callers
 # of 'alloc' will likely time out! Such a loop should contain sleeps or many
 # should be allocated with one call instead.
 #
 proc palloc::alloc {dbName {count 1} {timeout 1000}} {
    set res [list ]
    catch {lock::withLock {
       set h [open $dbName RDWR]
       seek $h 0
       set pool [read $h]
       set free 0
       while {$count > 0} {
          set free [string first "0" $pool $free]
          if {$free == -1} {
             break
          }
          lappend res $free
          set pool [string replace $pool $free $free "1"]
          incr count -1
          incr free
       }
       if {[llength $res]} {
          # save the changes
          seek $h 0
          puts -nonewline $h $pool
       }
       close $h
    } $timeout $dbName.lock}
    return $res
 }

 #-------------------------------------------------------------------------------
 # --free
 # Deallocating the 'handles', marking them as free in 'dbName'.
 # 'timeout' is passed over via 'withLock' to 'acquireLock'.
 # Returning the handles which are successfully freed.
 #
 proc palloc::free {dbName handles {timeout 1000}} {
    set res [list ]
    catch {lock::withLock {
       set h [open $dbName RDWR]
       seek $h 0
       set pool [read $h]
       foreach hdl $handles {
          if {[string range $pool $hdl $hdl] == "1"} {
             lappend res $hdl
             set pool [string replace $pool $hdl $hdl "0"]
          }
       }
       if {[llength $res]} {
          # save the changes
          seek $h 0
          puts -nonewline $h $pool
       }
       close $h
    } $timeout $dbName.lock}
    return $res
 }
----
 # palloc_test1.tcl -- Testsuite 03.07.2007 M.Hoffmann
 # This does not test concurrend operations, see test2 for that.

 lappend auto_path [pwd]

 package require palloc 2.0

 proc doTests {cmds} {
      foreach cmd $cmds {
              set command        [lindex $cmd 0]
              set expectedResult [lindex $cmd 1]
              set comment        [lindex $cmd 2]
              catch {uplevel $command} currentResult
              set failCount      0
              if {$expectedResult != $currentResult} {
                 set marker "***ERR***"
                 incr failCount
              } else {
                 set marker "ok"
              }
              puts "Command : $command"
              puts "Result  : $currentResult"
              puts "Expected: $expectedResult"
              puts "Comment : $comment"
              puts $marker\n
      }
      puts [expr {$failCount > 0 ? "***TESTS FAILED!!!***" : "Tests passed"}]
      return [expr {$failCount != 0}]
 }

 catch {file delete pool.1}
 exit [doTests {
      {{palloc::init pool.1 500 }  ""                                            {}                                                        }
      {{palloc::init pool.1 250 }  {couldn't open "pool.1": file already exists} {because of EXCL-flag with open, explicit delete required}}
      {{palloc::alloc pool.1    }  0                                             {}                                                        }
      {{palloc::alloc pool.1    }  1                                             {}                                                        }
      {{palloc::alloc pool.1    }  2                                             {}                                                        }
      {{palloc::alloc pool.1    }  3                                             {}                                                        }
      {{palloc::alloc pool.1    }  4                                             {}                                                        }
      {{palloc::free  pool.1 4 5}  4                                             {Handle 5 not allocated}                                  }
      {{palloc::alloc pool.1    }  4                                             {}                                                        }
      {{palloc::alloc pool.1 10 }  {5 6 7 8 9 10 11 12 13 14}                    {}                                                        }
      {{palloc::alloc pool.1    }  15                                            {}                                                        }
 }]
----
 # palloc_test2.tcl -- Concurrency-tests for palloc - 03.07.2007 M.Hoffmann
 # this calls palloc_test3.tcl multiple times after initializing a pool.

 lappend auto_path [pwd]
 package require palloc 2.0
 package require bgexec; # see http://wiki.tcl.tk/12704

 catch {
    file delete pool.2
    palloc::init pool.2 500
 }

 set pCount 0
 proc cb {data} {
    puts $data
 }
 # ok, this is not an exactly parrallel start...
 # should be revised to provide true parallel execution start
 bgExec [list tclsh palloc_test3.tcl] cb pCount
 bgExec [list tclsh palloc_test3.tcl] cb pCount
 bgExec [list tclsh palloc_test3.tcl] cb pCount
 bgExec [list tclsh palloc_test3.tcl] cb pCount
 bgExec [list tclsh palloc_test3.tcl] cb pCount
 while {$pCount > 0} {
    vwait pCount
 }
----
 # palloc_test2.tcl -- Concurrency-tests for palloc - 03.07.2007 M.Hoffmann
 # this calls palloc_test3.tcl multiple times after initializing a pool.

 lappend auto_path [pwd]
 package require palloc 2.0
 package require bgexec; # see http://wiki.tcl.tk/12704

 catch {
    file delete pool.2
    palloc::init pool.2 500
 }

 set pCount 0
 proc cb {data} {
    puts $data
 }
 # ok, this is not an exactly parrallel start...
 # should be revised to provide true parallel execution start
 bgExec [list tclsh palloc_test3.tcl] cb pCount
 bgExec [list tclsh palloc_test3.tcl] cb pCount
 bgExec [list tclsh palloc_test3.tcl] cb pCount
 bgExec [list tclsh palloc_test3.tcl] cb pCount
 bgExec [list tclsh palloc_test3.tcl] cb pCount
 while {$pCount > 0} {
    vwait pCount
 }
----
!!!!!!
%| [Category Dev. Tools] |%
!!!!!!