Posted to tcl by patthoyts at Sun Feb 24 22:43:47 GMT 2008view raw
- # resolver.tcl - Copyright (C) 2004 Pat Thoyts <patthoyts@users.sf.net>
- #
- # This package performs hostname resolution using a child process
- # to perform the name lookup to avoid blocking the Tcl process
- # during the blocking gethostbyname() C library function.
- #
- # Usage is a bit like the http package. You are responsible for
- # calling 'cleanup' on the token once you have finished.
- #
- # -------------------------------------------------------------------------
- # See the file "license.terms" for information on usage and redistribution
- # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
- # -------------------------------------------------------------------------
- # $Id: resolver.tcl,v 1.1 2004/08/26 09:47:49 pat Exp $
- namespace eval ::resolver {
- variable version 1.1.0
- variable uid; if {![info exists uid]} { set uid 0 }
- variable pipe; if {![info exists pipe]} { set pipe {} }
- variable queue; if {![info exists queue]} { set queue {} }
- variable waiting; if {![info exists waiting]} { set waiting {} }
- namespace export gethostbyname result wait cleanup
- }
- # -------------------------------------------------------------------------
- proc ::resolver::gethostbyname {host args} {
- variable uid
- set token [namespace current]::[incr uid]
- upvar #0 $token state
- array set state [list state waiting host $host -command {} -timeout {}]
- while {[string match -* [set option [lindex $args 0]]]} {
- switch -exact -- $option {
- -command { set state(-command) [Pop args 1] }
- -timeout { set state(-timeout) [Pop args 1] }
- -- { Pop args ; break }
- default {
- set erropts [join [array names state -*] ", "]
- return -code error "invalid option \"$option\":\
- must be one of $erropts"
- }
- }
- Pop args
- }
- if {$state(-timeout) ne {}} {
- set state(afterid) [after $state(-timeout)\
- [list set $token\(state\) timeout]]
- }
- Queue $token
- return $token
- }
- proc ::resolver::status {token} {
- upvar #0 $token state
- return $state(state)
- }
- proc ::resolver::error {token} {
- upvar #0 $token state
- set result ""
- if {$state(state) eq "error" } {
- set result $state(result)
- } elseif {$state(state) eq "timeout"} {
- set result "name lookup for \"$state(host)\" timed out"
- }
- return $result
- }
- proc ::resolver::query {token} {
- upvar #0 $token state
- return $state(host)
- }
- proc ::resolver::result {token} {
- upvar #0 $token state
- if {$state(state) eq "ok"} {
- return $state(result)
- }
- return ""
- }
- proc ::resolver::wait {token} {
- upvar #0 $token state
- if {$state eq "waiting"} {
- ::vwait $token\(state\)
- }
- }
- proc ::resolver::cleanup {token} {
- upvar #0 $token state
- unset -nocomplain state
- }
- # -------------------------------------------------------------------------
- proc ::resolver::Init {} {
- set cmd [auto_execok tcl_resolv]
- variable pipe [open |$cmd w+]
- puts stderr "opened new pipe '$pipe'"
- fconfigure $pipe -blocking 0 -buffering line -encoding utf-8
- fileevent $pipe readable [list [namespace origin Read] $pipe]
- variable queue
- if {[llength $queue] > 0} {
- fileevent $pipe writable [namespace code [list Write $pipe]]
- }
- }
- proc ::resolver::Queue {token} {
- variable pipe
- variable queue
- if {$pipe eq {}} { Init }
- lappend queue $token
- fileevent $pipe writable [list [namespace origin Write] $pipe]
- }
- proc ::resolver::Read {chan} {
- variable pipe
- variable waiting
- if {[gets $chan line] > 0} {
- #puts stderr "read: '$line'"
- set token [lindex $waiting 0]
- set waiting [lrange $waiting 1 end]
- if {$token ne {}} {
- upvar #0 $token state
- if {[info exists state(afterid)]} { after cancel $state(afterid) }
- set state(result) [string trim $line]
- set code ok
- if {[string match "error:*" $line]} { set code error }
- set state(state) $code
- if {$state(-command) ne {}} {
- if {[catch {uplevel \#0 $state(-command) [list $token]} err]} {
- puts stderr "callback failed: $err"
- }
- }
- } else {
- puts stderr "error: got token '$token' for '$line'"
- }
- }
- if {[eof $chan]} {
- puts stderr "eof on $chan"
- fileevent $chan readable {}
- close $chan
- set pipe {}
- }
- }
- proc ::resolver::Write {host} {
- variable pipe
- variable queue
- variable waiting
- fileevent $pipe writable {}
- foreach token $queue {
- upvar #0 $token state
- set state(channel) $pipe
- puts $pipe $state(host)
- #puts stderr "wrote: $state(host)"
- lappend waiting $token
- }
- set queue {}
- flush $pipe
- }
- proc ::resolver::Shutdown {} {
- variable pipe
- if {[catch {close $pipe} msg]} {
- puts stderr "closing pipe: '$msg'"
- }
- set pipe {}
- }
- proc ::resolver::Pop {varname {nth 0}} {
- upvar $varname args
- set r [lindex $args $nth]
- set args [lreplace $args $nth $nth]
- return $r
- }
- # -------------------------------------------------------------------------
- package provide resolver $::resolver::version
- # -------------------------------------------------------------------------