1# ident.tcl --
2#
3#	Implemetation of the client side of the ident protocol.
4#	See RFC 1413 for details on the protocol.
5#
6# Copyright (c) 2004 Reinhard Max <max@tclers.tk>
7#
8# -------------------------------------------------------------------------
9# This software is distributed in the hope that it will be useful, but
10# WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
11# or FITNESS FOR A PARTICULAR PURPOSE.  See the file 'license.terms' for
12# more details.
13# -------------------------------------------------------------------------
14# RCS: @(#) $Id: ident.tcl,v 1.2 2004/07/12 14:01:04 patthoyts Exp $
15
16package provide ident 0.42
17
18namespace eval ident {
19    namespace export query configure
20}
21
22proc ident::parse {string} {
23
24    # remove all white space for easier parsing
25    regsub -all {\s} $string "" s
26    if {[regexp {^\d+,\d+:(\w+):(.*)} $s -> resptype addinfo]} {
27	switch -exact -- $resptype {
28	    USERID {
29		if { [regexp {^([^,]+)(,([^:]+))?:} \
30			  $addinfo -> opsys . charset]
31		 } then {
32		    # get the user-if from the original string, because it
33		    # is allowed to contain white space.
34		    set index [string last : $string]
35		    incr index
36		    set userid [string range $string $index end]
37		    if {$charset != ""} {
38			set (user-id) \
39			    [encoding convertfrom $charset $userid]
40		    }
41		    set answer [list resp-type USERID opsys $opsys \
42				    user-id $userid]
43		}
44	    }
45	    ERROR {
46		set answer [list resp-type ERROR error $addinfo]
47	    }
48	}
49    }
50    if {![info exists answer]} {
51	set answer [list resp-type FATAL \
52			error "Unexpected response:\"$string\""]
53    }
54    return $answer
55}
56
57proc ident::Callback {sock command} {
58    gets $sock answer
59    close $sock
60    lappend command [parse $answer]
61    eval $command
62}
63
64proc ident::query {socket {command {}}} {
65
66    foreach {sock_ip sock_host sock_port} [fconfigure $socket -sockname] break
67    foreach {peer_ip peer_host peer_port} [fconfigure $socket -peername] break
68
69    set blocking [string equal $command ""]
70    set failed [catch {socket $peer_ip ident} sock]
71    if {$failed} {
72	set result [list resp-type FATAL error $sock]
73	if {$blocking} {
74	    return $result
75	} else {
76	    after idle [list $command $result]
77	    return
78	}
79    }
80    fconfigure $sock -encoding binary -buffering line -blocking $blocking
81    puts $sock "$peer_port,$sock_port"
82    if {$blocking} {
83	gets $sock answer
84	close $sock
85	return [parse $answer]
86    } else {
87	fileevent $sock readable \
88	    [namespace code [list Callback $sock $command]]
89    }
90}
91