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