TkWhiteboard est un "tableau blanc" entièrement écrit en Tcl/Tk, sans distinction de système d'exploitation (Linux, Mac, Windows, ...). Il permet de tenir des "conférences manuscrites" entre plusieurs utilisateurs distants sur un réseau (protocole TCP/IP), par exemple deux personnes conversant par téléphone et souhaitant simultanément gribouiller des équations de mathématiques "à la main" via internet. Les utilisateurs travaillent ensemble sur la même "feuille", l'un pouvant gommer le travail de l'autre. Il n'est pas encore possible de sauvegarder la session, ni taper du texte avec le clavier. Une tablette graphique est donc nécessaire à la plupart des cas d'utilisation. L'interface est écrite en Anglais. La licence est la GPL.
Utilisation test :
Assurez-vous que Tcl/Tk est installé sur votre ordinateur, ainsi qu'un accès réseau quelconque en TCP/IP (internet, réseau local).. Lancer deux fois TkWhiteboard, pour initier une "conférence" sur le même ordinateur. Sur l'une des applications, cliquer sur le bouton "Create server". Sur l'autre application, cliquer sur le bouton "Connect to server". Voilà, votre ordinateur fait correspondre deux tableaux blancs, l'un serveur, l'autre client. Ecrivez quelquechose sur l'une des applications et sa copie apparaît automatiquement sur l'autre.
Utilisation normale :
1) Pour créer le serveur : Choisir un numéro de "port", un nombre compris entre 1024 et 65535 Choisir un mot de passe. Cliquer sur le bouton "Create server".
2) Pour rejoindre la conférence depuis un autre ordinateur : Entrer le numéro d'IP du serveur. Entrer le numéro de "port" choisi pour le serveur. Entrer le mot de passe. Cliquer sur le bouton "Connect to server".
Le code :
#!/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 {# @} <jeanyves.chasle#free.fr>]
# David Zolli [string map {# @} <kroc#kroc.tk>]
#
################################################################################
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-1> {button-down %x %y}
bind $wb(canvas,w) <B1-Motion> {button-motion %x %y}
bind $wb(canvas,w) <ButtonRelease-1> {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) <Button-1> {
$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) <B1-Motion> {}
bind $wb(canvas,w) <ButtonRelease-1> {}
tkwait variable wb(txt)
bind $wb(canvas,w) <Button-1> {button-down %x %y}
bind $wb(canvas,w) <B1-Motion> {button-motion %x %y}
bind $wb(canvas,w) <ButtonRelease-1> {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 <KeyPress-Return> {.contenu.fond.boutons.ok invoke}
bind .contenu <KeyPress-KP_Enter> {.contenu.fond.boutons.ok invoke}
bind .contenu <KeyPress-Escape> {.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