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