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