[Tkabber-dev] r775 - in trunk/tkabber: . aniemoteicons emoticons emoticons/default ifacetk plugins plugins/chat plugins/general plugins/richtext

tkabber-svn at jabber.ru tkabber-svn at jabber.ru
Fri Nov 3 22:58:51 MSK 2006


Author: sergei
Date: 2006-11-03 22:58:27 +0300 (Fri, 03 Nov 2006)
New Revision: 775

Added:
   trunk/tkabber/emoticons/
   trunk/tkabber/emoticons/default/
   trunk/tkabber/plugins/richtext/
   trunk/tkabber/plugins/richtext/chatlog.tcl
   trunk/tkabber/plugins/richtext/emoticons.tcl
   trunk/tkabber/plugins/richtext/stylecodes.tcl
   trunk/tkabber/plugins/richtext/urls.tcl
   trunk/tkabber/richtext.tcl
Removed:
   trunk/tkabber/emoticons-tkabber/
   trunk/tkabber/emoticons.tcl
Modified:
   trunk/tkabber/ChangeLog
   trunk/tkabber/aniemoteicons/aniemoteicons.tcl
   trunk/tkabber/chats.tcl
   trunk/tkabber/custom.tcl
   trunk/tkabber/emoticons/default/icondef.xml
   trunk/tkabber/ifacetk/iface.tcl
   trunk/tkabber/messages.tcl
   trunk/tkabber/plugins/chat/draw_xhtml_message.tcl
   trunk/tkabber/plugins/general/headlines.tcl
   trunk/tkabber/plugins/general/message_archive.tcl
   trunk/tkabber/tkabber.tcl
   trunk/tkabber/userinfo.tcl
Log:
	* richtext.tcl: Wrapper around text widget, which allows to use
	  customizable message render plugins (thanks to Konstantin
	  Khomoutov).

	* plugins/richtext/chatlog.tcl, plugins/richtext/emoticons.tcl,
	  plugins/richtext/stylecodes.tcl, plugins/richtext/urls.tcl:
	  Plugins with basic colored messages, emoticons (now configurable
	  via GUI), stylecodes and URL handling support (thanks to
	  Konstantin Khomoutov).

	* custom.tcl: Added new configvar function, which allowes changing
	  config variable options on the fly (thanks to Konstantin
	  Khomoutov).

	* aniemoteicons/aniemoteicons.tcl, chats.tcl, ifacetk/iface.tcl,
	  messages.tcl, plugins/chat/draw_xhtml_message.tcl,
	  plugins/general/headlines.tcl, plugins/general/message_archive.tcl,
	  tkabber.tcl, userinfo.tcl: Use richtext for text widgets with
	  highlighting support (thanks to Konstantin Khomoutov).

	* emoticons-tkabber/*: Moved to emoticons/default/ (thanks to
	  Konstantin Khomoutov).


Modified: trunk/tkabber/ChangeLog
===================================================================
--- trunk/tkabber/ChangeLog	2006-11-03 18:04:08 UTC (rev 774)
+++ trunk/tkabber/ChangeLog	2006-11-03 19:58:27 UTC (rev 775)
@@ -1,5 +1,28 @@
 2006-11-03  Sergei Golovan  <sgolovan at nes.ru>
 
+	* richtext.tcl: Wrapper around text widget, which allows to use
+	  customizable message render plugins (thanks to Konstantin
+	  Khomoutov).
+
+	* plugins/richtext/chatlog.tcl, plugins/richtext/emoticons.tcl,
+	  plugins/richtext/stylecodes.tcl, plugins/richtext/urls.tcl:
+	  Plugins with basic colored messages, emoticons (now configurable
+	  via GUI), stylecodes and URL handling support (thanks to
+	  Konstantin Khomoutov).
+
+	* custom.tcl: Added new configvar function, which allowes changing
+	  config variable options on the fly (thanks to Konstantin
+	  Khomoutov).
+
+	* aniemoteicons/aniemoteicons.tcl, chats.tcl, ifacetk/iface.tcl,
+	  messages.tcl, plugins/chat/draw_xhtml_message.tcl,
+	  plugins/general/headlines.tcl, plugins/general/message_archive.tcl,
+	  tkabber.tcl, userinfo.tcl: Use richtext for text widgets with
+	  highlighting support (thanks to Konstantin Khomoutov).
+
+	* emoticons-tkabber/*: Moved to emoticons/default/ (thanks to
+	  Konstantin Khomoutov).
+
 	* examples/configs/badlop-config.tcl,
 	  examples/configs/badlop-config-home.tcl: Fixed paths of sourced
 	  scripts.

Modified: trunk/tkabber/aniemoteicons/aniemoteicons.tcl
===================================================================
--- trunk/tkabber/aniemoteicons/aniemoteicons.tcl	2006-11-03 18:04:08 UTC (rev 774)
+++ trunk/tkabber/aniemoteicons/aniemoteicons.tcl	2006-11-03 19:58:27 UTC (rev 775)
@@ -2,8 +2,10 @@
 
 namespace eval :: {
     source [file join [file dirname [info script]] anigif.tcl]
+}
 
-    proc emoteicons::create_image {dir graphic} {
+namespace eval emoteicons {
+    proc create_image {dir graphic} {
 	return [::anigif::anigif [file join $dir $graphic]]
     }
 }

Modified: trunk/tkabber/chats.tcl
===================================================================
--- trunk/tkabber/chats.tcl	2006-11-03 18:04:08 UTC (rev 774)
+++ trunk/tkabber/chats.tcl	2006-11-03 19:58:27 UTC (rev 775)
@@ -2,20 +2,21 @@
 
 package require textutil
 
-option add *Chat.theyforeground        red3   widgetDefault
-option add *Chat.meforeground          blue   widgetDefault
+option add *Chat.theyforeground        blue   widgetDefault
+option add *Chat.meforeground          red3   widgetDefault
+option add *Chat.highlightforeground   red3   widgetDefault
 option add *Chat.serverlabelforeground green  widgetDefault
 option add *Chat.serverforeground      violet widgetDefault
 option add *Chat.infoforeground        blue   widgetDefault
 option add *Chat.errforeground         red    widgetDefault
 option add *urlforeground              blue   widgetDefault
 option add *urlactiveforeground        red    widgetDefault
+option add *urlcursor                  hand2  widgetDefault
 option add *Chat.inputheight           3      widgetDefault
 
 
 namespace eval chat {
     array set opened {}
-    set urlid 0
     set enrichid 0
     custom::defgroup Chat [::msgcat::mc "Chat options."] -group Tkabber
     custom::defvar options(smart_scroll) 0 \
@@ -24,10 +25,6 @@
     custom::defvar options(stop_scroll) 0 \
 	[::msgcat::mc "Stop chat window autoscroll."] \
 	-type boolean -group Chat
-    custom::defvar options(emphasize) 1 \
-	[::msgcat::mc "Enable messages emphasize."] \
-	-type boolean -group Chat \
-	-command chat::switch_emphasize
     custom::defvar options(display_status_description) 1 \
 	[::msgcat::mc "Display description of user status in chat windows."] \
 	-type boolean -group Chat
@@ -552,38 +549,22 @@
 
     set csw [ScrolledWindow $cf.csw -scrollbar vertical -auto none]
     pack $csw -expand yes -fill both -side top -in $pack_in
-    text $cf.chat -width $chat_width -height $chat_height -font $font -wrap word
-    $csw setwidget $cf.chat
 
-    $cf.chat tag configure they \
-	-foreground [option get $cw theyforeground Chat]
-    $cf.chat tag configure me \
-	-foreground [option get $cw meforeground Chat]
-    $cf.chat tag configure highlight \
-	-foreground [option get $cw meforeground Chat]
-    $cf.chat tag configure server_lab \
-	-foreground [option get $cw serverlabelforeground Chat]
-    $cf.chat tag configure server \
-	-foreground [option get $cw serverforeground Chat]
-    $cf.chat tag configure info \
-	-foreground [option get $cw infoforeground Chat]
-    $cf.chat tag configure err \
-	-foreground [option get $cw errforeground Chat]
+    ::richtext::richtext $cf.chat \
+        -width $chat_width -height $chat_height \
+        -font $font -wrap word
 
-    $cf.chat tag configure bold -font $font_bold
-    $cf.chat tag configure italic -font $font_italic
-    $cf.chat tag configure bold_italic -font $font_bold_italic
-    $cf.chat tag configure underlined -underline 1
-    if {$options(emphasize)} {
-	$cf.chat tag configure emphasized -elide 0
-	$cf.chat tag configure nonemphasized -elide 1
-    } else {
-	$cf.chat tag configure emphasized -elide 1
-	$cf.chat tag configure nonemphasized -elide 0
-    }
+    ::plugins::chatlog::config $cf.chat \
+	-theyforeground [query_optiondb $cw theyforeground] \
+	-meforeground [query_optiondb $cw meforeground] \
+	-serverlabelforeground [query_optiondb $cw serverlabelforeground] \
+	-serverforeground [query_optiondb $cw serverforeground] \
+	-infoforeground [query_optiondb $cw infoforeground] \
+	-errforeground [query_optiondb $cw errforeground] \
+	-highlightforeground [query_optiondb $cw highlightforeground]
 
+    $csw setwidget $cf.chat
 
-    $cf.chat configure -state disabled
     focus $cw.input
 
     bind $cw.input <Shift-Key-Return> { }
@@ -606,6 +587,14 @@
 
 ###############################################################################
 
+# This proc is used by the "richtext widget" to query the option DB for
+# it's attributes which are really maintained by the main chat window
+proc chat::query_optiondb {w option} {
+    option get $w $option Chat
+}
+
+###############################################################################
+
 proc chat::draginitcmd {target x y top} {
     return {}
 }
@@ -779,24 +768,16 @@
 
 proc chat::add_chat_win_popup_menu {m chatwin X Y x y} {
     set tags [$chatwin tag names "@$x,$y"]
-    set idx [lsearch -glob $tags url*]
+    set idx [lsearch $tags url]
     if {$idx >= 0} {
 	$m add command -label [::msgcat::mc "Copy URL to clipboard"] \
-	    -command [list [namespace current]::copy_url $chatwin \
-			   [lindex $tags $idx]]
+	    -command [list ::plugins::urls::copy_url $chatwin $x $y]
     }
 }
 
 hook::add chat_win_popup_menu_hook \
     [namespace current]::chat::add_chat_win_popup_menu 10
 
-proc chat::copy_url {chatwin tag} {
-    regsub -all %% [$chatwin tag bind $tag <ButtonPress-1><ButtonRelease-1>] % res
-    # assuming "browseurl url"
-    clipboard clear -displayof $chatwin
-    clipboard append -displayof $chatwin [lrange $res 1 end]
-}
-
 proc chat::send_message {cw chatid type} {
     set iw $cw.input
 
@@ -858,163 +839,11 @@
     }
 }
 
-proc chat::highlighttext {chatw tag color cursor} {
-	$chatw configure -cursor $cursor
-	$chatw tag configure $tag -foreground $color
-}
-
 proc chat::add_emoteiconed_text {chatw body defaulttag {highlightlist {}}} {
-    if {[lempty $highlightlist]} {
-	add_emoteiconed_text1 $chatw $body $defaulttag
-    } else {
-	set ind 0
-	foreach {i1 i2} $highlightlist {
-	    add_emoteiconed_text1 $chatw [crange $body $ind [expr {$i1 - 1}]] $defaulttag
-	    $chatw insert end [crange $body $i1 [expr {$i2 - 1}]] highlight
-	    set ind $i2
-	}
-	chat::add_emoteiconed_text1 $chatw [crange $body $ind end] $defaulttag
-    }
+    # TODO get rid of chat::add_emoteiconed_text
+    richtext::render_message $chatw $body $defaulttag $highlightlist
 }
 
-proc chat::encode_url {url} {
-    set utf8_url [encoding convertto utf-8 $url]
-    set len [string length $utf8_url]
-    set encoded_url ""
-    for {set i 0} {$i < $len} {incr i} {
-	binary scan $utf8_url @${i}c sym
-	set sym [expr {$sym & 0xFF}]
-	if {$sym >= 128 || $sym <= 32} {
-	    append encoded_url [format "%%%02X" $sym]
-	} else {
-	    append encoded_url [binary format c $sym]
-	}
-    }
-    return $encoded_url
-}
-
-proc chat::add_url {tw msg url args} {
-    variable urlid
-
-    set command ""
-    foreach {key val} $args {
-	switch -- $key {
-	    -command { set command $val }
-	}
-    }
-
-    set tag url$urlid
-    set urlfg    [option get $tw urlforeground       Text]
-    set urlactfg [option get $tw urlactiveforeground Text]
-    $tw tag configure $tag -foreground $urlfg -underline 1
-    $tw tag bind $tag <ButtonPress-1><ButtonRelease-1> \
-	[list browseurl [double% [encode_url $url]]]
-    if {$command != ""} {
-	$tw tag bind $tag <ButtonPress-1><ButtonRelease-1> \
-	    +[list eval $command]
-    }
-    $tw tag bind $tag <Any-Enter> \
-	[list chat::highlighttext $tw $tag $urlactfg hand2]
-    $tw tag bind $tag <Any-Leave> \
-	[list chat::highlighttext $tw $tag $urlfg xterm]
-	    
-    $tw insert end $msg $tag
-    incr urlid
-}
-
-proc chat::on_browse_url {chatid w x y} {
-    set tags [$w tag names "@$x,$y"]
-    set idx [lsearch -glob $tags url*]
-    if {$idx >= 0} {
-	return stop
-    }
-    return
-}
-
-hook::add chat_window_click_hook chat::on_browse_url 10
-	
-proc chat::add_emoteiconed_text1 {chatw body defaulttag} {
-    variable url_regexp
-    variable options
-
-    set num_of_emoticons 0
-    set words [textutil::splitx $body {([\t \r\n]+)}]
-
-    foreach word $words {
-	if {$num_of_emoticons < 200} {
-	    if {[emoteicons::get $word] != ""} {
-		emoteicons::put $chatw $word
-		incr num_of_emoticons
-		continue
-	    }
-	}
-	if {[regexp -expanded -nocase -- $url_regexp $word ignore head url ignore2 tail]} {
-	    $chatw insert end $head $defaulttag
-	    add_url $chatw $url $url
-	    $chatw insert end $tail $defaulttag
-	} else {
-	    if {0 && !$options(emphasize)} {
-		$chatw insert end $word $defaulttag
-	    } else {
-		set enrichedText(bold) 0
-		set enrichedText(italic) 0
-		set enrichedText(underline) 0
-
-		set tmp $word
-		while {[regexp -- "^(_|/|\\*)(.+)(_|/|\\*)$" $tmp wholeMatch e1 subWord e2]} {
-		    if { $e1 != $e2 } {
-			break
-		    }
-		    if { "*" == $e1 } {
-			if {$enrichedText(bold)} break
-			set enrichedText(bold) 1
-		    } elseif { "/" == $e1 } {
-			if {$enrichedText(italic)} break
-			set enrichedText(italic) 1
-		    } elseif { "_" == $e1 } {
-			if {$enrichedText(underline)} break
-			set enrichedText(underline) 1
-		    }
-		    set tmp $subWord
-		}
-
-		set tag $defaulttag
-		switch -- $enrichedText(bold),$enrichedText(italic) {
-		    1,1 {lappend tag bold_italic}
-		    1,0 {lappend tag bold}
-		    0,1 {lappend tag italic}
-		}
-		if {$enrichedText(underline) == 1} {
-		    lappend tag underlined
-		}
-		if {$tmp != $word} {
-		    lappend tag emphasized
-		    $chatw insert end $tmp $tag
-		    $chatw insert end $word [concat nonemphasized $defaulttag]
-		} else {
-		    $chatw insert end $word $defaulttag
-		}
-	    }
-	}
-    }
-}
-
-proc chat::switch_emphasize {args} {
-    variable options
-    variable opened
-
-    foreach chatid [array names opened] {
-	set cw [chat_win $chatid]
-	if {$options(emphasize)} {
-	    $cw tag configure emphasized -elide 0
-	    $cw tag configure nonemphasized -elide 1
-	} else {
-	    $cw tag configure emphasized -elide 1
-	    $cw tag configure nonemphasized -elide 0
-	}
-    }
-}
-
 proc chat::add_open_to_user_menu_item {m connid jid} {
     $m add command -label [::msgcat::mc "Start chat"] \
 	-command [list chat::open_to_user $connid $jid]

Modified: trunk/tkabber/custom.tcl
===================================================================
--- trunk/tkabber/custom.tcl	2006-11-03 18:04:08 UTC (rev 774)
+++ trunk/tkabber/custom.tcl	2006-11-03 19:58:27 UTC (rev 775)
@@ -65,6 +65,50 @@
     set var(type,$fullname) string
     set var(state,$fullname) ""
 
+    eval { configvar $fullname } $args
+}
+
+proc custom::on_var_change {varname args} {
+    variable options
+    variable var
+    variable custom_loaded
+
+    switch -- $custom_loaded {
+	-1 {
+	    set var(config,$varname) [set $varname]
+	}
+	0 { }
+	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]} {
+		store_vars $varname
+	    }
+	}
+    }
+}
+
+proc custom::add_radio_options {vname values} {
+    variable var
+    
+    set fullname [uplevel 1 {namespace current}]::$vname
+
+    if {![info exists $fullname]} {
+	return
+    }
+
+    set var(values,$fullname) [concat $var(values,$fullname) $values]
+}
+
+proc custom::configvar {fullname args} {
+    variable var
+    variable group
+
+    if {![info exists $fullname]} {
+	error "No such variable: $fullname"
+    }
+
     foreach {attr val} $args {
 	switch -- $attr {
 	    -type {
@@ -82,6 +126,7 @@
 	    }
 	}
     }
+	
     switch -- $var(type,$fullname) {
 	radio {
 	    set q 0
@@ -95,6 +140,7 @@
 	    }
 	}
     }
+	
     foreach {attr val} $args {
 	switch -- $attr {
 	    -command {
@@ -104,39 +150,6 @@
     }
 }
 
-proc custom::on_var_change {varname args} {
-    variable options
-    variable var
-    variable custom_loaded
-
-    switch -- $custom_loaded {
-	-1 {
-	    set var(config,$varname) [set $varname]
-	}
-	0 { }
-	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]} {
-		store_vars $varname
-	    }
-	}
-    }
-}
-
-proc custom::add_radio_options {vname values} {
-    variable var
-    
-    set fullname [uplevel 1 {namespace current}]::$vname
-
-    if {![info exists $fullname]} {
-	return
-    }
-
-    set var(values,$fullname) [concat $var(values,$fullname) $values]
-}
-
 custom::defgroup Tkabber \
     [::msgcat::mc "Customization of the One True Jabber Client."]
 

Copied: trunk/tkabber/emoticons/default (from rev 774, trunk/tkabber/emoticons-tkabber)

Modified: trunk/tkabber/emoticons/default/icondef.xml
===================================================================
--- trunk/tkabber/emoticons-tkabber/icondef.xml	2006-11-03 18:04:08 UTC (rev 774)
+++ trunk/tkabber/emoticons/default/icondef.xml	2006-11-03 19:58:27 UTC (rev 775)
@@ -1,8 +1,8 @@
 <?xml version='1.0' encoding='UTF-8'?>
 <icondef>
   <meta>
-    <name>Tkabber's emoticons</name>
-    <version>0.0.2</version>
+    <name>Default</name>
+    <version>0.0.3</version>
     <description>Tkabber's emoticons.</description>
     <author>Alexey Shchepin</author>
     <creation>2002-08-12</creation>

Deleted: trunk/tkabber/emoticons.tcl
===================================================================
--- trunk/tkabber/emoticons.tcl	2006-11-03 18:04:08 UTC (rev 774)
+++ trunk/tkabber/emoticons.tcl	2006-11-03 19:58:27 UTC (rev 775)
@@ -1,235 +0,0 @@
-# $Id$
-
-namespace eval emoteicons {
-    array set emoteicons {}
-
-    variable lasttext ""
-    variable lastX
-    variable lastY
-}
-
-proc emoteicons::add {word image} {
-    variable emoteicons
-    set emoteicons($word) $image
-}
-
-proc emoteicons::get {word} {
-    variable emoteicons
-
-    if {[info exists emoteicons($word)]} {
-	return $emoteicons($word)
-    } else {
-	return ""
-    }
-}
-
-proc emoteicons::put {txt word} {
-    variable emoteicons
-
-    if {[info exists emoteicons($word)]} {
-	$txt image create end -image $emoteicons($word)
-    }
-}
-
-proc emoteicons::load_dir {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 parser [jlib::wrapper:new "#" "#" \
-		    [list emoteicons::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
-}
-
-proc emoteicons::parse_icondef {dir xmldata} {
-    jlib::wrapper:splitxml $xmldata tag vars isempty chdata children
-
-    if {$tag != "icondef"} {
-	# TODO: error message
-	return
-    }
-
-    foreach child $children {
-	parse_item $dir $child
-    }
-
-}
-
-proc emoteicons::parse_item {dir item} {
-    jlib::wrapper:splitxml $item tag vars isempty chdata children
-
-    switch -- $tag {
-	name {}
-	version {}
-	description {}
-	author {}
-	creation {}
-	meta {}
-	icon {
-	    parse_icon $dir $children
-	}
-    }
-}
-
-proc emoteicons::parse_icon {dir items} {
-    variable txtdefaults
-    variable txtlabels
-
-    set txts {}
-    set txtdefault ""
-    set graphic ""
-    foreach item $items {
-	jlib::wrapper:splitxml $item tag vars isempty chdata children
-	switch -- $tag {
-	    text {
-		lappend txts $chdata
-		if {$txtdefault == "" || \
-			[jlib::wrapper:getattr $vars default] == "true"} {
-		    set txtdefault $chdata
-		}
-	    }
-	    object {
-		switch -glob -- [jlib::wrapper:getattr $vars mime] {
-		    image/* {set graphic $chdata}
-		}
-	    }
-	    graphic {
-		# For compatibility with older versions of icondef.xml
-		switch -glob -- [jlib::wrapper:getattr $vars type] {
-		    image/* {set graphic $chdata}
-		}
-	    }
-	    sound {}
-	}
-    }
-    #debugmsg emoticons "E: $graphic; $txts"
-    if {$graphic != ""} {
-	set img [create_image $dir $graphic]
-	foreach txt $txts {
-	    emoteicons::add $txt $img
-	}
-	set txtdefaults($img) $txtdefault
-	set txtlabels($img) [file rootname [file tail $graphic]]
-    }
-}
-
-proc emoteicons::create_image {dir graphic} {
-    set img $dir/$graphic
-    image create photo $img -file [file join $dir $graphic]
-    return $img
-}
-
-emoteicons::load_dir [fullpath emoticons-tkabber]
-
-proc emoteicons::show_menu {iw} {
-    variable txtdefaults
-    variable txtlabels
-
-    set m .emoticonsmenu
-    if {[winfo exists $m]} {
-	destroy $m
-    }
-    menu $m -tearoff 0
-    set imgs [array names txtdefaults]
-    set rows [expr {floor(sqrt([llength $imgs]))}]
-    set row 0
-
-    foreach img $imgs {
-	if {$row >= $rows} {
-	    $m add command -image $img -columnbreak 1 \
-		-label $txtlabels($img) \
-		-command [list [namespace current]::insert $iw \
-						$txtdefaults($img)]
-	    set row 1
-	} else {
-	    $m add command -image $img \
-		-label $txtlabels($img) \
-		-command [list [namespace current]::insert $iw \
-						$txtdefaults($img)]
-	    incr row
-	}
-    }
-
-    bind $m <Any-Enter>  \
-	[list [namespace current]::balloon $m enter  %X %Y %x %y]
-    bind $m <Any-Motion> \
-	[list [namespace current]::balloon $m motion %X %Y %x %y]
-    bind $m <Any-Leave>  \
-	[list [namespace current]::balloon $m leave  %X %Y %x %y]
-
-    tk_popup $m [winfo pointerx .] [winfo pointery .]
-}
-
-# trying to get motion events in a menu is problematic...
-
-proc emoteicons::balloon {w action X Y x y} {
-    variable lasttext
-    variable lastX
-    variable lastY
-
-    if {[cequal [set index [$w index @$x,$y]] none]} {
-	if {![cequal $lasttext ""]} {
-	    balloon::default_balloon $w leave $lastX $lastY
-	}
-
-	return
-    }
-
-    set text [$w entrycget $index -label]
-    switch -- $action {
-        motion {
-            if {![cequal $text $lasttext]} {
-		if {![cequal $lasttext ""]} {
-                    balloon::default_balloon $w leave $lastX $lastY
-		}
-
-                balloon::default_balloon $w enter [set lastX $X] \
-						  [set lastY $Y] \
-						  -text [set lasttext $text]
-            }
-        }
-
-        leave {
-            set lasttext ""
-        }
-    }
-
-    balloon::default_balloon $w $action $X $Y -text $text
-}
-
-proc emoteicons::insert {iw text} {
-    set p ""
-    switch -- [$iw get "insert - 1 chars"] {
-	"" - " " - "\n" {}
-
-	default         { 
-	    if {![cequal [$iw index "insert -1 chars"] 1.0]} {
-		set p " "
-	    }
-	}
-    }
-
-    $iw insert insert "$p$text "
-}
-
-event add <<EmoteiconsMenu>> <Meta-e>
-event add <<EmoteiconsMenu>> <Alt-e>
-
-proc emoteicons::setup_bindings {chatid type} {
-    set iw [chat::input_win $chatid]
-
-    bind $iw <<EmoteiconsMenu>> \
-	[list emoteicons::show_menu $iw]
-    bind $iw <<EmoteiconsMenu>> +break
-}
-
-
-hook::add open_chat_post_hook emoteicons::setup_bindings

Modified: trunk/tkabber/ifacetk/iface.tcl
===================================================================
--- trunk/tkabber/ifacetk/iface.tcl	2006-11-03 18:04:08 UTC (rev 774)
+++ trunk/tkabber/ifacetk/iface.tcl	2006-11-03 19:58:27 UTC (rev 775)
@@ -306,7 +306,7 @@
 		    [list checkbutton [::msgcat::mc "Stop autoscroll"] {} {} {} \
 			 -variable chat::options(stop_scroll)] \
 		    [list checkbutton [::msgcat::mc "Emphasize"] {} {} {} \
-			 -variable chat::options(emphasize)] \
+			 -variable plugins::stylecodes::options(emphasize)] \
 		    {separator} \
 		  ]] \
 		  {separator} \

Modified: trunk/tkabber/messages.tcl
===================================================================
--- trunk/tkabber/messages.tcl	2006-11-03 18:04:08 UTC (rev 774)
+++ trunk/tkabber/messages.tcl	2006-11-03 19:58:27 UTC (rev 775)
@@ -157,8 +157,7 @@
 
     ScrolledWindow $mw.rsw
     text $mw.rbody -width 60 -height 8 -wrap word
-    $mw.rbody tag configure emphasized -elide 1
-    $mw.rbody tag configure nonemphasized -elide 0
+    ::richtext::config $mw.rbody -using {url emoticon stylecode}
     ::chat::add_emoteiconed_text $mw.rbody $body ""
     $mw.rbody configure -state disabled
     pack $mw.rsw -side top -fill both -expand yes -in $mw.frame

Modified: trunk/tkabber/plugins/chat/draw_xhtml_message.tcl
===================================================================
--- trunk/tkabber/plugins/chat/draw_xhtml_message.tcl	2006-11-03 18:04:08 UTC (rev 774)
+++ trunk/tkabber/plugins/chat/draw_xhtml_message.tcl	2006-11-03 19:58:27 UTC (rev 775)
@@ -392,9 +392,9 @@
     $chatw tag configure $tag -foreground $urlfg -underline 1
     $chatw tag bind $tag <1> [list browseurl [double% $url]]
     $chatw tag bind $tag <Any-Enter> \
-	[list chat::highlighttext $chatw $tag $urlactfg hand2]
+	[list ::richtext::highlighttext $chatw $tag $urlactfg hand2]
     $chatw tag bind $tag <Any-Leave> \
-	[list chat::highlighttext $chatw $tag $urlfg xterm]
+	[list ::richtext::highlighttext $chatw $tag $urlfg xterm]
     $chatw tag raise $tag
     return $tag
 }

Modified: trunk/tkabber/plugins/general/headlines.tcl
===================================================================
--- trunk/tkabber/plugins/general/headlines.tcl	2006-11-03 18:04:08 UTC (rev 774)
+++ trunk/tkabber/plugins/general/headlines.tcl	2006-11-03 19:58:27 UTC (rev 775)
@@ -193,10 +193,9 @@
 	set dsw [ScrolledWindow $dw.sw]
 	text $hw.body -font $font -height 12 -state disabled \
 	     -wrap word -takefocus 1
+	::richtext::config $hw.body -using url
 	$dsw setwidget $hw.body
 	pack $dsw -expand yes -fill both -anchor nw
-	$hw.body tag configure emphasized -elide 1
-	$hw.body tag configure nonemphasized -elide 0
 
 	bind $hw.body <ButtonPress-1> [list focus %W]
 
@@ -294,9 +293,8 @@
     $wbody delete 0.0 end
     chat::add_emoteiconed_text $wbody "$body\n\n" ""
     if {$url != ""} {
-	#chat::add_url $wbody [::msgcat::mc "See more..."] $url
-	chat::add_url $wbody $url $url \
-	    -command [list [namespace code action] markseen \
+        ::plugins::urls::render_url $wbody url $url {} \
+            -command [list [namespace code action] markseen \
 			   [winfo parent $tw] $node]
     }
     $wbody configure -state disabled

Modified: trunk/tkabber/plugins/general/message_archive.tcl
===================================================================
--- trunk/tkabber/plugins/general/message_archive.tcl	2006-11-03 18:04:08 UTC (rev 774)
+++ trunk/tkabber/plugins/general/message_archive.tcl	2006-11-03 19:58:27 UTC (rev 775)
@@ -75,8 +75,7 @@
     text $body.body -height 20 -state disabled -wrap word
     pack $body -expand yes -fill both -anchor nw
     $body setwidget $body.body
-    $body.body tag configure emphasized -elide 1
-    $body.body tag configure nonemphasized -elide 0
+    ::richtext::config $body.body -using {url emoticon stylecode}
 
     set sww [ScrolledWindow $w.items]
 

Added: trunk/tkabber/plugins/richtext/chatlog.tcl
===================================================================
--- trunk/tkabber/plugins/richtext/chatlog.tcl	                        (rev 0)
+++ trunk/tkabber/plugins/richtext/chatlog.tcl	2006-11-03 19:58:27 UTC (rev 775)
@@ -0,0 +1,78 @@
+# $Id: chatlog.tcl 18 2006-10-24 00:38:28Z kostix $
+# This is a (pretty much eclectic) framework to support various highlights
+# in chat messages. It registers a rich text entity "highlight" and provides
+# for configuring a text widget to be ready to display highlights.
+# On the other hand, detection of such highlights is done elsewhere -- in the
+# already existing bits of code (that is, handling /me messages, server messages,
+# MUC subjects, etc). There are plans to eventually move such code to
+# this "chatlog" plugin.
+
+namespace eval chatlog {
+}
+
+# These procs are here just for the reference.
+# Also, neither parser nor renderer are registered for the "highlight"
+# richtext entity (to speedup message processing).
+if 0 {
+    proc chatlog::process_highlights {atLevel accName} {
+    }
+
+    proc chatlog::render_highlight {w type piece tags} {
+    }
+}
+
+# This proc provides for reconfiguration of the chatlog tags.
+# It is intended to be used for post-configuration of the rich text
+# widgets when creating them to server as chat log windows,
+# since chatlog windows allow the customization of these parameters
+# via the Tk option database.
+proc chatlog::config {w args} {
+    foreach {opt val} $args {
+	switch -- $opt {
+	    -theyforeground {
+		$w tag configure they -foreground $val
+	    }
+	    -meforeground {
+		$w tag configure me -foreground $val
+	    }
+	    -serverlabelforeground {
+		$w tag configure server_lab -foreground $val
+	    }
+	    -serverforeground {
+		$w tag configure server -foreground $val
+	    }
+	    -infoforeground {
+		$w tag configure info -foreground $val
+	    }
+	    -errforeground {
+		$w tag configure err -foreground $val
+	    }
+	    -highlightforeground {
+		$w tag configure highlight -foreground $val
+	    }
+	    default {
+		error "Unknown option: $opt"
+	    }
+	}
+    }
+}
+
+proc chatlog::configure_richtext_widget {w} {
+    # TODO do we need to provide some defaults?
+
+    $w tag configure they
+    $w tag configure me
+    $w tag configure server_lab
+    $w tag configure server
+    $w tag configure info
+    $w tag configure err
+    $w tag configure highlight
+}
+
+namespace eval chatlog {
+    ::richtext::register_entity highlight \
+	-configurator [namespace current]::configure_richtext_widget
+
+    ::richtext::entity_state highlight 1
+}
+

Copied: trunk/tkabber/plugins/richtext/emoticons.tcl (from rev 774, trunk/tkabber/emoticons.tcl)
===================================================================
--- trunk/tkabber/plugins/richtext/emoticons.tcl	                        (rev 0)
+++ trunk/tkabber/plugins/richtext/emoticons.tcl	2006-11-03 19:58:27 UTC (rev 775)
@@ -0,0 +1,654 @@
+# $Id$
+
+namespace eval emoticons {
+    variable themes
+    variable emoticons  ;# mapping from text mnemonics to images
+    variable images     ;# reference counts of images
+    variable txtdefaults
+    variable txtlabels
+    variable lasttext ""
+    variable lastX
+    variable lastY
+    variable faces_list {}
+    variable faces_regexp ""
+
+    variable options
+
+    ::custom::defgroup Emoticons \
+	[::msgcat::mc "Handling of \"emoticons\".\
+		       Emoticons (also known as \"smileys\")\
+		       are small pictures resembling a human face\
+		       used to represent user's emotion. They are\
+		       typed in as special mnemonics like :)\
+		       or can be inserted using menu."]\
+	-group {Rich Text}
+
+    ::custom::defvar options(enabled) 1 \
+	[::msgcat::mc "Enable handling of emoticons."] \
+	-type boolean -group Emoticons \
+	-command [namespace current]::on_state_changed
+
+    set options(no_theme) [::msgcat::mc "None"]
+    set options(active_theme) $options(no_theme)
+	
+    custom::defvar options(theme) $options(no_theme) \
+	[::msgcat::mc "Tkabber emoticons theme. To make new theme visible\
+		       for Tkabber put it to some subdirectory of\
+		       ~/.tkabber/emoticons"] \
+	-group Emoticons -type options \
+	-values [list {} $options(no_theme)] \
+	-command [namespace current]::on_theme_changed
+
+    custom::defvar options(match_whole_word) 1 \
+	[::msgcat::mc "Use only whole words for emoticons."] \
+	-group Emoticons -type boolean
+
+    custom::defvar options(handle_lol) 0 \
+	[::msgcat::mc "Handle ROTFL/LOL smileys -- those like :))) --\
+		       by \"consuming\" all that parens and rendering the\
+		       whole word with appropriate icon."] \
+	-group Emoticons -type boolean \
+	-command [namespace current]::on_regex_mode_changed
+
+    # The [on_state_changed] proc called by finload_hook
+    # completes initialization, if needed.
+}
+
+proc emoticons::add {face image} {
+    variable options
+    variable emoticons
+    variable images
+    variable faces_regexp
+
+    if {[info exists emoticons($face)]} {
+	incr images($emoticons($face)) -1
+    }
+
+    set emoticons($face) $image
+
+    incr images($image)
+
+    lappend faces_list [re_escape $face]
+
+    if {$faces_regexp != ""} {
+	append faces_regexp |
+    }
+
+    append faces_regexp [re_escape $face]
+
+    if {$options(handle_lol)} {
+	append faces_regexp +
+    }
+}
+
+proc emoticons::get {word} {
+    variable emoticons
+
+    if {[info exists emoticons($word)]} {
+	return $emoticons($word)
+    } else {
+	return ""
+    }
+}
+
+proc emoticons::put {txt word} {
+    variable emoticons
+
+    if {[info exists emoticons($word)]} {
+	$txt image create end -image $emoticons($word)
+    }
+}
+
+# Destroys all emoticons, then loads a new set of them:
+proc emoticons::load_dir {dir} {
+    variable images
+    variable emoticons
+    variable txtdefaults
+    variable txtlabels
+    variable faces_regexp
+
+    # Prepare for loading:
+
+    array unset emoticons *
+    array unset txtdefaults *
+    array unset txtlabels *
+
+    set faces_regexp ""
+
+    # Set refcount to 0 on all images:
+    foreach iname [array names images] {
+	set images($iname) 0
+    }
+
+    # Load fresh images:
+    merge_dir $dir
+}
+
+# Merges a new set of emoticons, adding them to the existing set,
+# replacing any existing emoticons with the same mnemonics:
+proc emoticons::merge_dir {dir} {
+    variable images
+    variable faces_regexp
+
+    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):
+	    if {[catch {image inuse $iname} keep]} {
+		set keep 0
+	    }
+
+	    if {! $keep} {
+		image delete $iname
+		unset images($iname)
+	    }
+	}
+    }
+
+}
+
+proc emoticons::parse_icondef {dir xmldata} {
+    jlib::wrapper:splitxml $xmldata tag vars isempty chdata children
+
+    if {$tag != "icondef"} {
+	# TODO: error message
+	return
+    }
+
+    foreach child $children {
+	parse_item $dir $child
+    }
+
+}
+
+proc emoticons::parse_item {dir item} {
+    jlib::wrapper:splitxml $item tag vars isempty chdata children
+
+    switch -- $tag {
+	name {}
+	version {}
+	description {}
+	author {}
+	creation {}
+	meta {}
+	icon {
+	    parse_icon $dir $children
+	}
+    }
+}
+
+proc emoticons::parse_icon {dir items} {
+    variable txtdefaults
+    variable txtlabels
+    variable images
+
+    lappend faces
+    set txtdefault ""
+    set graphic ""
+    foreach item $items {
+	jlib::wrapper:splitxml $item tag vars isempty chdata children
+	switch -- $tag {
+	    text {
+		lappend faces $chdata
+		if {$txtdefault == "" || \
+			[jlib::wrapper:getattr $vars default] == "true"} {
+		    set txtdefault $chdata
+		}
+	    }
+	    object {
+		switch -glob -- [jlib::wrapper:getattr $vars mime] {
+		    image/* {set graphic $chdata}
+		}
+	    }
+	    graphic {
+		# For compatibility with older versions of icondef.xml
+		switch -glob -- [jlib::wrapper:getattr $vars type] {
+		    image/* {set graphic $chdata}
+		}
+	    }
+	    sound {}
+	}
+    }
+
+    #debugmsg emoticons "E: $graphic; $txts"
+
+    if {$graphic == "" || [llength $faces] == 0} return
+
+    # Work around absence of default face:
+    if {$txtdefault == ""} {
+	set txtdefault [lindex $faces 0]
+    }
+
+    set iname [imagename $txtdefault]
+
+    # TODO what if more than one face match existing images?
+    foreach face $faces {
+	set icon [imagename $face]
+	if {[info exists images($icon)]} {
+	    set iname $icon
+	    break
+	}
+    }
+	
+    image create photo $iname -file [file join $dir $graphic]
+
+    set images($iname) 0 ;# Initial refcount is zero since it'll bumped by successive [add]s:
+
+    foreach face $faces {
+	add $face $iname
+    }
+
+    set txtdefaults($iname) $txtdefault
+    set txtlabels($iname) [file rootname [file tail $graphic]]
+}
+
+# Constructs a name for the emoticon image from its mnemonic.
+# Since [image] creates a command with the name of the image, we
+# add our namespace as a prefix.
+proc emoticons::imagename {mnemonic} {
+    return [namespace current]::emoticon_$mnemonic
+}
+
+if 0 {
+proc emoticons::create_image {dir graphic} {
+    set img $dir/$graphic
+    image create photo $img -file [file join $dir $graphic]
+    return $img
+}
+} else {
+proc emoticons::create_image {name file} {
+    image create photo $name -file $file
+    return $name
+}
+}
+
+proc emoticons::show_menu {iw} {
+    variable txtdefaults
+    variable txtlabels
+
+    set m .emoticonsmenu
+    if {[winfo exists $m]} {
+	destroy $m
+    }
+    menu $m -tearoff 0
+    set imgs [array names txtdefaults]
+    set rows [expr {floor(sqrt([llength $imgs]))}]
+    set row 0
+
+    foreach img $imgs {
+	if {$row >= $rows} {
+	    $m add command -image $img -columnbreak 1 \
+		-label $txtlabels($img) \
+		-command [list [namespace current]::insert $iw \
+						$txtdefaults($img)]
+	    set row 1
+	} else {
+	    $m add command -image $img \
+		-label $txtlabels($img) \
+		-command [list [namespace current]::insert $iw \
+						$txtdefaults($img)]
+	    incr row
+	}
+    }
+
+    bind $m <Any-Enter>  \
+	[list [namespace current]::balloon $m enter  %X %Y %x %y]
+    bind $m <Any-Motion> \
+	[list [namespace current]::balloon $m motion %X %Y %x %y]
+    bind $m <Any-Leave>  \
+	[list [namespace current]::balloon $m leave  %X %Y %x %y]
+
+    tk_popup $m [winfo pointerx .] [winfo pointery .]
+}
+
+# trying to get motion events in a menu is problematic...
+
+proc emoticons::balloon {w action X Y x y} {
+    variable lasttext
+    variable lastX
+    variable lastY
+
+    if {[cequal [set index [$w index @$x,$y]] none]} {
+	if {![cequal $lasttext ""]} {
+	    balloon::default_balloon $w leave $lastX $lastY
+	}
+
+	return
+    }
+
+    set text [$w entrycget $index -label]
+    switch -- $action {
+        motion {
+            if {![cequal $text $lasttext]} {
+		if {![cequal $lasttext ""]} {
+                    balloon::default_balloon $w leave $lastX $lastY
+		}
+
+                balloon::default_balloon $w enter [set lastX $X] \
+						  [set lastY $Y] \
+						  -text [set lasttext $text]
+            }
+        }
+
+        leave {
+            set lasttext ""
+        }
+    }
+
+    balloon::default_balloon $w $action $X $Y -text $text
+}
+
+proc emoticons::insert {iw text} {
+    set p ""
+    switch -- [$iw get "insert - 1 chars"] {
+	"" - " " - "\n" {}
+
+	default         { 
+	    if {![cequal [$iw index "insert -1 chars"] 1.0]} {
+		set p " "
+	    }
+	}
+    }
+
+    $iw insert insert "$p$text "
+}
+
+event add <<EmoticonsMenu>> <Meta-e>
+event add <<EmoticonsMenu>> <Alt-e>
+
+proc emoticons::setup_bindings {chatid type} {
+    set iw [chat::input_win $chatid]
+
+    bind $iw <<EmoticonsMenu>> \
+	[list [namespace current]::show_menu $iw]
+    bind $iw <<EmoticonsMenu>> +break
+}
+
+proc emoticons::process_emoticons {atLevel accName} {
+    upvar #$atLevel $accName chunks
+
+    lappend out
+
+    foreach {s type tags} $chunks {
+	if {$type != "text"} {
+	    # pass through
+	    lappend out $s $type $tags
+	    continue
+	}
+
+	set ix 0; set fs 0; set fe 0
+
+	while {[spot_face $s $ix fs fe]} {
+	    if {$fs - $ix > 0} {
+		# dump chunk before emoticon:
+		lappend out [string range $s $ix [expr {$fs - 1}]] $type $tags
+	    }
+
+	    # dump emoticon:
+	    lappend out [string range $s $fs $fe] emoticon $tags
+
+	    set ix [expr {$fe + 1}]
+	}
+
+	if {[string length $s] - $ix > 0} {
+	    # dump chunk after emoticon:
+	    lappend out [string range $s $ix end] $type $tags
+	}
+    }
+
+    set chunks $out
+}
+
+proc emoticons::spot_face {what at fsVar feVar} {
+    variable options
+    variable faces_regexp
+
+    if {$faces_regexp == ""} {return false}
+
+    upvar 1 $fsVar fs $feVar fe
+    foreach inds [regexp -all -inline -indices -start $at -- $faces_regexp $what] {
+	lassign $inds fsv fev
+	if {!$options(match_whole_word) || \
+	    ([string is space [string index $what [expr {$fsv-1}]]] && \
+	     [string is space [string index $what [expr {$fev+1}]]])} {
+	    set fs $fsv
+	    set fe $fev
+	    return true
+	}
+    }
+    return false
+}
+
+proc emoticons::render_emoticon {w type word tags} {
+    variable options
+
+    if {$options(handle_lol)} {
+	set word [string_collapseright $word]
+    }
+
+    if {[get $word] != {}} {
+	$w insert end $word emoticon
+	put $w $word
+    } else {
+	$w insert end $word
+    }
+}
+
+
+
+# TODO good candidate to go outside:
+proc emoticons::re_escape {s} {
+    return [string map {\\ \\\\
+			* \\*
+			. \\.
+			[ \\[
+			] \\]
+			\{ \\{
+			\} \\}
+			( \\(
+			) \\)
+			| \\|
+			? \\?} $s]
+}
+
+proc emoticons::configure_richtext_widget {w} {
+    $w tag configure emoticon -elide 1
+}
+
+proc emoticons::enumerate_available_themes {} {
+    set dirs [concat \
+		  [glob -nocomplain -directory [fullpath emoticons] *] \
+		  [glob -nocomplain -directory [file join ~ .tkabber emoticons] *]]
+
+    foreach dir $dirs {
+	enumerate_theme [namespace current]::themes $dir
+    }
+
+    variable themes
+}
+
+
+
+proc emoticons::enumerate_theme {varName dir} {
+    set icondef_path [file join $dir icondef.xml]
+
+    if {![file isfile $icondef_path]} return
+
+    set f [open $icondef_path]
+    set icondef [read $f]
+    close $f
+
+    set parser [jlib::wrapper:new "#" "#" \
+		    [list [namespace current]::get_theme_name $varName $dir]]
+    jlib::wrapper:elementstart $parser stream:stream {} {}
+    jlib::wrapper:parser $parser parse $icondef
+    jlib::wrapper:parser $parser configure -final 0
+    jlib::wrapper:free $parser
+}
+
+
+
+proc emoticons::get_theme_name {varName dir xmldata} {
+    upvar #0 $varName themes
+
+    jlib::wrapper:splitxml $xmldata tag vars isempty cdata children
+
+    if {$tag == "name"} {
+	set themes($cdata) $dir
+	return 1
+    }
+
+    foreach child $children {
+	if {[get_theme_name $varName $dir $child]} {
+	    return 1
+	}
+    }
+    return 0
+}
+
+
+
+proc emoticons::load_theme {theme} {
+    variable themes
+
+    if {![info exists themes($theme)]} {
+	error "No emoteicons theme: $theme"
+    }
+
+    set dir $themes($theme)
+    if {$dir == ""} return ;# handles None -> {} pair
+
+    load_dir $themes($theme)
+}
+
+
+
+# Gets called when options(theme) changes
+proc emoticons::on_theme_changed {args} {
+    variable options
+
+    if {$options(active_theme) != $options(theme)} {
+	load_theme $options(theme)
+    }
+}
+
+
+
+# Gets called when the enabled/disabled state of emoticons subsystem changes
+proc emoticons::on_state_changed {args} {
+    variable options
+
+    if {$options(enabled)} {
+	enable_subsystem
+    } else {
+	disable_subsystem
+    }
+}
+
+
+
+proc emoticons::enable_subsystem {} {
+    variable options
+    variable themes
+
+    array unset themes *
+
+    enumerate_available_themes
+    
+    set theme_names [lsort [array names themes]]
+
+    if {[llength $theme_names] > 0} {
+	set idx [lsearch -sorted $theme_names Default]
+	if {$idx > 0} {
+	    set theme_names [linsert [lreplace $theme_names $idx $idx] 0 Default]
+	}
+
+	foreach theme $theme_names {
+	    lappend values $theme $theme
+	}
+
+	set idx [lsearch -sorted $theme_names $options(theme)]
+	if {$idx < 0} {
+	    set idx [lsearch -sorted $theme_names Default]
+	    if {$idx < 0} { set idx 0 }
+	}
+	set options(theme) [lindex $theme_names $idx]
+    } else {
+	set options(theme) $options(no_theme)
+	set values [list {} $options(no_theme)]
+    }
+
+    ::custom::configvar [namespace current]::options(theme) -values $values
+
+    ::richtext::entity_state emoticon 1
+}
+
+proc emoticons::disable_subsystem {} {
+    ::richtext::entity_state emoticon 0
+}
+
+proc emoticons::on_regex_mode_changed {args} {
+    rebuild_faces_regex
+}
+
+proc emoticons::rebuild_faces_regex {} {
+    variable options
+    variable emoticons
+    variable faces_list
+    variable faces_regexp
+
+    set faces_regexp ""
+
+    foreach face $faces_list {
+	if {$faces_regexp != ""} {
+	    append faces_regexp |
+	}
+
+	append faces_regexp [re_escape $face]
+
+	if {$options(handle_lol)} {
+	    append faces_regexp +
+	}
+    }
+}
+
+# Returns a string with its rightmost repeated characters collapsed into one.
+# TODO good candidate to go into utils.tcl
+proc emoticons::string_collapseright {s} {
+    set c [string index $s end]
+    set s [string trimright $s $c]
+    append s $c
+    return $s
+}
+
+namespace eval emoticons {
+    ::hook::add finload_hook [namespace current]::on_state_changed
+
+    ::hook::add open_chat_post_hook [namespace current]::setup_bindings
+
+    ::richtext::register_entity emoticon \
+	-configurator [namespace current]::configure_richtext_widget \
+	-parser [namespace current]::process_emoticons \
+	-renderer [namespace current]::render_emoticon \
+	-parser-priority 80
+	
+}
+

Added: trunk/tkabber/plugins/richtext/stylecodes.tcl
===================================================================
--- trunk/tkabber/plugins/richtext/stylecodes.tcl	                        (rev 0)
+++ trunk/tkabber/plugins/richtext/stylecodes.tcl	2006-11-03 19:58:27 UTC (rev 775)
@@ -0,0 +1,235 @@
+# $Id: stylecodes.tcl 18 2006-10-24 00:38:28Z kostix $
+
+namespace eval stylecodes {
+    variable options
+
+    ::custom::defgroup Stylecodes \
+	[::msgcat::mc "Handling of \"stylecodes\".\
+		       Stylecodes are (groups of) special formatting symbols\
+		       used to emphasize parts of the text by setting them\
+		       with boldface, italics or underlined styles,\
+		       or as combinations of these."] \
+	-group {Rich Text}
+
+    ::custom::defvar options(enabled) 1 \
+	[::msgcat::mc "Enable processing of stylecodes."] \
+	-type boolean -group Stylecodes \
+	-command [namespace current]::change_entity_state
+
+    ::custom::defvar options(emphasize) 1 \
+	[::msgcat::mc "Emphasize stylecoded messages using fonts."] \
+	-type boolean -group Stylecodes \
+	-command [namespace current]::toggle_codes
+}
+
+
+
+proc stylecodes::process_stylecodes {atLevel accName} {
+    upvar #$atLevel $accName chunks
+
+    lappend out
+
+    foreach {s type tags} $chunks {
+	if {$type != "text"} {
+	    # pass through
+	    lappend out $s $type $tags
+	    continue
+	}
+
+	foreach elem [scan_stylecodes $s $type $tags {* / _}] {
+	    lappend out $elem
+	}
+    }
+
+    set chunks $out
+}
+
+
+
+proc stylecodes::scan_stylecodes {what type tags stylecodes} {
+    set len [string length $what]
+
+    lappend out
+
+    set si 0
+
+    for {set ix 0} {$ix < $len} {incr ix} {
+	set startOK true
+
+	set sc [spot_highlight $what $stylecodes ix startOK]
+
+	if {$sc == {}} continue
+
+	foreach {ls le ms me rs re pat} $sc break
+
+	if {$ls - $si > 0} {
+	    # dump the text before opening stylecode block:
+	    lappend out [string range $what $si [expr {$ls - 1}]] $type $tags
+	}
+
+	set sctags [stylecodes->tags $pat]
+
+	# dump opening stylecode block:
+	lappend out [string range $what $ls $le] stylecode [lfuse $tags $sctags]
+
+	# dump highlighted text:
+	lappend out [string range $what $ms $me] $type [lfuse $tags $sctags]
+
+	# dump closing stylecode block:
+	lappend out [string range $what $rs $re] stylecode [lfuse $tags $sctags]
+
+	set si $ix
+    }
+
+    if {[string length $what] - $si > 0} {
+	lappend out [string range $what $si end] $type $tags
+    }
+
+    return $out
+}
+
+
+
+proc stylecodes::spot_highlight {what stylecodes ixVar startOKVar} {
+    upvar 1 $ixVar ix $startOKVar startOK
+
+    set ls $ix
+    lappend pattern
+
+    while {[eat_stylecode $what $ix stylecodes pattern startOK]} {
+	incr ix
+    }
+	
+    set startOK false
+
+    if {$ix == $ls} return
+    if {[is_scbreak [string index $what $ix]]} return ;# stylecode break after stylecode
+
+    # found opening stylecode block.
+    # create pattern for ending stylecode block and seek for it:
+
+    set pat [join $pattern ""]
+    set rs [string first $pat $what $ix]
+    if {$rs == -1} { return {} }
+
+    # found closing stylecode block.
+
+    if {$rs - $ix == 0} { return {} } ;# empty highlight
+
+    if {[is_scbreak [string index $what [expr {$rs - 1}]]]} {
+	# stylecode break before
+	return
+    }
+
+    if {[string first \n [string range $what $ix $rs]] != -1} {
+	# intervening newline
+	return {}
+    }
+
+    set patlen [string length $pat]
+
+    if {![is_scbreak [string index $what [expr {$rs + $patlen}]]]} {
+	# no proper break after closing stylecode block
+	return {}
+    }
+
+    set le [expr {$ls + $patlen - 1}]
+    set ms [expr {$ls + $patlen}]
+    set me [expr {$rs - 1}]
+    set re [expr {$rs + $patlen - 1}]
+
+    # skip past the closing stylecode block
+    set ix [expr {$re + 1}]
+
+    return [list $ls $le \
+		 $ms $me \
+		 $rs $re \
+		 $pat]
+}
+
+proc stylecodes::eat_stylecode {what at scodesVar patVar startOKVar} {
+    upvar 1 $scodesVar scodes $patVar pat $startOKVar startOK
+
+    set ix 0
+    set c [string index $what $at]
+
+    foreach sc $scodes {
+	if {$c == $sc} {
+	    if {!$startOK} { return false }
+	    set scodes [lreplace $scodes $ix $ix]
+	    set pat [linsert $pat 0 $c]
+	    return true
+	}
+
+	incr ix
+    }
+
+    set startOK [is_scbreak $c]
+
+    return false
+}
+
+proc stylecodes::is_scbreak {c} {
+    expr {[string is space $c] || [string is punct $c]}
+}
+
+proc stylecodes::stylecodes->tags {pattern} {
+    array set tags {* bold
+		    / italic
+		    _ underlined}
+	
+    foreach sc [split $pattern ""] {
+	lappend out $tags($sc)
+    }
+
+    return $out
+}
+
+proc stylecodes::render_stylecode {w type piece tags} {
+    $w insert end $piece \
+	[richtext::fixup_tags [concat $type $tags] {{bold italic}}]
+}
+
+proc stylecodes::configure_richtext_widget {w} {
+    global font font_bold font_italic font_bold_italic
+    variable options
+
+    if {$options(emphasize)} {
+	$w tag configure stylecode -elide 1
+	$w tag configure bold -font $font_bold
+	$w tag configure italic -font $font_italic
+	$w tag configure bold_italic -font $font_bold_italic
+	$w tag configure underlined -underline 1
+    } else {
+	$w tag configure stylecode -elide 0
+	$w tag configure bold -font $font
+	$w tag configure italic -font $font
+	$w tag configure bold_italic -font $font
+	$w tag configure underlined -underline 0
+    }
+}
+
+proc stylecodes::toggle_codes {args} {
+    variable options
+
+    foreach w [::richtext::textlist] {
+	configure_richtext_widget $w
+    }
+}
+
+proc stylecodes::change_entity_state {args} {
+    variable options
+
+    ::richtext::entity_state stylecode $options(enabled)
+}
+
+namespace eval stylecodes {
+    ::richtext::register_entity stylecode \
+	-configurator [namespace current]::configure_richtext_widget \
+	-parser [namespace current]::process_stylecodes \
+	-renderer [namespace current]::render_stylecode \
+	-parser-priority 70
+
+    change_entity_state ;# Customize won't do this by itself
+}
+

Added: trunk/tkabber/plugins/richtext/urls.tcl
===================================================================
--- trunk/tkabber/plugins/richtext/urls.tcl	                        (rev 0)
+++ trunk/tkabber/plugins/richtext/urls.tcl	2006-11-03 19:58:27 UTC (rev 775)
@@ -0,0 +1,236 @@
+# $Id: urls.tcl 19 2006-10-28 00:41:03Z kostix $
+# "Rich text" framework -- processing of URLs.
+
+namespace eval urls {
+    variable options
+    variable urlid 0
+
+    ::custom::defgroup URL [::msgcat::mc "URL handling options."] -group {Rich Text}
+
+    ::custom::defvar options(enabled) 1 \
+	[::msgcat::mc "Enable special URL processing."] \
+	-type boolean -group URL \
+	-command [namespace current]::change_entity_state
+
+    # TODO add user:pass@ match
+    # TODO sync TLDs with http://www.icann.org/tlds/app-index.htm
+    set url_regexp {
+	(\y
+	    (?:
+		(?: ftp|https?)://[-\w]+(\.\w[-\w]*)*
+		  |
+		(?: [a-z0-9][-a-z0-9]* \. )+
+		(?: com
+		  | edu
+		  | biz
+		  | gov
+		  | in(?:t|fo)
+		  | mil
+		  | net
+		  | org
+		  | name
+		  | aero
+		  | arpa
+		  | coop
+		  | museum
+		  | pro
+		  | travel
+		  | [a-z][a-z]
+		)
+	    )
+	    (?: : \d+ )?
+	    (?:
+		/
+		[^.,?!:;"'<>()\[\]{}\s\x7F-\xFF]*
+		(?:
+		    [.,?!:;]+ [^.,?!:;"'<>()\[\]{}\s\x7F-\xFF]+
+		)*
+	    )?
+	\y)
+    }
+}
+
+
+
+proc urls::process_urls {atLevel accName} {
+    upvar #$atLevel $accName chunks
+
+    lappend out
+
+    foreach {s type tags} $chunks {
+	if {$type != "text"} {
+	    # pass through
+	    lappend out $s $type $tags
+	    continue
+	}
+
+	set ix 0; set us 0; set ue 0
+	
+	while {[spot_url $s $ix us ue]} {
+	    if {$us - $ix > 0} {
+		# dump chunk before URL:
+		lappend out [string range $s $ix [expr {$us - 1}]] $type $tags
+	    }
+
+	    lappend out [string range $s $us $ue] url $tags
+
+	    set ix [expr {$ue + 1}]
+	}
+
+    	if {[string length $s] - $ix > 0} {
+	    # dump chunk after URL:
+	    lappend out [string range $s $ix end] $type $tags
+	}
+    }
+
+    set chunks $out
+}
+
+
+
+proc urls::spot_url {what at startVar endVar} {
+    variable url_regexp
+
+    set matched [regexp -expanded -nocase -indices \
+			-start $at -- $url_regexp $what -> bounds]
+
+    if {!$matched} { return false }
+
+    upvar 1 $startVar us $endVar ue
+    foreach {us ue} $bounds break
+    return true
+}
+
+
+
+proc urls::encode_url {url} {
+    set utf8_url [encoding convertto utf-8 $url]
+    set len [string length $utf8_url]
+    set encoded_url ""
+    for {set i 0} {$i < $len} {incr i} {
+	binary scan $utf8_url @${i}c sym
+	set sym [expr {$sym & 0xFF}]
+	if {$sym >= 128 || $sym <= 32} {
+	    append encoded_url [format "%%%02X" $sym]
+	} else {
+	    append encoded_url [binary format c $sym]
+	}
+    }
+    return $encoded_url
+}
+
+
+
+proc urls::render_url {w type url tags args} {
+    variable options
+    variable urlid
+
+    set privtag url_$urlid
+
+    $w tag configure $privtag
+    $w tag raise url
+
+    $w insert end $url [lfuse $type $tags $privtag]
+
+    $w tag bind $privtag <Enter> \
+	[list ::richtext::highlighttext \
+	      $w $privtag $options(activeforeground) $options(cursor)]
+    $w tag bind $privtag <Leave> \
+	[list ::richtext::highlighttext \
+	      $w $privtag $options(foreground) xterm]
+
+    eval { config_url $w $privtag } $args ;# poor man's {expand} for $args
+
+    incr urlid
+
+    return $privtag ;# to allow further configuration of this tag
+}
+
+
+
+# Configures a URL $tag rendered in a text widget $w.
+# This tag is either a metatag "url" or some other tag
+# returned by the [render_url] proc.
+
+# $args should be a list of option/value pairs.
+# Supported options:
+# -command: invoke this command when the URL is clicked with LMB;
+#   replaces any existing command bound to the URL.
+# -add-command: same as -command, but preserves the existing command.
+#   any number of commands can be assotiated with a URL this way.
+
+proc urls::config_url {w tag args} {
+    array set config $args
+
+    foreach opt [array names config] {
+	switch -- $opt {
+	    -command {
+		$w tag bind $tag <Button-1> $config($opt)
+	    }
+	    -add-command {
+		$w tag bind $tag <Button-1> +$config($opt)
+	    }
+	}
+    }
+}
+
+
+
+# Passes a URL containing the $x,$y point in the text widget $w
+# to the system-dependent browser program.
+# The URL undergoes W3C-urlencoding first, to be ASCII-clean.
+proc urls::browse_url {w x y} {
+    browseurl [encode_url [get_url $w $x $y]]
+}
+
+
+
+# Returns a URL containing the $x,$y point in the text widget $w:
+proc urls::get_url {w x y} {
+    foreach {a b} [$w tag prevrange url "@$x,$y + 1 char"] break
+
+    $w get $a $b
+}
+
+
+
+# Copies an URL under $x,$y in $w into CLIPBOARD:
+proc urls::copy_url {w x y} {
+    clipboard clear -displayof $w
+    clipboard append -displayof $w [get_url $w $x $y]
+}
+
+
+
+proc urls::configure_richtext_widget {w} {
+    variable options
+
+    set options(foreground)       [option get $w urlforeground       Text]
+    set options(activeforeground) [option get $w urlactiveforeground Text]
+    set options(cursor)           [option get $w urlcursor           Text]
+
+    $w tag configure url -foreground $options(foreground) -underline 1
+
+    config_url $w url -command [list [namespace current]::browse_url %W %x %y]
+}
+
+
+
+proc urls::change_entity_state {args} {
+    variable options
+
+    ::richtext::entity_state url $options(enabled)
+}
+
+
+
+namespace eval urls {
+    ::richtext::register_entity url \
+	-configurator [namespace current]::configure_richtext_widget \
+	-parser [namespace current]::process_urls \
+	-renderer [namespace current]::render_url \
+	-parser-priority 60
+
+    change_entity_state ;# Customize won't do this
+}
+

Added: trunk/tkabber/richtext.tcl
===================================================================
--- trunk/tkabber/richtext.tcl	                        (rev 0)
+++ trunk/tkabber/richtext.tcl	2006-11-03 19:58:27 UTC (rev 775)
@@ -0,0 +1,397 @@
+# $Id: richtext.tcl 18 2006-10-24 00:38:28Z kostix $
+# "Rich text" facility for Tk Text widgets -- allows to:
+# * Register parsers and renderers for particular patterns in plain text messages -- "entities";
+# * Parse plain text messages with registered parsers (in order of their priorities);
+# * Render the resulting chunks of text with the appropriate renderers;
+# * Get back the original text from PRIMARY and CLIPBOARD selections acquired from such Text widget.
+# This scheme supports URL highlighting, emoteicons and such.
+
+namespace eval richtext {
+    variable registered
+    variable entities
+    variable state
+    variable texts {}
+
+    ::custom::defgroup {Rich Text} \
+	[::msgcat::mc "Settings of rich text facility which is used\
+		       to render chat messages and logs."] \
+	-group Plugins
+}
+
+proc richtext::register_entity {type args} {
+    variable registered
+    variable entities
+
+    lappend registered $type
+    set entities($type,priority) 80
+
+    foreach {opt val} $args {
+	switch -glob -- $opt {
+	    -configurator {
+		set entities($type,configurator) $val
+	    }
+	    -parser {
+		set entities($type,parser) $val
+	    }
+	    -reconstructor {
+		set entities($type,reconstructor) $val
+	    }
+	    -renderer {
+		set entities($type,renderer) $val
+	    }
+	    -parser-priority {
+		set entities($type,priority) $val
+	    }
+	    default {
+		error "unknown option $opt"
+	    }
+	}
+    }
+}
+proc richtext::unregister_entity {type} {
+    variable registered
+    variable entities
+
+    lexclude registered $type
+    array unset entities $type,*
+}
+
+proc richtext::entity_state {args} {
+    variable entities
+
+    foreach {type val} $args break
+
+    if {$val == {}} {
+	set entities($type,enabled)
+    } else {
+	set entities($type,enabled) $val
+    }
+}
+
+# Configures a text widget so that the "::richtext::render_message" proc
+# can be used on it.
+
+# Accepts an optional parameter "-using ?list_of_entities?"; when specified,
+# the text widget is configured to support only the specified entities,
+# otherwise it's configured to support all registered entities. If the list
+# is empty, this is *almost* a no-op: render_message can be called on such
+# widget, but it won't trigger any special processing of the passed text.
+
+# NOTE that currently this proc can be safely called only once per widget
+# since it essentially has a "constructor" semantics (though it requires
+# an already created text widget).
+
+proc richtext::config {w args} {
+    variable registered
+    variable entities
+    variable state
+    variable texts
+
+    lappend texts $w
+
+    # By default, configure for all registered entities:
+    set using $registered
+
+    # Parse options:
+    foreach {opt val} $args {
+	switch -- $opt {
+	    -using {
+		set using $val
+	    }
+	    default {
+		error "Unknown option: $opt"
+	    }
+	}
+    }
+
+    # Run configurators for requested entities:
+    foreach type $using {
+	if {[info exists entities($type,configurator)]} {
+	    $entities($type,configurator) $w
+	}
+    }
+
+    # Save enabled entities in the widget state, sorted by the
+    # parsing priority:
+    set state($w,types) [lsort -command compare_entity_prios $using]
+
+    # Register a kind of "destructor" to clean up state:
+    bind $w <Destroy> +[list [namespace current]::richtext_on_destroy $w %W]
+}
+
+# Cleans up state of richtext widgets:
+proc richtext::richtext_on_destroy {w1 w2} {
+    if {$w1 != $w2} return
+
+    variable state
+    variable texts
+
+    lexclude texts $w1
+    array unset state $w1,*
+}
+
+proc richtext::textlist {} {
+    variable texts
+    return $texts
+}
+
+proc richtext::compare_entity_prios {a b} {
+    variable entities
+	
+    expr {$entities($a,priority) - $entities($b,priority)}
+}
+
+# Configure a text widget to be ready for enriched text:
+proc richtext::richtext {args} {
+    set w [eval text $args]
+    config $w
+    install_selection_handlers $w
+    $w configure -state disabled
+}
+
+# TODO get rid of "deftag" and "highlightlist"
+proc richtext::render_message {w body deftag {highlightlist {}}} {
+    variable entities
+    variable state
+
+    # Parse the message text with rich text entity parsers:
+    set chunks [process_highlights $body $deftag $highlightlist]
+    foreach type $state($w,types) {
+	if {$entities($type,enabled) && [info exists entities($type,parser)]} {
+	    $entities($type,parser) [info level] chunks
+	}
+    }
+	
+    # Render the parsed pieces with entity renderers:
+    foreach {piece type tags} $chunks {
+	#puts "(draw) piece: $piece; type: $type; tags: $tags"
+
+	if {! [info exists entities($type,renderer)]} {
+	    debugmsg richtext "Got piece with unknown type $type"
+	    set type text ;# fallback
+	}
+
+	$entities($type,renderer) $w $type $piece $tags
+    }
+
+    $w insert end \n
+}
+
+# TODO suppress empty chunks
+# TODO move searching for highlights into rich text plugin
+#      (see plugin/chat/me_command.tcl)
+proc richtext::process_highlights {body deftag {highlightlist {}}} {
+    if {[llength $highlightlist] == 0} {
+	lappend chunks $body text $deftag
+    } else {
+	set ind 0
+	foreach {i1 i2} $highlightlist {
+	    lappend chunks [crange $body $ind [expr {$i1 - 1}]] text $deftag
+	    lappend chunks [crange $body $i1 [expr {$i2 - 1}]] text highlight
+	    set ind $i2
+	}
+	lappend chunks [crange $body $ind end] text $deftag
+    }
+
+    return $chunks
+}
+
+proc richtext::fixup_tags {tags tgroups} {
+    foreach t $tags {
+	set thash($t) 0
+    }
+
+    foreach tg $tgroups {
+	glue_tags thash $tg
+    }
+
+    return [array names thash]
+}
+
+proc richtext::glue_tags {arrayName tags} {
+    upvar 1 $arrayName thash
+
+    foreach t $tags {
+	if {![info exists thash($t)]} return
+    }
+	
+    foreach t $tags {
+	unset thash($t)
+    }
+
+    set t [join $tags _]
+    set thash($t) 0
+}
+
+# TODO get rid of [puts]
+proc richtext::reconstruct_text {w first last} {
+    #puts "in [info level 0]"
+    if {[catch {$w dump -text -tag $first $last} dump]} {
+	#puts "dump failed: $dump"
+	return {}
+    }
+
+    set dump [concat {start {} {}} $dump {end {} {}}]
+
+    #puts "ready to parse: $dump"
+
+    foreach {what val where} $dump {
+	#puts "what: $what; val: $val; where $where"
+	switch -- $what {
+	    start {
+		set out ""
+		set in nowhere
+		set chunk ""
+		set tags {}
+	    }
+	    tagon {
+		if {[lsearch $state($w,types) $val] >= 0} {
+		    if {$in != "tag"} { write_chunk_out out chunk $tags }
+		    lappend tags $val
+		    set in tag
+		}
+	    }
+	    tagoff {
+		if {[lsearch $state($w,types) $val] >= 0} {
+		    if {$in != "tag"} { write_chunk_out out chunk $tags }
+		    lexclude tags $val
+		    set in tag
+		}
+	    }
+	    text {
+		append chunk $val
+		set in text
+	    }
+	    image {
+		set chunk $val
+		set in image
+	    }
+	    end {
+		if {$in != "tag"} { write_chunk_out out chunk $tags }
+	    }
+	}
+    }
+
+    #puts "parsed sel: $out"
+
+    return $out
+}
+
+proc richtext::write_chunk_out {outVar chunkVar t} {
+    upvar 1 $outVar out $chunkVar chunk
+    variable entities
+	
+    if {[string length $chunk] == 0} return
+
+    if {[llength $t] > 1} {
+	#puts stderr "chunk $chunk belongs to several rich text entities: $t"
+    }
+
+    if {[info exists entities($t,reconstructor)]} {
+	append out [$entities($t,reconstructor) $t $chunk]
+    } else {
+	append out $chunk
+    }
+	
+    set chunk ""
+}
+
+# TODO move to utils.tcl
+proc lexclude {listVar what} {
+    upvar 1 $listVar list
+	
+    set at [lsearch $list $what]
+
+    if {$at >= 0} {
+	set list [lreplace $list $at $at]
+    }
+}
+
+# Takes one or more lists and returns one list with only unique
+# members from all of the passed lists:
+# TODO move to utils.tcl
+proc lfuse {args} {
+    lsort -unique [lconcat $args]
+}
+
+# Takes a list of lists and flattens them into one list:
+# TODO move to utils.tcl
+proc lconcat {L} {
+    foreach S $L { foreach E $S { lappend out $E } }
+    set out
+}
+
+# List intersection.
+# For a number of lists, return only those elements
+# that are present in all lists.
+# (Richard Suchenwirth, from http://wiki.tcl.tk/43)
+proc lintersect {args} {
+    set res {}
+    foreach element [lindex $args 0] {
+	set found 1
+	foreach list [lrange $args 1 end] {
+	    if {[lsearch -exact $list $element] < 0} {
+		set found 0; break
+	    }
+	}
+	if {$found} {lappend res $element}
+    }
+    set res
+}
+
+# Used to handle PRIMARY selection requests on "rich text" widgets
+proc richtext::get_selection {w off max} {
+    return [string range \
+		   [reconstruct_text $w sel.first sel.last] \
+		   $off [expr {$off + $max}]]
+}
+
+# Used to subvert tk_textCopy on "rich text" widgets
+proc richtext::text_copy {w} {
+    if {![catch {set data [reconstruct_text $w sel.first sel.last]}]} {
+	clipboard clear -displayof $w
+	clipboard append -displayof $w $data
+    }
+}
+
+# Used to subvert tk_textCut on "rich text" widgets
+proc richtext::text_cut {w} {
+    if {![catch {set data [reconstruct_text $w sel.first sel.last]}]} {
+	clipboard clear -displayof $w
+	clipboard append -displayof $w $data
+	$w delete sel.first sel.last
+    }
+}
+
+# Installs selection handlers on a text widget.
+# 1) There's only need to support PRIMARY selection of type STRING
+#    since all other types are only used in application-private protocols
+#    (except UTF8_STRING, which is used by UTF-8-enabled software);
+# 2) Tk automagically handles UTF8_STRING if the handler for STRING is installed;
+# 3) (2) is not exactly true, see Tk bug #1571737, we work around it here.
+
+proc richtext::install_selection_handlers {w} {
+    # Handlers for PRIMARY selection:
+    selection handle -type UTF8_STRING $w {}
+    selection handle -type STRING $w \
+	      [list [namespace current]::get_selection $w]
+
+    # Handlers of CLIPBOARD selections
+    # (subvert tk_textCopy and tk_textCut)
+    bind $w <<Copy>> [list [namespace current]::text_copy $w]
+    bind $w <<Cut>>  [list [namespace current]::text_cut $w]
+}
+
+proc richtext::render_text {w type piece tags} {
+    $w insert end $piece [fixup_tags $tags {{bold italic}}]
+}
+
+proc richtext::highlighttext {w tag color cursor} {
+    $w configure -cursor $cursor
+    $w tag configure $tag -foreground $color
+}
+
+# Register the most basic renderer for type "text":
+richtext::register_entity text -renderer richtext::render_text
+richtext::entity_state text 1
+

Modified: trunk/tkabber/tkabber.tcl
===================================================================
--- trunk/tkabber/tkabber.tcl	2006-11-03 18:04:08 UTC (rev 774)
+++ trunk/tkabber/tkabber.tcl	2006-11-03 19:58:27 UTC (rev 775)
@@ -246,15 +246,16 @@
 load_source privacy.tcl
 load_source gpgme.tcl
 load_source pubsub.tcl
+load_source richtext.tcl
 
 load_source ifacetk bwidget_workarounds.tcl
 load_source ifacetk iface.tcl
-load_source emoticons.tcl
 load_source aniemoteicons aniemoteicons.tcl
 
 plugins::load [file join plugins general]
 plugins::load [file join plugins roster]
 plugins::load [file join plugins search]
+plugins::load [file join plugins richtext]
 plugins::load [file join plugins $tcl_platform(platform)]
 if {[info exists env(TKABBER_SITE_PLUGINS)] && \
 	[file isdirectory $env(TKABBER_SITE_PLUGINS)]} {

Modified: trunk/tkabber/userinfo.tcl
===================================================================
--- trunk/tkabber/userinfo.tcl	2006-11-03 18:04:08 UTC (rev 774)
+++ trunk/tkabber/userinfo.tcl	2006-11-03 19:58:27 UTC (rev 775)
@@ -122,8 +122,7 @@
 
     label $g.l$name -text $text
     text $g.$name -height 1 -state disabled -relief flat -background [option get $g background Notebook]
-    $g.$name tag configure emphasized -elide 1
-    $g.$name tag configure nonemphasized -elide 0
+    ::richtext::config $g.$name -using url
     fill_user_description $g.$name userinfo($name,$jid) 0
     
     grid $g.l$name -row $row -column 0 -sticky e
@@ -319,12 +318,11 @@
     set sw [ScrolledWindow $a.sw -scrollbar vertical]
     if {!$editable} {
 	text $a.text -font $font -height 12 -wrap word
+	::richtext::config $a.text -using {url emoticon}
     } else {
 	textUndoable $a.text -font $font -height 12 -wrap word
     }
     $sw setwidget $a.text
-    $a.text tag configure emphasized -elide 1
-    $a.text tag configure nonemphasized -elide 0
     bind $a.text <Key-Return> [bind Text <Key-Return>]
     bind $a.text <Key-Return> +break
     bind $a.text <Control-Key-Return> "
@@ -495,7 +493,7 @@
 	if {$editable} {
 	    $txt insert 0.0 [set $descvar]
 	} else {
-	    ::chat::add_emoteiconed_text $txt [set $descvar] ""
+	    ::richtext::render_message $txt [set $descvar] ""
 	}
 	$txt configure -state $state
     }



More information about the Tkabber-dev mailing list