Non-blocking name resolution

# 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

# -------------------------------------------------------------------------