Tcl/tk例項-局域傳送訊息工具
阿新 • • 發佈:2018-12-29
#!/usr/local/bin/wish8.5 # # author: [email protected] 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