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

#!/usr/local/bin/wish8.5
# # author: wn0112@gmail.com

package require Ttk
set 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 220
wm maxsize . 400 220
wm aspect . 200 120 200 120
wm resizable . 0 0

proc main { } {
	global lab entry
	set check_os [ array get tcl_platform ]

	ttk::frame .t -borderwidth 1 -relief groove
	pack .t -side right -anchor n

	ttk::frame .num -borderwidth 2 -relief groove
	pack .num -side top -anchor w

	ttk::frame .f -borderwidth 2 -relief groove
	pack .f -side top -anchor w

	ttk::label .num.ls -text "Talking to:" -anchor nw
	ttk::label .num.ldate -text "Message:" -anchor nw
	if { [ 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 y
	pack .t.log -side right -anchor n

	if { [ 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 y
	if { [ 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 3
	pack .trans -pady 5 -side top -expand true
	bind . <Escape> exit
	focus -force .num.s

	if { [ 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 code
proc client { addr { port 2345 } } {
	global lab
	set err [ catch { set connection [ socket $addr $port ]} result ]
	fconfigure $connection -encoding utf-8
	if { $err != 0 } {
		popErr "Can't connect to this IP address."
		return -1
	} else {
		return $connection
	}
}

proc send { channel data } {
	global lab entry
	puts $channel $data
	flush $channel
	insertLog "I said:\n$data"
	$entry delete 0.0 end
	close $channel
}

proc click_send {} {
	global lab
	if { [ .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 code
proc read_data_s { channel } {
	global lab a remote
	set err [ catch { set data [ read $channel nonewline ] } result ]
	if { $err!=0 } {
		close $channel
		insertLog "$result"
	} elseif {[ eof $channel ]} {
		close $channel
	} else {
		insertLog "$remote said:\n$data"
	}
}

proc accept { channel addr port } {
	global remote
	set remote $addr
	fconfigure $channel -translation auto -blocking 0 -encoding utf-8
	fileevent $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 blue
	if { [ 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 2345
main
server 2345