blob: 83f4519e09e102e86683fd25120854ac7372e5fc (
plain)
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
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
|
# -*- tcl -*-
# ### ### ### ######### ######### #########
##
# Class for the handling of stream sources.
# ### ### ### ######### ######### #########
## Requirements
package require transfer::copy ; # Data transmission core
package require snit
# ### ### ### ######### ######### #########
## Implementation
snit::type ::transfer::data::source {
# ### ### ### ######### ######### #########
## API
# Source is ...
option -string -default {} -configuremethod C-str ; # a string.
option -channel -default {} -configuremethod C-chan ; # an open & readable channel.
option -file -default {} -configuremethod C-file ; # a file.
option -variable -default {} -configuremethod C-var ; # a string held by the named variable.
option -size -default -1 ; # number of characters to transfer.
option -progress -default {}
method type {} {}
method data {} {}
method size {} {}
method valid {mv} {}
method transmit {sock blocksize done} {}
# ### ### ### ######### ######### #########
## Implementation
method type {} {
return $myxtype
}
method data {} {
switch -exact -- $myetype {
undefined {
return -code error "Data source is undefined"
}
string - chan {
return $mysrc
}
variable {
upvar \#0 $mysrc thevalue
return $thevalue
}
file {
return [open $mysrc r]
}
}
}
method size {} {
if {$options(-size) < 0} {
switch -exact -- $myetype {
undefined {
return -code error "Data source is undefined"
}
string {
return [string length $mysrc]
}
variable {
upvar \#0 $mysrc thevalue
return [string length $thevalue]
}
chan - file {
# Nothing, -1 passes through
# We do not use [file size] for a file, as a
# user-specified encoding may distort the
# counting.
}
}
}
return $options(-size)
}
method valid {mv} {
upvar 1 $mv message
switch -exact -- $myetype {
undefined {
set message "Data source is undefined"
return 0
}
string - variable {
if {[$self size] > [string length [$self data]]} {
set message "Not enough data to transmit"
return 0
}
}
chan {
# Additional check of option ?
}
file {
# Additional check of option ?
}
}
return 1
}
method transmit {sock blocksize done} {
::transfer::copy::do \
[$self type] [$self data] $sock \
-size [$self size] \
-blocksize $blocksize \
-command $done \
-progress $options(-progress)
return
}
# ### ### ### ######### ######### #########
## Internal helper commands.
method C-str {o newvalue} {
set myetype string
set myxtype string
set mysrc $newvalue
return
}
method C-var {o newvalue} {
set myetype variable
set myxtype string
if {![uplevel \#0 {info exists $newvalue}]} {
return -code error "Bad variable \"$newvalue\", does not exist"
}
set mysrc $newvalue
return
}
method C-chan {o newvalue} {
if {![llength [file channels $newvalue]]} {
return -code error "Bad channel handle \"$newvalue\", does not exist"
}
set myetype chan
set myxtype chan
set mysrc $newvalue
return
}
method C-file {o newvalue} {
if {![file exists $newvalue]} {
return -code error "File \"$newvalue\" does not exist"
}
if {![file readable $newvalue]} {
return -code error "File \"$newvalue\" not readable"
}
if {![file isfile $newvalue]} {
return -code error "File \"$newvalue\" not a file"
}
set myetype file
set myxtype chan
set mysrc $newvalue
return
}
# ### ### ### ######### ######### #########
## Data structures
variable myetype undefined
variable myxtype undefined
variable mysrc
##
# ### ### ### ######### ######### #########
}
# ### ### ### ######### ######### #########
## Ready
package provide transfer::data::source 0.2
|
