Posted to tcl by patthoyts at Sun Feb 24 22:43:47 GMT 2008view raw

  1. # resolver.tcl - Copyright (C) 2004 Pat Thoyts <patthoyts@users.sf.net>
  2. #
  3. # This package performs hostname resolution using a child process
  4. # to perform the name lookup to avoid blocking the Tcl process
  5. # during the blocking gethostbyname() C library function.
  6. #
  7. # Usage is a bit like the http package. You are responsible for
  8. # calling 'cleanup' on the token once you have finished.
  9. #
  10. # -------------------------------------------------------------------------
  11. # See the file "license.terms" for information on usage and redistribution
  12. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  13. # -------------------------------------------------------------------------
  14. # $Id: resolver.tcl,v 1.1 2004/08/26 09:47:49 pat Exp $
  15.  
  16. namespace eval ::resolver {
  17. variable version 1.1.0
  18. variable uid; if {![info exists uid]} { set uid 0 }
  19. variable pipe; if {![info exists pipe]} { set pipe {} }
  20. variable queue; if {![info exists queue]} { set queue {} }
  21. variable waiting; if {![info exists waiting]} { set waiting {} }
  22.  
  23. namespace export gethostbyname result wait cleanup
  24. }
  25.  
  26. # -------------------------------------------------------------------------
  27.  
  28. proc ::resolver::gethostbyname {host args} {
  29. variable uid
  30. set token [namespace current]::[incr uid]
  31. upvar #0 $token state
  32. array set state [list state waiting host $host -command {} -timeout {}]
  33. while {[string match -* [set option [lindex $args 0]]]} {
  34. switch -exact -- $option {
  35. -command { set state(-command) [Pop args 1] }
  36. -timeout { set state(-timeout) [Pop args 1] }
  37. -- { Pop args ; break }
  38. default {
  39. set erropts [join [array names state -*] ", "]
  40. return -code error "invalid option \"$option\":\
  41. must be one of $erropts"
  42. }
  43. }
  44. Pop args
  45. }
  46.  
  47. if {$state(-timeout) ne {}} {
  48. set state(afterid) [after $state(-timeout)\
  49. [list set $token\(state\) timeout]]
  50. }
  51. Queue $token
  52. return $token
  53. }
  54.  
  55. proc ::resolver::status {token} {
  56. upvar #0 $token state
  57. return $state(state)
  58. }
  59.  
  60. proc ::resolver::error {token} {
  61. upvar #0 $token state
  62. set result ""
  63. if {$state(state) eq "error" } {
  64. set result $state(result)
  65. } elseif {$state(state) eq "timeout"} {
  66. set result "name lookup for \"$state(host)\" timed out"
  67. }
  68. return $result
  69. }
  70.  
  71. proc ::resolver::query {token} {
  72. upvar #0 $token state
  73. return $state(host)
  74. }
  75.  
  76. proc ::resolver::result {token} {
  77. upvar #0 $token state
  78. if {$state(state) eq "ok"} {
  79. return $state(result)
  80. }
  81. return ""
  82. }
  83.  
  84. proc ::resolver::wait {token} {
  85. upvar #0 $token state
  86. if {$state eq "waiting"} {
  87. ::vwait $token\(state\)
  88. }
  89. }
  90.  
  91. proc ::resolver::cleanup {token} {
  92. upvar #0 $token state
  93. unset -nocomplain state
  94. }
  95.  
  96. # -------------------------------------------------------------------------
  97.  
  98. proc ::resolver::Init {} {
  99. set cmd [auto_execok tcl_resolv]
  100. variable pipe [open |$cmd w+]
  101. puts stderr "opened new pipe '$pipe'"
  102. fconfigure $pipe -blocking 0 -buffering line -encoding utf-8
  103. fileevent $pipe readable [list [namespace origin Read] $pipe]
  104. variable queue
  105. if {[llength $queue] > 0} {
  106. fileevent $pipe writable [namespace code [list Write $pipe]]
  107. }
  108. }
  109.  
  110. proc ::resolver::Queue {token} {
  111. variable pipe
  112. variable queue
  113. if {$pipe eq {}} { Init }
  114. lappend queue $token
  115. fileevent $pipe writable [list [namespace origin Write] $pipe]
  116. }
  117.  
  118. proc ::resolver::Read {chan} {
  119. variable pipe
  120. variable waiting
  121. if {[gets $chan line] > 0} {
  122. #puts stderr "read: '$line'"
  123. set token [lindex $waiting 0]
  124. set waiting [lrange $waiting 1 end]
  125. if {$token ne {}} {
  126. upvar #0 $token state
  127. if {[info exists state(afterid)]} { after cancel $state(afterid) }
  128. set state(result) [string trim $line]
  129. set code ok
  130. if {[string match "error:*" $line]} { set code error }
  131. set state(state) $code
  132. if {$state(-command) ne {}} {
  133. if {[catch {uplevel \#0 $state(-command) [list $token]} err]} {
  134. puts stderr "callback failed: $err"
  135. }
  136. }
  137. } else {
  138. puts stderr "error: got token '$token' for '$line'"
  139. }
  140. }
  141. if {[eof $chan]} {
  142. puts stderr "eof on $chan"
  143. fileevent $chan readable {}
  144. close $chan
  145. set pipe {}
  146. }
  147. }
  148.  
  149. proc ::resolver::Write {host} {
  150. variable pipe
  151. variable queue
  152. variable waiting
  153. fileevent $pipe writable {}
  154. foreach token $queue {
  155. upvar #0 $token state
  156. set state(channel) $pipe
  157. puts $pipe $state(host)
  158. #puts stderr "wrote: $state(host)"
  159. lappend waiting $token
  160. }
  161. set queue {}
  162. flush $pipe
  163. }
  164.  
  165. proc ::resolver::Shutdown {} {
  166. variable pipe
  167. if {[catch {close $pipe} msg]} {
  168. puts stderr "closing pipe: '$msg'"
  169. }
  170. set pipe {}
  171. }
  172.  
  173. proc ::resolver::Pop {varname {nth 0}} {
  174. upvar $varname args
  175. set r [lindex $args $nth]
  176. set args [lreplace $args $nth $nth]
  177. return $r
  178. }
  179.  
  180. # -------------------------------------------------------------------------
  181.  
  182. package provide resolver $::resolver::version
  183.  
  184. # -------------------------------------------------------------------------
  185.