Posted to tcl by mjanssen at Mon Jul 02 16:16:39 GMT 2007view raw

  1. package require html
  2.  
  3. namespace eval scgi {
  4. proc listen {port} {
  5. socket -server [namespace code connect] $port
  6. }
  7.  
  8. proc connect {sock ip port} {
  9. fconfigure $sock -blocking 0 -translation {binary crlf}
  10. fileevent $sock readable [namespace code [list read_length $sock]]
  11. }
  12.  
  13. proc read_length {sock} {
  14. set length {}
  15. while 1 {
  16. set c [read $sock 1]
  17. if {[eof $sock]} {
  18. close $sock
  19. return
  20. }
  21. if {$c eq ":"} {
  22. fileevent $sock readable [namespace code [list read_headers $sock $length {}]]
  23. return
  24. }
  25. append length $c
  26. }
  27. }
  28. proc read_headers {sock length read_data} {
  29. append read_data [read $sock]
  30.  
  31. # do we have enough data for the headers yet?
  32. if {[string length $read_data] < $length+1} {
  33. fileevent $sock readable [namespace code [list read_headers $sock $length $read_data]]
  34. return
  35. } else {
  36. set headers [string range $read_data 0 $length-1]
  37. set headers [lrange [split $headers \0] 0 end-1]
  38. set body [string range $read_data $length+1 end]
  39. set content_length [dict get $headers CONTENT_LENGTH]
  40. if {[string length $body] < $content_length} {
  41. fileevent $sock readable [namespace code [list read_body $sock $headers $content_length $body]]
  42. return
  43. } else {
  44. handle_request $sock $headers $body
  45. }
  46. }
  47. }
  48.  
  49. proc read_body {sock headers content_length body} {
  50. append body [read $sock]
  51. if {[string length $body] < $content_length} {
  52. fileevent $sock readable [namespace code [list read_body $sock $headers $content_length $body]]
  53. return
  54. } else {
  55. handle_request $sock $headers $body
  56. }
  57.  
  58. }
  59.  
  60. proc handle_request {sock headers body} {
  61. array set Headers $headers
  62.  
  63. parray Headers
  64. puts $sock "Status: 200 OK"
  65. puts $sock "Content-Type: text/html"
  66. puts $sock ""
  67. puts $sock "<HTML>"
  68. puts $sock "<BODY>"
  69. puts $sock [::html::tableFromArray Headers]
  70. puts $sock "</BODY>"
  71. puts $sock "<H3>Body</H3>"
  72. puts $sock "<PRE>$body</PRE>"
  73. puts $sock {<FORM METHOD="post" ACTION="/scgi">}
  74. foreach pair [split [dict get $headers QUERY_STRING] &] {
  75. lassign [split $pair =] key val
  76. puts $sock "$key: [::html::textInput $key $val]<BR>"
  77. }
  78.  
  79. puts $sock "<BR>"
  80. puts $sock {<INPUT TYPE="submit" VALUE="Try with post">}
  81. puts $sock "</FORM>"
  82. puts $sock "</HTML>"
  83. close $sock
  84. }
  85. }
  86.  
  87. scgi::listen 9999
  88. vwait forever