TclApps Library Source Code
Check-in [59d2cae22c]
Not logged in
Bounty program for improvements to Tcl and certain Tcl packages.

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:Support detection of suspend/resume. Added a muc join hook, ignore empty messages with chatstate notifications in chat windows. Some themeing on the colour dialog.
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: 59d2cae22ccf453650975a16b8d34990669d74ea
User & Date: patthoyts 2009-05-13 12:02:08
Context
2009-05-23
08:01
Add the XMPP.org issuer check-in: 929584d5c5 user: patthoyts tags: trunk
2009-05-13
12:02
Support detection of suspend/resume. Added a muc join hook, ignore empty messages with chatstate notifications in chat windows. Some themeing on the colour dialog. check-in: 59d2cae22c user: patthoyts tags: trunk
2009-04-23
00:54
removed misguided xml quoting from nicks and fixed a bug that prevented sending to a backslashed nick. check-in: b6d9df0907 user: patthoyts tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to apps/tkchat/ChangeLog.








1
2
3
4
5
6
7






2009-04-23  Pat Thoyts  <[email protected]>

 	* tkchat.tcl: removed misguided xml quoting from nicks and fixed a
	bug that prevented sending to a backslashed nick.
	* tkchat.tcl: tighten up our handling of jids by making more use
	of the jidsplit and jidequal functions.

>
>
>
>
>
>
>







1
2
3
4
5
6
7
8
9
10
11
12
13
14
2009-05-13  Pat Thoyts  <[email protected]>

	* tkchat.tcl: Added a muc join hook, ignore empty messages with
	chatstate notifications in chat windows. Some themeing on the
	colour dialog.
	* tkchat_power.tcl: Support detection of suspend/resume.

2009-04-23  Pat Thoyts  <[email protected]>

 	* tkchat.tcl: removed misguided xml quoting from nicks and fixed a
	bug that prevented sending to a backslashed nick.
	* tkchat.tcl: tighten up our handling of jids by making more use
	of the jidsplit and jidequal functions.

Changes to apps/tkchat/tkchat.tcl.

43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
...
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
....
1392
1393
1394
1395
1396
1397
1398
1399

1400
1401
1402
1403
1404
1405
1406
1407
1408

1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
....
5102
5103
5104
5105
5106
5107
5108

5109
5110
5111
5112
5113
5114
5115
....
5124
5125
5126
5127
5128
5129
5130
5131
5132
5133
5134
5135
5136
5137
5138
5139
5140
5141
5142
5143
5144
5145
5146
5147
5148
5149
5150
5151
5152
5153
5154
5155
5156
5157
5158
5159
5160
5161
5162
5163
5164
5165
5166
....
5182
5183
5184
5185
5186
5187
5188
5189
5190
5191
5192
5193
5194
5195
5196
5197
5198
5199
5200
5201
5202
5203
5204
5205
5206
5207
5208
5209
5210
5211
5212
....
8173
8174
8175
8176
8177
8178
8179
8180




8181
8182
8183
8184
8185
8186
8187
....
8190
8191
8192
8193
8194
8195
8196
8197
8198
8199
8200
8201
8202
8203
8204
8205
....
8708
8709
8710
8711
8712
8713
8714



8715
8716
8717
8718
8719
8720
8721
....
9047
9048
9049
9050
9051
9052
9053
9054
9055
9056
9057
9058
9059
9060
9061
package require uri             ; # tcllib

catch {package require tls}	  ; # tls (optional)
catch {package require choosefont}; # font selection (optional) 
catch {package require picoirc}   ; # irc client (optional)
catch {package require img::png}  ; # more image types (optional)
catch {package require img::jpeg} ; # more image types (optional)

package require sha1		; # tcllib
package require jlib		; # jlib
package require muc		; # jlib
package require disco           ; # jlib 

catch {package require khim}    ; # khim (optional)
catch {package require tooltip 1.2};# tooltips (optional)  
................................................................................
    }
}

namespace eval ::tkchat {
    variable chatWindowTitle "The Tcler's Chat"

    variable HEADUrl {http://tcllib.cvs.sourceforge.net/*checkout*/tcllib/tclapps/apps/tkchat/tkchat.tcl?revision=HEAD}
    variable rcsid   {$Id: tkchat.tcl,v 1.465 2009/04/23 00:54:35 patthoyts Exp $}

    variable MSGS
    set MSGS(entered) [list \
	    "%user% has entered the chat!" \
	    "Out of a cloud of smoke, %user% appears!" \
	    "%user% saunters in." \
	    "%user% wanders in." \
................................................................................
    }
}

# Hooks:
#  message hooks are called before displaying a new message
#  preinit hooks are called after app initialization before gui creation
#  init hooks are called after gui creation before login
#  login hooks are called after login

#  version hooks are called once we get the current version from the web
#  save hook are called when saving options to file.
#  options hooks are called to add pages to the Preferences dialog
proc ::tkchat::Hook {do type args} {
    switch -exact -- $type {
	message { set Hook [namespace current]::MessageHooks }
        preinit { set Hook [namespace current]::PreInitHooks }
        init    { set Hook [namespace current]::InitHooks }
        login   { set Hook [namespace current]::LoginHooks }

        version { set Hook [namespace current]::VersionHooks }
        save    { set Hook [namespace current]::SaveHooks }
        options { set Hook [namespace current]::OptionsHooks }
	default {
	    return -code error "unknown hook type \"$type\":\
                must be message, preinit, init, login, version, options or save"
	}
    }
    switch -exact -- $do {
	add {
            if {[llength $args] > 2} {
                return -code error "wrong # args: should be \"add hook cmd ?priority?\""
            }
................................................................................
    foreach idx [lsort [array names Options Macro,*]] {
	$w insert end [format "%-10s  %s" [string range $idx 6 end] $Options($idx)]
    }
}

proc ::tkchat::ChangeColors {} {
    global Options

    variable DlgData
    variable DlgDone
    variable OnlineUsers

    # clear old data
    unset -nocomplain DlgData
    # make copy of current settings
................................................................................
    set t .opts
    catch {destroy $t}
    Dialog $t
    wm protocol $t WM_DELETE_WINDOW {set ::tkchat::DlgDone cancel}
    wm withdraw $t
    wm title $t "Color Settings"

    label $t.l1 -text "Posting Color"
    label $t.l2 -text "Example Text" -background white \
	-foreground \#$DlgData(MyColor) -font ACT
    button $t.myclr -text "Change..." -command {
	set tmp [tk_chooseColor \
		       -title "Select Your User Color" \
		       -initialcolor \#$::tkchat::DlgData(MyColor)]
	if { $tmp ne "" } {
	    .opts.l2 configure -foreground $tmp
	    set ::tkchat::DlgData(MyColor) [string range $tmp 1 end]
	}
    }

    label $t.l3 -text "Display Color Overrides"
    frame $t.f -relief sunken -bd 2 -height 300
    canvas $t.f.cvs -yscrollcommand [list $t.f.scr set] \
	  -width 10 -height 300 -highlightthickness 0 -bd 0
    bind $t <Button-4> [list $t.f.cvs yview scroll -1 units]
    bind $t <Button-5> [list $t.f.cvs yview scroll  1 units]
    scrollbar $t.f.scr -command [list $t.f.cvs yview]
    pack $t.f.cvs -side left -expand 1 -fill both
    pack $t.f.scr -side left -fill y
    set f [frame $t.f.cvs.frm]
    $t.f.cvs create window 0 0 -anchor nw -window $f
    bind $f <Configure> {
	[winfo parent %W] configure -width [expr {%w+5}] -scrollregion [list 0 0 %w %h]
    }
    foreach {key str} { 1 "All\nDefault" 2 "All\nInverted" 3 "All\nCustom"} {
	button $f.all$key -text $str -padx 0 -pady 0 -command \
		[string map [list %val% $key] {
		    foreach idx [array names DlgData Color,*] {
			set idx [string range $idx 6 end]
			set DlgData($idx) %val%
		    }
		}]
    }
................................................................................
    grid [label $f.offline -text "Offline Users"] - - -
    foreach nick $Options(NickList) {
	set nick [lindex $nick 0]
	if { [lsearch -exact $UserList $nick] == -1 } {
	    buildRow $f NICK-$nick $nick
	}
    }
    frame $t.f2
    button $t.f2.ok \
	    -width 8 \
	    -text "OK" \
	    -command { set ::tkchat::DlgDone ok }
    button $t.f2.app \
	    -width 8 \
	    -text "Apply" \
	    -command { set ::tkchat::DlgDone apply }
    button $t.f2.can \
	    -width 8 \
	    -text "Cancel" \
	    -command { set ::tkchat::DlgDone cancel}
    pack $t.f2.ok $t.f2.app $t.f2.can -side left -expand 1 -fill none

    grid $t.l1  $t.l2 $t.myclr x -padx 1 -pady 3 -sticky {}
    grid $t.l3    -       -    - -padx 1 -pady 3 -sticky ew
    grid $t.f     -       -    - -padx 1 -pady 5 -sticky news
    grid $t.f2    -       -    - -padx 1 -pady 10 -sticky news
    grid rowconfigure $t 2 -weight 1
    grid columnconfigure $t 3 -weight 1
    wm resizable $t 0 1
    catch {::tk::PlaceWindow $t widget .}
    wm deiconify $t
................................................................................
            if {[jlib::jidequal [email protected]$domain $conference]} {
                set from $resource
                set w [getChatWidget $m(-from) $from]
            } else {
                set from $node
                set w [getChatWidget $m(-from) $from]
            }
            




            LogPrivateChat [normalized_jid $m(-from)] \
                $from $timestamp $m(-body)
	    if {$w eq ".txt"} {
		::tkchat::addMessage $w $color $from " whispers: $m(-body)" \
			ACTION end $timestamp
	    } else {
		if { [string match -nocase "/me *" $m(-body)] } {
................................................................................
		} else {
		    set msgtype NORMAL
                    if {[string match "Realname*" $m(-body)]} {
                        # We are handling IRC whois data - should do some 
                        # caching if we can get the nick (mod the bridge)
                    }
		}
		::tkchat::addMessage \
			$w $color $from $m(-body) $msgtype end $timestamp
	    }
	}
	groupchat {
            jlib::splitjidex $m(-from) node domain nick
	    if { [info exists m(-subject)] && $m(-subject) ne ""} {
		# changing topic.
		variable ::tkchat::chatWindowTitle
................................................................................
		$jabber send_presence -type available -from $jid \
                    -to $conference -show away -status $AwayStatus \
                    -extras [list [get_caps]]
	    }
            tkchat::addStatus 0 "Joined chat at $conference"
	    autoStatus
            #after 500 [namespace origin ParticipantVersions]



	}
	default {
	    ::tkchat::addSystem .txt "MucEnter: type=$type, args='$args'"
	}
    }
}

................................................................................
		}
		away {
		    .pane.names image create $mark -image ::tkchat::roster::away
		}
		xa {
		    .pane.names image create $mark -image ::tkchat::roster::xa
		}
		disabled {
		    .pane.names image create $mark -image ::tkchat::roster::disabled
		}
	    }
	    if { [info exists OnlineUsers($network-$nick,jid)] } {
                set tags [list NICK NICK-$nick URL URL-[incr ::URLID]]
		.pane.names insert $mark "$nick" $tags "\n" NICK
		.pane.names tag bind URL-$::URLID <Button-1> [list \






|







 







|







 







|
>









>





|







 







>







 







|


|









|
<




|








|







 







|
|
<
<
|
|
<
<
|
|
<
<
|



|







 







|
>
>
>
>







 







|
|







 







>
>
>







 







|







43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
...
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
....
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
....
5104
5105
5106
5107
5108
5109
5110
5111
5112
5113
5114
5115
5116
5117
5118
....
5127
5128
5129
5130
5131
5132
5133
5134
5135
5136
5137
5138
5139
5140
5141
5142
5143
5144
5145
5146
5147

5148
5149
5150
5151
5152
5153
5154
5155
5156
5157
5158
5159
5160
5161
5162
5163
5164
5165
5166
5167
5168
....
5184
5185
5186
5187
5188
5189
5190
5191
5192


5193
5194


5195
5196


5197
5198
5199
5200
5201
5202
5203
5204
5205
5206
5207
5208
....
8169
8170
8171
8172
8173
8174
8175
8176
8177
8178
8179
8180
8181
8182
8183
8184
8185
8186
8187
....
8190
8191
8192
8193
8194
8195
8196
8197
8198
8199
8200
8201
8202
8203
8204
8205
....
8708
8709
8710
8711
8712
8713
8714
8715
8716
8717
8718
8719
8720
8721
8722
8723
8724
....
9050
9051
9052
9053
9054
9055
9056
9057
9058
9059
9060
9061
9062
9063
9064
package require uri             ; # tcllib

catch {package require tls}	  ; # tls (optional)
catch {package require choosefont}; # font selection (optional) 
catch {package require picoirc}   ; # irc client (optional)
catch {package require img::png}  ; # more image types (optional)
catch {package require img::jpeg} ; # more image types (optional)
 
package require sha1		; # tcllib
package require jlib		; # jlib
package require muc		; # jlib
package require disco           ; # jlib 

catch {package require khim}    ; # khim (optional)
catch {package require tooltip 1.2};# tooltips (optional)  
................................................................................
    }
}

namespace eval ::tkchat {
    variable chatWindowTitle "The Tcler's Chat"

    variable HEADUrl {http://tcllib.cvs.sourceforge.net/*checkout*/tcllib/tclapps/apps/tkchat/tkchat.tcl?revision=HEAD}
    variable rcsid   {$Id: tkchat.tcl,v 1.466 2009/05/13 12:02:08 patthoyts Exp $}

    variable MSGS
    set MSGS(entered) [list \
	    "%user% has entered the chat!" \
	    "Out of a cloud of smoke, %user% appears!" \
	    "%user% saunters in." \
	    "%user% wanders in." \
................................................................................
    }
}

# Hooks:
#  message hooks are called before displaying a new message
#  preinit hooks are called after app initialization before gui creation
#  init hooks are called after gui creation before login
#  login hooks are called after login to the jabber server
#  join hooks are called after successfully joining a conference
#  version hooks are called once we get the current version from the web
#  save hook are called when saving options to file.
#  options hooks are called to add pages to the Preferences dialog
proc ::tkchat::Hook {do type args} {
    switch -exact -- $type {
	message { set Hook [namespace current]::MessageHooks }
        preinit { set Hook [namespace current]::PreInitHooks }
        init    { set Hook [namespace current]::InitHooks }
        login   { set Hook [namespace current]::LoginHooks }
        join    { set Hook [namespace current]::JoinHooks }
        version { set Hook [namespace current]::VersionHooks }
        save    { set Hook [namespace current]::SaveHooks }
        options { set Hook [namespace current]::OptionsHooks }
	default {
	    return -code error "unknown hook type \"$type\":\
                must be message, preinit, init, login, join, version, options or save"
	}
    }
    switch -exact -- $do {
	add {
            if {[llength $args] > 2} {
                return -code error "wrong # args: should be \"add hook cmd ?priority?\""
            }
................................................................................
    foreach idx [lsort [array names Options Macro,*]] {
	$w insert end [format "%-10s  %s" [string range $idx 6 end] $Options($idx)]
    }
}

proc ::tkchat::ChangeColors {} {
    global Options
    variable NS
    variable DlgData
    variable DlgDone
    variable OnlineUsers

    # clear old data
    unset -nocomplain DlgData
    # make copy of current settings
................................................................................
    set t .opts
    catch {destroy $t}
    Dialog $t
    wm protocol $t WM_DELETE_WINDOW {set ::tkchat::DlgDone cancel}
    wm withdraw $t
    wm title $t "Color Settings"

    ${NS}::label $t.l1 -text "Posting Color"
    label $t.l2 -text "Example Text" -background white \
	-foreground \#$DlgData(MyColor) -font ACT
    ${NS}::button $t.myclr -text "Change..." -command {
	set tmp [tk_chooseColor \
		       -title "Select Your User Color" \
		       -initialcolor \#$::tkchat::DlgData(MyColor)]
	if { $tmp ne "" } {
	    .opts.l2 configure -foreground $tmp
	    set ::tkchat::DlgData(MyColor) [string range $tmp 1 end]
	}
    }

    ${NS}::labelframe $t.f -text "Colour overrides" -height 300

    canvas $t.f.cvs -yscrollcommand [list $t.f.scr set] \
	  -width 10 -height 300 -highlightthickness 0 -bd 0
    bind $t <Button-4> [list $t.f.cvs yview scroll -1 units]
    bind $t <Button-5> [list $t.f.cvs yview scroll  1 units]
    ${NS}::scrollbar $t.f.scr -command [list $t.f.cvs yview]
    pack $t.f.cvs -side left -expand 1 -fill both
    pack $t.f.scr -side left -fill y
    set f [frame $t.f.cvs.frm]
    $t.f.cvs create window 0 0 -anchor nw -window $f
    bind $f <Configure> {
	[winfo parent %W] configure -width [expr {%w+5}] -scrollregion [list 0 0 %w %h]
    }
    foreach {key str} { 1 "All\nDefault" 2 "All\nInverted" 3 "All\nCustom"} {
	button $f.all$key -text $str -command \
		[string map [list %val% $key] {
		    foreach idx [array names DlgData Color,*] {
			set idx [string range $idx 6 end]
			set DlgData($idx) %val%
		    }
		}]
    }
................................................................................
    grid [label $f.offline -text "Offline Users"] - - -
    foreach nick $Options(NickList) {
	set nick [lindex $nick 0]
	if { [lsearch -exact $UserList $nick] == -1 } {
	    buildRow $f NICK-$nick $nick
	}
    }
    ${NS}::frame $t.f2
    ${NS}::button $t.f2.ok -text "OK" -default active\


        -command { set ::tkchat::DlgDone ok }
    ${NS}::button $t.f2.app -text "Apply" \


        -command { set ::tkchat::DlgDone apply }
    ${NS}::button $t.f2.can -text "Cancel" \


        -command { set ::tkchat::DlgDone cancel}
    pack $t.f2.ok $t.f2.app $t.f2.can -side left -expand 1 -fill none

    grid $t.l1  $t.l2 $t.myclr x -padx 1 -pady 3 -sticky {}
    #grid $t.l3    -       -    - -padx 1 -pady 3 -sticky ew
    grid $t.f     -       -    - -padx 1 -pady 5 -sticky news
    grid $t.f2    -       -    - -padx 1 -pady 10 -sticky news
    grid rowconfigure $t 2 -weight 1
    grid columnconfigure $t 3 -weight 1
    wm resizable $t 0 1
    catch {::tk::PlaceWindow $t widget .}
    wm deiconify $t
................................................................................
            if {[jlib::jidequal [email protected]$domain $conference]} {
                set from $resource
                set w [getChatWidget $m(-from) $from]
            } else {
                set from $node
                set w [getChatWidget $m(-from) $from]
            }

            # If someone sends chatstate notifications we may
            # get empty bodies. Ignore them.
            if {[string length $m(-body)] == 0} { return }

            LogPrivateChat [normalized_jid $m(-from)] \
                $from $timestamp $m(-body)
	    if {$w eq ".txt"} {
		::tkchat::addMessage $w $color $from " whispers: $m(-body)" \
			ACTION end $timestamp
	    } else {
		if { [string match -nocase "/me *" $m(-body)] } {
................................................................................
		} else {
		    set msgtype NORMAL
                    if {[string match "Realname*" $m(-body)]} {
                        # We are handling IRC whois data - should do some 
                        # caching if we can get the nick (mod the bridge)
                    }
		}
                ::tkchat::addMessage \
                    $w $color $from $m(-body) $msgtype end $timestamp
	    }
	}
	groupchat {
            jlib::splitjidex $m(-from) node domain nick
	    if { [info exists m(-subject)] && $m(-subject) ne ""} {
		# changing topic.
		variable ::tkchat::chatWindowTitle
................................................................................
		$jabber send_presence -type available -from $jid \
                    -to $conference -show away -status $AwayStatus \
                    -extras [list [get_caps]]
	    }
            tkchat::addStatus 0 "Joined chat at $conference"
	    autoStatus
            #after 500 [namespace origin ParticipantVersions]

	    # We have joined the conference so run any join hooks
            ::tkchat::Hook run join -muc $conference -nick [$muc mynick $conference]
	}
	default {
	    ::tkchat::addSystem .txt "MucEnter: type=$type, args='$args'"
	}
    }
}

................................................................................
		}
		away {
		    .pane.names image create $mark -image ::tkchat::roster::away
		}
		xa {
		    .pane.names image create $mark -image ::tkchat::roster::xa
		}
		disabled - offline {
		    .pane.names image create $mark -image ::tkchat::roster::disabled
		}
	    }
	    if { [info exists OnlineUsers($network-$nick,jid)] } {
                set tags [list NICK NICK-$nick URL URL-[incr ::URLID]]
		.pane.names insert $mark "$nick" $tags "\n" NICK
		.pane.names tag bind URL-$::URLID <Button-1> [list \

Added apps/tkchat/tkchat_power.tcl.


























































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
# Tkchat plugin that listens for power announcements and suspend changes.
#
# We should record the suspension time so that on resume we can decide
# if we should override the history reload and send a presence notification
# that we are offline.
#
# Requires the winpm extension from http://tkwinpm.googlecode.com/

if {[catch {
    package require winpm
}]} {
    return
}
namespace eval ::tkchat::power {
    variable version 1.0.0
    variable suspended 0
}

proc ::tkchat::power::OnSuspend {} {
    variable suspended [clock seconds]
    ::tkchat::addSystem .txt "system suspended"
    catch {::tkjabber::away "system going to sleep" offline}
}

proc ::tkchat::power::OnResume {} {
    global Options
    variable suspended
    set msg "system resumed"
    if {$Options(HistoryLines) != 0 && ([clock seconds] - $suspended) > 300} {
        set ::tkjabber::HaveHistory 0
        append msg ", enabling history refetch on reconnection"
    }
    tkchat::addSystem .txt $msg
    catch {::tkjabber::back "system resumed" online}
}

proc ::tkchat::power::InitHook {} {
    winpm bind PBT_APMSUSPEND [list [namespace origin OnSuspend]]
    winpm bind PBT_APMRESUMESUSPEND [list [namespace origin OnResume]]
}

# -------------------------------------------------------------------------
::tkchat::Hook add init ::tkchat::power::InitHook
package provide tkchat::power $::tkchat::power::version
# -------------------------------------------------------------------------