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