[tcltk]安全的socket发送示例

引自：http://www.unix-center.net/bbs/viewthread.php?tid=19079

 

[tcltk]安全的socket发送示例

作为server端的socket，在读取client连接时， 可以通过eof和catch {gets ... }来验证连接的可靠性。但是发送的时候，却很难仅仅依赖自身的信息来确定连接的状态，这一点无论在server还是client端都是一样的。我们可以举 个例子：

[server_for_test.tcl]

set server [socket -server onConnection 8808]
array set cli_arr {}

proc onConnection {s addr port} {
    global cli_arr
    set cli_arr($s) [list $addr $port]

    fileevent $s r [list log $s]
}

proc log {s} {
    if {![eof $s] && ![catch {gets $s buf}]} {
        # puts $buf
    }
}

after 500 {
    puts {server closed!}
    close $server
    foreach s [array names cli_arr] {
        puts "$s closed"
        close $s
    }
}

vwait forever

[client_for_test.tcl]

set s [socket 127.0.0.1 8808]

after 1500 {
    if [eof $s] {
        puts "eof"
    } elseif {[catch {puts $s ok} err]} {
        puts $err
    } else {
        puts {message has been sent.}
    }
}

vwait forever

使用上一篇《[tcltk]Socket编程的测试》 中 介绍的测试脚本进行测试。server里的socket服务器在建立之后的0.5秒时将被关闭，而在client将在1.5秒时发送一个ok给 server，并且在此之前使用eof和catch检测了socket的状态，当然这里的eof其实是没什么用的，关键是这个catch。但结果并没有 catch到什么error，ok还是被发送出去了，最终打印出了“message has been sent.”，当然其实这是有问题的。

事实上在每次发送信息之前，我们可以试着发送一个echo并等待返回，通过这个过程来确定对方的状态，从而再确定是否发送真正的信息或者关闭连接。于是我写了以下这个脚本。

[rpc_cli.tcl]

proc rpc_client {host port timeout} {
    global connected

    after [expr $timeout * 1000] {set connected timeout}
    set s [socket $host $port]
    fileevent $s w {set connected ok}

    vwait connected
    fileevent $s w {}

    if {$connected == "timeout"} {
        return -code error timeout
    } else {
        return $s
    }
}

proc rpc_cli_send {sock msg} {
    puts $sock {return echo}
    flush $sock
    fileevent $sock readable [list checkServerAndSend $sock $msg]
}

proc readResult {s} {
    log [gets $s]
}

proc checkServerAndSend {s msg} {
    global timeout
    set timeout {}

    after 5000 {set timeout 1}
    fileevent $s readable {set timeout 0}
    vwait timeout

    if {!$timeout && ([gets $s] == {result echo})} {
        puts $s $msg
        flush $s
        fileevent $s readable [list readResultAndFilter $s]
    } else {
        log {Connection failed!}
        close $s
        set ::forever 1
    }
}

proc readResultAndFilter {s} {
    set msg [gets $s]
    switch [lindex $msg 0] {
        result {
            log $msg
        }
        default {
            log {Connected failture}
            close $s
            set ::forever 1
        }
    }
}

proc log {msg} {
    puts "Client: $msg"
}

set test 1
if $test {
    if ![catch {set s [rpc_client 127.0.0.1 8808 5]}] {

        rpc_cli_send $s {
            proc hello {} {
                # test
                return "nihao shijie"
            }
            hello
        }

        vwait forever
    }
}

首先是一个安全的链接建立函数rpc_client，其中有一个timeout的变量，我们将vwait在它上面，一旦超时则链接建立失败，这基本上就是 抄《practical programming Tcl ... 》里的例子，要说一下的是socket一旦被建立，它就处于可写状态，我们就是通过这个状态来确定建立的成功与否。接下来的一个发送函数则是实现安全发送 的关键所在了，发送一个{return echo}的命令之后，socket的可读状态被绑定到了一个叫做checkServerAndSend的函数上，由它来确定服务器端的可用状态。一旦确 定信息是可以到达server的，这个时候在真正发送信息过去，并将socket的可读状态绑定到readResultAndFilter上，由它来处理 返回的结果。

最后给出服务器端的脚本，这是一个通用的远程tcl代码执行器，可执行传输过来的任何合法tcl指令并将结果返回给客户端，我觉得它很有意思，可以干一些不可告人的事情。

[rpc.tcl]

array set rpc_array {}

proc rpc {} {
    global rpc_array
    set rpc_array(server) [socket -server onRemoteConnection 8808]
}

proc onRemoteConnection {sock addr port} {
    global rpc_array

    set rpc_array(cli,$sock) {}
    trace add variable rpc_array(cli,$sock) write verifyAndRunCommands
    trace add variable rpc_array(cli,$sock) unset removeSubInterp
    interp create cli,$sock

    fileevent $sock readable [list readCommands $sock]
}

proc readCommands {sock} {
    global rpc_array

    if {[eof $sock] || [catch {gets $sock buf}]} {
        close $sock
        unset rpc_array(cli,$sock)
    } else {
        set buf [string trim $buf]
        if {$buf != {}} {
            lappend rpc_array(cli,$sock) $buf
        }
    }
}

proc verifyAndRunCommands {arr_name key op} {
    upvar #0 $arr_name ra

    set cmds [join $ra($key) /n]

    if ![catch {set result [interp eval $key $cmds]} err] {
        array set ra [list $key {}]
        set cli_sock [regsub {cli,(.+)} $key {/1}]
        puts $cli_sock [list result $result]
        flush $cli_sock
    } else {
        log $err
    }
}

proc removeSubInterp {arr_name key op} {
    interp delete $key
}

proc log {msg} {
    puts "Server: $msg"
}

set test 1
if $test {
    rpc
    vwait forever
}