Posted to tcl by patthoyts at Fri Apr 10 01:04:29 GMT 2009view raw

  1. commit 09ff76b16e1dd98fe49c5db1496538aa20de02b6
  2. Author: Pat Thoyts <patthoyts@users.sourceforge.net>
  3. Date: Fri Apr 10 01:49:10 2009 +0100
  4.  
  5. Improved HTTP/1.1 support and added specific HTTP/1.1 testing.
  6.  
  7. This patch makes use of the 8.6 zlib support to provide for
  8. deflate and gzip support and handles the -channel option with
  9. compression and chunked transfer encoding. For the -handler
  10. option we currently disable HTTP/1.1 features as we cannot
  11. properly pass the data through to the caller.
  12.  
  13. diff --git a/library/http/http.tcl b/library/http/http.tcl
  14. index 54732fd..1638109 100644
  15. --- a/library/http/http.tcl
  16. +++ b/library/http/http.tcl
  17. @@ -10,10 +10,10 @@
  18. #
  19. # RCS: @(#) $Id$
  20.  
  21. -package require Tcl 8.4
  22. +package require Tcl 8.6
  23. # Keep this in sync with pkgIndex.tcl and with the install directories in
  24. # Makefiles
  25. -package provide http 2.7.3
  26. +package provide http 2.8a1
  27.  
  28. namespace eval http {
  29. # Allow resourcing to not clobber existing data
  30. @@ -27,7 +27,13 @@ namespace eval http {
  31. -proxyfilter http::ProxyRequired
  32. -urlencoding utf-8
  33. }
  34. - set http(-useragent) "Tcl http client package [package provide http]"
  35. + # We need a useragent string of this style or various servers will refuse to
  36. + # send us compressed content even when we ask for it. This follows the
  37. + # de-facto layout of user-agent strings in current browsers.
  38. + set http(-useragent) "Mozilla/5.0\
  39. + ([string totitle $::tcl_platform(platform)]; U;\
  40. + $::tcl_platform(os) $::tcl_platform(osVersion))\
  41. + http/[package provide http] Tcl/[package provide Tcl]"
  42. }
  43.  
  44. proc init {} {
  45. @@ -94,7 +100,7 @@ namespace eval http {
  46. # Arguments:
  47. # msg Message to output
  48. #
  49. -proc http::Log {args} {}
  50. +if {[info command http::Log] eq {}} { proc http::Log {args} {} }
  51.  
  52. # http::register --
  53. #
  54. @@ -649,7 +655,11 @@ proc http::geturl {url args} {
  55. if {[info exists state(-method)] && $state(-method) ne ""} {
  56. set how $state(-method)
  57. }
  58. -
  59. + # We cannot handle chunked encodings with -handler, so force HTTP/1.0
  60. + # until we can manage this.
  61. + if {[info exists state(-handler)]} {
  62. + set state(-protocol) 1.0
  63. + }
  64. if {[catch {
  65. puts $sock "$how $srvurl HTTP/$state(-protocol)"
  66. puts $sock "Accept: $http(-accept)"
  67. @@ -693,14 +703,8 @@ proc http::geturl {url args} {
  68. puts $sock "$key: $value"
  69. }
  70. }
  71. - # Soft zlib dependency check - no package require
  72. - if {
  73. - !$accept_encoding_seen &&
  74. - ([package vsatisfies [package provide Tcl] 8.6]
  75. - || [llength [package provide zlib]]) &&
  76. - !([info exists state(-channel)] || [info exists state(-handler)])
  77. - } then {
  78. - puts $sock "Accept-Encoding: gzip, identity, *;q=0.1"
  79. + if {!$accept_encoding_seen && ![info exists state(-handler)]} {
  80. + puts $sock "Accept-Encoding: deflate,gzip,compress"
  81. }
  82. if {$isQueryChannel && $state(querylength) == 0} {
  83. # Try to determine size of data in channel. If we cannot seek, the
  84. @@ -1009,22 +1013,16 @@ proc http::Event {sock token} {
  85. # Turn off conversions for non-text data
  86. set state(binary) 1
  87. }
  88. - if {
  89. - $state(binary) || [string match *gzip* $state(coding)] ||
  90. - [string match *compress* $state(coding)]
  91. - } then {
  92. - if {[info exists state(-channel)]} {
  93. + if {[info exists state(-channel)]} {
  94. + if {$state(binary) || [llength [ContentEncoding $token]]} {
  95. fconfigure $state(-channel) -translation binary
  96. }
  97. - }
  98. - if {
  99. - [info exists state(-channel)] &&
  100. - ![info exists state(-handler)]
  101. - } then {
  102. - # Initiate a sequence of background fcopies
  103. - fileevent $sock readable {}
  104. - CopyStart $sock $token
  105. - return
  106. + if {![info exists state(-handler)]} {
  107. + # Initiate a sequence of background fcopies
  108. + fileevent $sock readable {}
  109. + CopyStart $sock $token
  110. + return
  111. + }
  112. }
  113. } elseif {$n > 0} {
  114. # Process header lines
  115. @@ -1170,14 +1168,54 @@ proc http::getTextLine {sock} {
  116. # Side Effects
  117. # This closes the connection upon error
  118.  
  119. -proc http::CopyStart {sock token} {
  120. - variable $token
  121. +proc http::CopyStart {sock token {initial 1}} {
  122. + upvar #0 $token state
  123. + if {[info exists state(transfer)] && $state(transfer) eq "chunked"} {
  124. + foreach coding [ContentEncoding $token] {
  125. + lappend state(zlib) [zlib stream $coding]
  126. + }
  127. + make-transformation-chunked $sock [namespace code [list CopyChunk $token]]
  128. + } else {
  129. + if {$initial} {
  130. + foreach coding [ContentEncoding $token] {
  131. + zlib push $coding $sock
  132. + }
  133. + }
  134. + if {[catch {
  135. + fcopy $sock $state(-channel) -size $state(-blocksize) -command \
  136. + [list http::CopyDone $token]
  137. + } err]} {
  138. + Finish $token $err
  139. + }
  140. + }
  141. +}
  142. +
  143. +proc http::CopyChunk {token chunk} {
  144. upvar 0 $token state
  145. - if {[catch {
  146. - fcopy $sock $state(-channel) -size $state(-blocksize) -command \
  147. - [list http::CopyDone $token]
  148. - } err]} then {
  149. - Finish $token $err
  150. + if {[set count [string length $chunk]]} {
  151. + incr state(currentsize) $count
  152. + if {[info exists state(zlib)]} {
  153. + foreach stream $state(zlib) {
  154. + set chunk [$stream add $chunk]
  155. + }
  156. + }
  157. + puts -nonewline $state(-channel) $chunk
  158. + if {[info exists state(-progress)]} {
  159. + eval [linsert $state(-progress) end \
  160. + $token $state(totalsize) $state(currentsize)]
  161. + }
  162. + } else {
  163. + Log "CopyChunk Finish $token"
  164. + if {[info exists state(zlib)]} {
  165. + set excess ""
  166. + foreach stream $state(zlib) {
  167. + catch {set excess [$stream add -finalize $excess]}
  168. + }
  169. + puts -nonewline $state(-channel) $excess
  170. + foreach stream $state(zlib) { $stream close }
  171. + unset state(zlib)
  172. + }
  173. + Eof $token ;# FIX ME: pipelining.
  174. }
  175. }
  176.  
  177. @@ -1207,7 +1245,7 @@ proc http::CopyDone {token count {error {}}} {
  178. } elseif {[catch {eof $sock} iseof] || $iseof} {
  179. Eof $token
  180. } else {
  181. - CopyStart $sock $token
  182. + CopyStart $sock $token 0
  183. }
  184. }
  185.  
  186. @@ -1231,34 +1269,31 @@ proc http::Eof {token {force 0}} {
  187. set state(status) ok
  188. }
  189.  
  190. - if {($state(coding) eq "gzip") && [string length $state(body)] > 0} {
  191. - if {[catch {
  192. - if {[package vsatisfies [package present Tcl] 8.6]} {
  193. - # The zlib integration into 8.6 includes proper gzip support
  194. - set state(body) [zlib gunzip $state(body)]
  195. - } else {
  196. - set state(body) [Gunzip $state(body)]
  197. + if {[string length $state(body)] > 0} {
  198. + if {[catch {
  199. + foreach coding [ContentEncoding $token] {
  200. + set state(body) [zlib $coding $state(body)]
  201. }
  202. - } err]} then {
  203. + } err]} {
  204. + Log "error doing $coding '$state(body)'"
  205. return [Finish $token $err]
  206. - }
  207. - }
  208. -
  209. - if {!$state(binary)} {
  210. - # If we are getting text, set the incoming channel's encoding
  211. - # correctly. iso8859-1 is the RFC default, but this could be any IANA
  212. - # charset. However, we only know how to convert what we have
  213. - # encodings for.
  214. -
  215. - set enc [CharsetToEncoding $state(charset)]
  216. - if {$enc ne "binary"} {
  217. - set state(body) [encoding convertfrom $enc $state(body)]
  218. - }
  219. -
  220. - # Translate text line endings.
  221. - set state(body) [string map {\r\n \n \r \n} $state(body)]
  222. + }
  223. +
  224. + if {!$state(binary)} {
  225. + # If we are getting text, set the incoming channel's encoding
  226. + # correctly. iso8859-1 is the RFC default, but this could be any IANA
  227. + # charset. However, we only know how to convert what we have
  228. + # encodings for.
  229. +
  230. + set enc [CharsetToEncoding $state(charset)]
  231. + if {$enc ne "binary"} {
  232. + set state(body) [encoding convertfrom $enc $state(body)]
  233. + }
  234. +
  235. + # Translate text line endings.
  236. + set state(body) [string map {\r\n \n \r \n} $state(body)]
  237. + }
  238. }
  239. -
  240. Finish $token
  241. }
  242.  
  243. @@ -1403,59 +1438,57 @@ proc http::CharsetToEncoding {charset} {
  244. }
  245. }
  246.  
  247. -# http::Gunzip --
  248. -#
  249. -# Decompress data transmitted using the gzip transfer coding.
  250. -#
  251. -
  252. -# FIX ME: redo using zlib sinflate
  253. -proc http::Gunzip {data} {
  254. - binary scan $data Scb5icc magic method flags time xfl os
  255. - set pos 10
  256. - if {$magic != 0x1f8b} {
  257. - return -code error "invalid data: supplied data is not in gzip format"
  258. - }
  259. - if {$method != 8} {
  260. - return -code error "invalid compression method"
  261. - }
  262. -
  263. - # lassign [split $flags ""] f_text f_crc f_extra f_name f_comment
  264. - foreach {f_text f_crc f_extra f_name f_comment} [split $flags ""] break
  265. - set extra ""
  266. - if {$f_extra} {
  267. - binary scan $data @${pos}S xlen
  268. - incr pos 2
  269. - set extra [string range $data $pos $xlen]
  270. - set pos [incr xlen]
  271. - }
  272. -
  273. - set name ""
  274. - if {$f_name} {
  275. - set ndx [string first \0 $data $pos]
  276. - set name [string range $data $pos $ndx]
  277. - set pos [incr ndx]
  278. - }
  279. -
  280. - set comment ""
  281. - if {$f_comment} {
  282. - set ndx [string first \0 $data $pos]
  283. - set comment [string range $data $pos $ndx]
  284. - set pos [incr ndx]
  285. - }
  286. -
  287. - set fcrc ""
  288. - if {$f_crc} {
  289. - set fcrc [string range $data $pos [incr pos]]
  290. - incr pos
  291. +# Return the list of content-encoding transformations we need to do in order.
  292. +proc http::ContentEncoding {token} {
  293. + upvar 0 $token state
  294. + set r {}
  295. + if {[info exists state(coding)]} {
  296. + foreach coding [split $state(coding) ,] {
  297. + switch -exact -- $coding {
  298. + deflate { lappend r inflate }
  299. + gzip - x-gzip { lappend r gunzip }
  300. + compress - x-compress { lappend r decompress }
  301. + identity {}
  302. + default {
  303. + return -code error "unsupported content-encoding \"$coding\""
  304. + }
  305. + }
  306. + }
  307. }
  308. + return $r
  309. +}
  310.  
  311. - binary scan [string range $data end-7 end] ii crc size
  312. - set inflated [zlib inflate [string range $data $pos end-8]]
  313. - set chk [zlib crc32 $inflated]
  314. - if {($crc & 0xffffffff) != ($chk & 0xffffffff)} {
  315. - return -code error "invalid data: checksum mismatch $crc != $chk"
  316. - }
  317. - return $inflated
  318. +proc http::make-transformation-chunked {chan command} {
  319. + set lambda {{chan command} {
  320. + set data ""
  321. + set size -1
  322. + yield
  323. + while {1} {
  324. + chan configure $chan -translation {crlf binary}
  325. + while {[gets $chan line] < 1} { yield }
  326. + chan configure $chan -translation {binary binary}
  327. + if {[scan $line %x size] != 1} { return -code error "invalid size: \"$line\"" }
  328. + set chunk ""
  329. + while {$size && ![chan eof $chan]} {
  330. + set part [chan read $chan $size]
  331. + incr size -[string length $part]
  332. + append chunk $part
  333. + }
  334. + if {[catch {
  335. + uplevel #0 [linsert $command end $chunk]
  336. + }]} then {
  337. + http::Log "Error in callback: $::errorInfo"
  338. + }
  339. + if {[string length $chunk] == 0} {
  340. + # channel might have been closed in the callback
  341. + catch {chan event $chan readable {}}
  342. + return
  343. + }
  344. + }
  345. + }}
  346. + coroutine dechunk$chan ::apply $lambda $chan $command
  347. + chan event $chan readable [namespace origin dechunk$chan]
  348. + return
  349. }
  350.  
  351. # Local variables:
  352. diff --git a/library/http/pkgIndex.tcl b/library/http/pkgIndex.tcl
  353. index 07724d3..1e27324 100644
  354. --- a/library/http/pkgIndex.tcl
  355. +++ b/library/http/pkgIndex.tcl
  356. @@ -1,4 +1,2 @@
  357. -# Tcl package index file, version 1.1
  358. -
  359. -if {![package vsatisfies [package provide Tcl] 8.4]} {return}
  360. -package ifneeded http 2.7.3 [list tclPkgSetup $dir http 2.7.3 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait ::http::register ::http::unregister ::http::mapReply}}}]
  361. +if {![package vsatisfies [package provide Tcl] 8.6]} {return}
  362. +package ifneeded http 2.8a1 [list tclPkgSetup $dir http 2.8a1 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait ::http::register ::http::unregister ::http::mapReply}}}]
  363. diff --git a/tests/http11.test b/tests/http11.test
  364. new file mode 100644
  365. index 0000000..66dca57
  366. --- /dev/null
  367. +++ b/tests/http11.test
  368. @@ -0,0 +1,573 @@
  369. +# http11.test -- -*- tcl-*-
  370. +
  371. +package require tcltest 2
  372. +namespace import -force ::tcltest::*
  373. +
  374. +package require http ;#2.8a0
  375. +#source http.tcl
  376. +
  377. +# start the server
  378. +variable httpd_output
  379. +proc create_httpd {} {
  380. + proc httpd_read {chan} {
  381. + variable httpd_output
  382. + if {[gets $chan line] != -1} {
  383. + #puts stderr "read '$line'"
  384. + set httpd_output $line
  385. + }
  386. + if {[eof $chan]} {
  387. + puts stderr "eof from httpd"
  388. + fileevent $chan readable {}
  389. + close $chan
  390. + }
  391. + }
  392. + variable httpd_output
  393. + set httpd_script [file join [pwd] [file dirname [info script]] httpd11.tcl]
  394. + set httpd [open "|[list [interpreter] -encoding utf-8 $httpd_script]" r+]
  395. + fconfigure $httpd -buffering line -blocking 0
  396. + fileevent $httpd readable [list httpd_read $httpd]
  397. + vwait httpd_output
  398. + variable httpd_port [lindex $httpd_output 2]
  399. + return $httpd
  400. +}
  401. +
  402. +proc halt_httpd {} {
  403. + variable httpd_output
  404. + variable httpd
  405. + if {[info exists httpd]} {
  406. + puts $httpd "quit"
  407. + vwait httpd_output
  408. + close $httpd
  409. + }
  410. + unset -nocomplain httpd_output httpd
  411. +}
  412. +
  413. +proc meta {tok {key ""}} {
  414. + set meta [http::meta $tok]
  415. + if {$key ne ""} {
  416. + if {[dict exists $meta $key]} {
  417. + return [dict get $meta $key]
  418. + } else {
  419. + return ""
  420. + }
  421. + }
  422. + return $meta
  423. +}
  424. +
  425. +proc check_crc {tok args} {
  426. + set crc [meta $tok x-crc32]
  427. + if {[llength $args]} {set data [lindex $args 0]} else {set data [http::data $tok]}
  428. + set chk [format %x [zlib crc32 $data]]
  429. + if {$crc ne $chk} {
  430. + return "crc32 mismatch: $crc ne $chk"
  431. + }
  432. + return "ok"
  433. +}
  434. +
  435. +makeFile "<html><head><title>test</title></head>\
  436. +<body><p>this is a test</p>\n\
  437. +[string repeat {<p>This is a tcl test file.</p>} 4192]\n\
  438. +</body></html>" testdoc.html
  439. +
  440. +# -------------------------------------------------------------------------
  441. +
  442. +test http-1.0 "normal request for document " -setup {
  443. + variable httpd [create_httpd]
  444. +} -body {
  445. + set tok [http::geturl http://localhost:$httpd_port/testdoc.html -timeout 10000]
  446. + http::wait $tok
  447. + list [http::status $tok] [http::code $tok] [check_crc $tok] [meta $tok connection]
  448. +} -cleanup {
  449. + http::cleanup $tok
  450. + halt_httpd
  451. +} -result {ok {HTTP/1.1 200 OK} ok close}
  452. +
  453. +test http-1.1 "normal,gzip,non-chunked" -setup {
  454. + variable httpd [create_httpd]
  455. +} -body {
  456. + set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1 \
  457. + -timeout 10000 -headers {accept-encoding gzip}]
  458. + http::wait $tok
  459. + list [http::status $tok] [http::code $tok] [check_crc $tok] \
  460. + [meta $tok content-encoding] [meta $tok transfer-encoding]
  461. +} -cleanup {
  462. + http::cleanup $tok
  463. + halt_httpd
  464. +} -result {ok {HTTP/1.1 200 OK} ok gzip {}}
  465. +
  466. +test http-1.2 "normal,deflated,non-chunked" -setup {
  467. + variable httpd [create_httpd]
  468. +} -body {
  469. + set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1 \
  470. + -timeout 10000 -headers {accept-encoding deflate}]
  471. + http::wait $tok
  472. + list [http::status $tok] [http::code $tok] [check_crc $tok] \
  473. + [meta $tok content-encoding] [meta $tok transfer-encoding]
  474. +} -cleanup {
  475. + http::cleanup $tok
  476. + halt_httpd
  477. +} -result {ok {HTTP/1.1 200 OK} ok deflate {}}
  478. +
  479. +test http-1.3 "normal,compressed,non-chunked" -setup {
  480. + variable httpd [create_httpd]
  481. +} -body {
  482. + set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1 \
  483. + -timeout 10000 -headers {accept-encoding compress}]
  484. + http::wait $tok
  485. + list [http::status $tok] [http::code $tok] [check_crc $tok] \
  486. + [meta $tok content-encoding] [meta $tok transfer-encoding]
  487. +} -cleanup {
  488. + http::cleanup $tok
  489. + halt_httpd
  490. +} -result {ok {HTTP/1.1 200 OK} ok compress {}}
  491. +
  492. +test http-1.4 "normal,identity,non-chunked" -setup {
  493. + variable httpd [create_httpd]
  494. +} -body {
  495. + set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1 \
  496. + -timeout 10000 -headers {accept-encoding identity}]
  497. + http::wait $tok
  498. + list [http::status $tok] [http::code $tok] [check_crc $tok] \
  499. + [meta $tok content-encoding] [meta $tok transfer-encoding]
  500. +} -cleanup {
  501. + http::cleanup $tok
  502. + halt_httpd
  503. +} -result {ok {HTTP/1.1 200 OK} ok {} {}}
  504. +
  505. +test http-1.5 "normal request for document, unsupported coding" -setup {
  506. + variable httpd [create_httpd]
  507. +} -body {
  508. + set tok [http::geturl http://localhost:$httpd_port/testdoc.html \
  509. + -timeout 10000 -headers {accept-encoding unsupported}]
  510. + http::wait $tok
  511. + list [http::status $tok] [http::code $tok] [check_crc $tok] \
  512. + [meta $tok content-encoding]
  513. +} -cleanup {
  514. + http::cleanup $tok
  515. + halt_httpd
  516. +} -result {ok {HTTP/1.1 200 OK} ok {}}
  517. +
  518. +test http-1.6 "normal, specify 1.1 " -setup {
  519. + variable httpd [create_httpd]
  520. +} -body {
  521. + set tok [http::geturl http://localhost:$httpd_port/testdoc.html \
  522. + -protocol 1.1 -timeout 10000]
  523. + http::wait $tok
  524. + list [http::status $tok] [http::code $tok] [check_crc $tok] \
  525. + [meta $tok connection] [meta $tok transfer-encoding]
  526. +} -cleanup {
  527. + http::cleanup $tok
  528. + halt_httpd
  529. +} -result {ok {HTTP/1.1 200 OK} ok close chunked}
  530. +
  531. +test http-1.7 "normal, 1.1 and keepalive " -setup {
  532. + variable httpd [create_httpd]
  533. +} -body {
  534. + set tok [http::geturl http://localhost:$httpd_port/testdoc.html \
  535. + -protocol 1.1 -keepalive 1 -timeout 10000]
  536. + http::wait $tok
  537. + list [http::status $tok] [http::code $tok] [check_crc $tok] \
  538. + [meta $tok connection] [meta $tok transfer-encoding]
  539. +} -cleanup {
  540. + http::cleanup $tok
  541. + halt_httpd
  542. +} -result {ok {HTTP/1.1 200 OK} ok {} chunked}
  543. +
  544. +test http-1.8 "normal, 1.1 and keepalive, server close" -setup {
  545. + variable httpd [create_httpd]
  546. +} -body {
  547. + set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1 \
  548. + -protocol 1.1 -keepalive 1 -timeout 10000]
  549. + http::wait $tok
  550. + list [http::status $tok] [http::code $tok] [check_crc $tok] \
  551. + [meta $tok connection] [meta $tok transfer-encoding]
  552. +} -cleanup {
  553. + http::cleanup $tok
  554. + halt_httpd
  555. +} -result {ok {HTTP/1.1 200 OK} ok close {}}
  556. +
  557. +test http-1.9 "normal,gzip,chunked" -setup {
  558. + variable httpd [create_httpd]
  559. +} -body {
  560. + set tok [http::geturl http://localhost:$httpd_port/testdoc.html \
  561. + -timeout 10000 -headers {accept-encoding gzip}]
  562. + http::wait $tok
  563. + list [http::status $tok] [http::code $tok] [check_crc $tok] \
  564. + [meta $tok content-encoding] [meta $tok transfer-encoding]
  565. +} -cleanup {
  566. + http::cleanup $tok
  567. + halt_httpd
  568. +} -result {ok {HTTP/1.1 200 OK} ok gzip chunked}
  569. +
  570. +test http-1.10 "normal,deflate,chunked" -setup {
  571. + variable httpd [create_httpd]
  572. +} -body {
  573. + set tok [http::geturl http://localhost:$httpd_port/testdoc.html \
  574. + -timeout 10000 -headers {accept-encoding deflate}]
  575. + http::wait $tok
  576. + list [http::status $tok] [http::code $tok] [check_crc $tok] \
  577. + [meta $tok content-encoding] [meta $tok transfer-encoding]
  578. +} -cleanup {
  579. + http::cleanup $tok
  580. + halt_httpd
  581. +} -result {ok {HTTP/1.1 200 OK} ok deflate chunked}
  582. +
  583. +test http-1.11 "normal,compress,chunked" -setup {
  584. + variable httpd [create_httpd]
  585. +} -body {
  586. + set tok [http::geturl http://localhost:$httpd_port/testdoc.html \
  587. + -timeout 10000 -headers {accept-encoding compress}]
  588. + http::wait $tok
  589. + list [http::status $tok] [http::code $tok] [check_crc $tok] \
  590. + [meta $tok content-encoding] [meta $tok transfer-encoding]
  591. +} -cleanup {
  592. + http::cleanup $tok
  593. + halt_httpd
  594. +} -result {ok {HTTP/1.1 200 OK} ok compress chunked}
  595. +
  596. +test http-1.11 "normal,identity,chunked" -setup {
  597. + variable httpd [create_httpd]
  598. +} -body {
  599. + set tok [http::geturl http://localhost:$httpd_port/testdoc.html \
  600. + -timeout 10000 -headers {accept-encoding identity}]
  601. + http::wait $tok
  602. + list [http::status $tok] [http::code $tok] [check_crc $tok] \
  603. + [meta $tok content-encoding] [meta $tok transfer-encoding]
  604. +} -cleanup {
  605. + http::cleanup $tok
  606. + halt_httpd
  607. +} -result {ok {HTTP/1.1 200 OK} ok {} chunked}
  608. +
  609. +# -------------------------------------------------------------------------
  610. +
  611. +test http-2.0 "-channel" -setup {
  612. + variable httpd [create_httpd]
  613. + set chan [open [makeFile {} testfile.tmp] wb+]
  614. +} -body {
  615. + set tok [http::geturl http://localhost:$httpd_port/testdoc.html \
  616. + -timeout 5000 -channel $chan]
  617. + http::wait $tok
  618. + seek $chan 0
  619. + set data [read $chan]
  620. + list [http::status $tok] [http::code $tok] [check_crc $tok $data]\
  621. + [meta $tok connection] [meta $tok transfer-encoding]
  622. +} -cleanup {
  623. + http::cleanup $tok
  624. + close $chan
  625. + removeFile testfile.tmp
  626. + halt_httpd
  627. +} -result {ok {HTTP/1.1 200 OK} ok close chunked}
  628. +
  629. +test http-2.1 "-channel, encoding gzip" -setup {
  630. + variable httpd [create_httpd]
  631. + set chan [open [makeFile {} testfile.tmp] wb+]
  632. +} -body {
  633. + set tok [http::geturl http://localhost:$httpd_port/testdoc.html \
  634. + -timeout 5000 -channel $chan -headers {accept-encoding gzip}]
  635. + http::wait $tok
  636. + seek $chan 0
  637. + set data [read $chan]
  638. + list [http::status $tok] [http::code $tok] [check_crc $tok $data]\
  639. + [meta $tok connection] [meta $tok content-encoding]\
  640. + [meta $tok transfer-encoding]
  641. +} -cleanup {
  642. + http::cleanup $tok
  643. + close $chan
  644. + removeFile testfile.tmp
  645. + halt_httpd
  646. +} -result {ok {HTTP/1.1 200 OK} ok close gzip chunked}
  647. +
  648. +test http-2.2 "-channel, encoding deflate" -setup {
  649. + variable httpd [create_httpd]
  650. + set chan [open [makeFile {} testfile.tmp] wb+]
  651. +} -body {
  652. + set tok [http::geturl http://localhost:$httpd_port/testdoc.html \
  653. + -timeout 5000 -channel $chan -headers {accept-encoding deflate}]
  654. + http::wait $tok
  655. + seek $chan 0
  656. + set data [read $chan]
  657. + list [http::status $tok] [http::code $tok] [check_crc $tok $data]\
  658. + [meta $tok connection] [meta $tok content-encoding]\
  659. + [meta $tok transfer-encoding]
  660. +} -cleanup {
  661. + http::cleanup $tok
  662. + close $chan
  663. + removeFile testfile.tmp
  664. + halt_httpd
  665. +} -result {ok {HTTP/1.1 200 OK} ok close deflate chunked}
  666. +
  667. +test http-2.3 "-channel,encoding compress" -setup {
  668. + variable httpd [create_httpd]
  669. + set chan [open [makeFile {} testfile.tmp] wb+]
  670. +} -body {
  671. + set tok [http::geturl http://localhost:$httpd_port/testdoc.html \
  672. + -timeout 5000 -channel $chan \
  673. + -headers {accept-encoding compress}]
  674. + http::wait $tok
  675. + seek $chan 0
  676. + set data [read $chan]
  677. + list [http::status $tok] [http::code $tok] [check_crc $tok $data]\
  678. + [meta $tok connection] [meta $tok content-encoding]\
  679. + [meta $tok transfer-encoding]
  680. +} -cleanup {
  681. + http::cleanup $tok
  682. + close $chan
  683. + removeFile testfile.tmp
  684. + halt_httpd
  685. +} -result {ok {HTTP/1.1 200 OK} ok close compress chunked}
  686. +
  687. +test http-2.4 "-channel,encoding identity" -setup {
  688. + variable httpd [create_httpd]
  689. + set chan [open [makeFile {} testfile.tmp] wb+]
  690. +} -body {
  691. + set tok [http::geturl http://localhost:$httpd_port/testdoc.html \
  692. + -timeout 5000 -channel $chan \
  693. + -headers {accept-encoding identity}]
  694. + http::wait $tok
  695. + seek $chan 0
  696. + set data [read $chan]
  697. + list [http::status $tok] [http::code $tok] [check_crc $tok $data]\
  698. + [meta $tok connection] [meta $tok content-encoding]\
  699. + [meta $tok transfer-encoding]
  700. +} -cleanup {
  701. + http::cleanup $tok
  702. + close $chan
  703. + removeFile testfile.tmp
  704. + halt_httpd
  705. +} -result {ok {HTTP/1.1 200 OK} ok close {} chunked}
  706. +
  707. +test http-2.5 "-channel,encoding unsupported" -setup {
  708. + variable httpd [create_httpd]
  709. + set chan [open [makeFile {} testfile.tmp] wb+]
  710. +} -body {
  711. + set tok [http::geturl http://localhost:$httpd_port/testdoc.html \
  712. + -timeout 5000 -channel $chan \
  713. + -headers {accept-encoding unsupported}]
  714. + http::wait $tok
  715. + seek $chan 0
  716. + set data [read $chan]
  717. + list [http::status $tok] [http::code $tok] [check_crc $tok $data]\
  718. + [meta $tok connection] [meta $tok content-encoding]\
  719. + [meta $tok transfer-encoding]
  720. +} -cleanup {
  721. + http::cleanup $tok
  722. + close $chan
  723. + removeFile testfile.tmp
  724. + halt_httpd
  725. +} -result {ok {HTTP/1.1 200 OK} ok close {} chunked}
  726. +
  727. +test http-2.6 "-channel,encoding gzip,non-chunked" -setup {
  728. + variable httpd [create_httpd]
  729. + set chan [open [makeFile {} testfile.tmp] wb+]
  730. +} -body {
  731. + set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1 \
  732. + -timeout 5000 -channel $chan -headers {accept-encoding gzip}]
  733. + http::wait $tok
  734. + seek $chan 0
  735. + set data [read $chan]
  736. + list [http::status $tok] [http::code $tok] [check_crc $tok $data]\
  737. + [meta $tok connection] [meta $tok content-encoding]\
  738. + [meta $tok transfer-encoding]\
  739. + [expr {[file size testdoc.html]-[file size testfile.tmp]}]
  740. +} -cleanup {
  741. + http::cleanup $tok
  742. + close $chan
  743. + removeFile testfile.tmp
  744. + halt_httpd
  745. +} -result {ok {HTTP/1.1 200 OK} ok close gzip {} 0}
  746. +
  747. +test http-2.7 "-channel,encoding deflate,non-chunked" -setup {
  748. + variable httpd [create_httpd]
  749. + set chan [open [makeFile {} testfile.tmp] wb+]
  750. +} -body {
  751. + set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1 \
  752. + -timeout 5000 -channel $chan -headers {accept-encoding deflate}]
  753. + http::wait $tok
  754. + seek $chan 0
  755. + set data [read $chan]
  756. + list [http::status $tok] [http::code $tok] [check_crc $tok $data]\
  757. + [meta $tok connection] [meta $tok content-encoding]\
  758. + [meta $tok transfer-encoding]\
  759. + [expr {[file size testdoc.html]-[file size testfile.tmp]}]
  760. +} -cleanup {
  761. + http::cleanup $tok
  762. + close $chan
  763. + removeFile testfile.tmp
  764. + halt_httpd
  765. +} -result {ok {HTTP/1.1 200 OK} ok close deflate {} 0}
  766. +
  767. +test http-2.8 "-channel,encoding compress,non-chunked" -setup {
  768. + variable httpd [create_httpd]
  769. + set chan [open [makeFile {} testfile.tmp] wb+]
  770. +} -body {
  771. + set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1 \
  772. + -timeout 5000 -channel $chan -headers {accept-encoding compress}]
  773. + http::wait $tok
  774. + seek $chan 0
  775. + set data [read $chan]
  776. + list [http::status $tok] [http::code $tok] [check_crc $tok $data]\
  777. + [meta $tok connection] [meta $tok content-encoding]\
  778. + [meta $tok transfer-encoding]\
  779. + [expr {[file size testdoc.html]-[file size testfile.tmp]}]
  780. +} -cleanup {
  781. + http::cleanup $tok
  782. + close $chan
  783. + removeFile testfile.tmp
  784. + halt_httpd
  785. +} -result {ok {HTTP/1.1 200 OK} ok close compress {} 0}
  786. +
  787. +test http-2.9 "-channel,encoding identity,non-chunked" -setup {
  788. + variable httpd [create_httpd]
  789. + set chan [open [makeFile {} testfile.tmp] wb+]
  790. +} -body {
  791. + set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1 \
  792. + -timeout 5000 -channel $chan -headers {accept-encoding identity}]
  793. + http::wait $tok
  794. + seek $chan 0
  795. + set data [read $chan]
  796. + list [http::status $tok] [http::code $tok] [check_crc $tok $data]\
  797. + [meta $tok connection] [meta $tok content-encoding]\
  798. + [meta $tok transfer-encoding]\
  799. + [expr {[file size testdoc.html]-[file size testfile.tmp]}]
  800. +} -cleanup {
  801. + http::cleanup $tok
  802. + close $chan
  803. + removeFile testfile.tmp
  804. + halt_httpd
  805. +} -result {ok {HTTP/1.1 200 OK} ok close {} {} 0}
  806. +
  807. +test http-2.10 "-channel,deflate,keepalive" -setup {
  808. + variable httpd [create_httpd]
  809. + set chan [open [makeFile {} testfile.tmp] wb+]
  810. +} -body {
  811. + set tok [http::geturl http://localhost:$httpd_port/testdoc.html \
  812. + -timeout 5000 -channel $chan -keepalive 1]
  813. + http::wait $tok
  814. + seek $chan 0
  815. + set data [read $chan]
  816. + list [http::status $tok] [http::code $tok] [check_crc $tok $data]\
  817. + [meta $tok connection] [meta $tok content-encoding]\
  818. + [meta $tok transfer-encoding]\
  819. + [expr {[file size testdoc.html]-[file size testfile.tmp]}]
  820. +} -cleanup {
  821. + http::cleanup $tok
  822. + close $chan
  823. + removeFile testfile.tmp
  824. + halt_httpd
  825. +} -result {ok {HTTP/1.1 200 OK} ok {} deflate chunked 0}
  826. +
  827. +test http-2.11 "-channel,identity,keepalive" -setup {
  828. + variable httpd [create_httpd]
  829. + set chan [open [makeFile {} testfile.tmp] wb+]
  830. +} -body {
  831. + set tok [http::geturl http://localhost:$httpd_port/testdoc.html \
  832. + -headers {accept-encoding identity} \
  833. + -timeout 5000 -channel $chan -keepalive 1]
  834. + http::wait $tok
  835. + seek $chan 0
  836. + set data [read $chan]
  837. + list [http::status $tok] [http::code $tok] [check_crc $tok $data]\
  838. + [meta $tok connection] [meta $tok content-encoding]\
  839. + [meta $tok transfer-encoding]
  840. +} -cleanup {
  841. + http::cleanup $tok
  842. + close $chan
  843. + removeFile testfile.tmp
  844. + halt_httpd
  845. +} -result {ok {HTTP/1.1 200 OK} ok {} {} chunked}
  846. +
  847. +# -------------------------------------------------------------------------
  848. +#
  849. +# The following tests for the -handler option will require changes in
  850. +# the future. At the moment we cannot handler chunked data with this
  851. +# option. Therefore we currently force HTTP/1.0 protocol version.
  852. +#
  853. +# Once this is solved, these tests should be fixed to assume chunked
  854. +# returns in 3.2 and 3.3 and HTTP/1.1 in all but test 3.1
  855. +
  856. +proc handler {var sock token} {
  857. + upvar #0 $var data
  858. + set chunk [read $sock]
  859. + append data $chunk
  860. + #::http::Log "handler read [string length $chunk] ([chan configure $sock -buffersize])"
  861. + if {[eof $sock]} {
  862. + #::http::Log "handler eof $sock"
  863. + chan event $sock readable {}
  864. + }
  865. +}
  866. +
  867. +test http-3.0 "-handler,close,identity" -setup {
  868. + variable httpd [create_httpd]
  869. + set testdata ""
  870. +} -body {
  871. + set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1 \
  872. + -timeout 10000 -handler [namespace code [list handler testdata]]]
  873. + http::wait $tok
  874. + list [http::status $tok] [http::code $tok] [check_crc $tok $testdata]\
  875. + [meta $tok connection] [meta $tok content-encoding] \
  876. + [meta $tok transfer-encoding] \
  877. + [expr {[file size testdoc.html]-[string length $testdata]}]
  878. +} -cleanup {
  879. + http::cleanup $tok
  880. + unset -nocomplain testdata
  881. + halt_httpd
  882. +} -result {ok {HTTP/1.0 200 OK} ok close {} {} 0}
  883. +
  884. +test http-3.1 "-handler,protocol1.0" -setup {
  885. + variable httpd [create_httpd]
  886. + set testdata ""
  887. +} -body {
  888. + set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1 \
  889. + -timeout 10000 -protocol 1.0 \
  890. + -handler [namespace code [list handler testdata]]]
  891. + http::wait $tok
  892. + list [http::status $tok] [http::code $tok] [check_crc $tok $testdata]\
  893. + [meta $tok connection] [meta $tok content-encoding] \
  894. + [meta $tok transfer-encoding] \
  895. + [expr {[file size testdoc.html]-[string length $testdata]}]
  896. +} -cleanup {
  897. + http::cleanup $tok
  898. + unset -nocomplain testdata
  899. + halt_httpd
  900. +} -result {ok {HTTP/1.0 200 OK} ok close {} {} 0}
  901. +
  902. +test http-3.2 "-handler,close,chunked" -setup {
  903. + variable httpd [create_httpd]
  904. + set testdata ""
  905. +} -body {
  906. + set tok [http::geturl http://localhost:$httpd_port/testdoc.html \
  907. + -timeout 10000 -keepalive 0 -binary 1\
  908. + -handler [namespace code [list handler testdata]]]
  909. + http::wait $tok
  910. + list [http::status $tok] [http::code $tok] [check_crc $tok $testdata]\
  911. + [meta $tok connection] [meta $tok content-encoding] \
  912. + [meta $tok transfer-encoding] \
  913. + [expr {[file size testdoc.html]-[string length $testdata]}]
  914. +} -cleanup {
  915. + http::cleanup $tok
  916. + unset -nocomplain testdata
  917. + halt_httpd
  918. +} -result {ok {HTTP/1.0 200 OK} ok close {} {} 0}
  919. +
  920. +test http-3.3 "-handler,keepalive,chunked" -setup {
  921. + variable httpd [create_httpd]
  922. + set testdata ""
  923. +} -body {
  924. + set tok [http::geturl http://localhost:$httpd_port/testdoc.html \
  925. + -timeout 10000 -keepalive 1 -binary 1\
  926. + -handler [namespace code [list handler testdata]]]
  927. + http::wait $tok
  928. + list [http::status $tok] [http::code $tok] [check_crc $tok $testdata]\
  929. + [meta $tok connection] [meta $tok content-encoding] \
  930. + [meta $tok transfer-encoding] \
  931. + [expr {[file size testdoc.html]-[string length $testdata]}]
  932. +} -cleanup {
  933. + http::cleanup $tok
  934. + unset -nocomplain testdata
  935. + halt_httpd
  936. +} -result {ok {HTTP/1.0 200 OK} ok close {} {} 0}
  937. +
  938. +# -------------------------------------------------------------------------
  939. +
  940. +unset -nocomplain httpd_port
  941. +::tcltest::cleanupTests
  942. diff --git a/tests/httpd11.tcl b/tests/httpd11.tcl
  943. new file mode 100644
  944. index 0000000..09630e1
  945. --- /dev/null
  946. +++ b/tests/httpd11.tcl
  947. @@ -0,0 +1,221 @@
  948. +# httpd11.tcl -- -*- tcl -*-
  949. +#
  950. +# A simple httpd for testing HTTP/1.1 client features.
  951. +# Not suitable for use on a internet connected port.
  952. +#
  953. +
  954. +package require Tcl 8.6
  955. +
  956. +proc ::tcl::dict::get? {dict key} {
  957. + if {[dict exists $dict $key]} {
  958. + return [dict get $dict $key]
  959. + }
  960. + return
  961. +}
  962. +namespace ensemble configure dict \
  963. + -map [linsert [namespace ensemble configure dict -map] end get? ::tcl::dict::get?]
  964. +
  965. +proc make-chunk-generator {data {size 4096}} {
  966. + variable _chunk_gen_uid
  967. + if {![info exists _chunk_gen_uid]} {set _chunk_gen_uid 0}
  968. + set lambda {{data size} {
  969. + set pos 0
  970. + yield
  971. + while {1} {
  972. + set payload [string range $data $pos [expr {$pos + $size - 1}]]
  973. + incr pos $size
  974. + set chunk [format %x [string length $payload]]\r\n$payload\r\n
  975. + yield $chunk
  976. + if {![string length $payload]} {return}
  977. + }
  978. + }}
  979. + set name chunker[incr _chunk_gen_uid]
  980. + coroutine $name ::apply $lambda $data $size
  981. + return $name
  982. +}
  983. +
  984. +proc get-chunks {data {compression gzip}} {
  985. + switch -exact -- $compression {
  986. + gzip { set data [zlib gzip $data] }
  987. + deflate { set data [zlib deflate $data] }
  988. + compress { set data [zlib compress $data] }
  989. + }
  990. +
  991. + set data ""
  992. + set chunker [make-chunk-generator $data 512]
  993. + while {[string length [set chunk [$chunker]]]} {
  994. + append data $chunk
  995. + }
  996. + return $data
  997. +}
  998. +
  999. +proc blow-chunks {data {ochan stdout} {compression gzip}} {
  1000. + switch -exact -- $compression {
  1001. + gzip { set data [zlib gzip $data] }
  1002. + deflate { set data [zlib deflate $data] }
  1003. + compress { set data [zlib compress $data] }
  1004. + }
  1005. +
  1006. + set chunker [make-chunk-generator $data 512]
  1007. + while {[string length [set chunk [$chunker]]]} {
  1008. + puts -nonewline $ochan $chunk
  1009. + }
  1010. + return
  1011. +}
  1012. +
  1013. +proc mime-type {filename} {
  1014. + switch -exact -- [file extension $filename] {
  1015. + .htm - .html { return {text text/html}}
  1016. + .png { return {binary image/png} }
  1017. + .jpg { return {binary image/jpeg} }
  1018. + .gif { return {binary image/gif} }
  1019. + .css { return {text text/css} }
  1020. + .xml { return {text text/xml} }
  1021. + .xhtml {return {text application/xml+html} }
  1022. + .svg { return {text image/svg+xml} }
  1023. + .txt - .tcl - .c - .h { return {text text/plain}}
  1024. + }
  1025. + return {binary text/plain}
  1026. +}
  1027. +
  1028. +proc Puts {chan s} {puts $chan $s; puts $s}
  1029. +
  1030. +proc Service {chan addr port} {
  1031. + chan event $chan readable [info coroutine]
  1032. + while {1} {
  1033. + set meta {}
  1034. + chan configure $chan -buffering line -encoding iso8859-1 -translation crlf
  1035. + yield
  1036. + while {[gets $chan line] < 0} {
  1037. + if {[eof $chan]} {chan event $chan readable {}; close $chan; return}
  1038. + yield
  1039. + }
  1040. + if {[eof $chan]} {chan event $chan readable {}; close $chan; return}
  1041. + foreach {req url protocol} {GET {} HTTP/1.1} break
  1042. + regexp {^(\S+)\s+(.*)\s(\S+)?$} $line -> req url protocol
  1043. +
  1044. + puts $line
  1045. + while {[gets $chan line] > 0} {
  1046. + if {[regexp {^([^:]+):(.*)$} $line -> key val]} {
  1047. + #puts "$key $val"
  1048. + lappend meta [string tolower $key] [string trim $val]
  1049. + }
  1050. + yield
  1051. + }
  1052. +
  1053. + if {[scan $url {%[^?]?%s} path query] < 2} {
  1054. + set query ""
  1055. + }
  1056. +
  1057. + set encoding identity
  1058. + set transfer ""
  1059. + set close 1
  1060. + set type text/html
  1061. + set code "404 Not Found"
  1062. + set data "<html><head><title>Error 404</title></head>"
  1063. + append data "<body><h1>Not Found</h1><p>Try again.</p></body></html>"
  1064. +
  1065. + set path [string trimleft $path /]
  1066. + set path [file join [pwd] $path]
  1067. + if {[file exists $path] && [file isfile $path]} {
  1068. + foreach {what type} [mime-type $path] break
  1069. + set f [open $path r]
  1070. + if {$what eq "binary"} {chan configure $f -translation binary}
  1071. + set data [read $f]
  1072. + close $f
  1073. + set code "200 OK"
  1074. + set close [expr {[dict get? $meta connection] eq "close"}]
  1075. + }
  1076. +
  1077. + if {$protocol eq "HTTP/1.1"} {
  1078. + if {[string match "*deflate*" [dict get? $meta accept-encoding]]} {
  1079. + set encoding deflate
  1080. + } elseif {[string match "*gzip*" [dict get? $meta accept-encoding]]} {
  1081. + set encoding gzip
  1082. + } elseif {[string match "*compress*" [dict get? $meta accept-encoding]]} {
  1083. + set encoding compress
  1084. + }
  1085. + set transfer chunked
  1086. + } else {
  1087. + set close 1
  1088. + }
  1089. +
  1090. + foreach pair [split $query &] {
  1091. + if {[scan $pair {%[^=]=%s} key val] != 2} {set val ""}
  1092. + switch -exact -- $key {
  1093. + close {set close 1 ; set transfer 0}
  1094. + transfer {set transfer $val}
  1095. + content-type {set type $val}
  1096. + }
  1097. + }
  1098. +
  1099. + chan configure $chan -translation crlf
  1100. + Puts $chan "$protocol $code"
  1101. + Puts $chan "content-type: $type"
  1102. + Puts $chan [format "x-crc32: %x" [zlib crc32 $data]]
  1103. + if {$close} {
  1104. + Puts $chan "connection: close"
  1105. + }
  1106. + if {$encoding eq "identity"} {
  1107. + Puts $chan "content-length: [string length $data]"
  1108. + } else {
  1109. + Puts $chan "content-encoding: $encoding"
  1110. + }
  1111. + if {$transfer eq "chunked"} {
  1112. + Puts $chan "transfer-encoding: chunked"
  1113. + }
  1114. + puts $chan ""
  1115. + flush $chan
  1116. +
  1117. + chan configure $chan -translation binary
  1118. + if {$transfer eq "chunked"} {
  1119. + blow-chunks $data $chan $encoding
  1120. + } elseif {$encoding ne "identity"} {
  1121. + puts -nonewline $chan [zlib $encoding $data]
  1122. + } else {
  1123. + puts -nonewline $chan $data
  1124. + }
  1125. +
  1126. + if {$close} {
  1127. + chan event $chan readable {}
  1128. + close $chan
  1129. + puts "close $chan"
  1130. + return
  1131. + } else {
  1132. + flush $chan
  1133. + }
  1134. + puts "pipeline $chan"
  1135. + }
  1136. +}
  1137. +
  1138. +proc Accept {chan addr port} {
  1139. + coroutine client$chan Service $chan $addr $port
  1140. + return
  1141. +}
  1142. +
  1143. +proc Control {chan} {
  1144. + if {[gets $chan line] != -1} {
  1145. + if {[string trim $line] eq "quit"} {
  1146. + set ::forever 1
  1147. + }
  1148. + }
  1149. + if {[eof $chan]} {
  1150. + chan event $chan readable {}
  1151. + }
  1152. +}
  1153. +
  1154. +proc Main {{port 0}} {
  1155. + set server [socket -server Accept -myaddr localhost $port]
  1156. + puts [chan configure $server -sockname]
  1157. + flush stdout
  1158. + chan event stdin readable [list Control stdin]
  1159. + vwait ::forever
  1160. + close $server
  1161. + return "done"
  1162. +}
  1163. +
  1164. +if {!$tcl_interactive} {
  1165. + set r [catch [linsert $argv 0 Main] err]
  1166. + if {$r} {puts stderr $errorInfo} elseif {[string length $err]} {puts $err}
  1167. + exit $r
  1168. +}