[Tkabber-dev] r789 - in trunk/tkabber: . ifacetk plugins/chat plugins/general plugins/richtext

tkabber-svn at jabber.ru tkabber-svn at jabber.ru
Sat Nov 11 00:00:30 MSK 2006


Author: sergei
Date: 2006-11-11 00:00:22 +0300 (Sat, 11 Nov 2006)
New Revision: 789

Added:
   trunk/tkabber/plugins/richtext/highlight.tcl
Removed:
   trunk/tkabber/plugins/chat/highlight.tcl
Modified:
   trunk/tkabber/ChangeLog
   trunk/tkabber/ifacetk/idefault.tcl
   trunk/tkabber/ifacetk/iface.tcl
   trunk/tkabber/ifacetk/iroster.tcl
   trunk/tkabber/plugins/chat/bookmark_highlighted.tcl
   trunk/tkabber/plugins/chat/complete_last_nick.tcl
   trunk/tkabber/plugins/chat/draw_normal_message.tcl
   trunk/tkabber/plugins/chat/me_command.tcl
   trunk/tkabber/plugins/general/sound.tcl
   trunk/tkabber/plugins/richtext/emoticons.tcl
   trunk/tkabber/plugins/richtext/urls.tcl
   trunk/tkabber/richtext.tcl
   trunk/tkabber/utils.tcl
Log:
	* ifacetk/iroster.tcl: Bugfix (thanks to Irek Chmielowiec).

	* ifacetk/iface.tcl: Added two hooks: get_focus_hook and
	  loose_focus_hook (thanks to thanks to Pavel Borzenkov).

	* plugins/richtext/emoticons.tcl: Added 'sweep' command, which
	  removes all unused emoticons from the memory. Fixed loading
	  emoticons at Tkabber start (thanks to Konstantin Khomoutov).

	* ifacetk/idefault.tcl: Moved workaround for calling emoticons
	  menu using Alt-e in nonenglish keyboard layout to
	  plugins/richtext/emoticons.tcl.

	* richtext.tcl, plugins/richtext/highlight.tcl,
	  plugins/chat/draw_normal_message.tcl, plugins/richtext/urls.tcl:
	  Moved highlight plugin to richtext plugins, changed priority
	  of URL parsing plugin to higher value (thanks to Konstantin
	  Khomoutov).

	* utils.tcl, plugins/richtext/highlight.tcl: Added new hook
	  check_personal_message_hook and made using it in
	  highlight plugin. Changed syntax of check_message.

	* ifacetk/iface.tcl, plugins/chat/bookmark_highlighted.tcl,
	  plugins/chat/complete_last_nick.tcl,
	  plugins/chat/draw_normal_message.tcl,
	  plugins/chat/me_command.tcl, plugins/general/sound.tcl:
	  Adapted calls of check_message to new syntax.


Modified: trunk/tkabber/ChangeLog
===================================================================
--- trunk/tkabber/ChangeLog	2006-11-06 15:22:00 UTC (rev 788)
+++ trunk/tkabber/ChangeLog	2006-11-10 21:00:22 UTC (rev 789)
@@ -1,3 +1,34 @@
+2006-11-10  Sergei Golovan  <sgolovan at nes.ru>
+
+	* ifacetk/iroster.tcl: Bugfix (thanks to Irek Chmielowiec).
+
+	* ifacetk/iface.tcl: Added two hooks: get_focus_hook and
+	  loose_focus_hook (thanks to thanks to Pavel Borzenkov).
+
+	* plugins/richtext/emoticons.tcl: Added 'sweep' command, which
+	  removes all unused emoticons from the memory. Fixed loading
+	  emoticons at Tkabber start (thanks to Konstantin Khomoutov).
+
+	* ifacetk/idefault.tcl: Moved workaround for calling emoticons
+	  menu using Alt-e in nonenglish keyboard layout to
+	  plugins/richtext/emoticons.tcl.
+
+	* richtext.tcl, plugins/richtext/highlight.tcl,
+	  plugins/chat/draw_normal_message.tcl, plugins/richtext/urls.tcl:
+	  Moved highlight plugin to richtext plugins, changed priority
+	  of URL parsing plugin to higher value (thanks to Konstantin
+	  Khomoutov).
+
+	* utils.tcl, plugins/richtext/highlight.tcl: Added new hook
+	  check_personal_message_hook and made using it in
+	  highlight plugin. Changed syntax of check_message.
+
+	* ifacetk/iface.tcl, plugins/chat/bookmark_highlighted.tcl,
+	  plugins/chat/complete_last_nick.tcl,
+	  plugins/chat/draw_normal_message.tcl,
+	  plugins/chat/me_command.tcl, plugins/general/sound.tcl:
+	  Adapted calls of check_message to new syntax.
+
 2006-11-06  Sergei Golovan  <sgolovan at nes.ru>
 
 	* msgs/pl.msg, trans/pl.msg: Updated (thanks to Irek

Modified: trunk/tkabber/ifacetk/idefault.tcl
===================================================================
--- trunk/tkabber/ifacetk/idefault.tcl	2006-11-06 15:22:00 UTC (rev 788)
+++ trunk/tkabber/ifacetk/idefault.tcl	2006-11-10 21:00:22 UTC (rev 789)
@@ -88,5 +88,4 @@
     event add <<Redo>>  <Control-ssharp>
     event add <<CollapseRoster>>  <Control-ecircumflex>
     event add <<OpenSearchPanel>> <Control-ucircumflex>
-    event add <<EmoteiconsMenu>> <Alt-oacute>
 }

Modified: trunk/tkabber/ifacetk/iface.tcl
===================================================================
--- trunk/tkabber/ifacetk/iface.tcl	2006-11-06 15:22:00 UTC (rev 788)
+++ trunk/tkabber/ifacetk/iface.tcl	2006-11-10 21:00:22 UTC (rev 789)
@@ -1029,7 +1029,7 @@
 	    incr number_msg($chatid)
 	}
 	if {![cequal $jid $from] && ![cequal $myjid $from] && \
-		[lindex [check_message $mynick $body] 0]} {
+		[check_message $mynick $body]} {
 	    set personal_msg($chatid) 1
 	}
     }
@@ -1130,6 +1130,8 @@
 	set after_focused_id \
 	    [after $options(update_title_delay) [list [namespace current]::set_title $path]]
 	set focused $path
+
+	hook::run get_focus_hook $path
     }
 }
 
@@ -1168,6 +1170,8 @@
     }
     set focused ""
     balloon::destroy
+
+    hook::run loose_focus_hook $path
 }
 
 proc ifacetk::tab_move {nb shift args} {

Modified: trunk/tkabber/ifacetk/iroster.tcl
===================================================================
--- trunk/tkabber/ifacetk/iroster.tcl	2006-11-06 15:22:00 UTC (rev 788)
+++ trunk/tkabber/ifacetk/iroster.tcl	2006-11-10 21:00:22 UTC (rev 789)
@@ -1562,7 +1562,7 @@
 	    if {$idx != "none"} {
 		set var [$m1 entrycget $idx -variable]
 		set command [$m1 entrycget $idx -command]
-		$m2 add checkbutton -label $jid variable $var -command $command
+		$m2 add checkbutton -label $jid -variable $var -command $command
 	    }
 	}
     } else {

Modified: trunk/tkabber/plugins/chat/bookmark_highlighted.tcl
===================================================================
--- trunk/tkabber/plugins/chat/bookmark_highlighted.tcl	2006-11-06 15:22:00 UTC (rev 788)
+++ trunk/tkabber/plugins/chat/bookmark_highlighted.tcl	2006-11-10 21:00:22 UTC (rev 789)
@@ -81,7 +81,7 @@
     set myjid [chat::our_jid $chatid]
     set mynick [chat::get_nick $connid $myjid $type]
     if {[cequal $jid $from] || [cequal $myjid $from] || \
-	    ![lindex [check_message $mynick $body] 0]} {
+	    ![check_message $mynick $body]} {
 	return
     }
     

Modified: trunk/tkabber/plugins/chat/complete_last_nick.tcl
===================================================================
--- trunk/tkabber/plugins/chat/complete_last_nick.tcl	2006-11-06 15:22:00 UTC (rev 788)
+++ trunk/tkabber/plugins/chat/complete_last_nick.tcl	2006-11-10 21:00:22 UTC (rev 789)
@@ -17,7 +17,7 @@
     set myjid [chat::our_jid $chatid]
     set mynick [chat::get_nick $connid $myjid $type]
     if {$nick != $mynick} {
-	if {[lindex [check_message $mynick $body] 0]} {
+	if {[check_message $mynick $body]} {
 	    set my_last_nick($chatid) $nick
 	    set my_last_nick_counter($chatid) 0
 	} else {

Modified: trunk/tkabber/plugins/chat/draw_normal_message.tcl
===================================================================
--- trunk/tkabber/plugins/chat/draw_normal_message.tcl	2006-11-06 15:22:00 UTC (rev 788)
+++ trunk/tkabber/plugins/chat/draw_normal_message.tcl	2006-11-10 21:00:22 UTC (rev 789)
@@ -21,15 +21,16 @@
 	set myjid [chat::our_jid $chatid]
 	set mynick [chat::get_nick $connid $myjid $type]
 
-	lassign [check_message $mynick $body] mymessage mylist
-	chat::add_emoteiconed_text $chatw $body "" $mylist
-	if {$mymessage} {
+	::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 {
-	chat::add_emoteiconed_text $chatw $body ""
+	::richtext::render_message $chatw $body ""
 	tab_set_updated $cw 1 mesg_to_user
     }
 
@@ -38,3 +39,5 @@
     return stop
 }
 hook::add draw_message_hook [namespace current]::draw_normal_message 87
+
+# vim:ts=8:sw=4:sts=4:noet

Deleted: trunk/tkabber/plugins/chat/highlight.tcl
===================================================================
--- trunk/tkabber/plugins/chat/highlight.tcl	2006-11-06 15:22:00 UTC (rev 788)
+++ trunk/tkabber/plugins/chat/highlight.tcl	2006-11-10 21:00:22 UTC (rev 789)
@@ -1,84 +0,0 @@
-# $Id$
-
-namespace eval highlight {
-    custom::defgroup Highlight [::msgcat::mc "Groupchat message highlighting plugin options."] \
-	-group Chat
-    custom::defvar options(enable_highlighting) 0 \
-	[::msgcat::mc "Enable highlighting plugin."] \
-	-type boolean -group Highlight
-    custom::defvar options(highlight_nick) 1 \
-	[::msgcat::mc "Highlight current nickname in messages."] \
-	-type boolean -group Highlight
-    custom::defvar options(highlight_substrings) {} \
-	[::msgcat::mc "Substrings to highlight in messages."] \
-	-type string -group Highlight
-    custom::defvar options(highlight_whole_words) 1 \
-	[::msgcat::mc "Highlight only whole words in messages."] \
-	-type boolean -group Highlight
-
-    rename ::check_message ::check_message.orig
-    proc ::check_message {nick body} \
-	"return \[[namespace current]::check_message \$nick \$body\]"
-}
-
-proc highlight::check_message {nick body} {
-    variable options
-
-    if {!$options(enable_highlighting)} {
-	return [::check_message.orig $nick $body]
-    }
-
-    set words [textutil::splitx $body {([\t \r\n]+)}]
-    set wordborders {}
-    set index 0
-    foreach word $words {
-	set index [expr {$index + [string length $word]}]
-	lappend wordborders $index
-    }
-
-    set subs [split $options(highlight_substrings) " "]
-    if {$options(highlight_nick)} {
-	set subs [linsert $subs 0 $nick]
-    }
-
-    set ind_end 0
-    set stop_ind [string length $body]
-    set matches {}
-    set highlight 0
-    set found 1
-    while {$found && $ind_end < $stop_ind} {
-	set found 0
-	set ind $ind_end
-	foreach str $subs {
-	    set len [string length $str]
-	    if {$len > 0 && [set match [string first $str $body $ind]] >= 0} {
-		if {!$options(highlight_whole_words) || \
-			(![string is wordchar -strict [string index $body [expr {$match - 1}]]] && \
-			![string is wordchar -strict [string index $body [expr {$match + $len}]]])} {
-		    if {!$found} {
-			set found 1
-			set ind_start $match
-			set ind_end [expr {$match + $len}]
-		    } elseif {$match < $ind_start} {
-			set ind_start $match
-			set ind_end [expr {$match + $len}]
-		    }
-		}
-	    }
-	}
-	if {$found} {
-	    set highlight 1
-	    set i 0
-	    while {[lindex $wordborders $i] <= $ind_start} {
-		incr i
-	    }
-	    set word [lindex $words $i]
-	    
-	    if {![regexp -expanded -nocase -- $::chat::url_regexp $word]} {
-		lappend matches $ind_start $ind_end
-	    }
-	}
-    }
-    return [list $highlight $matches]
-}
-

Modified: trunk/tkabber/plugins/chat/me_command.tcl
===================================================================
--- trunk/tkabber/plugins/chat/me_command.tcl	2006-11-06 15:22:00 UTC (rev 788)
+++ trunk/tkabber/plugins/chat/me_command.tcl	2006-11-10 21:00:22 UTC (rev 789)
@@ -24,9 +24,10 @@
 	    set myjid [chat::our_jid $chatid]
 	    set mynick [chat::get_nick $connid $myjid $type]
 
-	    lassign [check_message $mynick $body] mymessage mylist
-	    chat::add_emoteiconed_text $chatw $body $tag $mylist
-	    if {$mymessage} {
+	    ::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

Modified: trunk/tkabber/plugins/general/sound.tcl
===================================================================
--- trunk/tkabber/plugins/general/sound.tcl	2006-11-06 15:22:00 UTC (rev 788)
+++ trunk/tkabber/plugins/general/sound.tcl	2006-11-10 21:00:22 UTC (rev 789)
@@ -220,7 +220,7 @@
 	    } else {
 		set mynick [chat::get_nick [chat::get_connid $chatid] \
 					   [chat::our_jid $chatid] $type]
-		if {[lindex [check_message $mynick $body] 0]} {
+		if {[check_message $mynick $body]} {
 		    play $sounds(groupchat_their_message_to_me) -1
 		} else {
 		    play $sounds(groupchat_their_message)

Modified: trunk/tkabber/plugins/richtext/emoticons.tcl
===================================================================
--- trunk/tkabber/plugins/richtext/emoticons.tcl	2006-11-06 15:22:00 UTC (rev 788)
+++ trunk/tkabber/plugins/richtext/emoticons.tcl	2006-11-10 21:00:22 UTC (rev 789)
@@ -45,7 +45,7 @@
 	-group Emoticons -type boolean \
 	-command [namespace current]::on_regex_mode_changed
 
-    # The [on_state_changed] proc called by finload_hook
+    # The [enable_subsystem] proc called by postload_hook
     # completes initialization, if needed.
 }
 
@@ -96,7 +96,11 @@
     }
 }
 
-# Destroys all emoticons:
+# Clears all arrays related to emoticons
+# and sets logical reference counts of images to zero.
+# NOTE that it does not actually frees unused images.
+# Call [sweep] or [load_dir] (which calls [sweep]) after
+# calling [clear].
 proc emoticons::clean {} {
     variable images
     variable emoticons
@@ -118,33 +122,13 @@
     }
 }
 
-# Loads a new set of emoticons, adding them to the existing set,
-# replacing any existing emoticons with the same mnemonics:
-proc emoticons::load_dir {dir} {
+# Sweeps out orphaned (not used anymore) physical images (i.e. those
+# with logical refcounts less or equal than 0.
+# NOTE that images which are still physically in use (by Tk) are not
+# deleted in 8.4+.
+proc emoticons::sweep {} {
     variable images
-    variable faces_regexp
 
-    if {$dir == ""} return
-
-    set icondef_path [file join $dir icondef.xml]
-    if {![file isfile $icondef_path]} {
-	### TODO: some error messages
-	return
-    }
-    set f [open $icondef_path]
-    set icondef [read $f]
-    close $f
-
-    set faces_regexp ""
-
-    set parser [jlib::wrapper:new "#" "#" \
-		    [list [namespace current]::parse_icondef $dir]]
-    jlib::wrapper:elementstart $parser stream:stream {} {}
-    jlib::wrapper:parser $parser parse $icondef
-    jlib::wrapper:parser $parser configure -final 0
-    jlib::wrapper:free $parser
-
-    # Sweep out orphaned images:
     foreach iname [array names images] {
 	if {$images($iname) < 1} {
 	    # Work around Tcl 8.3 which lacks [image inuse] (always kill in this case):
@@ -158,7 +142,36 @@
 	    }
 	}
     }
+}
 
+# Loads a new set of emoticons, adding them to the existing set,
+# replacing any existing emoticons with the same mnemonics:
+proc emoticons::load_dir {dir} {
+    variable images
+    variable faces_regexp
+
+    if {$dir != ""} {
+	set icondef_path [file join $dir icondef.xml]
+	if {![file isfile $icondef_path]} {
+	    ### TODO: some error messages
+	    return
+	}
+	set f [open $icondef_path]
+	set icondef [read $f]
+	close $f
+
+	set faces_regexp ""
+
+	set parser [jlib::wrapper:new "#" "#" \
+			[list [namespace current]::parse_icondef $dir]]
+	jlib::wrapper:elementstart $parser stream:stream {} {}
+	jlib::wrapper:parser $parser parse $icondef
+	jlib::wrapper:parser $parser configure -final 0
+	jlib::wrapper:free $parser
+    }
+
+    # Sweep out orphaned images:
+    sweep
 }
 
 proc emoticons::parse_icondef {dir xmldata} {
@@ -370,6 +383,11 @@
 event add <<EmoticonsMenu>> <Meta-e>
 event add <<EmoticonsMenu>> <Alt-e>
 
+if {$::tcl_platform(platform) == "windows"} {
+    # workaround for shortcuts in russian keyboard layout
+    event add <<EmoticonsMenu>> <Alt-oacute>
+}
+
 proc emoticons::setup_bindings {chatid type} {
     set iw [chat::input_win $chatid]
 
@@ -561,16 +579,16 @@
     }
 
     ::custom::configvar [namespace current]::options(theme) -values $values
-    set options(theme) $theme
 }
 
 proc emoticons::enable_subsystem {} {
     find_themes
+    on_theme_changed
+
     ::richtext::entity_state emoticon 1
 }
 
 proc emoticons::disable_subsystem {} {
-    find_themes
     ::richtext::entity_state emoticon 0
 }
 
@@ -608,7 +626,7 @@
 }
 
 namespace eval emoticons {
-    ::hook::add postload_hook [namespace current]::enable_subsystem
+    ::hook::add postload_hook [namespace current]::enable_subsystem 70
 
     ::hook::add open_chat_post_hook [namespace current]::setup_bindings
 
@@ -620,3 +638,4 @@
 	
 }
 
+# vim:ts=8:sts=4:sw=4:noet

Copied: trunk/tkabber/plugins/richtext/highlight.tcl (from rev 788, trunk/tkabber/plugins/chat/highlight.tcl)
===================================================================
--- trunk/tkabber/plugins/richtext/highlight.tcl	                        (rev 0)
+++ trunk/tkabber/plugins/richtext/highlight.tcl	2006-11-10 21:00:22 UTC (rev 789)
@@ -0,0 +1,141 @@
+# $Id$
+
+namespace eval highlight {
+
+    custom::defgroup Highlight [::msgcat::mc "Groupchat message highlighting plugin options."] \
+	-group Chat \
+	-group {Rich Text}
+
+    custom::defvar options(enable_highlighting) 0 \
+	[::msgcat::mc "Enable highlighting plugin."] \
+	-type boolean -group Highlight \
+	-command [namespace current]::on_state_changed
+
+    custom::defvar options(highlight_nick) 1 \
+	[::msgcat::mc "Highlight current nickname in messages."] \
+	-type boolean -group Highlight
+
+    custom::defvar options(highlight_substrings) {} \
+	[::msgcat::mc "Substrings to highlight in messages."] \
+	-type string -group Highlight
+
+    custom::defvar options(highlight_whole_words) 1 \
+	[::msgcat::mc "Highlight only whole words in messages."] \
+	-type boolean -group Highlight
+
+    ::richtext::register_entity highlight \
+	-configurator [namespace current]::configure_richtext_widget \
+	-parser [namespace current]::process_highlights \
+	-renderer [namespace current]::render_highlight \
+	-parser-priority 60
+}
+
+proc highlight::configure_richtext_widget {w} {
+}
+
+proc highlight::process_highlights {atLevel accVar} {
+    upvar #$atLevel $accVar chunks
+
+    variable options
+
+    set subs [split $options(highlight_substrings) " "]
+    if {$options(highlight_nick) && [::richtext::property_exists mynick]} {
+	lappend subs [::richtext::property_get mynick]
+    }
+
+    lappend out
+
+    foreach {s type tags} $chunks {
+	if {$type != "text"} {
+	    # pass through
+	    lappend out $s $type $tags
+	    continue
+	}
+
+	set ts 0
+
+	foreach {ms me} [spot_highlights $s $subs] {
+	    # Write out text before current highlight, if any:
+	    if {$ts < $ms} {
+		lappend out [string range $s $ts [expr {$ms - 1}]] $type $tags
+	    }
+	    # Write out current highlight:
+	    lappend out [string range $s $ms $me] highlight $tags
+
+	    set ts [expr {$me + 1}]
+	}
+
+	# Write out text after the last highlight, if any:
+	if {[string length $s] - $ts > 0} {
+	    lappend out [string range $s $ts end] $type $tags
+	}
+    }
+
+    set chunks $out
+}
+
+proc highlight::spot_highlights {s subs} {
+    variable options
+
+    set words [textutil::splitx $s {([\t \r\n]+)}]
+
+    set ind_end 0
+    set stop_ind [string length $s]
+    lappend ranges
+    set found 1
+    while {$found && $ind_end < $stop_ind} {
+	set found 0
+	set ind $ind_end
+	foreach str $subs {
+	    set len [string length $str]
+	    if {$len > 0 && [set match [string first $str $s $ind]] >= 0} {
+		if {!$options(highlight_whole_words) || \
+			(![string is wordchar -strict [string index $s [expr {$match - 1}]]] && \
+			![string is wordchar -strict [string index $s [expr {$match + $len}]]])} {
+		    if {!$found} {
+			set found 1
+			set ind_start $match
+			set ind_end [expr {$match + $len - 1}]
+		    } elseif {$match < $ind_start} {
+			set ind_start $match
+			set ind_end [expr {$match + $len - 1}]
+		    }
+		}
+	    }
+	}
+	if {$found} {
+	    lappend ranges $ind_start $ind_end
+	}
+    }
+
+    return $ranges
+}
+
+proc highlight::render_highlight {w type piece tags} {
+    $w insert end $piece [lfuse $type $tags]
+}
+
+# The following procedure reports highlighting inside URLs too
+proc highlight::check_highlighted_message {vpersonal nick body} {
+    variable options
+    upvar 2 $vpersonal personal
+
+    set subs [split $options(highlight_substrings) " "]
+    if {$options(highlight_nick)} {
+	lappend subs $nick
+    }
+    if {![lempty [spot_highlights $body $subs]]} {
+	set personal 1
+    }
+}
+
+hook::add check_personal_message_hook \
+	  [namespace current]::highlight::check_highlighted_message
+
+proc highlight::on_state_changed {args} {
+    variable options
+
+    ::richtext::entity_state highlight $options(enable_highlighting)
+}
+
+# vim:ts=8:sw=4:sts=4:noet

Modified: trunk/tkabber/plugins/richtext/urls.tcl
===================================================================
--- trunk/tkabber/plugins/richtext/urls.tcl	2006-11-06 15:22:00 UTC (rev 788)
+++ trunk/tkabber/plugins/richtext/urls.tcl	2006-11-10 21:00:22 UTC (rev 789)
@@ -221,7 +221,7 @@
 	-configurator [namespace current]::configure_richtext_widget \
 	-parser [namespace current]::process_urls \
 	-renderer [namespace current]::render_url \
-	-parser-priority 60
+	-parser-priority 50
 
     ::richtext::entity_state url 1
 }

Modified: trunk/tkabber/richtext.tcl
===================================================================
--- trunk/tkabber/richtext.tcl	2006-11-06 15:22:00 UTC (rev 788)
+++ trunk/tkabber/richtext.tcl	2006-11-10 21:00:22 UTC (rev 789)
@@ -11,6 +11,7 @@
     variable entities
     variable state
     variable texts {}
+    variable msgprops ;# free-form properties for processing of current message
 
     ::custom::defgroup {Rich Text} \
 	[::msgcat::mc "Settings of rich text facility which is used\
@@ -153,6 +154,7 @@
 proc richtext::render_message {w body deftag {highlightlist {}}} {
     variable entities
     variable state
+    variable msgprops
 
     # Parse the message text with rich text entity parsers:
     set chunks [process_highlights $body $deftag $highlightlist]
@@ -175,6 +177,9 @@
     }
 
     $w insert end \n
+
+    # Get rid of the current message properties
+    array unset msgprops *
 }
 
 # TODO suppress empty chunks
@@ -391,7 +396,37 @@
     $w tag configure $tag -foreground $color
 }
 
+# Message properties may be added before [::richtext::render_message]
+# is called and are intended to be used by rich text plugins whatever
+# they wish to use them.
+# Message properties are automatically killed when message rendering
+# process is over.
+
+# Assotiates "message property" $name and assigns value $val to it:
+proc richtext::property_add {name value} {
+    variable msgprops
+
+    if {[info exists msgprops(name)]} {
+	error "Attempted to overwrite message property: $name"
+    }
+
+    set msgprops($name) $value
+}
+
+proc richtext::property_get {name} {
+    variable msgprops
+
+    set msgprops($name)
+}
+
+proc richtext::property_exists {name} {
+    variable msgprops
+    
+    info exists msgprops($name)
+}
+
 # Register the most basic renderer for type "text":
 richtext::register_entity text -renderer richtext::render_text
 richtext::entity_state text 1
 
+# vim:ts=8:sw=4:sts=4:noet

Modified: trunk/tkabber/utils.tcl
===================================================================
--- trunk/tkabber/utils.tcl	2006-11-06 15:22:00 UTC (rev 788)
+++ trunk/tkabber/utils.tcl	2006-11-10 21:00:22 UTC (rev 789)
@@ -130,6 +130,16 @@
 }
 
 proc check_message {nick body} {
+    set personal 0
+
+    hook::run check_personal_message_hook personal $nick $body
+
+    return $personal
+}
+
+proc personal_message_fallback {vpersonal nick body} {
+    upvar 2 $vpersonal personal
+
     set prefixes {"" "2"}
     set suffixes {":" any " " any "" end}
 
@@ -140,13 +150,15 @@
 		    ([cequal [crange $body 0 [expr {[clength $str] - 1}]] $str] && \
 		    [cequal $pos any])} {
 		set l [clength $pref]
-		return [list 1 [list $l [expr {$l + [clength $nick]}]]]
+		set personal 1
+		return
 	    }
 	}
     }
-    return {0 {}}
 }
 
+hook::add check_personal_message_hook personal_message_fallback 100
+
 proc format_time {t} {
 	if {[cequal $t ""]} {
 	    return



More information about the Tkabber-dev mailing list