# 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
}
