TclApps Library Source Code
Check-in [b6d9df0907]
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:removed misguided xml quoting from nicks and fixed a bug that prevented sending to a backslashed nick.
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: b6d9df09079433074f6d749d79b2ea2ad8f454f3
User & Date: patthoyts 2009-04-23 00:54:35
Context
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
2009-04-22
23:15
Tightened up on the handling of jids by making use of jidsplit and jidequal check-in: 8ca38c4784 user: patthoyts tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to apps/tkchat/ChangeLog.

1
2


3
4
5
6
7
8
9
2009-04-23  Pat Thoyts  <[email protected]>



	* tkchat.tcl: tighten up our handling of jids by making more use
	of the jidsplit and jidequal functions.

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

	* tkchat.tcl: Applied MacOSX patch from Daniel Steffen


>
>







1
2
3
4
5
6
7
8
9
10
11
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.

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

	* tkchat.tcl: Applied MacOSX patch from Daniel Steffen

Changes to apps/tkchat/tkchat.tcl.

254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
....
4612
4613
4614
4615
4616
4617
4618

4619
4620
4621
4622
4623
4624
4625
....
6233
6234
6235
6236
6237
6238
6239

6240
6241
6242
6243
6244
6245
6246
....
8280
8281
8282
8283
8284
8285
8286
8287
8288
8289
8290
8291
8292
8293
8294
8295
....
8574
8575
8576
8577
8578
8579
8580
8581
8582
8583
8584
8585
8586
8587
8588
....
8643
8644
8645
8646
8647
8648
8649
8650
8651
8652
8653
8654
8655
8656
8657
....
8676
8677
8678
8679
8680
8681
8682
8683
8684
8685
8686
8687
8688
8689
8690
....
8829
8830
8831
8832
8833
8834
8835
8836
8837
8838
8839
8840
8841
8842
8843
....
8847
8848
8849
8850
8851
8852
8853
8854
8855
8856
8857
8858
8859
8860
8861
8862
....
9260
9261
9262
9263
9264
9265
9266

9267
9268
9269
9270
9271
9272
9273
9274
9275
9276
....
9295
9296
9297
9298
9299
9300
9301
9302
9303
9304
9305
9306
9307
9308
9309
....
9332
9333
9334
9335
9336
9337
9338
9339
9340
9341
9342
9343
9344
9345
9346
.....
10000
10001
10002
10003
10004
10005
10006
10007
10008
10009
10010
10011
10012
10013
10014
    }
}

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.464 2009/04/22 23:15:57 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." \
................................................................................
    focus -force .logon.ok
    grab .logon
    vwait ::tkchat::DlgDone
    grab release .logon
    wm withdraw .logon
    if { $DlgDone eq "ok" } {
        unset -nocomplain Options(ProxyAuth)


	# connect
	logonChat
    }
}

proc ::tkchat::IRCLogonScreen {} {
................................................................................
    return [array get Defaults]
}

proc ::tkchat::setNickname { nick } {
    global Options
    variable ::tkjabber::baseNick


    if { ![info exist Options(Color,NICK-$nick)] } {
	if { [info exists Options(Color,NICK-$baseNick)] } {
	    set Options(Color,NICK-$nick) $Options(Color,NICK-$baseNick)
	} else {
	    set Options(Color,NICK-$nick) $Options(Color,MainFG)
	}
    }
................................................................................
			}] } {
			    ::log::log debug "MUC EXIT: $::errorInfo"
			}
			set msg [lindex $m(-error) 1]
			::tkchat::addSystem .txt \
				"$m(-from): $msg. Trying to get in again..."
			$muc enter $::tkjabber::conference \
				[xmlSafe $::Options(Nickname)] \
				-command ::tkjabber::MucEnterCB
		    }
		    default {
			::tkchat::addSystem .txt  "MsgCB (error) args='$args'"
		    }
		}
	    }
	}
................................................................................
	    if { $::Options(Nickname) eq "" } {
		::tkchat::setNickname $::Options(Username)
	    }
	    set baseNick $::Options(Nickname)
	    set nickTries 0
            if {[string length $conference] > 0} {
                after idle [list $muc enter $conference \
                                [xmlSafe $::Options(Nickname)] \
                                -command ::tkjabber::MucEnterCB]
            }
            ::tkchat::SetServerTooltip

	    # We are logged in. Now any of the callbacks can be called,
	    # Likely ones are MsgCB, MucEnterCB, RosterCB for normal traffic.
            ::tkchat::Hook run login
................................................................................
		}
		404 - "item-not-found" {
                    if {$mucTries < 3} {
                        ::tkchat::addSystem .txt "This room is unavailable.\
                           Retrying in 30 seconds..."
                        incr mucTries
                        after 10000 [list $muc enter $conference \
                                         [xmlSafe $::Options(Nickname)] \
                                         -command ::tkjabber::MucEnterCB]
                    } else {
                        ::tkchat::addSystem .txt "This room does not exist."
                    }
		}
		405 - "service-unavailable" {
		    ::tkchat::addSystem .txt [concat \
................................................................................
			if { $nickTries < 3 } {
			    ::tkchat::setNickname "$::Options(Nickname)_"
			} else {
			    ::tkchat::setNickname "${baseNick}_$nickTries"
			}
			::tkchat::addSystem .txt \
			    "Trying to enter using $::Options(Nickname)."
			$muc enter $conference [xmlSafe $::Options(Nickname)] \
				-command ::tkjabber::MucEnterCB
		    }
		}
		default {
		    ::tkchat::addSystem .txt \
			    "An error occurred joining $conference.\
                             Unfortunately '[lindex $m(-error) 0]' was not\
................................................................................
	}
	if { !$found } {
	    ::tkchat::addStatus 0 "Unknown nick name '$user'"
	    return
	}
    }
    if { [llength $users] == 0 } {
	set users $user
    }

    # Example usage
    #set x [wrapper::createtag x -attrlist {xmlns urn:tkchat:chat} \
    #    -subtags [list [wrapper::createtag color \
    #                        -attrlist {attr1 val1 attr2 val2} \
    #                        -chdata $::Options(MyColor)]]]
................................................................................

    set xlist [concat [list [wrapper::createtag x -attrlist $attrs]] \
		   $opts(-xlist)]
    ::log::log debug "send_message $msg $xlist"
    foreach user $users {
	$jabber send_message $user -body $msg -type $type -xlist $xlist
    }
    #-xlist [wrapper::createtag x -attrlist {xmlns http://tcl.tk/tkchat foo bar}]

}

# returns true if a jid is a participant in the conference.
proc ::tkjabber::is_participant {jid} {
    variable muc
    variable conference
    foreach participant [$muc participants $conference] {
................................................................................
    variable conference
    variable roster
    variable jabber
    variable grabNick
    variable baseNick
    variable ::tkchat::OnlineUsers


    if { [lsearch -exact $OnlineUsers(Jabber) $newnick] > -1 } {
	# Perhaps it is my own nick, in another window?
	set x [$roster getx $conference/[xmlSafe $newnick] "muc#user"]
        set item [wrapper::getchildswithtag $x item]
	set otherjid ""
	if {[llength $item] > 0} {
	    set otherjid [wrapper::getattribute [lindex $item 0] jid]
	}
        jlib::splitjid [$jabber myjid] myjid myres

................................................................................
	return
    }

    # There is a race condition here. new nick could enter between the check
    # and the setnick call...
    ::tkchat::setNickname $newnick
    set baseNick $newnick
    $muc setnick $conference [xmlSafe $newnick]
}

proc ::tkjabber::transferNick { reqfrom } {
    variable muc
    variable conference
    variable roster
    variable jabber
................................................................................
	::tkchat::addStatus 0 \
		"Got a nick transfer request, but $newnick is already in use."
	return
    }

    # Set my nick name to newnick.
    ::tkchat::setNickname $newnick
    $muc setnick $conference [xmlSafe $newnick]

    # The other party does not need to be notified
    # - it should be in nickgrab mode.
}

proc ::tkjabber::setTopic { newtopic } {
    variable conference
................................................................................
}

proc ::tkjabber::LogPrivateChat {user spkr ztime message} {
    global Options env
    if {![info exist env(HOME)]} { return }
    if {[info exists Options(LogPrivateChat)] && $Options(LogPrivateChat)} {
        variable PrivateChatLogs
        set user [string map {/ _ \\ _ : _ . _} $user]
        if {![info exists PrivateChatLogs]} { array set PrivateChatLogs {} }
        if {![info exists PrivateChatLogs($user)]} {
            set dir [file join $env(HOME) .tkchat_logs]
            if {![file isdirectory $dir]} {
                file mkdir $dir
                catch {file attributes $dir -hidden 1}
            }






|







 







>







 







>







 







|
|







 







|







 







|







 







|







 







|







 







<
<







 







>


|







 







|







 







|







 







|







254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
....
4612
4613
4614
4615
4616
4617
4618
4619
4620
4621
4622
4623
4624
4625
4626
....
6234
6235
6236
6237
6238
6239
6240
6241
6242
6243
6244
6245
6246
6247
6248
....
8282
8283
8284
8285
8286
8287
8288
8289
8290
8291
8292
8293
8294
8295
8296
8297
....
8576
8577
8578
8579
8580
8581
8582
8583
8584
8585
8586
8587
8588
8589
8590
....
8645
8646
8647
8648
8649
8650
8651
8652
8653
8654
8655
8656
8657
8658
8659
....
8678
8679
8680
8681
8682
8683
8684
8685
8686
8687
8688
8689
8690
8691
8692
....
8831
8832
8833
8834
8835
8836
8837
8838
8839
8840
8841
8842
8843
8844
8845
....
8849
8850
8851
8852
8853
8854
8855


8856
8857
8858
8859
8860
8861
8862
....
9260
9261
9262
9263
9264
9265
9266
9267
9268
9269
9270
9271
9272
9273
9274
9275
9276
9277
....
9296
9297
9298
9299
9300
9301
9302
9303
9304
9305
9306
9307
9308
9309
9310
....
9333
9334
9335
9336
9337
9338
9339
9340
9341
9342
9343
9344
9345
9346
9347
.....
10001
10002
10003
10004
10005
10006
10007
10008
10009
10010
10011
10012
10013
10014
10015
    }
}

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." \
................................................................................
    focus -force .logon.ok
    grab .logon
    vwait ::tkchat::DlgDone
    grab release .logon
    wm withdraw .logon
    if { $DlgDone eq "ok" } {
        unset -nocomplain Options(ProxyAuth)
        set Options(Nickname) [jlib::resourceprep $Options(Nickname)]

	# connect
	logonChat
    }
}

proc ::tkchat::IRCLogonScreen {} {
................................................................................
    return [array get Defaults]
}

proc ::tkchat::setNickname { nick } {
    global Options
    variable ::tkjabber::baseNick

    set nick [jlib::resourceprep $nick]
    if { ![info exist Options(Color,NICK-$nick)] } {
	if { [info exists Options(Color,NICK-$baseNick)] } {
	    set Options(Color,NICK-$nick) $Options(Color,NICK-$baseNick)
	} else {
	    set Options(Color,NICK-$nick) $Options(Color,MainFG)
	}
    }
................................................................................
			}] } {
			    ::log::log debug "MUC EXIT: $::errorInfo"
			}
			set msg [lindex $m(-error) 1]
			::tkchat::addSystem .txt \
				"$m(-from): $msg. Trying to get in again..."
			$muc enter $::tkjabber::conference \
                            $::Options(Nickname)\
                            -command ::tkjabbjler::MucEnterCB
		    }
		    default {
			::tkchat::addSystem .txt  "MsgCB (error) args='$args'"
		    }
		}
	    }
	}
................................................................................
	    if { $::Options(Nickname) eq "" } {
		::tkchat::setNickname $::Options(Username)
	    }
	    set baseNick $::Options(Nickname)
	    set nickTries 0
            if {[string length $conference] > 0} {
                after idle [list $muc enter $conference \
                                $::Options(Nickname) \
                                -command ::tkjabber::MucEnterCB]
            }
            ::tkchat::SetServerTooltip

	    # We are logged in. Now any of the callbacks can be called,
	    # Likely ones are MsgCB, MucEnterCB, RosterCB for normal traffic.
            ::tkchat::Hook run login
................................................................................
		}
		404 - "item-not-found" {
                    if {$mucTries < 3} {
                        ::tkchat::addSystem .txt "This room is unavailable.\
                           Retrying in 30 seconds..."
                        incr mucTries
                        after 10000 [list $muc enter $conference \
                                         $::Options(Nickname) \
                                         -command ::tkjabber::MucEnterCB]
                    } else {
                        ::tkchat::addSystem .txt "This room does not exist."
                    }
		}
		405 - "service-unavailable" {
		    ::tkchat::addSystem .txt [concat \
................................................................................
			if { $nickTries < 3 } {
			    ::tkchat::setNickname "$::Options(Nickname)_"
			} else {
			    ::tkchat::setNickname "${baseNick}_$nickTries"
			}
			::tkchat::addSystem .txt \
			    "Trying to enter using $::Options(Nickname)."
			$muc enter $conference $::Options(Nickname) \
				-command ::tkjabber::MucEnterCB
		    }
		}
		default {
		    ::tkchat::addSystem .txt \
			    "An error occurred joining $conference.\
                             Unfortunately '[lindex $m(-error) 0]' was not\
................................................................................
	}
	if { !$found } {
	    ::tkchat::addStatus 0 "Unknown nick name '$user'"
	    return
	}
    }
    if { [llength $users] == 0 } {
	set users [list $user]
    }

    # Example usage
    #set x [wrapper::createtag x -attrlist {xmlns urn:tkchat:chat} \
    #    -subtags [list [wrapper::createtag color \
    #                        -attrlist {attr1 val1 attr2 val2} \
    #                        -chdata $::Options(MyColor)]]]
................................................................................

    set xlist [concat [list [wrapper::createtag x -attrlist $attrs]] \
		   $opts(-xlist)]
    ::log::log debug "send_message $msg $xlist"
    foreach user $users {
	$jabber send_message $user -body $msg -type $type -xlist $xlist
    }


}

# returns true if a jid is a participant in the conference.
proc ::tkjabber::is_participant {jid} {
    variable muc
    variable conference
    foreach participant [$muc participants $conference] {
................................................................................
    variable conference
    variable roster
    variable jabber
    variable grabNick
    variable baseNick
    variable ::tkchat::OnlineUsers

    set newnick [jlib::resourceprep $newnick]
    if { [lsearch -exact $OnlineUsers(Jabber) $newnick] > -1 } {
	# Perhaps it is my own nick, in another window?
	set x [$roster getx $conference/$newnick "muc#user"]
        set item [wrapper::getchildswithtag $x item]
	set otherjid ""
	if {[llength $item] > 0} {
	    set otherjid [wrapper::getattribute [lindex $item 0] jid]
	}
        jlib::splitjid [$jabber myjid] myjid myres

................................................................................
	return
    }

    # There is a race condition here. new nick could enter between the check
    # and the setnick call...
    ::tkchat::setNickname $newnick
    set baseNick $newnick
    $muc setnick $conference $newnick
}

proc ::tkjabber::transferNick { reqfrom } {
    variable muc
    variable conference
    variable roster
    variable jabber
................................................................................
	::tkchat::addStatus 0 \
		"Got a nick transfer request, but $newnick is already in use."
	return
    }

    # Set my nick name to newnick.
    ::tkchat::setNickname $newnick
    $muc setnick $conference $newnick

    # The other party does not need to be notified
    # - it should be in nickgrab mode.
}

proc ::tkjabber::setTopic { newtopic } {
    variable conference
................................................................................
}

proc ::tkjabber::LogPrivateChat {user spkr ztime message} {
    global Options env
    if {![info exist env(HOME)]} { return }
    if {[info exists Options(LogPrivateChat)] && $Options(LogPrivateChat)} {
        variable PrivateChatLogs
        set user [string map {/ _ \\ _ : _ . _ < _ > _} $user]
        if {![info exists PrivateChatLogs]} { array set PrivateChatLogs {} }
        if {![info exists PrivateChatLogs($user)]} {
            set dir [file join $env(HOME) .tkchat_logs]
            if {![file isdirectory $dir]} {
                file mkdir $dir
                catch {file attributes $dir -hidden 1}
            }