home *** CD-ROM | disk | FTP | other *** search
/ Internet Tools (CDV) / cdv_internet_tools.iso / KATALOG / ARCHIV / PROG / W21452.ZIP / dustmote.tcl next >
Encoding:
Text File  |  1999-02-03  |  2.9 KB  |  142 lines
  1. set root     d:/mytcls/webpages
  2. set default  index.htm
  3. set port     80
  4.  
  5.  
  6.  
  7.  
  8. set peerCount 0
  9.  
  10.  
  11.  
  12.  
  13. proc peer {socketChannel} {
  14. global peerCount
  15.  
  16. set info [fconfigure $socketChannel -peername]
  17. set peerName [lindex $info 1]
  18. incr peerCount
  19. set when [clock format [clock seconds] ]
  20. puts stdout "$peerCount  $peerName  $when"
  21. }
  22.  
  23.  
  24.  
  25.  
  26. set mimeType(htm)  text/html
  27. set mimeType(html) text/html
  28. set mimeType(gif)  image/gif
  29. set mimeType(jpg)  image/jpeg
  30. set mimeType(jpe)  image/jpeg
  31. set mimeType(jpeg) image/jpeg
  32. set mimeType(txt)  text/plain
  33. set mimeType(text) text/plain
  34. set mimeType(tru)  text/plain
  35. set mimeType(tcl)  text/plain
  36.  
  37.  
  38.  
  39.  
  40. proc mime {name channel} {
  41. global mimeType
  42.  
  43. set wordList [split $name .]
  44. set ell [llength $wordList]
  45. set suffix [lindex $wordList [expr $ell-1] ]
  46. set suffix [string tolower $suffix]
  47.  
  48. if { [info exists mimeType($suffix)] } then {
  49. puts $channel "Content-type: $mimeType($suffix)"
  50. } elseif { [string length $suffix]==1 } then {
  51. puts $channel "Content-type: text/plain"
  52. } else {
  53. puts $channel "Content-type: application/$suffix"
  54. }
  55.  
  56. }
  57.  
  58.  
  59.  
  60.  
  61. proc bgerror {trouble} {puts stdout "bgerror: $trouble"}
  62.  
  63.  
  64.  
  65.  
  66. proc answer {socketChannel host2 port2} {
  67. global gotLine
  68.  
  69. peer $socketChannel
  70.  
  71. if { [info exists gotLine($socketChannel)] } then {
  72. unset gotLine($socketChannel)
  73. }
  74.  
  75. fconfigure $socketChannel -buffering line -blocking 0
  76. fileevent $socketChannel readable [list readIt $socketChannel]
  77. }
  78.  
  79.  
  80.  
  81.  
  82. proc readIt {socketChannel} {
  83. global gotLine
  84.  
  85. gets $socketChannel line
  86. if { [fblocked $socketChannel] } then {return}
  87.  
  88. if {[eof $socketChannel] || $line=="" } then {
  89. fileevent $socketChannel readable ""
  90. writeIt $socketChannel
  91. } else {
  92. puts stdout "          $line"
  93.  
  94. if {![info exists gotLine($socketChannel)]} then {
  95. set gotLine($socketChannel) $line
  96. }
  97.  
  98. }
  99.  
  100. }
  101.  
  102.  
  103.  
  104.  
  105. proc writeIt {socketChannel} {
  106. global root default gotLine
  107.  
  108. set shortName "/"
  109. regexp {/[^ ]*} $gotLine($socketChannel) shortName
  110. set many [string length $shortName]
  111. set last [string index $shortName [expr $many-1] ]
  112. if {$last=="/"} then {set shortName $shortName$default }
  113. set wholeName $root$shortName
  114.  
  115. if [catch {set fileChannel [open $wholeName RDONLY] } ] then {
  116. puts $socketChannel "HTTP/0.9 404 Not found"
  117. puts $socketChannel "Content-type: text/html"
  118. puts $socketChannel ""
  119. puts $socketChannel "<html><head><title><No such URL.></title></head>"
  120. puts $socketChannel "<body><center>"
  121. puts $socketChannel "The URL you requested does not exist on this site."
  122. puts $socketChannel "</center></body></html>"
  123. } else {
  124. fconfigure $fileChannel -translation binary
  125. fconfigure $socketChannel -translation binary -buffering full
  126. puts $socketChannel "HTTP/0.9 200 OK"
  127. mime $shortName $socketChannel
  128. puts $socketChannel ""
  129. set work [read $fileChannel]
  130. puts -nonewline $socketChannel $work
  131. close $fileChannel
  132. }
  133.  
  134. close $socketChannel
  135. }
  136.  
  137.  
  138.  
  139.  
  140. socket -server answer $port
  141. # vwait forEver
  142.