1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
|
# -*- tcl -*-
# ### ### ### ######### ######### #########
##
# Class for the handling of stream destinations.
# ### ### ### ######### ######### #########
## Requirements
package require snit
# ### ### ### ######### ######### #########
## Implementation
snit::type ::transfer::data::destination {
# ### ### ### ######### ######### #########
## API
# Destination is ...
option -channel {} ; # an open & writable channel.
option -file {} ; # a writable file.
option -variable {} ; # the named variable.
method put {chunk} {}
method done {} {}
method valid {mv} {}
method receive {sock done} {}
# ### ### ### ######### ######### #########
## Implementation
method put {chunk} {
if {$xtype eq "file"} {
set value [open $value w]
set xtype channel
set close 1
}
switch -exact -- $xtype {
variable {
upvar \#0 $value var
append var $chunk
}
channel {
puts -nonewline $value $chunk
}
}
return
}
method done {} {
switch -exact -- $xtype {
file - variable {}
channel {
if {$close} {close $value}
}
}
}
method valid {mv} {
upvar 1 $mv message
switch -exact -- $xtype {
undefined {
set message "Data destination is undefined"
return 0
}
default {}
}
return 1
}
method receive {sock done} {
set ntransfered 0
set old [fconfigure $sock -blocking]
fconfigure $sock -blocking 0
fileevent $sock readable \
[mymethod Read $sock $old $done]
return
}
method Read {sock oldblock done} {
set chunk [read $sock]
if {[set l [string length $chunk]]} {
$self put $chunk
incr ntransfered $l
}
if {[eof $sock]} {
$self done
fileevent $sock readable {}
fconfigure $sock -blocking $oldblock
lappend done $ntransfered
uplevel #0 $done
}
return
}
# ### ### ### ######### ######### #########
## Internal helper commands.
onconfigure -variable {newvalue} {
set etype variable
set xtype string
if {![uplevel \#0 {info exists $newvalue}]} {
return -code error "Bad variable \"$newvalue\", does not exist"
}
set value $newvalue
return
}
onconfigure -channel {newvalue} {
if {![llength [file channels $newvalue]]} {
return -code error "Bad channel handle \"$newvalue\", does not exist"
}
set etype channel
set xtype channel
set value $newvalue
return
}
onconfigure -file {newvalue} {
if {![file exists $newvalue]} {
set d [file dirname $newvalue]
if {![file writable $d]} {
return -code error "File \"$newvalue\" not creatable"
}
if {![file isdirectory $d]} {
return -code error "File \"$newvalue\" not creatable"
}
} else {
if {![file writable $newvalue]} {
return -code error "File \"$newvalue\" not writable"
}
if {![file isfile $newvalue]} {
return -code error "File \"$newvalue\" not a file"
}
}
set etype channel
set xtype file
set value $newvalue
return
}
# ### ### ### ######### ######### #########
## Data structures
variable etype undefined
variable xtype undefined
variable value
variable close 0
variable ntransfered
##
# ### ### ### ######### ######### #########
}
# ### ### ### ######### ######### #########
## Ready
package provide transfer::data::destination 0.1
|
