tkWhiteboard FROM: http://wfr.tcl.tk/292 (imaged on 2009 mar 19) #!/usr/bin/wish # the next line restarts using wish\ exec wish "$0" "$@" ################################################################################ # # TkWhiteboard - version 0.3 # # A simple cross-plateform network whiteboard (Linux/Mac/Windows). # # Copyright (C) 2001-2002 Jean-Yves Chasle # Copyright (C) 2001-2002 David Zolli # # Ce programme est un logiciel libre ; vous pouvez le redistribuer et/ou le # modifier conformément aux dispositions de la Licence Publique Générale GNU, # telle que publiée par la Free Software Foundation ; version 2 de la licence, # ou toute version ultérieure. # # Ce programme est distribué dans l'espoir qu'il sera utile, mais SANS AUCUNE # GARANTIE ; sans même la garantie implicite de COMMERCIALISATION ou # D'ADAPTATION A UN OBJET PARTICULIER. Pour plus de détail, voir la Licence # Publique Générale GNU. # # TkWhiteboard is distributed under the GNU General Public Licence. # TkWhiteboard comes with ABSOLUTELY NO WARRANTY or GUARANTEE OF FITNESS # FOR A PARTICULAR PURPOSE. See the file COPYING for complete # information. # # Authors : # Jean-Yves Chasle [string map {# @} ] # David Zolli [string map {# @} ] # ################################################################################ proc wbInitialization { } { global wb fbcpt set wb(generalinfo) {Click on "Create server" to initialize a new\ session, or "Connect to server" to join an open session.} set wb(servip) 127.0.0.1 ;# Default server ip address. set wb(servport) 33000 ;# Default server port. set wb(servpass) "" ;# No Default password. set wb(timeout) 30000 ;# Equivalent to 30 seconds. # Server and client messages. set wb(msg_askpasswd) "Server waiting for password..." set wb(msg_serverok) "Server OK, waiting for commands..." set wb(msg_clientok) "Client OK, waiting for feedback..." set wb(msg_fbcompleted) "Feedback completed." # Connection status messages. set wb(status_disconnected) "disconnected" set wb(status_connectioninprogress) "connection in progress" set wb(status_authenticationinprogress) "authentication in progress" set wb(status_feedbackinprogress) "feedback in progress" set wb(status_initsessioncompleted) "init session completed" # Connection variables. set wb(mysock) "" set wb(connected) 0 set wb(insession) 0 set wb(connectionstatus) $wb(status_disconnected) set wb(servsock) "" set wb(servrunning) 0 set fbcpt -1 ;# Feedback counter (number of the last canvas object). # Gid variables. wbSetPenStyle "free" set wb(curcolor) "black" wbSetPenWidth 1 set wb(button-down) 0 set wb(colorenable) black set wb(colordisable) grey50 set wb(colorhilight) red } ################################################################################ # wbCreateWidgets ################################################################################ proc wbCreateWidgets { } { global wb # Initialize button images set wb(curdir) [pwd] image create photo wb(img_free) -data {R0lGODdhEgASAKIAAP/4/////wAAA N94f7+4v/C4Px4A/////ywAAAAAEgASAAADkgi6DBiqCLoMgqEBoAi6KoMSARAYg aCrIigRAIERCLoghBIRABiKoAsiKBEAgKEIulKCoQCggUBXSjACAABDEVSlBCMQV CMCQVVKMAJBNSIQFKQEQwFUFYGClGAogKoiUCkJDAAzw1AFAJSSCARVi8AIgBAUD N21RYCQCIywgMCwiAgEiDBDszAzNAxVgN21VkAJADs=} image create photo wb(img_text) -data {R0lGODdhEAAQAJEAAP///wBI/x1d/ 8fX/ywAAAAAEAAQAAACMYSPqcutFB8JfshABGEKgh8XcUHw4yIuCD5GIKJRQviIE ZlICeEjRmQaxSf4mLrcTAUAOw==} image create photo wb(img_imgif) -data {R0lGODdhEAAQAPcAAE1BRGc9OyUq VCEsYyEtZyEubR8sbB8qYiAuaFZef24+M//Ywx8OagAi3AAv1QAx6AAz7QA3/wA0 9gAt0wAt4AAx5gAz9QAo/VV16GkqJP+Yad1wRQASoAAdmwgkqwQooQUrsQUsuQUr tgUpowcorwcmtgYquQARrFVw0U0jJOgXDf/Ami4AHAATcAkXbAQZhQUbgQQjmQQb iAYWewUcgQMhjAUonQAUplVvzikeIokEAP+RhtJcRAAENAoWWgoUSgAQVwARagAY hQcflwQosAUrtAYrxAAUl1ZpvwkABuMTBNO7pgoQFw0DBwAJSGI+KaxXNQAFSwQa eAYamAYbgwQdjwAKfFZjqSIeIgAAACJRWpWxyYuKnAAAD9WWSv/RWR0ACg0PKgYI GwABEwAGOl1aaBoAFXC/vv///wAAARcAAOGZaAAGDAABEmhhX7t+WQAAFV5bZCMf JQkAAiMAACRDR9z//5uioWEAAFIAAOKeTTkAAFwAACoAAMJuV5MfAG5cYG85I/9S AP9sAE4mBGJ+m7k1A/+rT/+sS+OQO//Qdf+9gP+uae4yAP9OAPGGWnE4I/+WQ/ms e48aChYhMZfI0igaIL1MC/+BJ/2mI/yoW/7JavfqfuvW2/CLVemXb28+I/+iP8ya g2oAAFgFAyEJABoNFjcuJv+UTv/QYY2Fkf/Pd/vknfTz27g2J+eIXHE7I/96FOKx gas0Hg0AAH1MFAAAEVsYBYdRJv+oLJVtPv/unP//yrpDEcYMAOiIV248JP9oD/iB KfWfSP3Lgv/jk4VhVVhUSXh/if/Cd6IRBb9NVb8NALwPDf5NAPedXG45JP9BAPZP AO1GAN5AAPxOAP04AOpCFtcOANUZAMQfAPhDAPlQAP1eAPtvAPawZJdyaPCBWvCE WvaTWfOLWveVWfWOVvaQWvaRVveYWfacY/Wdd/W9e/bAcvXRp/////////////// /////////////////////////////////////////////////////ywAAAAAEAAQ AAAI/wABBBAwYAABAgUMEDgwgEABBAkULGDQwMEDCBEiSJhAoYKFCxgyaNjAoYOH DyBCiBhBooSJEyhSqFjBooWLFzBiyJhBo4aNGzhy6NjBo4ePH0CCCBlCpIiRI0hy JFGyhEkTJ0+gRJEyhUoVK1ewZNGyhUuWLl6+gAkjZgyZLGWwZDFzBk2WNGrWZGHT xs0bOHHkzKFTx84dPHn07OHTx8+fLIACCRpEqBAaQ4cQJVK0iFEjR48gRZI0iVIl S5cwZdK0iVMnT59AhRI1ilQpU6dQpVK1ilUrV69gxZI1i1YtW7dw5dK1i1cvX7+A BRM2jFgxY8eQJVO2jFkzZ8+gRSWTNo1aNWvXsGXTto1bN2/fwIUTN45cOXPn0J1L p24dO4Dt3AUEADs=} image create photo wb(img_erase) -data {R0lGODdhEgASAKIAAP////8AAAAA AJSRlN7a3v///////////ywAAAAAEgASAAADcQi63A4oAAIAIRB0NwADAgAwEHQ3 AgMCADAQdDcAAyICMBRBl9sfINFVBN0VViQyCLogrEhIBkFXdlGIZBBUZReFSGYQ FGQXhUhmEBRQdJUIZQZBVZB0hQRnEHQFSVdkcBB0AUVXZxB0F0dXEXS5vVECADs=} image create photo wb(img_line) -data {R0lGODdhEgASAJEAAP///wAAAP/// ////ywAAAAAEgASAAACMYSPqctGIXzMC1WlED7mhapSCB/zQlUphI95oaoUwse8U FUK4WNeqCqF8DEvVFWVMqQAOw==} image create photo wb(img_arrow) -data {R0lGODdhEgASAJEAAP///wAAAP// /////ywAAAAAEgASAAACPISPqctGIXzMC1WlED7mhapSCB/zQlUphI95cUHwEcMi M0mAIPiYAZFpJAEEBMHHi4CgED5mRGRmSikdUgA7} image create photo wb(img_rectempt) -data {R0lGODdhEgASAJEAAP///wAAA P///////ywAAAAAEgASAAACOYSPqcvtz0h8RAAACuGjBUamkQAAQfDRAiPTSACAI PhogZFpJABAEHy0wMg0EgCA4iMSfExdbn9GCgA7} image create photo wb(img_rectfill) -data {R0lGODdhEgASAJEAAP///wAAA H6RzP///ywAAAAAEgASAAACRISPqcvtz0h8RAAACuWjBQAQQvloAQCEUD5aAAAhl I8WAEAI5aMFABBC+WgBAIRQPloAACGUjxYAQGB8RIKPqcvtz0gBADs=} image create photo wb(img_elpsempt) -data {R0lGODdhEgASAJEAAP///wAAA P///////ywAAAAAEgASAAACPoSPqcvtSeITfIxACwrhQyBaEPy4OwiCHXd3QTDi7 i4IRtzdBcGOu4Mg+HF3EAQfItCCQvhI8Qk+pi63PyQFADs=} image create photo wb(img_elpsfill) -data {R0lGODdhEgASAJEAAP///wAAA H6RzP///ywAAAAAEgASAAACQoSPqcvtSeITfIwg+REEH4LkYxD8IPkYBDtIPloAA CGUjxYAQAjlowXBDpKPQfCD5GMQfIgg+REEHyk+wcfU5faHpAA7} image create photo wb(img_wid1) -data {R0lGODdhEgASAJEAAP///wICAgQEB AEBASwAAAAAEgASAAACGYSPqcvtD6OclJKI8DFhhuBj6nL7wygnpaQAOw==} image create photo wb(img_wid2) -data {R0lGODdhEgASAJEAAP///6qqqj8/P wAAACwAAAAAEgASAAACI4SPqcvtD6OckUQKgo8oM0LwEWVGCD5iiATBx9Tl9odRz kgKADs=} image create photo wb(img_wid4) -data {R0lGODdhEgASAKIAAP///+Xl5X9/f yoqKgAAAP///////////ywAAAAAEgASAAADNgi63P4wykmrjShkRgJBl1WQlARBl 3WQlAZBl3WQlAZBl1WQlARBlzVQZiQQdLn9YZSTVhtRAgA7} image create photo wb(img_wid8) -data {R0lGODdhEgASAKIAAP////7+/qOjo 1RUVBkZGX9/fwAAAP///ywAAAAAEgASAAADTQi63P4wyjlRyBANSiDobhSabgWCr gqargqCrg6arg6CrhKarhKCrhKarhKCrg6arg6CrgqargqCrkah6VYg6G4IDtFII Ohy+8Mo50QJADs=} # Frames frame .fu -bd 2 -relief groove frame .fl -bd 2 -relief groove frame .fr -bd 2 -relief groove frame .fd -bd 2 -relief groove grid .fu -row 0 -column 0 -columnspan 2 -sticky w grid .fl -row 1 -column 0 -sticky ns grid .fr -row 1 -column 1 -sticky news grid .fd -row 2 -column 0 -columnspan 2 -sticky ew grid rowconfigure . 0 -weight 0 grid rowconfigure . 1 -weight 1 grid rowconfigure . 2 -weight 0 grid columnconfigure . 0 -weight 0 grid columnconfigure . 1 -weight 1 # Inside upper frame set wb(btn_client,w) [button .fu.b1 -text "Connect to server" \ -width 20 -command { if $wb(connected) wbCloseClient else wbOpenClient }] set wb(btn_server,w) [button .fu.b2 -text "Create server" \ -width 20 -command { if $wb(servrunning) wbCloseServer else wbOpenServer }] set wb(lbl_ip,w) [label .fu.l1 -text "Server IP : "] set wb(ent_ip,w) [entry .fu.e1 -textvariable wb(servip) \ -width 15 -relief sunken] set wb(lbl_port,w) [label .fu.l2 -text "Port : " -fg black] set wb(ent_port,w) [entry .fu.e2 -textvariable wb(servport) \ -width 5 -relief sunken] set wb(lbl_pass,w) [label .fu.l3 -text "Password"] set wb(ent_pass,w) [entry .fu.e3 -textvariable wb(servpass) \ -width 8 -show "*" -relief sunken] set wb(btn_quit,w) [button .fu.b3 -text "Quit" -command "exit"] grid $wb(btn_client,w) \ $wb(btn_server,w) \ $wb(btn_quit,w) \ $wb(lbl_pass,w) \ $wb(ent_pass,w) \ $wb(lbl_ip,w) \ $wb(ent_ip,w) \ $wb(lbl_port,w) \ $wb(ent_port,w) # Inside left frame # Sub-frames frame .fl.sf1 -bd 2 -relief groove frame .fl.sf2 -bd 2 -relief groove frame .fl.sf3 -bd 2 -relief groove pack .fl.sf1 .fl.sf2 .fl.sf3 -side top -padx 1 -pady 1 # Sub_frame "pen style" : buttons set wb(chk_free,w) [checkbutton .fl.sf1.b00 -image wb(img_free) \ -indicatoron 0 -variable wb(chk_free,s) -command { wbSetPenStyle "free"}] set wb(text,w) [button .fl.sf1.b01 -image wb(img_text) \ -command {wbText}] set wb(chk_line,w) [checkbutton .fl.sf1.b10 -image wb(img_line) \ -indicatoron 0 -variable wb(chk_line,s) -command { wbSetPenStyle "line"}] set wb(chk_arrow,w) [checkbutton .fl.sf1.b11 -image wb(img_arrow) \ -indicatoron 0 -variable wb(chk_arrow,s) -command { wbSetPenStyle "arrow"}] set wb(chk_rectempt,w) [checkbutton .fl.sf1.b20 \ -image wb(img_rectempt) -indicatoron 0 \ -variable wb(chk_rectempt,s) -command { wbSetPenStyle "rectempt"}] set wb(chk_rectfill,w) [checkbutton .fl.sf1.b21 \ -image wb(img_rectfill) -indicatoron 0 \ -variable wb(chk_rectfill,s) -command { wbSetPenStyle "rectfill"}] set wb(chk_elpsempt,w) [checkbutton .fl.sf1.b30 \ -image wb(img_elpsempt) -indicatoron 0 \ -variable wb(chk_elpsempt,s) -command { wbSetPenStyle "elpsempt"}] set wb(chk_elpsfill,w) [checkbutton .fl.sf1.b31 \ -image wb(img_elpsfill) -indicatoron 0 \ -variable wb(chk_elpsfill,s) -command { wbSetPenStyle "elpsfill"}] set wb(erase,w) [button .fl.sf1.b40 -image wb(img_erase) \ -command { $wb(canvas,w) delete all wbSendOwnCmd erase }] set wb(imgif,w) [button .fl.sf1.b41 -image wb(img_imgif) \ -command { set baseimg [tk_getOpenFile \ -filetypes "{{Image} {*.gif *.GIF}}" \ -title "Import Gif"] if [string compare $baseimg ""]!=0 { $wb(canvas,w) delete imgfond image create photo imgfond -file $baseimg $wb(canvas,w) create image 0 0 -anchor nw -image imgfond -tag fond $wb(canvas,w) lower fond set imgdata [string map { \n "" } [imgfond data -format gif]] wbSendOwnCmd [list fond $imgdata] } }] grid $wb(chk_free,w) $wb(text,w) grid $wb(chk_line,w) $wb(chk_arrow,w) grid $wb(chk_rectempt,w) $wb(chk_rectfill,w) grid $wb(chk_elpsempt,w) $wb(chk_elpsfill,w) grid $wb(imgif,w) $wb(erase,w) # Sub_frame "pen color" : button set wb(btn_color0,w) [radiobutton .fl.sf2.b0 -bg black \ -indicatoron 0 -width 2 -selectcolor black \ -variable color -value 0 -command { global wb set wb(curcolor) "black"}] set wb(btn_color1,w) [radiobutton .fl.sf2.b1 -bg white \ -indicatoron 0 -width 2 -selectcolor white \ -variable color -value 1 -command { global wb set wb(curcolor) "white"}] set wb(btn_color2,w) [radiobutton .fl.sf2.b2 -bg red \ -indicatoron 0 -width 2 -selectcolor red \ -variable color -value 2 -command { global wb set wb(curcolor) "red"}] set wb(btn_color3,w) [radiobutton .fl.sf2.b3 -bg blue \ -indicatoron 0 -width 2 -selectcolor blue \ -variable color -value 3 -command { global wb set wb(curcolor) "blue"}] set wb(btn_color4,w) [radiobutton .fl.sf2.b4 -bg green \ -indicatoron 0 -width 2 -selectcolor green \ -variable color -value 4 -command { global wb set wb(curcolor) "green"}] set wb(btn_color5,w) [radiobutton .fl.sf2.b5 -bg darkgrey \ -indicatoron 0 -width 2 -selectcolor darkgrey \ -variable color -value 5 -command { global wb set wb(curcolor) "darkgrey"}] grid $wb(btn_color0,w) $wb(btn_color1,w) grid $wb(btn_color2,w) $wb(btn_color3,w) grid $wb(btn_color4,w) $wb(btn_color5,w) # Sub_frame "pen width" : buttons set wb(chk_wid1,w) [checkbutton .fl.sf3.b00 -image wb(img_wid1) \ -indicatoron 0 -variable wb(chk_wid1,s) \ -command {wbSetPenWidth 1}] set wb(chk_wid2,w) [checkbutton .fl.sf3.b01 -image wb(img_wid2) \ -indicatoron 0 -variable wb(chk_wid2,s) \ -command {wbSetPenWidth 2}] set wb(chk_wid4,w) [checkbutton .fl.sf3.b10 -image wb(img_wid4) \ -indicatoron 0 -variable wb(chk_wid4,s) \ -command {wbSetPenWidth 4}] set wb(chk_wid8,w) [checkbutton .fl.sf3.b11 -image wb(img_wid8) \ -indicatoron 0 -variable wb(chk_wid8,s) \ -command {wbSetPenWidth 8}] grid $wb(chk_wid1,w) $wb(chk_wid2,w) grid $wb(chk_wid4,w) $wb(chk_wid8,w) # Inside right frame set wb(canvas,w) [canvas .fr.canvas -bg white] bind $wb(canvas,w) {button-down %x %y} bind $wb(canvas,w) {button-motion %x %y} bind $wb(canvas,w) {button-release %x %y} pack $wb(canvas,w) -fill both -expand yes # Inside lower frame set wb(lbl_geninfo,w) [label .fd.l1 -textvariable wb(generalinfo) \ -fg black -width 50] pack $wb(lbl_geninfo,w) -fill both -expand yes wbInitialization } ################################################################################ # wbSetPenStyle : proc linked to the "pen style" checkbuttons. ################################################################################# proc wbSetPenStyle { style } { global wb set chk_name [format "%s%s" "chk_" $style] set wb([format "%s%s%s" "chk_" $style ",s"]) 1 set wb(curstyle) $style if {$style != "free"} {set wb(chk_free,s) 0} if {$style != "line"} {set wb(chk_line,s) 0} if {$style != "arrow"} {set wb(chk_arrow,s) 0} if {$style != "rectempt"} {set wb(chk_rectempt,s) 0} if {$style != "rectfill"} {set wb(chk_rectfill,s) 0} if {$style != "elpsempt"} {set wb(chk_elpsempt,s) 0} if {$style != "elpsfill"} {set wb(chk_elpsfill,s) 0} } ################################################################################ # wbSetPenWidth : proc linked to the "pen width" checkbuttons. ################################################################################ proc wbSetPenWidth { width } { global wb set wb([format "%s%s%s" "chk_wid" $width ",s"]) 1 set wb(curwidth) $width if {$width != 1} {set wb(chk_wid1,s) 0} if {$width != 2} {set wb(chk_wid2,s) 0} if {$width != 4} {set wb(chk_wid4,s) 0} if {$width != 8} {set wb(chk_wid8,s) 0} } ################################################################################ # wbOpenServer : proc to add a new text. ################################################################################ proc wbText {} { global wb set wb(txt) 1 toplevel .contenu -relief ridge -borderwidth 6 wm overrideredirect .contenu 1 wm title .contenu "Insert Text" wm geometry .contenu +320+240 wm transient .contenu . frame .contenu.fond pack configure .contenu.fond -side top -fill both -expand 1 frame .contenu.fond.txt pack configure .contenu.fond.txt -side top -fill x label .contenu.fond.txt.l -text "String to add : " pack configure .contenu.fond.txt.l -side left entry .contenu.fond.txt.e -textvariable wb(newtxt) -width 30 -highlightthickness 0 pack configure .contenu.fond.txt.e -side right -padx 5 -pady 5 frame .contenu.fond.boutons pack configure .contenu.fond.boutons -side bottom -expand 1 -fill x button .contenu.fond.boutons.non -text Cancel -highlightthickness 0 -command { destroy .contenu } pack configure .contenu.fond.boutons.non -side right -expand 1 -fill x button .contenu.fond.boutons.ok -text "Add it" -highlightthickness 0 -command { destroy .contenu . configure -cursor crosshair update idletasks bind $wb(canvas,w) { $wb(canvas,w) create text %x %y -text $wb(newtxt) -anchor sw set wb(txt) 1 wbSendOwnCmd [list texte %x %y $wb(newtxt)] } bind $wb(canvas,w) {} bind $wb(canvas,w) {} tkwait variable wb(txt) bind $wb(canvas,w) {button-down %x %y} bind $wb(canvas,w) {button-motion %x %y} bind $wb(canvas,w) {button-release %x %y} . configure -cursor left_ptr } pack configure .contenu.fond.boutons.ok -side left -expand 1 -fill x grab set .contenu .contenu.fond.txt.e select range 0 end focus -force .contenu.fond.txt.e bind .contenu {.contenu.fond.boutons.ok invoke} bind .contenu {.contenu.fond.boutons.ok invoke} bind .contenu {.contenu.fond.boutons.non invoke} tkwait visibility .contenu tkwait window .contenu } ################################################################################ # wbOpenServer : proc linked to the "create server" button. ################################################################################ proc wbOpenServer { } { global wb # Open the server socket. catch {close $wb(servsock)} if [catch { socket -server wbServerOpenNewClientSocket $wb(servport) } wb(servsock)] { set wb(generalinfo) "Server socket couldn't be attached \ to already used port $wb(servport)..." } else { set wb(servrunning) 1 set wb(generalinfo) "Server attached to port $wb(servport).\ Waiting for a client to call..." $wb(btn_server,w) config -text "Close server" \ -foreground $wb(colorhilight) $wb(btn_client,w) config -state disabled $wb(ent_ip,w) config -state disabled \ -foreground $wb(colordisable) $wb(ent_port,w) config -state disabled \ -foreground $wb(colordisable) $wb(ent_pass,w) config -state disabled \ -foreground $wb(colordisable) } } ################################################################################ # wbServerOpenNewClientSocket : callback proc called by the listening system. ################################################################################ proc wbServerOpenNewClientSocket {sock ip port} { global wb guest # This function is called when the server receives a connection. set guest($sock) [list $wb(status_authenticationinprogress) $ip $port] set wb(connected) 1 # fconfigure $sock -buffering line # "Receive character line from guest or client" callback. fileevent $sock readable [list wbServerReadGuestLineFromBuffer $sock] # Ask new guest for a password. puts $sock $wb(msg_askpasswd) flush $sock set wb(generalinfo) "A new guest ([lindex $guest($sock) 1]) \ is connected to the server." } ################################################################################ # wbServerReadGuestLineFromBuffer : reads a single line from buffer linked to a # socket. ################################################################################ proc wbServerReadGuestLineFromBuffer { sock } { global wb guest client fb # Read a line when it's completely buffered. set numargs [gets $sock line] if {$numargs == -1} { catch {close $sock} set wb(generalinfo) "Guest ([lindex $guest($sock) 1]) is \ disconnected." unset guest($sock) # Update $wb(connected) after deleting a guest socket. if {[array size guest] == 0 && [array size client] == 0} { set wb(connected) 0 } $wb(btn_server,w) config -state normal $wb(btn_client,w) config -text "Connect to server" \ -foreground $wb(colorenable) $wb(ent_ip,w) config -state normal -foreground $wb(colorenable) $wb(ent_port,w) config -state normal -foreground $wb(colorenable) $wb(ent_pass,w) config -state normal -foreground $wb(colorenable) } else { set wb(generalinfo) "Received $line." switch [lindex $guest($sock) 0] \ $wb(status_authenticationinprogress) { if {$line == $wb(servpass)} { set guest($sock) [lreplace $guest($sock) \ 0 0 $wb(status_feedbackinprogress)] # Send "Ok" message to guest. puts $sock $wb(msg_serverok) flush $sock set wb(generalinfo) "A new client \ ([lindex $guest($sock) 0]) is about \ to join the open session. Sending \ feedback..." } else { # Disconnect guest : wrong password. catch {close $sock} set wb(generalinfo) "Wrong password. Guest \ ([lindex $guest($sock) 1]) disconnected\ by server." unset guest($sock) # Update $wb(connected) after deleting a guest socket. if {[array size guest] == 0 && [array size client] == 0} { set wb(connected) 0 } } } \ $wb(status_feedbackinprogress) { if {$line == $wb(msg_clientok)} { # Send feedback to client. set cpt 0 while {[info exists fb($cpt)]} { puts $sock $fb($cpt) flush $sock incr cpt } # Send "end of feedback" message to client. puts $sock $wb(msg_fbcompleted) flush $sock # Guest upgrades to client. set client($sock) [list [lindex $guest($sock) 1] \ [lindex $guest($sock) 2]] unset guest($sock) set wb(insession) 1 # Change the "receive character line from client" callback. fileevent $sock readable [list \ wbServerReadClientLineFromBuffer $sock] set wb(generalinfo) "Client \ ([lindex $client($sock) 0]) is now \ participating..." } } \ default { set wb(generalinfo) "Received unknown command : \ \"$line\" !" } } } ################################################################################ # wbServerReadClientLineFromBuffer : reads a single line from buffer linked to a # socket. ################################################################################ proc wbServerReadClientLineFromBuffer { sock } { global wb guest client fbcpt fb # Read a line when it's completely buffered. set numargs [gets $sock line] if {$numargs == -1} { catch {close $sock} set wb(generalinfo) "Client ([lindex $client($sock) 0]) is\ disconnected." unset client($sock) # Update and $wb(insession) after deleting a guest or client socket. if {[array size client] == 0} { set wb(insession) 0 if {[array size guest] == 0} { set wb(connected) 0 } } $wb(btn_server,w) config -state normal $wb(btn_client,w) config -text "Connect to server" \ -foreground $wb(colorenable) $wb(ent_ip,w) config -state normal -foreground $wb(colorenable) $wb(ent_port,w) config -state normal -foreground $wb(colorenable) $wb(ent_pass,w) config -state normal -foreground $wb(colorenable) } else { set wb(generalinfo) "Received $line."; wbProcessReceivedCmd $line incr fbcpt 1 set fb($fbcpt) $line wbDispatchReceivedCmd $sock $line } } ################################################################################ # wbCloseServer : proc linked to the "create server" button. ################################################################################ proc wbCloseServer { } { global wb guest client # Close every socket stored in client array. set wb(generalinfo) "Closing connections..." foreach {sock} [array names guest] { fileevent $sock readable {} catch {close $sock} unset guest($sock) } foreach {sock} [array names client] { fileevent $sock readable {} catch {close $sock} unset client($sock) } set wb(connected) 0 set wb(generalinfo) "Connections closed." # Close the server socket. catch {close $wb(servsock)} set wb(servrunning) 0 set wb(generalinfo) "Server closed." $wb(btn_server,w) config -text "Create server" \ -foreground $wb(colorenable) $wb(btn_client,w) config -state normal $wb(ent_ip,w) config -state normal -foreground $wb(colorenable) $wb(ent_port,w) config -state normal -foreground $wb(colorenable) $wb(ent_pass,w) config -state normal -foreground $wb(colorenable) } ################################################################################ # wbOpenClient : proc linked to the "connect to server" button. ################################################################################ proc wbOpenClient { } { global wb # Open the data socket. catch {close $wb(mysock)} set wb(connected) 0 set wb(insession) 0 set wb(connectionstatus) $wb(status_disconnected) if {[catch {socket -async $wb(servip) $wb(servport)} wb(mysock)]} { set wb(generalinfo) "No socket could be opened on this computer\ !" return } # "Receive character line from server" callback. fileevent $wb(mysock) readable wbGuestReadServerLineFromBuffer set wb(generalinfo) "Trying to connect to server $wb(servip) \ on port $wb(servport)." set wb(connectionstatus) $wb(status_connectioninprogress) $wb(btn_client,w) config -state disabled $wb(btn_server,w) config -state disabled $wb(ent_ip,w) config -state disabled -foreground $wb(colordisable) $wb(ent_port,w) config -state disabled -foreground $wb(colordisable) $wb(ent_pass,w) config -state disabled -foreground $wb(colordisable) # Waiting $timeout milliseconds before declaring that connection failed. set afterid [after $wb(timeout) {set wb(connected) 0}] # Either modified by wbGuestReadLineFromBuffer or timeout. vwait wb(connected) after cancel $afterid # Connection issue : it may be 1 (successfull) or 0 (timeout). if {$wb(connected)} { # This code is run after the msg_serverok is received in # wbClientReadLineFromBuffer. $wb(btn_client,w) config -state normal -text "Close \ connection" -foreground $wb(colorhilight) $wb(ent_ip,w) config -state disabled \ -foreground $wb(colordisable) $wb(ent_port,w) config -state disabled \ -foreground $wb(colordisable) $wb(ent_pass,w) config -state disabled \ -foreground $wb(colordisable) } else { # This code is run after the preceeding "after" command (timeout). catch {close $wb(mysock)} set wb(connectionstatus) $wb(status_disconnected) set wb(generalinfo) "Server $wb(servip) on port $wb(servport) \ not responding. Connection failed." $wb(btn_client,w) config -state normal $wb(btn_server,w) config -state normal $wb(ent_ip,w) config -state normal -foreground $wb(colorenable) $wb(ent_port,w) config -state normal -foreground $wb(colorenable) $wb(ent_pass,w) config -state normal -foreground $wb(colorenable) } } ################################################################################ # wbGuestReadServerLineFromBuffer : reads a single line from buffer linked to a # socket. ################################################################################ proc wbGuestReadServerLineFromBuffer { } { global wb # Read a line when it's completely arrived. set numargs [gets $wb(mysock) line] if {$numargs == -1} { catch {close $wb(mysock)} set wb(mysock) "" switch $wb(connectionstatus) \ $wb(status_authenticationinprogress) { set wb(generalinfo) "Incorrect password. Disconnected\ by server." } \ default { set wb(generalinfo) "Disconnected by server." } set wb(connected) 0 set wb(insession) 0 set wb(connectionstatus) $wb(status_disconnected) $wb(btn_server,w) config -state normal $wb(btn_client,w) config -text "Connect to server" \ -foreground $wb(colorenable) $wb(ent_ip,w) config -state normal -foreground $wb(colorenable) $wb(ent_port,w) config -state normal -foreground $wb(colorenable) $wb(ent_pass,w) config -state normal -foreground $wb(colorenable) } else { set wb(generalinfo) "[string length $line] \ [string length $wb(msg_askpasswd)] \"$line\" !" switch $line \ $wb(msg_askpasswd) { # Send the password to server. puts $wb(mysock) $wb(servpass) flush $wb(mysock) set wb(connected) 1 set wb(generalinfo) "Connected to server. Sending \ password..." set wb(connectionstatus) $wb(status_authenticationinprogress) \ } \ $wb(msg_serverok) { # Change the "receive character line from server" callback. fileevent $wb(mysock) readable wbClientReadServerLineFromBuffer # Send "ok" message to server. puts $wb(mysock) $wb(msg_clientok) flush $wb(mysock) set wb(generalinfo) "Joining an open session. Waiting\ for feedback..." set wb(connectionstatus) wb(status_feedbackinprogress) } \ default { set wb(generalinfo) "Received unknown command\ : \"$line\" !" } } } ################################################################################ # wbClientReadServerLineFromBuffer : reads a single line from buffer linked to a # socket. ################################################################################ proc wbClientReadServerLineFromBuffer { } { global wb # Read a line when it's completely arrived. set numargs [gets $wb(mysock) line] if {$numargs == -1} { catch {close $wb(mysock)} set wb(mysock) "" set wb(generalinfo) "Disconnected from server." set wb(connected) 0 set wb(insession) 0 set wb(connectionstatus) $wb(status_disconnected) $wb(btn_server,w) config -state normal $wb(btn_client,w) config -text "Connect to server" \ -foreground $wb(colorenable) $wb(ent_ip,w) config -state normal -foreground $wb(colorenable) $wb(ent_port,w) config -state normal -foreground $wb(colorenable) $wb(ent_pass,w) config -state normal -foreground $wb(colorenable) } else { set wb(generalinfo) "Received $line."; if {$line == $wb(msg_fbcompleted)} { set wb(insession) 1 set wb(connectionstatus) $wb(status_initsessioncompleted) set wb(generalinfo) "Feedback completed. Now participating\ to the open session." } else { wbProcessReceivedCmd $line } } } ################################################################################ # wbCloseClient : proc linked to the "connect to server" button. ################################################################################ proc wbCloseClient { } { global wb # Close the data socket. set wb(generalinfo) "Closing connection..." catch {close $wb(mysock)} set wb(mysock) "" set wb(generalinfo) "Disconnected from server." set wb(connected) 0 set wb(insession) 0 set wb(connectionstatus) $wb(status_disconnected) $wb(btn_server,w) config -state normal $wb(btn_client,w) config -text "Connect to server" \ -foreground $wb(colorenable) $wb(ent_ip,w) config -state normal -foreground $wb(colorenable) $wb(ent_port,w) config -state normal -foreground $wb(colorenable) $wb(ent_pass,w) config -state normal -foreground $wb(colorenable) } ################################################################################ # wbSendOwnCmd : proc called from mouse callbacks button-move and button-release. ################################################################################ proc wbSendOwnCmd { cmd } { global wb client fbcpt fb if $wb(insession) { if $wb(servrunning) { # Server part. incr fbcpt 1 set fb($fbcpt) $cmd foreach sock [array names client] { puts $sock $cmd flush $sock } } else { # Client part. puts $wb(mysock) $cmd flush $wb(mysock) } } } ################################################################################ # wbDispatchReceivedCmd : proc called by wbServerReadlLineFromBuffer. ################################################################################ proc wbDispatchReceivedCmd { sendersock cmd } { global wb client if {$wb(servrunning) && $wb(insession)} { foreach sock [array names client] { if {$sendersock == $sock} {continue} puts $sock $cmd flush $sock } } } ################################################################################ # wbProcessReceivedCmd : proc called from wbServerReadLineFromBuffer and wbClientReadLineFromBuffer . ################################################################################ proc wbProcessReceivedCmd { cmd } { global wb set style [lindex $cmd 0] switch $style { free - line { $wb(canvas,w) create line [lindex $cmd 1] [lindex $cmd 2] \ [lindex $cmd 3] [lindex $cmd 4] \ -width [lindex $cmd 5] -fill [lindex $cmd 6] } arrow { $wb(canvas,w) create line [lindex $cmd 1] [lindex $cmd 2] \ [lindex $cmd 3] [lindex $cmd 4] \ -width [lindex $cmd 5] -fill [lindex $cmd 6] \ -arrow last } rectempt { $wb(canvas,w) create rectangle [lindex $cmd 1] \ [lindex $cmd 2] [lindex $cmd 3] [lindex $cmd 4] \ -width [lindex $cmd 5] -outline [lindex $cmd 6] } rectfill { $wb(canvas,w) create rectangle [lindex $cmd 1] \ [lindex $cmd 2] [lindex $cmd 3] [lindex $cmd 4] \ -width [lindex $cmd 5] -fill [lindex $cmd 6]\ -outline [lindex $cmd 6] } elpsempt { $wb(canvas,w) create arc [lindex $cmd 1] [lindex $cmd 2] \ [lindex $cmd 3] [lindex $cmd 4] \ -width [lindex $cmd 5] -outline [lindex $cmd 6] \ -start 0 -extent 359 -style arc } elpsfill { $wb(canvas,w) create arc [lindex $cmd 1] [lindex $cmd 2] \ [lindex $cmd 3] [lindex $cmd 4] \ -width [lindex $cmd 5] -fill [lindex $cmd 6] \ -start 0 -extent 359 -style chord\ -outline [lindex $cmd 6] } texte { $wb(canvas,w) create text [lindex $cmd 1] [lindex $cmd 2] \ -text [lindex $cmd 3] -anchor sw } fond { $wb(canvas,w) delete imgfond # @kroc image create photo imgfond -data [lindex $cmd 1] $wb(canvas,w) create image 0 0 -anchor nw -image imgfond -tag fond $wb(canvas,w) lower fond } erase { $wb(canvas,w) delete all } default { set wb(generalinfo) "Received unknown command : \"$cmd\"" } } } ################################################################################ # button-down : mouse callback linked to the canvas. ################################################################################ proc button-down { sx sy } { global wb if $wb(insession) { set wb(button-down) 1 switch $wb(curstyle) { free - line { set wb(lastx) $sx set wb(lasty) $sy set wb(lastobj,w) [ $wb(canvas,w) create line $sx $sy $sx $sy \ -width $wb(curwidth) -fill $wb(curcolor) ] } arrow { set wb(lastx) $sx set wb(lasty) $sy set wb(lastobj,w) [ $wb(canvas,w) create line $sx $sy $sx $sy \ -width $wb(curwidth) -fill $wb(curcolor) \ -arrow last ] } rectempt { set wb(lastx) $sx set wb(lasty) $sy set wb(lastobj,w) [ $wb(canvas,w) create rectangle $sx $sy $sx $sy \ -width $wb(curwidth) -outline $wb(curcolor) ] } rectfill { set wb(lastx) $sx set wb(lasty) $sy set wb(lastobj,w) [ $wb(canvas,w) create rectangle $sx $sy $sx $sy \ -width $wb(curwidth) -fill $wb(curcolor)\ -outline $wb(curcolor) ] } elpsempt { set wb(lastx) $sx set wb(lasty) $sy set wb(lastobj,w) [ $wb(canvas,w) create arc $sx $sy $sx $sy \ -width $wb(curwidth) -outline $wb(curcolor) \ -start 0 -extent 359 -style arc ] } elpsfill { set wb(lastx) $sx set wb(lasty) $sy set wb(lastobj,w) [ $wb(canvas,w) create arc $sx $sy $sx $sy \ -width $wb(curwidth) -fill $wb(curcolor) \ -start 0 -extent 359 -style chord\ -outline $wb(curcolor) ] } default { set wb(generalinfo) "Unknown pen style \"$wb(curstyle)\ \"..." } } } } ################################################################################ # button-motion : mouse callback linked to the canvas. ################################################################################ proc button-motion { nx ny } { global wb if {$wb(insession) && $wb(button-down)} { switch $wb(curstyle) { free { $wb(canvas,w) create line $wb(lastx) \ $wb(lasty) $nx $ny -width $wb(curwidth) \ -fill $wb(curcolor) wbSendOwnCmd [list $wb(curstyle) $wb(lastx) \ $wb(lasty) $nx $ny $wb(curwidth) $wb(curcolor)] set wb(lastx) $nx set wb(lasty) $ny } line - arrow - rectempt - rectfill - elpsempt - elpsfill { $wb(canvas,w) coords $wb(lastobj,w) $wb(lastx) \ $wb(lasty) $nx $ny } default { set wb(generalinfo) "Unknown pen style \"$wb(curstyle)\ \"..." } } } } ################################################################################ # button-release : mouse callback linked to the canvas. ################################################################################ proc button-release { nx ny } { global wb if {$wb(insession) && $wb(button-down)} { set $wb(button-down) 0 switch $wb(curstyle) { free {} line - arrow - rectempt - rectfill - elpsempt - elpsfill { wbSendOwnCmd [list $wb(curstyle) $wb(lastx) \ $wb(lasty) $nx $ny $wb(curwidth) $wb(curcolor)] } default { set wb(generalinfo) "Unknown pen style \"$wb(curstyle)\ \"..." } } } } ################################################################################ # wbMain : main proc. ################################################################################ proc wbMain { } { wm minsize . 640 480 wm resizable . false false wm title . "tkWhiteBoard v0.3" wm deiconify . wbCreateWidgets } package require Img encoding system iso8859-15 wbMain