1# -*- tcl -*-
2# ### ### ### ######### ######### #########
3##
4# Transfer class built on top of the basic facilities. Accepts many
5# transfer requests, any time, and executes them serially. Each
6# request has its own progress and completion commands.
7#
8# Note: The output channel used is part of the queue, and not
9#       contained in the transfer requests themselves. Otherwise
10#       we would not need a queue and serialized execution.
11#
12# Instances also have a general callback to report the instance status
13# (#pending transfer requests, busy).
14
15# ### ### ### ######### ######### #########
16## Requirements
17
18package require transfer::copy ; # Basic transfer facilities
19package require struct::queue  ; # Request queue
20package require snit           ; # OO system
21package require Tcl 8.4
22
23namespace eval ::transfer::copy::queue {
24    namespace import ::transfer::copy::options
25    namespace import ::transfer::copy::doChan
26    namespace import ::transfer::copy::doString
27}
28
29# ### ### ### ######### ######### #########
30## Implementation
31
32snit::type ::transfer::copy::queue {
33    # ### ### ### ######### ######### #########
34    ## API
35
36    option -on-status-change {}
37
38    constructor {thechan args} {}
39    method put     {request} {}
40    method busy    {} {}
41    method pending {} {}
42
43    # ### ### ### ######### ######### #########
44    ## Implementation
45
46    constructor {thechan args} {
47	if {![llength [file channels $chan]]} {
48	    return -code error "Channel \"$chan\" does not exist"
49	}
50
51	set chan  $thechan
52	set queue [struct::queue ${selfns}::queue]
53	set busy  0
54
55	$self configurelist $args
56	return
57    }
58
59    destructor {
60	if {$queue eq ""} return
61	$queue destroy
62	return
63    }
64
65    method put {request} {
66	# Request syntax: type dataref ?options?
67	# Accepted options are those of 'transfer::transmit::copy',
68	# etc.
69
70	# We parse out the completion callback so that we can use it
71	# directly. This also checks the request for basic validity.
72
73	if {[llength $request] < 2} {
74	    return -code error "Bad request: Not enough elements"
75	}
76
77	set type [lindex $request 0]
78	switch -exact -- $type {
79	    chan - string {}
80	    default {
81		return -code error "Bad request: Unknown type \"$type\", expected chan, or string"
82	    }
83	}
84
85	set options [lrange $request 2 end]
86	if {[catch {
87	    options $chan $options opts
88	} res]} {
89	    return -code error "Bad request: $res"
90	}
91
92	set ref [lindex $request 1]
93
94	# We store the fully parsed request. Later
95	# we call lower-level copy functionality
96	# which avoids a reparsing.
97
98	$queue put [list $type $ref [array get opts]]
99
100	# Start the engine executing transfers in the background, if
101	# it is not already running.
102
103	if {!$busy} {
104	    after 0 [mymethod Transfer]
105	}
106
107	$self ReportStatus
108	return
109    }
110
111    method busy {} {
112	return $busy
113    }
114
115    method pending {} {
116	return [$queue size]
117    }
118
119    # ### ### ### ######### ######### #########
120    ## Internal helper commands
121
122    method Transfer {} {
123	# Get the next pending request. It is already fully-parsed.
124
125	foreach {type ref o} [$queue get] break
126	array set opts $o
127
128	# Save the actual completion callback and redirect the
129	# completion of the copy operation to ourselves for proper
130	# management.
131
132	set opts(-command) [mymethod \
133		Done $opts(-command)]
134
135	# Start the transfer. We catch this as it can fail immediately
136	# (example: string-type copy and not enough data). We go
137	# through 'Done' for the reporting of such errors to avoid
138	# forgetting all the other management stuff (like the engine
139	# forced to stop).
140
141	set busy 1
142	$self ReportStatus
143
144	switch -exact -- $type {
145	    chan {
146		set code [catch {
147		    doChan $ref $chan opts
148		} res]
149	    }
150	    string {
151		set code [catch {
152		    doString $ref $chan opts
153		} res]
154	    }
155	}
156
157	if {$code} {
158	    $self Done $command 0 $res
159	}
160
161	return
162    }
163
164    method Done {command args} {
165	# args is either (n)
166	#             or (n errormessage)
167
168	# A transfer ending in an error causes the instance to stop
169	# processing requests. I.e. all requests waiting after the
170	# failed one are not executed anymore.
171
172	if {[llength $args] == 2} {
173	    set busy 0
174	    $self ReportStatus
175	    $self Notify $command $args
176	    return
177	}
178
179	# Depending on the status of the queue of pending requests we
180	# either trigger the start of the next transfer, or stop the
181	# engine. The completion of the current transfer however is
182	# unconditionally reported through its completion callback.
183
184	if {[$queue size]} {
185	    after 0 [mymethod Transfer]
186	} else {
187	    set busy 0
188	    $self ReportStatus
189	}
190
191	$self Notify $command $args
192	return
193    }
194
195    method ReportStatus {} {
196	if {![llength $options(-on-status-change)]} return
197	uplevel #0 [linsert $options(-on-status-change) end $self [$queue size] $busy]
198	return
199    }
200
201    method Notify {cmd alist} {
202	foreach a $args {lappend cmd $a}
203	uplevel #0 $cmd
204    }
205
206    # ### ### ### ######### ######### #########
207    ## Data structures
208    ## - Channel the transfered data is written to
209    ## - Queue of pending requests.
210
211    variable chan  {}
212    variable queue {}
213    variable busy  0
214
215    ##
216    # ### ### ### ######### ######### #########
217}
218
219# ### ### ### ######### ######### #########
220## Ready
221
222package provide transfer::copy::queue 0.1
223
224