1################################################################################ 2# pool.tcl 3# 4# 5# Author: Erik Leunissen 6# 7# 8# Acknowledgement: 9# The author is grateful for the advice provided by 10# Andreas Kupries during the development of this code. 11# 12################################################################################ 13 14package require cmdline 15 16namespace eval ::struct {} 17namespace eval ::struct::pool { 18 19 # a list of all current pool names 20 variable pools {} 21 22 # counter is used to give a unique name to a pool if 23 # no name was supplied, e.g. pool1, pool2 etc. 24 variable counter 0 25 26 # `commands' is the list of subcommands recognized by a pool-object command 27 variable commands {add clear destroy info maxsize release remove request} 28 29 # All errors with corresponding (unformatted) messages. 30 # The format strings will be replaced by the appropriate 31 # values when an error occurs. 32 variable Errors 33 array set Errors { 34 BAD_SUBCMD {Bad subcommand "%s": must be %s} 35 DUPLICATE_ITEM_IN_ARGS {Duplicate item `%s' in arguments.} 36 DUPLICATE_POOLNAME {The pool `%s' already exists.} 37 EXCEED_MAXSIZE "This command would increase the total number of items\ 38 \nbeyond the maximum size of the pool. No items registered." 39 FORBIDDEN_ALLOCID "The value -1 is not allowed as an allocID." 40 INVALID_POOLSIZE {The pool currently holds %s items.\ 41 Can't set maxsize to a value less than that.} 42 ITEM_ALREADY_IN_POOL {`%s' already is a member of the pool. No items registered.} 43 ITEM_NOT_IN_POOL {`%s' is not a member of %s.} 44 ITEM_NOT_ALLOCATED {Can't release `%s' because it isn't allocated.} 45 ITEM_STILL_ALLOCATED {Can't remove `%s' because it is still allocated.} 46 NONINT_REQSIZE {The second argument must be a positive integer value} 47 SOME_ITEMS_NOT_FREE {Couldn't %s `%s' because some items are still allocated.} 48 UNKNOWN_ARG {Unknown argument `%s'} 49 UNKNOWN_POOL {Nothing known about `%s'.} 50 VARNAME_EXISTS {A variable `::struct::pool::%s' already exists.} 51 WRONG_INFO_TYPE "Expected second argument to be one of:\ 52 \n allitems, allocstate, cursize, freeitems, maxsize,\ 53 \nbut received: `%s'." 54 WRONG_NARGS "wrong#args" 55 } 56 57 namespace export pool 58} 59 60# A small helper routine to generate structured errors 61 62if {[package vsatisfies [package present Tcl] 8.5]} { 63 # Tcl 8.5+, have expansion operator and syntax. And option -level. 64 proc ::struct::pool::Error {error args} { 65 variable Errors 66 return -code error -level 1 \ 67 -errorcode [list STRUCT POOL $error {*}$args] \ 68 [format $Errors($error) {*}$args] 69 } 70} else { 71 # Tcl 8.4. No expansion operator available. Nor -level. 72 # Construct the pieces explicitly, via linsert/eval hop&dance. 73 proc ::struct::pool::Error {error args} { 74 variable Errors 75 lappend code STRUCT POOL $error 76 eval [linsert $args 0 lappend code] 77 set msg [eval [linsert $args 0 format $Errors($error)]] 78 return -code error -errorcode $code $msg 79 } 80} 81 82# A small helper routine to check list membership 83proc ::struct::pool::lmember {list element} { 84 if { [lsearch -exact $list $element] >= 0 } { 85 return 1 86 } else { 87 return 0 88 } 89} 90 91# General note 92# ============ 93# 94# All procedures below use the following method to reference 95# a particular pool-object: 96# 97# variable $poolname 98# upvar #0 ::struct::pool::$poolname pool 99# upvar #0 ::struct::pool::Allocstate_$poolname state 100# 101# Therefore, the names `pool' and `state' refer to a particular 102# instance of a pool. 103# 104# In the comments to the code below, the words `pool' and `state' 105# also refer to a particular pool. 106# 107 108# ::struct::pool::create 109# 110# Creates a new instance of a pool (a pool-object). 111# ::struct::pool::pool (see right below) is an alias to this procedure. 112# 113# 114# Arguments: 115# poolname: name of the pool-object 116# maxsize: the maximum number of elements that the pool is allowed 117# consist of. 118# 119# 120# Results: 121# the name of the newly created pool 122# 123# 124# Side effects: 125# - Registers the pool-name in the variable `pools'. 126# 127# - Creates the pool array which holds general state about the pool. 128# The following elements are initialized: 129# pool(freeitems): a list of non-allocated items 130# pool(cursize): the current number of elements in the pool 131# pool(maxsize): the maximum allowable number of pool elements 132# Additional state may be hung off this array as long as the three 133# elements above are not corrupted. 134# 135# - Creates a separate array `state' that will hold allocation state 136# of the pool elements. 137# 138# - Creates an object-procedure that has the same name as the pool. 139# 140proc ::struct::pool::create { {poolname ""} {maxsize 10} } { 141 variable pools 142 variable counter 143 144 # check maxsize argument 145 if { ![string equal $maxsize 10] } { 146 if { ![regexp {^\+?[1-9][0-9]*$} $maxsize] } { 147 Error NONINT_REQSIZE 148 } 149 } 150 151 # create a name if no name was supplied 152 if { [string length $poolname]==0 } { 153 incr counter 154 set poolname pool$counter 155 set incrcnt 1 156 } 157 158 # check whether there exists a pool named $poolname 159 if { [lmember $pools $poolname] } { 160 if { [::info exists incrcnt] } { 161 incr counter -1 162 } 163 Error DUPLICATE_POOLNAME $poolname 164 } 165 166 # check whether the namespace variable exists 167 if { [::info exists ::struct::pool::$poolname] } { 168 if { [::info exists incrcnt] } { 169 incr counter -1 170 } 171 Error VARNAME_EXISTS $poolname 172 } 173 174 variable $poolname 175 176 # register 177 lappend pools $poolname 178 179 # create and initialize the new pool data structure 180 upvar #0 ::struct::pool::$poolname pool 181 set pool(freeitems) {} 182 set pool(maxsize) $maxsize 183 set pool(cursize) 0 184 185 # the array that holds allocation state 186 upvar #0 ::struct::pool::Allocstate_$poolname state 187 array set state {} 188 189 # create a pool-object command and map it to the pool commands 190 interp alias {} ::$poolname {} ::struct::pool::poolCmd $poolname 191 return $poolname 192} 193 194# 195# This alias provides compatibility with the implementation of the 196# other data structures (stack, queue etc...) in the tcllib::struct package. 197# 198proc ::struct::pool::pool { {poolname ""} {maxsize 10} } { 199 ::struct::pool::create $poolname $maxsize 200} 201 202 203# ::struct::pool::poolCmd 204# 205# This proc constitutes a level of indirection between the pool-object 206# subcommand and the pool commands (below); it's sole function is to pass 207# the command along to one of the pool commands, and receive any results. 208# 209# Arguments: 210# poolname: name of the pool-object 211# subcmd: the subcommand, which identifies the pool-command to 212# which calls will be passed. 213# args: any arguments. They will be inspected by the pool-command 214# to which this call will be passed along. 215# 216# Results: 217# Whatever result the pool command returns, is once more returned. 218# 219# Side effects: 220# Dispatches the call onto a specific pool command and receives any results. 221# 222proc ::struct::pool::poolCmd {poolname subcmd args} { 223 # check the subcmd argument 224 if { [lsearch -exact $::struct::pool::commands $subcmd] == -1 } { 225 set optlist [join $::struct::pool::commands ", "] 226 set optlist [linsert $optlist "end-1" "or"] 227 Error BAD_SUBCMD $subcmd $optlist 228 } 229 230 # pass the call to the pool command indicated by the subcmd argument, 231 # and return the result from that command. 232 return [eval [linsert $args 0 ::struct::pool::$subcmd $poolname]] 233} 234 235 236# ::struct::pool::destroy 237# 238# Destroys a pool-object, its associated variables and "object-command" 239# 240# Arguments: 241# poolname: name of the pool-object 242# forceArg: if set to `-force', the pool-object will be destroyed 243# regardless the allocation state of its objects. 244# 245# Results: 246# none 247# 248# Side effects: 249# - unregisters the pool name in the variable `pools'. 250# - unsets `pool' and `state' (poolname specific variables) 251# - destroys the "object-procedure" that was associated with the pool. 252# 253proc ::struct::pool::destroy {poolname {forceArg ""}} { 254 variable pools 255 256 # check forceArg argument 257 if { [string length $forceArg] } { 258 if { [string equal $forceArg -force] } { 259 set force 1 260 } else { 261 Error UNKNOWN_ARG $forceArg 262 } 263 } else { 264 set force 0 265 } 266 267 set index [lsearch -exact $pools $poolname] 268 if {$index == -1 } { 269 Error UNKNOWN_POOL $poolname 270 } 271 272 if { !$force } { 273 # check for any lingering allocated items 274 variable $poolname 275 upvar #0 ::struct::pool::$poolname pool 276 upvar #0 ::struct::pool::Allocstate_$poolname state 277 if { [llength $pool(freeitems)] != $pool(cursize) } { 278 Error SOME_ITEMS_NOT_FREE destroy $poolname 279 } 280 } 281 282 rename ::$poolname {} 283 unset ::struct::pool::$poolname 284 catch {unset ::struct::pool::Allocstate_$poolname} 285 set pools [lreplace $pools $index $index] 286 287 return 288} 289 290 291# ::struct::pool::add 292# 293# Add items to the pool 294# 295# Arguments: 296# poolname: name of the pool-object 297# args: the items to add 298# 299# Results: 300# none 301# 302# Side effects: 303# sets the initial allocation state of the added items to -1 (free) 304# 305proc ::struct::pool::add {poolname args} { 306 variable $poolname 307 upvar #0 ::struct::pool::$poolname pool 308 upvar #0 ::struct::pool::Allocstate_$poolname state 309 310 # argument check 311 if { [llength $args] == 0 } { 312 Error WRONG_NARGS 313 } 314 315 # will this operation exceed the size limit of the pool? 316 if {[expr { $pool(cursize) + [llength $args] }] > $pool(maxsize) } { 317 Error EXCEED_MAXSIZE 318 } 319 320 321 # check for duplicate items on the command line 322 set N [llength $args] 323 if { $N > 1} { 324 for {set i 0} {$i<=$N} {incr i} { 325 foreach item [lrange $args [expr {$i+1}] end] { 326 if { [string equal [lindex $args $i] $item]} { 327 Error DUPLICATE_ITEM_IN_ARGS $item 328 } 329 } 330 } 331 } 332 333 # check whether the items exist yet in the pool 334 foreach item $args { 335 if { [lmember [array names state] $item] } { 336 Error ITEM_ALREADY_IN_POOL $item 337 } 338 } 339 340 # add items to the pool, and initialize their allocation state 341 foreach item $args { 342 lappend pool(freeitems) $item 343 set state($item) -1 344 incr pool(cursize) 345 } 346 return 347} 348 349 350 351# ::struct::pool::clear 352# 353# Removes all items from the pool and clears corresponding 354# allocation state. 355# 356# 357# Arguments: 358# poolname: name of the pool-object 359# forceArg: if set to `-force', all items are removed 360# regardless their allocation state. 361# 362# Results: 363# none 364# 365# Side effects: 366# see description above 367# 368proc ::struct::pool::clear {poolname {forceArg ""} } { 369 variable $poolname 370 upvar #0 ::struct::pool::$poolname pool 371 upvar #0 ::struct::pool::Allocstate_$poolname state 372 373 # check forceArg argument 374 if { [string length $forceArg] } { 375 if { [string equal $forceArg -force] } { 376 set force 1 377 } else { 378 Error UNKNOWN_ARG $forceArg 379 } 380 } else { 381 set force 0 382 } 383 384 # check whether some items are still allocated 385 if { !$force } { 386 if { [llength $pool(freeitems)] != $pool(cursize) } { 387 Error SOME_ITEMS_NOT_FREE clear $poolname 388 } 389 } 390 391 # clear the pool, clean up state and adjust the pool size 392 set pool(freeitems) {} 393 array unset state 394 array set state {} 395 set pool(cursize) 0 396 return 397} 398 399 400 401# ::struct::pool::info 402# 403# Returns information about the pool in data structures that allow 404# further programmatic use. 405# 406# Arguments: 407# poolname: name of the pool-object 408# type: the type of info requested 409# 410# 411# Results: 412# The info requested 413# 414# 415# Side effects: 416# none 417# 418proc ::struct::pool::info {poolname type args} { 419 variable $poolname 420 upvar #0 ::struct::pool::$poolname pool 421 upvar #0 ::struct::pool::Allocstate_$poolname state 422 423 # check the number of arguments 424 if { [string equal $type allocID] } { 425 if { [llength $args]!=1 } { 426 Error WRONG_NARGS 427 } 428 } elseif { [llength $args] > 0 } { 429 Error WRONG_NARGS 430 } 431 432 switch $type { 433 allitems { 434 return [array names state] 435 } 436 allocstate { 437 return [array get state] 438 } 439 allocID { 440 set item [lindex $args 0] 441 if {![lmember [array names state] $item]} { 442 Error ITEM_NOT_IN_POOL $item $poolname 443 } 444 return $state($item) 445 } 446 cursize { 447 return $pool(cursize) 448 } 449 freeitems { 450 return $pool(freeitems) 451 } 452 maxsize { 453 return $pool(maxsize) 454 } 455 default { 456 Error WRONG_INFO_TYPE $type 457 } 458 } 459} 460 461 462# ::struct::pool::maxsize 463# 464# Returns the current or sets a new maximum size of the pool. 465# As far as querying only is concerned, this is an alias for 466# `::struct::pool::info maxsize'. 467# 468# 469# Arguments: 470# poolname: name of the pool-object 471# reqsize: if supplied, it is the requested size of the pool, i.e. 472# the maximum number of elements in the pool. 473# 474# 475# Results: 476# The current/new maximum size of the pool. 477# 478# 479# Side effects: 480# Sets pool(maxsize) if a new size is supplied. 481# 482proc ::struct::pool::maxsize {poolname {reqsize ""} } { 483 variable $poolname 484 upvar #0 ::struct::pool::$poolname pool 485 upvar #0 ::struct::pool::Allocstate_$poolname state 486 487 if { [string length $reqsize] } { 488 if { [regexp {^\+?[1-9][0-9]*$} $reqsize] } { 489 if { $pool(cursize) <= $reqsize } { 490 set pool(maxsize) $reqsize 491 } else { 492 Error INVALID_POOLSIZE $pool(cursize) 493 } 494 } else { 495 Error NONINT_REQSIZE 496 } 497 } 498 return $pool(maxsize) 499} 500 501 502# ::struct::pool::release 503# 504# Deallocates an item 505# 506# 507# Arguments: 508# poolname: name of the pool-object 509# item: name of the item to be released 510# 511# 512# Results: 513# none 514# 515# Side effects: 516# - sets the item's allocation state to free (-1) 517# - appends item to the list of free items 518# 519proc ::struct::pool::release {poolname item} { 520 variable $poolname 521 upvar #0 ::struct::pool::$poolname pool 522 upvar #0 ::struct::pool::Allocstate_$poolname state 523 524 # Is item in the pool? 525 if {![lmember [array names state] $item]} { 526 Error ITEM_NOT_IN_POOL $item $poolname 527 } 528 529 # check whether item was allocated 530 if { $state($item) == -1 } { 531 Error ITEM_NOT_ALLOCATED $item 532 } else { 533 534 # set item free and return it to the pool of free items 535 set state($item) -1 536 lappend pool(freeitems) $item 537 538 } 539 return 540} 541 542# ::struct::pool::remove 543# 544# Removes an item from the pool 545# 546# 547# Arguments: 548# poolname: name of the pool-object 549# item: the item to be removed 550# forceArg: if set to `-force', the item is removed 551# regardless its allocation state. 552# 553# Results: 554# none 555# 556# Side effects: 557# - cleans up allocation state related to the item 558# 559proc ::struct::pool::remove {poolname item {forceArg ""} } { 560 variable $poolname 561 upvar #0 ::struct::pool::$poolname pool 562 upvar #0 ::struct::pool::Allocstate_$poolname state 563 564 # check forceArg argument 565 if { [string length $forceArg] } { 566 if { [string equal $forceArg -force] } { 567 set force 1 568 } else { 569 Error UNKNOWN_ARG $forceArg 570 } 571 } else { 572 set force 0 573 } 574 575 # Is item in the pool? 576 if {![lmember [array names state] $item]} { 577 Error ITEM_NOT_IN_POOL $item $poolname 578 } 579 580 set index [lsearch $pool(freeitems) $item] 581 if { $index >= 0} { 582 583 # actual removal 584 set pool(freeitems) [lreplace $pool(freeitems) $index $index] 585 586 } elseif { !$force } { 587 Error ITEM_STILL_ALLOCATED $item 588 } 589 590 # clean up state and adjust the pool size 591 unset state($item) 592 incr pool(cursize) -1 593 return 594} 595 596 597 598# ::struct::pool::request 599# 600# Handles requests for an item, taking into account a preference 601# for a particular item if supplied. 602# 603# 604# Arguments: 605# poolname: name of the pool-object 606# 607# itemvar: variable to which the item-name will be assigned 608# if the request is honored. 609# 610# args: an optional sequence of key-value pairs, indicating the 611# following options: 612# -prefer: the preferred item to allocate. 613# -allocID: An ID for the entity to which the item will be 614# allocated. This facilitates reverse lookups. 615# 616# Results: 617# 618# 1 if the request was honored; an item is allocated 619# 0 if the request couldn't be honored; no item is allocated 620# 621# The user is strongly advised to check the return values 622# when calling this procedure. 623# 624# 625# Side effects: 626# 627# if the request is honored: 628# - sets allocation state to $allocID (or dummyID if it was not supplied) 629# if allocation was succesful. Allocation state is maintained in the 630# namespace variable state (see: `General note' above) 631# - sets the variable passed via `itemvar' to the allocated item. 632# 633# if the request is denied, no side effects occur. 634# 635proc ::struct::pool::request {poolname itemvar args} { 636 variable $poolname 637 upvar #0 ::struct::pool::$poolname pool 638 upvar #0 ::struct::pool::Allocstate_$poolname state 639 640 # check args 641 set nargs [llength $args] 642 if { ! ($nargs==0 || $nargs==2 || $nargs==4) } { 643 if { ![string equal $args -?] && ![string equal $args -help]} { 644 Error WRONG_NARGS 645 } 646 } elseif { $nargs } { 647 foreach {name value} $args { 648 if { ![string match -* $name] } { 649 Error UNKNOWN_ARG $name 650 } 651 } 652 } 653 654 set allocated 0 655 656 # are there any items available? 657 if { [llength $pool(freeitems)] > 0} { 658 659 # process command options 660 set options [cmdline::getoptions args { \ 661 {prefer.arg {} {The preference for a particular item}} \ 662 {allocID.arg {} {An ID for the entity to which the item will be allocated} } \ 663 } \ 664 "usage: $poolname request itemvar ?options?:"] 665 foreach {key value} $options { 666 set $key $value 667 } 668 669 if { $allocID == -1 } { 670 Error FORBIDDEN_ALLOCID 671 } 672 673 # let `item' point to a variable two levels up the call stack 674 upvar 2 $itemvar item 675 676 # check whether a preference was supplied 677 if { [string length $prefer] } { 678 if {![lmember [array names state] $prefer]} { 679 Error ITEM_NOT_IN_POOL $prefer $poolname 680 } 681 if { $state($prefer) == -1 } { 682 set index [lsearch $pool(freeitems) $prefer] 683 set item $prefer 684 } else { 685 return 0 686 } 687 } else { 688 set index 0 689 set item [lindex $pool(freeitems) 0] 690 } 691 692 # do the actual allocation 693 set pool(freeitems) [lreplace $pool(freeitems) $index $index] 694 if { [string length $allocID] } { 695 set state($item) $allocID 696 } else { 697 set state($item) dummyID 698 } 699 set allocated 1 700 } 701 return $allocated 702} 703 704 705# EOF pool.tcl 706 707# ### ### ### ######### ######### ######### 708## Ready 709 710namespace eval ::struct { 711 # Get 'pool::pool' into the general structure namespace. 712 namespace import -force pool::pool 713 namespace export pool 714} 715package provide struct::pool 1.2.3 716