################################################################################
# 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 : https://wiki.tcl-lang.org/19673
# History :
# 03072007 2.0 - everything rewritten using 'lock', partially incompatible api.
#
################################################################################
package require lock ; # see https://wiki.tcl-lang.org/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
}