blob: 6efa6172c6a695e7a6bd3e5c3b1236083c103c25 (
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
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
|
###
# scgi.test - Copyright (c) 2015 Sean Woods
#
# Author: Sean Woods, yoda@etoyoc.com
# Unit tests of the SCGI server
###
# -------------------------------------------------------------------------
source [file join \
[file dirname [file dirname [file join [pwd] [info script]]]] \
devtools testutilities.tcl]
testsNeedTcl 8.6
testsNeedTcltest 2
testsNeed TclOO 1
support {
use cmdline/cmdline.tcl cmdline
use fileutil/fileutil.tcl fileutil
use md5/md5.tcl md5
use base64/base64.tcl base64
use mime/mime.tcl mime
use uri/uri.tcl uri
use ncgi/ncgi.tcl ncgi
use dns/ip.tcl ip
use nettool/nettool.tcl nettool
use html/html.tcl html
use dicttool/dicttool.tcl dicttool
use cron/cron.tcl cron
use oodialect/oodialect.tcl oo::dialect
use oometa/oometa.tcl oo::meta
use sha1/sha1.tcl sha1
use tool/index.tcl tool
}
testing {
useLocal httpd.tcl httpd
useLocal scgi-app.tcl scgi::app
}
# -------------------------------------------------------------------------
namespace eval ::scgi {}
namespace eval ::scgi::test {}
###
# Minimal test harness for the .tests
# Not intended for public consumption
# (But if you find it handy, please steal!)
namespace eval ::scgi::test {}
proc ::scgi::encode_request {headers body info} {
variable server_block
dict set outdict CONTENT_LENGTH [string length $body]
set outdict [dict merge $outdict $server_block $info]
dict set outdict PWD [pwd]
foreach {key value} $headers {
switch $key {
SCRIPT_NAME -
REQUEST_METHOD -
REQUEST_URI {
dict set outdict $key $value
}
default {
dict set outdict HTTP_[string map {"-" "_"} [string toupper $key]] $value
}
}
}
set result {}
foreach {name value} $outdict {
append result $name \x00 $value \x00
}
return "[string length $result]:$result,"
}
proc ::scgi::test::send {port text} {
set sock [socket localhost $port]
variable reply
set reply($sock) {}
chan configure $sock -translation binary -blocking 0 -buffering full -buffersize 4096
chan event $sock readable [list ::scgi::test::get_reply $sock]
set headers {}
set body {}
set read_headers 1
foreach line [split $text \n] {
if {$read_headers} {
if { $line eq {} } {
set read_headers 0
} else {
append headers $line \n
}
} else {
append body $line \n
}
}
set block [::scgi::encode_request $headers $body {}]
puts -nonewline $sock $block
flush $sock
puts -nonewline $sock $body
flush $sock
while {$reply($sock) eq {}} {
update
}
#vwait [namespace current]::reply($sock)
return $reply($sock)
}
proc ::scgi::test::get_reply {sock} {
variable buffer
set data [read $sock]
append buffer($sock) $data
if {[eof $sock]} {
chan event $sock readable {}
set [namespace current]::reply($sock) $buffer($sock)
unset buffer($sock)
}
}
namespace eval ::scgi {
variable server_block {SCGI 1.0 SERVER_SOFTWARE {TclScgiServer/0.1}}
}
###
# Build the reply class
###
tool::class create ::scgi::test::reply {
superclass ::scgi::reply
method error {code {msg {}}} {
my reset
my variable data error_codes
if {![info exists data(url)]} {
set data(url) {}
}
if {![info exists error_codes($code)]} {
set errorstring "Unknown Error Code"
} else {
set errorstring $error_codes($code)
}
my reply_headers replace {}
my reply_headers set Status: "$code $errorstring"
my reply_headers set Content-Type: {text/plain}
my puts "
$code $errorstring
Got the error $code $errorstring
while trying to obtain $data(url)
"
}
method reset {} {
my variable reply_body
my reply_headers replace {Status: {200 OK} Content-Type: text/plain}
set reply_body {}
}
method content {} {
my reset
switch [my query_headers get REQUEST_URI] {
/file {
my variable reply_file
set reply_file [file join $::here pkgIndex.tcl]
}
/time {
my puts [clock seconds]
}
/error {
error {
The programmer asked me to die this way
}
}
/echo -
default {
my puts [my PostData]
}
}
}
###
# Output the result or error to the channel
# and destroy this object
###
method output {} {
my variable reply_body reply_file reply_chan chan
chan configure $chan -translation {binary binary}
set headers [my reply_headers dump]
if {[dict exists $headers Status:]} {
set result "[my EncodeStatus [dict get $headers Status:]]\n"
} else {
set result "[my EncodeStatus {505 Internal Error}]\n"
}
foreach {key value} $headers {
# Ignore Status and Content-length, if given
if {$key in {Status: Content-length:}} continue
append result "$key $value" \n
}
if {![info exists reply_file] || [string length $reply_body]} {
###
# Return dynamic content
###
set reply_body [string trim $reply_body]
append result "Content-length: [string length $reply_body]" \n \n
append result $reply_body
puts -nonewline $chan $result
} else {
###
# Return a stream of data from a file
###
append result "Content-length: [file size $reply_file]" \n \n
puts -nonewline $chan $result
set reply_chan [open $reply_file r]
chan copy $reply_chan $chan
catch {close $reply_chan}
}
chan flush $chan
my destroy
}
}
###
# Build the server
###
tool::class create scgi::test::app {
superclass ::scgi::app
property reply_class ::scgi::test::reply
}
scgi::test::app create TESTAPP port 10001
test scgi-client-0001 {Do an echo request} {
set reply [::scgi::test::send 10001 {REQUEST_METHOD POST
REQUEST_URI /echo
THIS IS MY CODE
}]
} {Status: 200 OK
Content-Type: text/plain
Connection: close
Content-length: 15
THIS IS MY CODE}
test scgi-client-0002 {Do another echo request} {
set reply [::scgi::test::send 10001 {REQUEST_METHOD POST
REQUEST_URI /echo
THOUGH THERE ARE MANY LIKE IT
}]
} {Status: 200 OK
Content-Type: text/plain
Connection: close
Content-length: 29
THOUGH THERE ARE MANY LIKE IT}
test scgi-client-0003 {Do another echo request} {
set reply [::scgi::test::send 10001 {REQUEST_METHOD POST
REQUEST_URI /echo
THIS ONE ALONE IS MINE
}]
} {Status: 200 OK
Content-Type: text/plain
Connection: close
Content-length: 22
THIS ONE ALONE IS MINE}
test scgi-client-0004 {URL Generates Error} {
set reply [::scgi::test::send 10001 {REQUEST_METHOD POST
REQUEST_URI /error
THIS ONE ALONE IS MINE
}] } {Status: 500 Server Internal Error
Content-Type: text/plain
Connection: close
Content-length: 89
500 Server Internal Error
Got the error 500 Server Internal Error
while trying to obtain}
set checkreply [subst {Status: 200 OK
Content-Type: text/plain
Connection: close
Content-length: 10
[clock seconds]}]
test scgi-client-0005 {URL Different output with a different request} {
set reply [::scgi::test::send 10001 {REQUEST_METHOD POST
REQUEST_URI /time
THIS ONE ALONE IS MINE
}] } $checkreply
set fin [open [file join $here pkgIndex.tcl] r]
set checkreply [read $fin]
close $fin
test scgi-client-0006 {Return a file} {
set reply [::scgi::test::send 10001 {REQUEST_METHOD POST
REQUEST_URI /file
}] } "Status: 200 OK
Content-Type: text/plain
Connection: close
Content-length: [string length $checkreply]
$checkreply"
# -------------------------------------------------------------------------
testsuiteCleanup
# Local variables:
# mode: tcl
# indent-tabs-mode: nil
# End:
|