Tcl/tk实例－局域发送消息工具

#!/usr/local/bin/wish8.5# # author: [e-mail] require Ttkset top .set sheight [ winfo screenheight $top ]set swidth [ winfo screenwidth $top ]wm geometry $top +[ format %.0f [ expr {($swidth-410)/2} ]]+[ format %.0f [ expr {($sheight-220)*0.3} ]]wm title . "LAN\ Chat"wm minsize . 409 220wm maxsize . 400 220wm aspect . 200 120 200 120wm resizable . 0 0proc main { } {global lab entryset check_os [ array get tcl_platform ]ttk::frame .t -borderwidth 1 -relief groovepack .t -side right -anchor nttk::frame .num -borderwidth 2 -relief groovepack .num -side top -anchor wttk::frame .f -borderwidth 2 -relief groovepack .f -side top -anchor wttk::label .num.ls -text "Talking to:" -anchor nwttk::label .num.ldate -text "Message:" -anchor nwif { [ string match *Linux* $check_os ] } {ttk::combobox .num.s -width 25 } elseif { [ string match *osVersion\ 6.1* $check_os ] } {ttk::combobox .num.s -width 27 } else {ttk::combobox .num.s -width 27 }ttk::scrollbar .t.scroll -command { .t.log yview }set lab [ text .t.log -state disabled -width 26 -height 20 -borderwidth 2 -wrap word -relief sunken -yscrollcommand { .t.scroll set }]pack .t.scroll -side right -fill ypack .t.log -side right -anchor nif { [ string match *Linux* $check_os ] } {$lab config -width 31}set entry [ text .f.date -width 19 -height 5 -borderwidth 1 -relief sunken -yscrollcommand { .f.scroll set } ]ttk::scrollbar .f.scroll -command { .f.date yview }pack .f.scroll -side right -fill yif { [ string match *Linux* $check_os ] } {$entry config -width 20}ttk::button .trans -text "Send" -width 10 -command [ list click_send ]pack .num.ls .num.s .num.ldate .f.date -anchor nw -pady 3 -ipadx 3pack .trans -pady 5 -side top -expand truebind . <Escape> exitfocus -force .num.sif { [ string match *Linux* $check_os ] } {insertLog "*******************************"} elseif { [ string match *osVersion\ 6.1* $check_os ] } {insertLog "**************************"} else {insertLog "**************************"}insertLog "Run this tool on other computers,  you can send message to them."if { [ string match *Linux* $check_os ] } {insertLog "*******************************"} elseif { [ string match *osVersion\ 6.1* $check_os ] } {insertLog "**************************"} else {insertLog "**************************"}}set remote ""# client codeproc client { addr { port 2345 } } {global labset err [ catch { set connection [ socket $addr $port ]} result ]fconfigure $connection -encoding utf-8if { $err != 0 } {popErr "Can't connect to this IP address."return -1} else {return $connection}}proc send { channel data } {global lab entryputs $channel $dataflush $channelinsertLog "I said:\n$data"$entry delete 0.0 endclose $channel}proc click_send {} {global labif { [ .num.s get ] !="" } {set temp [ split [ .num.s get ] . ]for { set i 0 } { $i < [ llength $temp ] } { incr i } {  if { [ lindex $temp $i ] > 255 || [ lindex $temp $i ] < 0 } {insertLog "Invalid IP address"return} elseif { [ llength $temp ] < 4 || [ llength $temp ] > 4 } {insertLog "Invalid IP address"return  }}} else {insertLog "Please input IP address."return}set connection [ client [.num.s get ]]if { $connection != -1 } {set value [ .num.s cget -value ]if { ![ string match *[ .num.s get ]* $value ] } {lappend value [ .num.s get ].num.s config -values $value}send $connection [ string trimright [.f.date get 0.0 end ] \n ]}}# server codeproc read_data_s { channel } {global lab a remoteset err [ catch { set data [ read $channel nonewline ] } result ]if { $err!=0 } {close $channelinsertLog "$result"} elseif {[ eof $channel ]} {close $channel} else {insertLog "$remote said:\n$data"}}proc accept { channel addr port } {global remoteset remote $addrfconfigure $channel -translation auto -blocking 0 -encoding utf-8fileevent $channel readable [ list read_data_s $channel ]}proc server { port } {socket -server accept $port}proc insertLog { msg } {global lab$lab config -state normal$lab tag configure blue -foreground blueif { [ string match *I\ said:* $msg ] } {$lab insert end $msg\n blue} else {$lab insert end $msg\n}$lab yview moveto 1.0$lab config -state disabled }proc popErr { str } {tk_messageBox -type ok -title "Error" -icon error -message "$str"} # monitor port 2345mainserver 2345