#
# $Source: /home/nlfm/Working/Zircon/Released/lib/RCS/SOCKS.tcl,v $
# $Date: 2000/07/17 12:37:15 $
# $Revision: 1.18.1.5 $
#
# ----------------------------------------------------------------------
#   AUTHOR:  Lindsay Marshall <lindsay.marshall@newcastle.ac.uk>
# ----------------------------------------------------------------------
# Copyright 2000 The University of Newcastle upon Tyne (see COPYRIGHT)
# ======================================================================
#
#
package provide zircon 1.18
#

switch -glob [info tclversion] {[1234567].*} {
#
proc usesocks {args} {
    puts stderr "Sorry, but to use SOCKS you must upgrade to tcl/tk 8.0"
    exit 1
}
} default {
#
proc usesocks {host args} {
    global currentNet
    switch {} $args { set p 1080} default {
	set p [lindex $args 0]
    }
    $currentNet configure -sockshost $host -socksport $p -sockcmd SOCKSet
}
#
proc SOCKSet {args} {
    switch -- -async [lindex $args 0] {
        set async 1
        set host [lindex $args 1]
	set port [lindex $args 2]
    } -server {
        error "Sorry. You cannot do this behind a SOCKS firewall."
    } default {
        set async 0
        set host [lindex $args 0]
	set port [lindex $args 1]
    }
    global currentNet SOCKSwait
    if {[set match [scan $host "%d.%d.%d.%d" a b c d]] != 4} {
        error "SOCKS: Host must be IP address, not name : $host"
    }
    upvar #0 $currentNet ndata

    set sk [socket $ndata(sockshost) $ndata(socksport)]
    puts -nonewline $sk [binary format "ccScccca*c" 4 1 $port $a $b $c $d [username] 0]
    flush $sk
    
    if {$async} {
        fileevent $sk readable "SOCKSreply $sk"
        set SOCKSwait($sk) 0
        vwait SOCKSwait($sk)
    } {
	SOCKSreply $sk
    }
    switch 90 [set r $SOCKSwait($sk)] {
        unset SOCKSwait($sk)
        return $sk
    }
    unset SOCKSwait($sk)
    error "SOCKS Request failed : code $r"
}
#
proc SOCKSreply {sk} {
    global SOCKSwait
    if {[binary scan [read $sk 8] "ccSI" v r port ip] < 4} {
        error "SOCKS reply not in expected format."
    }
    set SOCKSwait($sk) $r
}
#
}
