1# queue.tcl -- 2# 3# Queue implementation for Tcl. 4# 5# Copyright (c) 1998-2000 by Ajuba Solutions. 6# Copyright (c) 2008-2010 Andreas Kupries 7# 8# See the file "license.terms" for information on usage and redistribution 9# of this file, and for a DISCLAIMER OF ALL WARRANTIES. 10# 11# RCS: @(#) $Id: queue_tcl.tcl,v 1.2 2010/03/24 06:13:00 andreas_kupries Exp $ 12 13namespace eval ::struct::queue { 14 # counter is used to give a unique name for unnamed queues 15 variable counter 0 16 17 # Only export one command, the one used to instantiate a new queue 18 namespace export queue_tcl 19} 20 21# ::struct::queue::queue_tcl -- 22# 23# Create a new queue with a given name; if no name is given, use 24# queueX, where X is a number. 25# 26# Arguments: 27# name name of the queue; if null, generate one. 28# 29# Results: 30# name name of the queue created 31 32proc ::struct::queue::queue_tcl {args} { 33 variable I::qat 34 variable I::qret 35 variable I::qadd 36 variable counter 37 38 switch -exact -- [llength [info level 0]] { 39 1 { 40 # Missing name, generate one. 41 incr counter 42 set name "queue${counter}" 43 } 44 2 { 45 # Standard call. New empty queue. 46 set name [lindex $args 0] 47 } 48 default { 49 # Error. 50 return -code error \ 51 "wrong # args: should be \"queue ?name?\"" 52 } 53 } 54 55 # FIRST, qualify the name. 56 if {![string match "::*" $name]} { 57 # Get caller's namespace; append :: if not global namespace. 58 set ns [uplevel 1 [list namespace current]] 59 if {"::" != $ns} { 60 append ns "::" 61 } 62 63 set name "$ns$name" 64 } 65 if {[llength [info commands $name]]} { 66 return -code error \ 67 "command \"$name\" already exists, unable to create queue" 68 } 69 70 # Initialize the queue as empty 71 set qat($name) 0 72 set qret($name) [list] 73 set qadd($name) [list] 74 75 # Create the command to manipulate the queue 76 interp alias {} $name {} ::struct::queue::QueueProc $name 77 78 return $name 79} 80 81########################## 82# Private functions follow 83 84# ::struct::queue::QueueProc -- 85# 86# Command that processes all queue object commands. 87# 88# Arguments: 89# name name of the queue object to manipulate. 90# args command name and args for the command 91# 92# Results: 93# Varies based on command to perform 94 95if {[package vsatisfies [package provide Tcl] 8.5]} { 96 # In 8.5+ we can do an ensemble for fast dispatch. 97 98 proc ::struct::queue::QueueProc {name cmd args} { 99 # Shuffle method to front and then simply run the ensemble. 100 # Dispatch, argument checking, and error message generation 101 # are all done in the C-level. 102 103 I $cmd $name {*}$args 104 } 105 106 namespace eval ::struct::queue::I { 107 namespace export clear destroy get peek \ 108 put unget size 109 namespace ensemble create 110 } 111 112} else { 113 # Before 8.5 we have to code our own dispatch, including error 114 # checking. 115 116 proc ::struct::queue::QueueProc {name cmd args} { 117 # Do minimal args checks here 118 if { [llength [info level 0]] == 2 } { 119 return -code error "wrong # args: should be \"$name option ?arg arg ...?\"" 120 } 121 122 # Split the args into command and args components 123 if { [llength [info commands ::struct::queue::I::$cmd]] == 0 } { 124 set optlist [lsort [info commands ::struct::queue::I::*]] 125 set xlist {} 126 foreach p $optlist { 127 set p [namespace tail $p] 128 if {($p eq "K") || ($p eq "Shift") || ($p eq "Shift?")} continue 129 lappend xlist $p 130 } 131 set optlist [linsert [join $xlist ", "] "end-1" "or"] 132 return -code error \ 133 "bad option \"$cmd\": must be $optlist" 134 } 135 136 uplevel 1 [linsert $args 0 ::struct::queue::I::$cmd $name] 137 } 138} 139 140namespace eval ::struct::queue::I { 141 # The arrays hold all of the queues which were made. 142 variable qat ; # Index in qret of next element to return 143 variable qret ; # List of elements waiting for return 144 variable qadd ; # List of elements added and not yet reached for return. 145} 146 147# ::struct::queue::I::clear -- 148# 149# Clear a queue. 150# 151# Arguments: 152# name name of the queue object. 153# 154# Results: 155# None. 156 157proc ::struct::queue::I::clear {name} { 158 variable qat 159 variable qret 160 variable qadd 161 set qat($name) 0 162 set qret($name) [list] 163 set qadd($name) [list] 164 return 165} 166 167# ::struct::queue::I::destroy -- 168# 169# Destroy a queue object by removing it's storage space and 170# eliminating it's proc. 171# 172# Arguments: 173# name name of the queue object. 174# 175# Results: 176# None. 177 178proc ::struct::queue::I::destroy {name} { 179 variable qat ; unset qat($name) 180 variable qret ; unset qret($name) 181 variable qadd ; unset qadd($name) 182 interp alias {} $name {} 183 return 184} 185 186# ::struct::queue::I::get -- 187# 188# Get an item from a queue. 189# 190# Arguments: 191# name name of the queue object. 192# count number of items to get; defaults to 1 193# 194# Results: 195# item first count items from the queue; if there are not enough 196# items in the queue, throws an error. 197 198proc ::struct::queue::I::get {name {count 1}} { 199 if { $count < 1 } { 200 error "invalid item count $count" 201 } elseif { $count > [size $name] } { 202 error "insufficient items in queue to fill request" 203 } 204 205 Shift? $name 206 207 variable qat ; upvar 0 qat($name) AT 208 variable qret ; upvar 0 qret($name) RET 209 variable qadd ; upvar 0 qadd($name) ADD 210 211 if { $count == 1 } { 212 # Handle this as a special case, so single item gets aren't 213 # listified 214 215 set item [lindex $RET $AT] 216 incr AT 217 Shift? $name 218 return $item 219 } 220 221 # Otherwise, return a list of items 222 223 if {$count > ([llength $RET] - $AT)} { 224 # Need all of RET and parts of ADD, maybe all. 225 set max [expr {$count - ([llength $RET] - $AT) - 1}] 226 set result [concat $RET [lrange $ADD 0 $max]] 227 Shift $name 228 set AT $max 229 } else { 230 # Request can be satisified from RET alone. 231 set max [expr {$AT + $count - 1}] 232 set result [lrange $RET $AT $max] 233 set AT $max 234 } 235 236 incr AT 237 Shift? $name 238 return $result 239} 240 241# ::struct::queue::I::peek -- 242# 243# Retrieve the value of an item on the queue without removing it. 244# 245# Arguments: 246# name name of the queue object. 247# count number of items to peek; defaults to 1 248# 249# Results: 250# items top count items from the queue; if there are not enough items 251# to fulfill the request, throws an error. 252 253proc ::struct::queue::I::peek {name {count 1}} { 254 variable queues 255 if { $count < 1 } { 256 error "invalid item count $count" 257 } elseif { $count > [size $name] } { 258 error "insufficient items in queue to fill request" 259 } 260 261 Shift? $name 262 263 variable qat ; upvar 0 qat($name) AT 264 variable qret ; upvar 0 qret($name) RET 265 variable qadd ; upvar 0 qadd($name) ADD 266 267 if { $count == 1 } { 268 # Handle this as a special case, so single item pops aren't 269 # listified 270 return [lindex $RET $AT] 271 } 272 273 # Otherwise, return a list of items 274 275 if {$count > [llength $RET] - $AT} { 276 # Need all of RET and parts of ADD, maybe all. 277 set over [expr {$count - ([llength $RET] - $AT) - 1}] 278 return [concat $RET [lrange $ADD 0 $over]] 279 } else { 280 # Request can be satisified from RET alone. 281 return [lrange $RET $AT [expr {$AT + $count - 1}]] 282 } 283} 284 285# ::struct::queue::I::put -- 286# 287# Put an item into a queue. 288# 289# Arguments: 290# name name of the queue object 291# args items to put. 292# 293# Results: 294# None. 295 296proc ::struct::queue::I::put {name args} { 297 variable qadd 298 if { [llength $args] == 0 } { 299 error "wrong # args: should be \"$name put item ?item ...?\"" 300 } 301 foreach item $args { 302 lappend qadd($name) $item 303 } 304 return 305} 306 307# ::struct::queue::I::unget -- 308# 309# Put an item into a queue. At the _front_! 310# 311# Arguments: 312# name name of the queue object 313# item item to put at the front of the queue 314# 315# Results: 316# None. 317 318proc ::struct::queue::I::unget {name item} { 319 variable qat ; upvar 0 qat($name) AT 320 variable qret ; upvar 0 qret($name) RET 321 322 if {![llength $RET]} { 323 set RET [list $item] 324 } elseif {$AT == 0} { 325 set RET [linsert [K $RET [unset RET]] 0 $item] 326 } else { 327 # step back and modify return buffer 328 incr AT -1 329 set RET [lreplace [K $RET [unset RET]] $AT $AT $item] 330 } 331 return 332} 333 334# ::struct::queue::I::size -- 335# 336# Return the number of objects on a queue. 337# 338# Arguments: 339# name name of the queue object. 340# 341# Results: 342# count number of items on the queue. 343 344proc ::struct::queue::I::size {name} { 345 variable qat 346 variable qret 347 variable qadd 348 return [expr { 349 [llength $qret($name)] + [llength $qadd($name)] - $qat($name) 350 }] 351} 352 353# ### ### ### ######### ######### ######### 354 355proc ::struct::queue::I::Shift? {name} { 356 variable qat 357 variable qret 358 if {$qat($name) < [llength $qret($name)]} return 359 Shift $name 360 return 361} 362 363proc ::struct::queue::I::Shift {name} { 364 variable qat 365 variable qret 366 variable qadd 367 set qat($name) 0 368 set qret($name) $qadd($name) 369 set qadd($name) [list] 370 return 371} 372 373proc ::struct::queue::I::K {x y} { set x } 374 375# ### ### ### ######### ######### ######### 376## Ready 377 378namespace eval ::struct { 379 # Get 'queue::queue' into the general structure namespace for 380 # pickup by the main management. 381 namespace import -force queue::queue_tcl 382} 383 384