[Tkabber-dev] r882 - in trunk/tkabber: . examples/configs ifacetk jabberlib-tclxml plugins/chat plugins/general plugins/iq

tkabber-svn at jabber.ru tkabber-svn at jabber.ru
Fri Jan 26 20:56:06 MSK 2007


Author: sergei
Date: 2007-01-26 20:55:57 +0300 (Fri, 26 Jan 2007)
New Revision: 882

Added:
   trunk/tkabber/plugins/chat/muc_ignore.tcl
   trunk/tkabber/plugins/chat/update_tab.tcl
Modified:
   trunk/tkabber/ChangeLog
   trunk/tkabber/chats.tcl
   trunk/tkabber/custom.tcl
   trunk/tkabber/examples/configs/mtr-config.tcl
   trunk/tkabber/ifacetk/iface.tcl
   trunk/tkabber/jabberlib-tclxml/jabberlib.tcl
   trunk/tkabber/login.tcl
   trunk/tkabber/muc.tcl
   trunk/tkabber/plugins/chat/draw_error.tcl
   trunk/tkabber/plugins/chat/draw_info.tcl
   trunk/tkabber/plugins/chat/draw_normal_message.tcl
   trunk/tkabber/plugins/chat/draw_server_message.tcl
   trunk/tkabber/plugins/chat/draw_xhtml_message.tcl
   trunk/tkabber/plugins/chat/me_command.tcl
   trunk/tkabber/plugins/general/headlines.tcl
   trunk/tkabber/plugins/general/message_archive.tcl
   trunk/tkabber/plugins/general/rawxml.tcl
   trunk/tkabber/plugins/iq/ping.tcl
   trunk/tkabber/utils.tcl
Log:
	* jabberlib-tclxml/jabberlib.tcl: Added -timeout option to send_iq.

	* login.tcl: Removed unnecessary check whether "replace connections"
	  is set. Added extra call to jlib::disconnect to client:reconnect
	  procedure.

	* plugins/iq/ping.tcl: Implemented aggressive server ping with
	  reconnection on ping timeout.

	* utils.tcl: Added function caller, which returns the name
	  of upper level procedure or empty string if it is called at levels 0
	  or 1 (thanks to Konstantin Khomoutov).

	* custom.tcl: Use caller procedure from utils.tcl (thanks to
	  Konstantin Khomoutov).

	* examples/configs/mtr-config.tcl, ifacetk/iface.tcl,
	  plugins/chat/draw_error.tcl, plugins/chat/draw_info.tcl,
	  plugins/chat/draw_normal_message.tcl,
	  plugins/chat/draw_server_message.tcl,
	  plugins/chat/draw_xhtml_message.tcl,
	  plugins/chat/me_command.tcl,
	  plugins/general/headlines.tcl, plugins/general/message_archive.tcl,
	  plugins/general/rawxml.tcl, plugins/chat/update_tab.tcl: Moved
	  most instances of tab_set_updated calls to ifacetk/iface.tcl and
	  plugins/chat/update_tab.tcl.

	* ifacetk/iface.tcl, plugins/chat/draw_normal_message.tcl,
	  plugins/chat/me_command.tcl, plugins/chat/update_tab.tcl,
	  plugins/chat/muc_ignore.tcl: Added new plugin, which allows to
	  ignore messages from given conference occupants. It is not finished
	  yet, but usable. (Thanks to Konstantin Khomoutov.)


Modified: trunk/tkabber/ChangeLog
===================================================================
--- trunk/tkabber/ChangeLog	2007-01-22 12:08:18 UTC (rev 881)
+++ trunk/tkabber/ChangeLog	2007-01-26 17:55:57 UTC (rev 882)
@@ -1,3 +1,38 @@
+2007-01-26  Sergei Golovan  <sgolovan at nes.ru>
+
+	* jabberlib-tclxml/jabberlib.tcl: Added -timeout option to send_iq.
+
+	* login.tcl: Removed unnecessary check whether "replace connections"
+	  is set. Added extra call to jlib::disconnect to client:reconnect
+	  procedure.
+
+	* plugins/iq/ping.tcl: Implemented aggressive server ping with
+	  reconnection on ping timeout.
+
+	* utils.tcl: Added function caller, which returns the name
+	  of upper level procedure or empty string if it is called at levels 0
+	  or 1 (thanks to Konstantin Khomoutov).
+
+	* custom.tcl: Use caller procedure from utils.tcl (thanks to
+	  Konstantin Khomoutov).
+
+	* examples/configs/mtr-config.tcl, ifacetk/iface.tcl,
+	  plugins/chat/draw_error.tcl, plugins/chat/draw_info.tcl,
+	  plugins/chat/draw_normal_message.tcl,
+	  plugins/chat/draw_server_message.tcl,
+	  plugins/chat/draw_xhtml_message.tcl,
+	  plugins/chat/me_command.tcl,
+	  plugins/general/headlines.tcl, plugins/general/message_archive.tcl,
+	  plugins/general/rawxml.tcl, plugins/chat/update_tab.tcl: Moved
+	  most instances of tab_set_updated calls to ifacetk/iface.tcl and
+	  plugins/chat/update_tab.tcl.
+
+	* ifacetk/iface.tcl, plugins/chat/draw_normal_message.tcl,
+	  plugins/chat/me_command.tcl, plugins/chat/update_tab.tcl,
+	  plugins/chat/muc_ignore.tcl: Added new plugin, which allows to
+	  ignore messages from given conference occupants. It is not finished
+	  yet, but usable. (Thanks to Konstantin Khomoutov.)
+
 2007-01-22  Sergei Golovan  <sgolovan at nes.ru>
 
 	* plugins/iq/ping.tcl: Added reply to XMPP ping (XEP-0199) support.

Modified: trunk/tkabber/chats.tcl
===================================================================
--- trunk/tkabber/chats.tcl	2007-01-22 12:08:18 UTC (rev 881)
+++ trunk/tkabber/chats.tcl	2007-01-26 17:55:57 UTC (rev 882)
@@ -396,7 +396,6 @@
 	-tabtitle $chats(tabtitlename,$chatid) \
 	-class Chat -type $type \
 	-raisecmd "focus [list $cw.input]
-		   tab_set_updated [list $cw]
                    hook::run raise_chat_tab_hook [list $cw] [list $chatid]"
 
     frame $cw.status

Modified: trunk/tkabber/custom.tcl
===================================================================
--- trunk/tkabber/custom.tcl	2007-01-22 12:08:18 UTC (rev 881)
+++ trunk/tkabber/custom.tcl	2007-01-26 17:55:57 UTC (rev 882)
@@ -81,8 +81,7 @@
 	1 {
 	    # Store variable if it has been changed by
 	    # any procedure which is not in ::custom namespace
-	    if {[catch {info level -1} prc] || \
-		    ![regexp {^(::)*custom::} $prc]} {
+	    if {[namespace qualifiers [caller]] != [namespace current]} {
 		# Don't store loginconf here
 		# (storing all loginconf except password may be
 		# confusing)
@@ -825,4 +824,4 @@
     debugmsg custom [array get history]
 }
 
-
+# vim:ts=8:sw=4:sts=4:noet

Modified: trunk/tkabber/examples/configs/mtr-config.tcl
===================================================================
--- trunk/tkabber/examples/configs/mtr-config.tcl	2007-01-22 12:08:18 UTC (rev 881)
+++ trunk/tkabber/examples/configs/mtr-config.tcl	2007-01-26 17:55:57 UTC (rev 882)
@@ -336,8 +336,7 @@
             if {$usetabbar} {
                 .nb itemconfigure [crange [win_id tab $cw] 1 end] \
                     -text jbot \
-                    -raisecmd "tab_set_updated [list $cw]
-                               hook::run raise_chat_tab_hook [list $cw] [list $chatid]"
+                    -raisecmd "hook::run raise_chat_tab_hook [list $cw] [list $chatid]"
             }
 
             return stop

Modified: trunk/tkabber/ifacetk/iface.tcl
===================================================================
--- trunk/tkabber/ifacetk/iface.tcl	2007-01-22 12:08:18 UTC (rev 881)
+++ trunk/tkabber/ifacetk/iface.tcl	2007-01-26 17:55:57 UTC (rev 882)
@@ -85,6 +85,8 @@
 
     variable number_msg
     variable personal_msg
+
+    namespace export add_win tab_set_updated
 }
 
 proc ifacetk::configure_tabs {args} {
@@ -1038,6 +1040,11 @@
     variable number_msg
     variable personal_msg
 
+    if {![catch {::plugins::mucignore::is_ignored $connid $from $type} ignore] && \
+	    $ignore != ""} {
+	    return
+    }
+
     foreach xelem $extras {
 	jlib::wrapper:splitxml $xelem tag vars isempty chdata children
 	# Don't add number to title if this 'empty' tag is present. It indicates
@@ -1097,10 +1104,6 @@
 hook::add disconnected_hook \
     [namespace current]::ifacetk::set_main_window_title_on_disconnect
 
-proc add_win {args} {
-    eval ifacetk::add_win $args
-}
-
 proc ifacetk::add_win {path args} {
     global usetabbar
     variable options
@@ -1124,7 +1127,10 @@
 
     if {$usetabbar} {
 	set page [nbpage $path]
-	set f [.nb insert end $page -text $tabtitle -raisecmd $raisecmd]
+	set f [.nb insert end $page \
+		   -text $tabtitle \
+		   -raisecmd [list [namespace current]::tab_raise \
+				   $path $raisecmd]]
 	frame $path -class $class
 	pack $path -expand yes -fill both -in $f
 	#tkwait visibility $path
@@ -1146,6 +1152,13 @@
     }
 }
 
+proc ifacetk::tab_raise {path command} {
+    tab_set_updated $path
+    if {$command != ""} {
+	eval $command
+    }
+}
+
 proc ifacetk::get_focus {path} {
     variable focused
     variable after_focused_id
@@ -1267,10 +1280,6 @@
     }
 }
 
-proc tab_set_updated {args} {
-    eval ifacetk::tab_set_updated $args
-}
-
 array set ::alert_lvls {info 1 error 1 server 1 message 2 mesg_to_user 3}
 
 proc ifacetk::tab_set_updated {path {updated 0} {level ""}} {
@@ -1439,3 +1448,7 @@
     signal trap SIGTERM quit
 }
 
+# Import add_win tab_set_updated to the root namespace:
+namespace import ::ifacetk::add_win ::ifacetk::tab_set_updated
+
+# vim:ts=8:sw=4:sts=4:noet

Modified: trunk/tkabber/jabberlib-tclxml/jabberlib.tcl
===================================================================
--- trunk/tkabber/jabberlib-tclxml/jabberlib.tcl	2007-01-22 12:08:18 UTC (rev 881)
+++ trunk/tkabber/jabberlib-tclxml/jabberlib.tcl	2007-01-26 17:55:57 UTC (rev 882)
@@ -1359,10 +1359,16 @@
     set id     {}
     set cmd    [namespace current]::noop
     set vars   {}
+    set timeout 0
 
     foreach {attr val} $args {
 	switch -- $attr {
 	    -command    {set cmd $val}
+	    -timeout {
+		if {$val > 0} {
+		    set timeout $val
+		}
+	    }
 	    -to         {set useto 1; set to $val}
 	    -id         {set useid 1; set id $val}
 	    -connection {set connid $val}
@@ -1387,6 +1393,9 @@
     if {$type == "get" || $type == "set"} {
 	lappend vars id $iq(num)
 	set iq($iq(num)) $cmd
+	if {$timeout > 0} {
+	    after $timeout [list [namespace current]::iq_timeout $iq(num)]
+	}
 	incr iq(num)
     } elseif {$useid} {
 	lappend vars id $id
@@ -1410,6 +1419,18 @@
 
 ######################################################################
 
+proc jlib::iq_timeout {id} {
+    variable iq
+
+    ::LOG "(jlib::iq_timeout) id: $id"
+    if {[info exists iq($id)]} {
+	uplevel #0 $iq($id) [list TIMEOUT [::msgcat::mc "Timeout"]]
+	unset iq($id)
+    }
+}
+
+######################################################################
+
 proc jlib::route {jid} {
     variable lib
 

Modified: trunk/tkabber/login.tcl
===================================================================
--- trunk/tkabber/login.tcl	2007-01-22 12:08:18 UTC (rev 881)
+++ trunk/tkabber/login.tcl	2007-01-26 17:55:57 UTC (rev 882)
@@ -201,7 +201,7 @@
 	return
     }
     # OK, connected.
-    debugmsg login "Connect successful ($user)"
+    debugmsg login "Connect successful ($user) $connid"
     set login_after_time 15000
     login_login $logindata $connid
 }
@@ -287,10 +287,6 @@
 
     array set lc $logindata
 
-    if {$lc(replace_opened) && [jlib::connections] != {}} {
-	return -1
-    }
-
     set connid [jlib::new -user $lc(user) \
 			  -server $lc(server) \
 			  -resource $lc(resource)]
@@ -441,6 +437,7 @@
 
     hook::run predisconnected_hook $connid
 
+    jlib::disconnect $connid
     roster::clean_connection $connid
 
     if {[jlib::connections] == {}} {
@@ -448,6 +445,7 @@
     }
 
     disconnected $connid
+
     if {[incr reconnect_retries] <= 3} {
         after 1000 [list login $loginconf_hist($connid)]
     }

Modified: trunk/tkabber/muc.tcl
===================================================================
--- trunk/tkabber/muc.tcl	2007-01-22 12:08:18 UTC (rev 881)
+++ trunk/tkabber/muc.tcl	2007-01-26 17:55:57 UTC (rev 882)
@@ -1029,6 +1029,8 @@
 			    if {$nick == [get_our_groupchat_nick $chatid]} {
 				set_our_groupchat_nick $chatid $new_nick
 			    }
+			    # TODO may be this reporting should not be done
+			    # if the $nick is being ignored (MUC ignore)
 			    if {$options(gen_enter_exit_msgs)} {
 				variable ignore_available   $new_nick
 				variable ignore_unavailable $nick
@@ -1042,6 +1044,7 @@
 				    [::msgcat::mc "%s is now known as %s" \
 					 $nick$real_jid $new_nick] {}
 			    }
+			    ::hook::run room_nickname_changed_hook $connid $group $nick $new_nick
 			}
 		    }
 		}

Modified: trunk/tkabber/plugins/chat/draw_error.tcl
===================================================================
--- trunk/tkabber/plugins/chat/draw_error.tcl	2007-01-22 12:08:18 UTC (rev 881)
+++ trunk/tkabber/plugins/chat/draw_error.tcl	2007-01-26 17:55:57 UTC (rev 882)
@@ -7,7 +7,6 @@
 	$chatw insert end $body err
 
 	set cw [chat::winid $chatid]
-	tab_set_updated $cw 1 error
 
 	return stop
     }

Modified: trunk/tkabber/plugins/chat/draw_info.tcl
===================================================================
--- trunk/tkabber/plugins/chat/draw_info.tcl	2007-01-22 12:08:18 UTC (rev 881)
+++ trunk/tkabber/plugins/chat/draw_info.tcl	2007-01-26 17:55:57 UTC (rev 882)
@@ -4,7 +4,6 @@
 
     if {[cequal $type info]} {
 	::richtext::render_message [chat::chat_win $chatid] $body info
-	tab_set_updated [chat::winid $chatid] 1 info
 	return stop
     }
 }

Modified: trunk/tkabber/plugins/chat/draw_normal_message.tcl
===================================================================
--- trunk/tkabber/plugins/chat/draw_normal_message.tcl	2007-01-22 12:08:18 UTC (rev 881)
+++ trunk/tkabber/plugins/chat/draw_normal_message.tcl	2007-01-26 17:55:57 UTC (rev 882)
@@ -23,19 +23,17 @@
 
 	::richtext::property_add mynick $mynick
 	::richtext::render_message $chatw $body ""
-
-	if {[check_message $mynick $body]} {
-	    tab_set_updated $cw 1 mesg_to_user
-	} else {
-	    tab_set_updated $cw 1 message
-	}
     } else {
 	::richtext::render_message $chatw $body ""
-	tab_set_updated $cw 1 mesg_to_user
     }
 
     $chatw tag add MSG-$nick MSGLEFT "end - 1 char"
 
+    if {![catch {::plugins::mucignore::is_ignored $connid $from $type} ignore] && \
+	    $ignore != ""} {
+	$chatw tag add $ignore {MSGLEFT linestart} {end - 1 char}
+    }
+
     return stop
 }
 hook::add draw_message_hook [namespace current]::draw_normal_message 87

Modified: trunk/tkabber/plugins/chat/draw_server_message.tcl
===================================================================
--- trunk/tkabber/plugins/chat/draw_server_message.tcl	2007-01-22 12:08:18 UTC (rev 881)
+++ trunk/tkabber/plugins/chat/draw_server_message.tcl	2007-01-26 17:55:57 UTC (rev 882)
@@ -9,7 +9,6 @@
 	$chatw insert end --- server_lab " "
 	::richtext::render_message [::chat::chat_win $chatid] $body server
 	set cw [chat::winid $chatid]
-	tab_set_updated $cw 1 server
 	return stop
     }
 }

Modified: trunk/tkabber/plugins/chat/draw_xhtml_message.tcl
===================================================================
--- trunk/tkabber/plugins/chat/draw_xhtml_message.tcl	2007-01-22 12:08:18 UTC (rev 881)
+++ trunk/tkabber/plugins/chat/draw_xhtml_message.tcl	2007-01-26 17:55:57 UTC (rev 882)
@@ -66,16 +66,13 @@
 	    $chatw insert end $mynick me
 	    ::richtext::render_message [::chat::chat_win $chatid] \
 		[crange $body [clength $mynick] end] ""
-	    tab_set_updated $cw 1 mesg_to_user
 	} else {
 	    ::richtext::render_message [::chat::chat_win $chatid] $body ""
-	    tab_set_updated $cw 1 message
 	}
     } else {
 	$chatw insert end "<$nick>" $tag " "
 	init [::chat::chat_win $chatid]
 	add_xhtml [::chat::chat_win $chatid] $body
-	tab_set_updated $cw 1 mesg_to_user
     }
 
     return stop

Modified: trunk/tkabber/plugins/chat/me_command.tcl
===================================================================
--- trunk/tkabber/plugins/chat/me_command.tcl	2007-01-22 12:08:18 UTC (rev 881)
+++ trunk/tkabber/plugins/chat/me_command.tcl	2007-01-26 17:55:57 UTC (rev 882)
@@ -26,20 +26,17 @@
 
 	    ::richtext::property_add mynick $mynick
 	    ::richtext::render_message $chatw $body $tag
-
-	    if {[check_message $mynick $body]} {
-		tab_set_updated $cw 1 mesg_to_user
-	    } else {
-		tab_set_updated $cw 1 message
-	    }
 	} else {
 	    ::richtext::render_message $chatw $body $tag
-
-	    tab_set_updated $cw 1 mesg_to_user
 	}
 
         $chatw tag add NICKMSG-$nick MSGLEFT "end - 1 char"
 
+	if {![catch {::plugins::mucignore::is_ignored $connid $from $type} ignore] && \
+		$ignore != ""} {
+	    $chatw tag add $ignore {MSGLEFT linestart} {end - 1 char}
+	}
+
 	return stop
     }
 }

Added: trunk/tkabber/plugins/chat/muc_ignore.tcl
===================================================================
--- trunk/tkabber/plugins/chat/muc_ignore.tcl	                        (rev 0)
+++ trunk/tkabber/plugins/chat/muc_ignore.tcl	2007-01-26 17:55:57 UTC (rev 882)
@@ -0,0 +1,615 @@
+# $Id$
+# Support for ignoring occupant activity in MUC rooms.
+#
+# A note on runtime ruleset format:
+# * A hash is used to hold ignore rules at runtime; each key
+#   uniquely refers to its related "connid, room, occupant,
+#   message type" tuple; the existence of a key is used to
+#   determine the fact of some type of a room occupant messages
+#   being ignored.
+# * The format of the ruleset keys is as follows:
+#   SESSION_JID NUL ROOM_JID/OCCUPANT NUL TYPE
+#   where:
+#   * NUL means character with code 0 (\u0000 in Tcl lingo).
+#     It is used since ASCII NUL is prohibited in JIDs;
+#   * SESSION_JID is the bare JID of a particular connection of
+#     the Tkabber user (support for multiaccounting);
+#   * ROOM_JID is the room bare JID;
+#   * OCCUPANT is either an occupant's room nick OR her full
+#     bare JID, if it's available;
+#   * TYPE is either "chat" or "groupchat", literally, which determines
+#     the type of messages to ignore.
+
+namespace eval mucignore {
+    variable options
+
+    variable ignored
+
+    variable tid 0
+    variable tags
+
+    variable menustate
+
+    # Cutsomize section:
+
+    custom::defvar stored_rules {} \
+	"Stored MUC ignore rules" \
+	-group Hidden \
+	-type string
+
+    hook::add post_custom_restore [namespace current]::restore_rules
+
+    custom::defgroup {MUC Ignoring} \
+	[::msgcat::mc "Ignoring of groupchat and chat messages\
+		       from selected occupants of multi-user chats"] \
+	-group Privacy \
+	-group Chat
+
+    custom::defvar options(transient_rules) 0 \
+	[::msgcat::mc "When set, all changes to the rules are in force\
+		       only until Tkabber is closed;\
+		       they are not saved and thus aren't restored at\
+		       the next run."] \
+	-group {MUC Ignoring} \
+	-type boolean
+
+    # Event handlers:
+
+    # Handlers for creating various menus:
+    hook::add chat_create_conference_menu_hook \
+	[namespace current]::setup_muc_menu
+    hook::add chat_create_user_menu_hook \
+	[namespace current]::setup_private_muc_chat_menu
+    hook::add roster_create_groupchat_user_menu_hook \
+	[namespace current]::setup_occupant_menu
+    hook::add finload_hook \
+	[namespace current]::on_init
+
+    # Block private MUC messages:
+    hook::add process_message_hook \
+	[namespace current]::process_message
+
+    # Weed out MUC room messages upon entering a room:
+    hook::add open_chat_post_hook \
+	[namespace current]::sanitize_muc_display
+
+    # Catch presence of ignored users.
+    # NOTE: the order of this handler must be higher than
+    # that of ::muc::process_presence (which is the default of 50)
+    # since that handler extracts and stores the room occupant's
+    # real JID in the non-anonymous rooms.
+    hook::add client_presence_hook \
+	[namespace current]::catch_junkie_presence 55
+
+    # Adjust ignore rules on nick renames.
+    # NOTE: this hook must be run earlier than client_presence_hook.
+    hook::add room_nickname_changed_hook \
+	[namespace current]::trace_room_nick_change
+}
+
+# "Ignore tags" are used to mark whole messages posted in the room
+# by an ignored occupant. Their names are autogenerated and unique
+# throughout one Tkabber run. Each tag is bound to one particular
+# "room JID" of the ignored occupant. Ignore tags may be rebound
+# to another room JID when these change (on nickname changes).
+
+# Creates the ignore tag for a particular "room JID".
+# If matching tag exists, this proc does nothing, silently.
+# This provides for ignore tag "persistence".
+proc mucignore::ignore_tag_create {roomjid} {
+    variable tid
+    variable tags
+
+    if {[info exists tags($roomjid)]} return
+
+    set tags($roomjid) IGNORED-$tid
+    incr tid
+}
+
+proc mucignore::ignore_tag_get {roomjid} {
+    variable tags
+
+    set tags($roomjid)
+}
+
+proc mucignore::ignore_tag_rebind {from to} {
+    variable tags
+
+    set tags($to) $tags($from)
+    unset tags($from)
+}
+
+proc mucignore::ignore_tag_forget {roomjid} {
+    variable tags
+
+    unset tags($roomjid)
+}
+
+# Returns bare JID of the session identified by $connid
+proc mucignore::session_bare_jid {connid} {
+    ::node_and_server_from_jid [::jlib::connection_jid $connid]
+}
+
+# Tries to get the real bare JID of the room occupant identified
+# by the $room_occupant_jid; returns that JID if it's available,
+# empty string otherwise.
+proc mucignore::get_real_bare_jid {connid room_occupant_jid} {
+    set real_jid [::muc::get_real_jid $connid $room_occupant_jid]
+    if {$real_jid != {}} {
+	return [::node_and_server_from_jid $real_jid]
+    } else {
+	return {}
+    }
+}
+
+# Creates an ignore rule suitable for using as a key to a hash of rules.
+# Expects:
+# * entity -- session's bare JID;
+# * jid -- JID to ignore ("room/nick" or "room/real_bare_jid");
+# * type -- type of chat to ignore ("groupchat" or "chat").
+# These parts are joined using the NUL character (since its appearance
+# is prohibited in any part of a JID) and so the rule can be reliably
+# split back into parts.
+# See also: [split_rule].
+proc mucignore::mkrulekey {entity jid type} {
+    join [list $entity $jid $type] \u0000
+}
+
+# Creates an ignore rule suitable for using as a key to a hash of rules.
+# The $connid parameter is converted to the session's bare JID first.
+# It's just a convenient wrapper around [mkrulekey].
+proc mucignore::mkrule {connid jid type} {
+    mkrulekey [session_bare_jid $connid] $jid $type
+}
+
+# Splits given rule into the list of [entity jid type], where:
+# * entity -- is a bare JID of the user's session;
+# * jid -- is a JID to be ignored (usually a full room JID);
+# * type -- one of: "groupchat" or "chat", designating the type of messages
+#   originating from jid to be ignored.
+# This proc reverses what [mkrulekey] does.
+proc mucignore::split_rule {rule} {
+    split $rule \u0000
+}
+
+proc mucignore::setup_muc_menu {m connid jid} {
+    # TODO
+    return
+    $m add command \
+	-label [::msgcat::mc "Edit MUC ignore rules"] \
+	-command [list [namespace current]::editor::open $connid $jid]
+}
+
+proc mucignore::on_init {} {
+    # TODO
+    return
+    set menu [.mainframe getmenu plugins]
+    $menu add command -label [::msgcat::mc "Edit MUC ignore rules"] \
+        -command [list [namespace current]::editor::open {} {}]
+}
+
+proc mucignore::setup_private_muc_chat_menu {m connid jid} {
+    set room [::node_and_server_from_jid $jid]
+    if {![::chat::is_groupchat [::chat::chatid $connid $room]]} return
+
+    setup_occupant_menu $m $connid $jid
+}
+
+# Prepares two global variables mirroring the current state of
+# ignoring for the room occupant on which groupchat roster nick
+# the menu is being created. They are used to represent
+# ignore state checkbutton menu entries.
+proc mucignore::setup_occupant_menu {m connid jid} {
+    variable ignored
+    variable menustate
+
+    set our_nick [::get_our_groupchat_nick [
+	::chat::chatid $connid [
+	    ::node_and_server_from_jid $jid]]]
+    set nick [::chat::get_nick $connid $jid groupchat]
+
+    if {$nick == $our_nick} {
+	# don't allow to ignore ourselves
+	set state disabled
+    } else {
+	set state normal
+    }
+
+    foreach type {groupchat chat} {
+	set menustate($connid,$jid,$type) [
+	    info exists ignored([mkrule $connid $jid $type])]
+    }
+
+    set sm [menu $m.mucignore -tearoff 0]
+    $m add cascade -menu $sm \
+	-state $state \
+	-label [::msgcat::mc "Occupant ignoring"]
+
+    $sm add checkbutton -label [::msgcat::mc "Ignore groupchat messages"] \
+	-variable [namespace current]::menustate($connid,$jid,groupchat) \
+	-command [list [namespace current]::menu_toggle_ignoring \
+		       $connid $jid groupchat]
+    $sm add checkbutton -label [::msgcat::mc "Ignore chat messages"] \
+	-variable [namespace current]::menustate($connid,$jid,chat) \
+	-command [list [namespace current]::menu_toggle_ignoring \
+		       $connid $jid chat]
+
+    bind $m <Destroy> +[list \
+	[namespace current]::menu_cleanup_state $connid $jid]
+}
+
+proc mucignore::menu_toggle_ignoring {connid jid type} {
+    variable menustate
+
+    if {$menustate($connid,$jid,$type)} {
+	occupant_ignore $connid $jid $type
+    } else {
+	occupant_attend $connid $jid $type
+    }
+}
+
+proc mucignore::menu_cleanup_state {connid jid} {
+    variable menustate
+
+    array unset menustate $connid,$jid,*
+}
+
+# Ignores specified room occupant:
+# * Creates an ignore rule for her;
+# * Creates an ignore tag, if needed;
+# * Hides messages tagged with that tag, if any;
+# * Builds and saves current ruleset to the Customize db.
+proc mucignore::occupant_ignore {connid jid args} {
+    variable options
+    variable ignored
+
+    foreach type $args {
+	set ignored([mkrule $connid $jid $type]) true
+
+	if {$type == "groupchat"} {
+	    ignore_tag_create $jid
+	    room_weed_messages $connid $jid true
+	}
+    }
+
+    if {!$options(transient_rules)} {
+	store_rules $connid
+    }
+}
+
+# Un-ignores specified room occupant:
+# * Removes her ignore rules;
+# * Shows any hidden messages from her;
+# * Ignore tag is NOT removed to provide for "quick picking"
+#   into what the ignored occupant have had written so far --
+#   when she is ignored again, all her messages tagged with
+#   the appropriate ignore tag are again hidden.
+# * Builds and saves current ruleset to the Customize db.
+proc mucignore::occupant_attend {connid jid args} {
+    variable options
+    variable ignored
+
+    foreach type $args {
+	set rule [mkrule $connid $jid $type]
+	if {[info exists ignored($rule)]} {
+	    unset ignored($rule)
+	    if {$type == "groupchat"} {
+		room_weed_messages $connid $jid false
+		# we don't use [ignore_tag_forget] here
+		# so when we switch ignoring back on,
+		# all already marked messagess will be weed out
+	    }
+	}
+    }
+
+    if {!$options(transient_rules)} {
+	store_rules $connid
+    }
+}
+
+# Hides or shows messages tagged as ignored for the $jid, if any.
+proc mucignore::room_weed_messages {connid jid hide} {
+    set room [::node_and_server_from_jid $jid]
+    set cw [::chat::chat_win [::chat::chatid $connid $room]]
+
+    $cw tag configure [ignore_tag_get $jid] -elide $hide
+}
+
+# This handler blocks further processing of the private room message
+# if its sender is blacklisted.
+# If the message is groupchat and its sender is blacklisted, it sets
+# the appropriate message property so that other message handlers
+# could treat such message in some special way.
+proc mucignore::process_message {connid from id type args} {
+    variable ignored
+
+    if {$type == "chat" && \
+	[info exists ignored([mkrule $connid $from chat])]} {
+	return stop
+    }
+}
+
+proc mucignore::is_ignored {connid jid type} {
+    variable ignored
+
+    if {[info exists ignored([mkrule $connid $jid $type])]} {
+	return [ignore_tag_get $jid]
+    } else {
+	return ""
+    }
+}
+
+# This handler is being run after opening the chat window.
+# It searches the ignore rules for JIDs matching the JID of the room,
+# extracts them from the rules and weeds out their messages from
+# the room display (chatlog).
+# NOTE that it gets executed before any presences arrive from the room
+# occupants, so the whole idea is to weed out messages with known (ignored)
+# nicks.
+proc mucignore::sanitize_muc_display {chatid type} {
+    variable ignored
+
+    if {$type != "groupchat"} return
+
+    set connid [::chat::get_connid $chatid]
+    set jid [::chat::get_jid $chatid]
+
+    foreach rule [array names ignored [mkrule $connid $jid/* groupchat]] {
+	set junkie [lindex [split_rule $rule] 1]
+	# TODO handle "real JIDs" case...
+	ignore_tag_create $junkie
+	room_weed_messages $connid $junkie true
+    }
+}
+
+# This handler is being run after the room_nickname_changed_hook
+# (which takes care of renaming the ignore list entries).
+# This proc serves two purposes:
+# * It converts rules from real JIDs and room JIDs and back
+#   so that room JIDs are used for rule matching and real JIDs
+#   are stored, if they are available, between sessions.
+# * It arranges for chat log display to be prepared to weed out
+#   messages from ignored JIDs.
+
+# TODO why does real JID is available when this handler is run with
+#      $type == "unavailable". memory leak in chats.tcl?
+# TODO use chat_user_enter/chat_user_exit instead?
+proc mucignore::catch_junkie_presence {connid from pres args} {
+    variable options
+    variable ignored
+
+    set room [::node_and_server_from_jid $from]
+    set rjid [get_real_bare_jid $connid $from]
+
+    if {$pres == "available"} {
+	debugmsg mucignore "avail: $from; real jid: $rjid"
+	foreach type {groupchat chat} {
+	    if {$rjid != {} && \
+		[info exists ignored([mkrule $connid $room/$rjid $type])]} {
+		rename_rule_jid $connid $room/$rjid $from $type
+	    }
+	}
+
+	if {[info exists ignored([mkrule $connid $from groupchat])]} {
+	    ignore_tag_create $from
+	    room_weed_messages $connid $from true
+	}
+    } elseif {$pres == "unavailable"} {
+	debugmsg mucignore "unavail: $from; real jid: $rjid"
+	if {[info exists ignored([mkrule $connid $from groupchat])]} {
+	    ignore_tag_forget $from
+	}
+
+	foreach type {groupchat chat} {
+	    if {$rjid != {} && \
+		[info exists ignored([mkrule $connid $from $type])]} {
+		rename_rule_jid $connid $from $room/$rjid $type
+	    }
+	}
+    }
+}
+
+proc mucignore::trace_room_nick_change {connid room oldnick newnick} {
+    variable ignored
+
+    foreach type {groupchat chat} {
+	if {[info exists ignored([mkrule $connid $room/$oldnick $type])]} {
+	    rename_rule_jid $connid $room/$oldnick $room/$newnick $type
+
+	    if {$type == "groupchat"} {
+		ignore_tag_rebind $room/$oldnick $room/$newnick
+	    }
+	}
+    }
+}
+
+proc mucignore::rename_rule_jid {connid from to type} {
+    variable ignored
+
+    set oldrule [mkrule $connid $from $type]
+    set newrule [mkrule $connid $to $type]
+
+    set ignored($newrule) [set ignored($oldrule)]
+    unset ignored($oldrule)
+
+    debugmsg mucignore "rule renamed:\
+	[string map {\u0000 |} $oldrule]\
+	[string map {\u0000 |} $newrule]"
+}
+
+proc mucignore::explode_room_jid {connid room_occupant_jid vroom voccupant} {
+    upvar 1 $vroom room $voccupant occupant
+
+    set room [::node_and_server_from_jid $room_occupant_jid]
+
+    set occupant [get_real_bare_jid $connid $room_occupant_jid]
+    if {$occupant == {}} {
+	set occupant [::resource_from_jid $room_occupant_jid]
+    }
+}
+
+# Parses the runtime hash of ignore rules, makes up the hierarchical list
+# (a tree) of ignore rules, resolving the room JIDs to real JIDs,
+# if possible, then saves the list to the corresponding Customize variable.
+# The list has the form:
+# * session_bare_jid_1
+#   * room_bare_jid_1
+#     * occupant_1 (nick or real_jid)
+#       * "groupchat" or "chat" or both
+# ...and so on
+proc mucignore::store_rules {connid} {
+    variable ignored
+    variable stored_rules
+
+    array set entities {}
+
+    foreach rule [array names ignored] {
+	lassign [split_rule $rule] entity jid type
+
+	explode_room_jid $connid $jid room occupant
+
+	set entities($entity) 1
+
+	set rooms rooms_$entity
+	if {![info exists $rooms]} {
+	    array set $rooms {}
+	}
+	set [set rooms]($room) 1
+
+	set occupants occupants_$entity$room
+	if {![info exists $occupants]} {
+	    array set $occupants {}
+	}
+
+	lappend [set occupants]($occupant) $type
+    }
+
+    set LE {}
+    foreach entity [array names entities] {
+	set LR {}
+	foreach room [array names rooms_$entity] {
+	    set LO {}
+	    set occupants occupants_$entity$room
+	    foreach occupant [array names $occupants] {
+		lappend LO $occupant [set [set occupants]($occupant)]
+	    }
+	    
+	    lappend LR $room $LO
+	}
+
+	lappend LE $entity $LR
+    }
+
+    set stored_rules [list 1.0 $LE] ;# also record "ruleset syntax" version
+
+    debugmsg mucignore "STORED: $LE"
+}
+
+proc mucignore::restore_rules {args} {
+    variable ignored
+    variable stored_rules
+
+    array set ignored {}
+
+    set failed [catch {
+	lassign $stored_rules version ruleset
+	array set entities $ruleset
+	foreach entity [array names entities] {
+	    array set rooms $entities($entity)
+	    foreach room [array names rooms] {
+		array set occupants $rooms($room)
+		foreach occupant [array names occupants] {
+		    foreach type $occupants($occupant) {
+			set ignored([mkrulekey $entity $room/$occupant $type]) true
+		    }
+		}
+		array unset occupants
+	    }
+	    array unset rooms
+	}
+    } err]
+
+    if {$failed} {
+	global errorInfo
+	set bt $errorInfo
+	
+	set stored_rules {}
+
+	after idle [list error \
+	    [::msgcat::mc "Error loading MUC ignore rules, purged."] $bt]
+    }
+
+    debugmsg mucignore "RESTORED: [string map {\u0000 |} [array names ignored]]"
+}
+
+########################################################################
+# MUC Ignore ruleset editor
+########################################################################
+
+namespace eval mucignore::editor {}
+
+# ...
+# NOTE that both $connid and $jid may be empty at the time of invocation.
+proc mucignore::editor::open {connid jid} {
+    set w .mucignore_rules_editor
+    if {[winfo exists $w]} {
+	return
+    }
+
+    add_win $w -title [::msgcat::mc "MUC Ignore Rules"] \
+	-tabtitle [::msgcat::mc "MUC Ignore Rules"] \
+	-class MUCIgnoreRulesetEditor
+	#-raisecmd "focus [list $w.input]"
+
+    bind $w <Destroy> [list [namespace current]::cleanup $w %W]
+
+    set sw [ScrolledWindow $w.sw -auto both]
+    set t [Tree $w.tree -background [$w cget -background]]
+    $sw setwidget $t
+
+    pack $sw -fill both -expand true
+
+    # NOTE that BWidget Tree doesn't aceept keyboard bindings.
+
+    $t bindText <Double-ButtonPress-1> [list $t toggle]
+    bind $w <KeyPress-Return> [list [namespace current]::tree_toggle $t]
+
+    bind $w <KeyPress-F2> [list [namespace current]::tree_edit_item $t]
+    bind $w <Any-KeyPress-Insert> [list [namespace current]::tree_insert_item $t]
+    bind $w <Any-KeyPress-Delete> [list [namespace current]::tree_insert_item $t]
+}
+
+proc mucignore::editor::cleanup {w1 w2} {
+    if {$w1 != $w2} return
+
+    # TODO do appropriate cleanup...
+}
+
+proc mucignore::editor::tree_toggle {t} {
+    set node [lindex [$t selection get] 0]
+    if {$node != {}} {
+	$t toggle $node
+    }
+}
+
+proc mucignore::editor::tree_edit_item {t} {
+    set node [lindex [$t selection get] 0]
+    if {$node == {}} return
+
+    set text [$t itemcget $node -text]
+
+    $t edit $node $text
+}
+
+proc mucignore::editor::tree_insert_item {t} {
+    set parent [lindex [$t selection get] 0]
+
+    if {$parent == {}} {
+	set parent root
+    }
+
+    # TODO implement
+    #add_nodes $t $parent {New {}}
+}
+
+# vim:ts=8:sw=4:sts=4:noet


Property changes on: trunk/tkabber/plugins/chat/muc_ignore.tcl
___________________________________________________________________
Name: svn:keywords
   + Author Date Id Revision
Name: svn:eol-style
   + native

Added: trunk/tkabber/plugins/chat/update_tab.tcl
===================================================================
--- trunk/tkabber/plugins/chat/update_tab.tcl	                        (rev 0)
+++ trunk/tkabber/plugins/chat/update_tab.tcl	2007-01-26 17:55:57 UTC (rev 882)
@@ -0,0 +1,46 @@
+# $Id$
+
+namespace eval update_tab {
+    hook::add draw_message_hook [namespace current]::update 8
+}
+
+proc update_tab::update {chatid from type body x} {
+    set connid [chat::get_connid $chatid]
+    set jid [chat::get_jid $chatid]
+    set cw [chat::winid $chatid]
+
+    if {![catch {::plugins::mucignore::is_ignored $connid $from $type} ignore] && \
+	    $ignore != ""} {
+	return
+    }
+
+    switch -- $type {
+	error -
+	info {
+	    tab_set_updated $cw 1 $type
+	}
+	groupchat {
+	    if {$from == $jid} {
+		tab_set_updated $cw 1 server
+	    } else {
+		set myjid [chat::our_jid $chatid]
+		set mynick [chat::get_nick $connid $myjid $type]
+
+		if {[check_message $mynick $body]} {
+		    tab_set_updated $cw 1 mesg_to_user
+		} else {
+		    tab_set_updated $cw 1 message
+		}
+	    }
+	}
+	chat -
+	default {
+	    if {$from == "synthetic"} {
+		tab_set_updated $cw 1 server
+	    } else {
+		tab_set_updated $cw 1 mesg_to_user
+	    }
+	}
+    }
+}
+


Property changes on: trunk/tkabber/plugins/chat/update_tab.tcl
___________________________________________________________________
Name: svn:keywords
   + Author Date Id Revision
Name: svn:eol-style
   + native

Modified: trunk/tkabber/plugins/general/headlines.tcl
===================================================================
--- trunk/tkabber/plugins/general/headlines.tcl	2007-01-22 12:08:18 UTC (rev 881)
+++ trunk/tkabber/plugins/general/headlines.tcl	2007-01-26 17:55:57 UTC (rev 882)
@@ -113,8 +113,7 @@
     }
 
     add_win $hw -title $title -tabtitle $tabtitle \
-		-raisecmd "focus [list $tw]
-			   tab_set_updated [list $hw]" \
+		-raisecmd [list focus $tw] \
 		-class JBrowser
 
     PanedWin $hw.pw -side right -pad 0 -width 8

Modified: trunk/tkabber/plugins/general/message_archive.tcl
===================================================================
--- trunk/tkabber/plugins/general/message_archive.tcl	2007-01-22 12:08:18 UTC (rev 881)
+++ trunk/tkabber/plugins/general/message_archive.tcl	2007-01-26 17:55:57 UTC (rev 882)
@@ -62,8 +62,7 @@
 
     add_win $w -title [::msgcat::mc "Messages"] \
 	    -tabtitle [::msgcat::mc "Messages"] \
-	    -class Messages \
-	    -raisecmd "tab_set_updated [list $w]"
+	    -class Messages
 
     PanedWin $w.pw -side right -pad 0 -width 8
     pack $w.pw -fill both -expand yes

Modified: trunk/tkabber/plugins/general/rawxml.tcl
===================================================================
--- trunk/tkabber/plugins/general/rawxml.tcl	2007-01-22 12:08:18 UTC (rev 881)
+++ trunk/tkabber/plugins/general/rawxml.tcl	2007-01-26 17:55:57 UTC (rev 882)
@@ -169,8 +169,7 @@
     add_win $w -title [::msgcat::mc "Raw XML"] \
 	-tabtitle [::msgcat::mc "Raw XML"] \
 	-class RawXML \
-	-raisecmd "focus [list $w.input]
-		   tab_set_updated [list $w]"
+	-raisecmd [list focus $w.input]
 
 
     set tools [frame $w.tools]

Modified: trunk/tkabber/plugins/iq/ping.tcl
===================================================================
--- trunk/tkabber/plugins/iq/ping.tcl	2007-01-22 12:08:18 UTC (rev 881)
+++ trunk/tkabber/plugins/iq/ping.tcl	2007-01-26 17:55:57 UTC (rev 882)
@@ -4,12 +4,29 @@
 #############################################################################
 
 namespace eval ping {
+    custom::defvar options(ping) 0 \
+	[::msgcat::mc "Ping server using (urn:xmpp:ping) requests."] \
+	-group IQ \
+	-type boolean \
+	-command [namespace current]::start_all
+
+    custom::defvar options(timeout) 30 \
+	[::msgcat::mc "Reconnect to server if it does not reply (with result)\
+		       or with error) to ping (urn:xmpp:ping) request in\
+		       specified time interval (in seconds)."] \
+	-group IQ \
+	-type integer \
+	-command [namespace current]::start_all
+
     custom::defvar options(pong) 1 \
 	[::msgcat::mc "Reply to ping (urn:xmpp:ping) requests."] \
 	-group IQ \
 	-type boolean
 
+    variable sequence
+
     iq::register_handler get query urn:xmpp:ping [namespace current]::reply
+    hook::add connected_hook [namespace current]::start
 }
 
 #############################################################################
@@ -26,3 +43,60 @@
 
 #############################################################################
 
+proc ping::start_all {args} {
+    variable options
+
+    if {!$options(ping) || ($options(timeout) <= 0)} return
+
+    foreach connid [jlib::connections] {
+	start $connid
+    }
+}
+
+#############################################################################
+
+proc ping::start {connid} {
+    variable options
+    variable sequence
+
+    after cancel [list [namespace current]::start $connid]
+
+    if {!$options(ping) || ($options(timeout) <= 0)} return
+
+    if {![info exists sequence($connid)]} {
+	set sequence($connid) 0
+    } else {
+	incr sequence($connid)
+    }
+
+    jlib::send_iq get \
+	[jlib::wrapper:createtag ping \
+	     -vars [list xmlns urn:xmpp:ping]] \
+	-timeout [expr {$options(timeout)*1000}] \
+	-connection $connid \
+	-command [list [namespace current]::result $connid $sequence($connid)]
+}
+
+proc ping::result {connid seq res child} {
+    variable options
+    variable sequence
+
+    if {!$options(ping) || ($options(timeout) <= 0)} return
+
+    if {![lcontain [jlib::connections] $connid]} return
+
+    if {$res == "DISCONNECT"} return
+
+    if {$seq < $sequence($connid)} return
+
+    if {$res == "TIMEOUT"} {
+	client:reconnect $connid
+	return
+    }
+
+    after [expr {$options(timeout)*1000}] \
+	  [list [namespace current]::start $connid]
+}
+
+#############################################################################
+

Modified: trunk/tkabber/utils.tcl
===================================================================
--- trunk/tkabber/utils.tcl	2007-01-22 12:08:18 UTC (rev 881)
+++ trunk/tkabber/utils.tcl	2007-01-26 17:55:57 UTC (rev 882)
@@ -514,4 +514,23 @@
     return $newlist
 }
 
+# Returns a fully-qualified name of the command that has invoked
+# the caller of this procedure.
+# To put is simple: if ::one::bar has invoked ::two::foo, the
+# ::two::foo proc can use [caller] to know that its caller
+# is ::one::bar
+# If the caller of this proc has no caller (i.e. it was called
+# on level 0), this proc returns empty string.
+# You can specify 2, 3, etc as the argument to get info about
+# the caller of the caller and so on (think of [uplevel]).
+
+proc caller {{level 1}} {
+    incr level
+    if {[catch {info level -$level} prc]} {
+	return ""
+    } else {
+	return [namespace which -command [lindex $prc 0]]
+    }
+}
+
 # vim:ts=8:sw=4:sts=4:noet



More information about the Tkabber-dev mailing list