[Tkabber-dev] r793 - in trunk/tkabber: . plugins/general plugins/richtext

tkabber-svn at jabber.ru tkabber-svn at jabber.ru
Wed Nov 15 23:33:10 MSK 2006


Author: sergei
Date: 2006-11-15 23:33:05 +0300 (Wed, 15 Nov 2006)
New Revision: 793

Modified:
   trunk/tkabber/ChangeLog
   trunk/tkabber/chats.tcl
   trunk/tkabber/plugins/general/headlines.tcl
   trunk/tkabber/plugins/richtext/urls.tcl
   trunk/tkabber/richtext.tcl
   trunk/tkabber/userinfo.tcl
   trunk/tkabber/utils.tcl
Log:
	* userinfo.tcl: Bugfix. Add script to <Destroy> event, not
	  override existing.

	* chats.tcl: Removed unused URL regexp (thanks to Konstantin
	  Khomoutov).

	* richtext.tcl, plugins/richtext/urls.tcl: Added URLs with
	  label, which differs from URL itself (thanks to Konstantin
	  Khomoutov).

	* plugins/general/headlines.tcl: Replaced link text by a
	  neutral message (the URL is showed in a tooltip) (thanks to
	  Konstantin Khomoutov).

	* utils.tcl: Moved some useful functions from richtext.tcl
	  (thanks to Konstantin Khomoutov).


Modified: trunk/tkabber/ChangeLog
===================================================================
--- trunk/tkabber/ChangeLog	2006-11-12 14:49:36 UTC (rev 792)
+++ trunk/tkabber/ChangeLog	2006-11-15 20:33:05 UTC (rev 793)
@@ -1,3 +1,22 @@
+2006-11-15  Sergei Golovan  <sgolovan at nes.ru>
+
+	* userinfo.tcl: Bugfix. Add script to <Destroy> event, not
+	  override existing.
+
+	* chats.tcl: Removed unused URL regexp (thanks to Konstantin
+	  Khomoutov).
+
+	* richtext.tcl, plugins/richtext/urls.tcl: Added URLs with
+	  label, which differs from URL itself (thanks to Konstantin
+	  Khomoutov).
+
+	* plugins/general/headlines.tcl: Replaced link text by a
+	  neutral message (the URL is showed in a tooltip) (thanks to
+	  Konstantin Khomoutov).
+
+	* utils.tcl: Moved some useful functions from richtext.tcl
+	  (thanks to Konstantin Khomoutov).
+
 2006-11-12  Sergei Golovan  <sgolovan at nes.ru>
 
 	* INSTALL: Corrected link to README.

Modified: trunk/tkabber/chats.tcl
===================================================================
--- trunk/tkabber/chats.tcl	2006-11-12 14:49:36 UTC (rev 792)
+++ trunk/tkabber/chats.tcl	2006-11-15 20:33:05 UTC (rev 793)
@@ -34,47 +34,6 @@
     custom::defvar open_chat_list {} [::msgcat::mc "List of users for chat."] \
 	    -group Hidden
 
-    set url_regexp {^
-		([^\w\d]*)
-		(
-
-		 (?:
-			(?: 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]+
-
-			)*
-
-		)?
-	     )
-	     ([^\w\d]*)$
-    }
-
 }
 
 set chat_width 50

Modified: trunk/tkabber/plugins/general/headlines.tcl
===================================================================
--- trunk/tkabber/plugins/general/headlines.tcl	2006-11-12 14:49:36 UTC (rev 792)
+++ trunk/tkabber/plugins/general/headlines.tcl	2006-11-15 20:33:05 UTC (rev 793)
@@ -295,7 +295,8 @@
     if {$url != ""} {
         ::plugins::urls::render_url $wbody url $url {} \
             -command [list [namespace code action] markseen \
-			   [winfo parent $tw] $node]
+			   [winfo parent $tw] $node] \
+			-title [::msgcat::mc "Read on..."]
     }
     $wbody configure -state disabled
 }

Modified: trunk/tkabber/plugins/richtext/urls.tcl
===================================================================
--- trunk/tkabber/plugins/richtext/urls.tcl	2006-11-12 14:49:36 UTC (rev 792)
+++ trunk/tkabber/plugins/richtext/urls.tcl	2006-11-15 20:33:05 UTC (rev 793)
@@ -1,14 +1,10 @@
-# $Id: urls.tcl 19 2006-10-28 00:41:03Z kostix $
+# $Id$
 # "Rich text" framework -- processing of URLs.
 
-
-
 option add *urlforeground       blue  widgetDefault
 option add *urlactiveforeground red   widgetDefault
 option add *urlcursor           hand2 widgetDefault
 
-
-
 namespace eval urls {
     variable options
     variable urlid 0
@@ -55,8 +51,6 @@
     }
 }
 
-
-
 proc urls::process_urls {atLevel accName} {
     upvar #$atLevel $accName chunks
 
@@ -91,8 +85,6 @@
     set chunks $out
 }
 
-
-
 proc urls::spot_url {what at startVar endVar} {
     variable url_regexp
 
@@ -106,8 +98,6 @@
     return true
 }
 
-
-
 proc urls::encode_url {url} {
     set utf8_url [encoding convertto utf-8 $url]
     set len [string length $utf8_url]
@@ -124,18 +114,49 @@
     return $encoded_url
 }
 
+# Renders a rich text chunk of type "url" in the rich text widget.
+#
+# Accepts several trailing options:
+#   -title TITLE -- allows to "hide" the actual URL
+#                   and display its title instead;
+#   other options are passed to [config_url], see below.
+#
+# An URL is physically represented by pieces of text between tags:
+#
+# <url> [<uri>actual URL</uri>] <href_N>title or URL</href_N> </url>
+#
+# That is:
+# * The "url" tag is always present and it covers all the URL text;
+# * The "href_N" tag (whth auto-generated integer part N) is also
+#   always pesent. It contains also the URL itself, if the URL title
+#   is not specified, or that URL title;
+# * The "uri" tag is present only if the URL title was specified, and
+#   then this tag denotes the actuall hidden URL and it then appears
+#   earlier in the text that the related "href_N" tag.
 
-
 proc urls::render_url {w type url tags args} {
     variable options
     variable urlid
 
-    set privtag url_$urlid
+    set privtag href_$urlid
 
     $w tag configure $privtag -foreground $options(foreground) -underline 1
 
-    $w insert end $url [lfuse $type $tags $privtag]
+    set url_start [$w index {end - 1 char}]
+    
+    set title [url_get_title $url $args]
+    if {$title != {}} {
+	$w insert end $url {uri transient}
+	set url $title
+	set show_hints true
+    } else {
+	set show_hints false
+    }
 
+    $w insert end $url [lfuse $tags $privtag]
+
+    $w tag add $type $url_start {end - 1 char}
+
     $w tag bind $privtag <Enter> \
 	[list ::richtext::highlighttext \
 	      $w $privtag $options(activeforeground) $options(cursor)]
@@ -143,15 +164,46 @@
 	[list ::richtext::highlighttext \
 	      $w $privtag $options(foreground) xterm]
 
-    eval { config_url $w $privtag } $args ;# poor man's {expand} for $args
+    if {$show_hints} {
+	$w tag bind $privtag <Enter> \
+	    +[list [namespace current]::show_hint $w %x %y %X %Y]
+	$w tag bind $privtag <Leave> \
+	    +[namespace current]::hide_hint
+    }
 
+    eval {config_url $w $privtag} $args
+
     incr urlid
 
     return $privtag ;# to allow further configuration of this tag
 }
 
+# Tries to find the title for the URL $url either in the $options
+# (which are usually those passed to [render_url] or among the
+# properties of the message being processed.
+proc urls::url_get_title {url options} {
+    array set opts $options
 
+    if {[info exists opts(-title)]} {
+	set title $opts(-title)
+    } elseif {[::richtext::property_exists url:title,$url]} {
+	set title [::richtext::property_get url:title,$url]
+    } else {
+	set title ""
+    }
 
+    return $title
+}
+
+proc urls::show_hint {w x y X Y} {
+    ::balloon::set_text [get_url $w $x $y]
+    ::balloon::show $X $Y
+}
+
+proc urls::hide_hint {} {
+    ::balloon::destroy
+}
+
 # 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.
@@ -176,8 +228,6 @@
     }
 }
 
-
-
 # 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.
@@ -185,26 +235,27 @@
     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} {
+    lassign [$w tag prevrange url "@$x,$y"] a b
 
+    set uri [$w tag nextrange uri $a $b]
+    if {$uri != {}} {
+	lassign $uri a b
+    }
 
-# Returns a URL containing the $x,$y point in the text widget $w:
-proc urls::get_url {w x y} {
-    lassign [$w tag prevrange url "@$x,$y + 1 char"] a b
     $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::add_chat_win_popup_menu {m chatwin X Y x y} {
     set tags [$chatwin tag names "@$x,$y"]
-    set idx [lsearch $tags url]
+    set idx [lsearch $tags href_*]
     if {$idx >= 0} {
 	$m add command -label [::msgcat::mc "Copy URL to clipboard"] \
 	    -command [list [namespace current]::copy_url $chatwin $x $y]
@@ -223,6 +274,9 @@
     set options(cursor)           [option get $w urlcursor           Text]
 
     config_url $w url -command [list [namespace current]::browse_url %W %x %y]
+
+    # "uri" -- tag for "hidden" URLs (presented as their alt. text):
+    $w tag configure uri -elide 1
 }
 
 namespace eval urls {
@@ -235,3 +289,4 @@
     ::richtext::entity_state url 1
 }
 
+# vim:ts=8:sts=4:sw=4:noet

Modified: trunk/tkabber/richtext.tcl
===================================================================
--- trunk/tkabber/richtext.tcl	2006-11-12 14:49:36 UTC (rev 792)
+++ trunk/tkabber/richtext.tcl	2006-11-15 20:33:05 UTC (rev 793)
@@ -212,8 +212,29 @@
     set thash($t) 0
 }
 
+# Selection handlers are "wrapped" by Tk so that they cannot fail
+# due to errors since they are silenced.
+# So this proc is kind of "error-enabled selection handler" -- it will
+# raise any error occured in the selection handler.
+proc richtext::chk_reconstruct_text {w first last} {
+    if {[catch [list reconstruct_text $w $first $last] out]} {
+	after idle [list error $out]
+	return
+    } else {
+	return $out
+    }
+}
+
+# Parses the contents of Text widget $w from $first to $last
+# and returns reconstructed "plain text".
+# It's main purpose is to return the "original" text that was
+# submitted to that Text widget and then undergone
+# "rich text" processing.
 proc richtext::reconstruct_text {w first last} {
+    variable state
+
     #puts "in [info level 0]"
+
     if {[catch {$w dump -text -tag $first $last} dump]} {
 	#puts "dump failed: $dump"
 	return {}
@@ -231,12 +252,15 @@
 		set in nowhere
 		set chunk ""
 		set tags {}
+		set ignore false
 	    }
 	    tagon {
 		if {[lsearch $state($w,types) $val] >= 0} {
 		    if {$in != "tag"} { write_chunk_out out chunk $tags }
 		    lappend tags $val
 		    set in tag
+		} elseif {$val == "transient"} {
+		    set ignore true
 		}
 	    }
 	    tagoff {
@@ -244,9 +268,12 @@
 		    if {$in != "tag"} { write_chunk_out out chunk $tags }
 		    lexclude tags $val
 		    set in tag
+		} elseif {$val == "transient"} {
+		    set ignore false
 		}
 	    }
 	    text {
+		if {$ignore} continue
 		append chunk $val
 		set in text
 	    }
@@ -255,6 +282,7 @@
 		set in image
 	    }
 	    end {
+		if {$ignore} continue
 		if {$in != "tag"} { write_chunk_out out chunk $tags }
 	    }
 	}
@@ -284,72 +312,26 @@
     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] \
+		   [chk_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
-    }
+    set data [chk_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
-    }
+    set data [chk_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.
@@ -398,6 +380,13 @@
     set msgprops($name) $value
 }
 
+# Unlike _add, allows stomping on existing property value:
+proc richtext::property_update {name value} {
+    variable msgprops
+
+    set msgprops($name) $value
+}
+
 proc richtext::property_get {name} {
     variable msgprops
 

Modified: trunk/tkabber/userinfo.tcl
===================================================================
--- trunk/tkabber/userinfo.tcl	2006-11-12 14:49:36 UTC (rev 792)
+++ trunk/tkabber/userinfo.tcl	2006-11-15 20:33:05 UTC (rev 793)
@@ -121,7 +121,8 @@
     set w [w_from_jid $jid]
 
     label $g.l$name -text $text
-    text $g.$name -height 1 -state disabled -relief flat -background [option get $g background Notebook]
+    text $g.$name -height 1 -state disabled -relief flat \
+		  -background [option get $g background Notebook]
     ::richtext::config $g.$name -using url
     fill_user_description $g.$name userinfo($name,$jid) 0
     
@@ -131,8 +132,9 @@
     trace variable [namespace current]::userinfo($name,$jid) w \
 	[list userinfo::fill_user_description $g.$name userinfo($name,$jid) 0]
     bind $g.$name <Destroy> \
-	[list trace vdelete [namespace current]::userinfo($name,$jid) w \
-		  [list userinfo::fill_user_description $g.$name userinfo($name,$jid) 0]]
+	+[list trace vdelete [namespace current]::userinfo($name,$jid) w \
+	       [list userinfo::fill_user_description $g.$name \
+		     userinfo($name,$jid) 0]]
 }
 
 proc userinfo::pack_spinbox {jid g row col name low high text} {
@@ -333,10 +335,12 @@
     pack $sw -fill both -expand yes
     pack $a -fill both -expand yes
     trace variable [namespace current]::userinfo(desc,$jid) w \
-	[list userinfo::fill_user_description $a.text userinfo(desc,$jid) $editable]
+	[list userinfo::fill_user_description $a.text \
+	      userinfo(desc,$jid) $editable]
     bind $a.text <Destroy> \
-	[list trace variable [namespace current]::userinfo(desc,$jid) w \
-		  [list userinfo::fill_user_description $a.text userinfo(desc,$jid) $editable]]
+	+[list trace variable [namespace current]::userinfo(desc,$jid) w \
+	       [list userinfo::fill_user_description $a.text \
+		     userinfo(desc,$jid) $editable]]
     set userinfo(descfield,$jid) $a.text
 
     manage_focus $jid about $b.bday[expr {$editable ? "year" : ""}] $editable

Modified: trunk/tkabber/utils.tcl
===================================================================
--- trunk/tkabber/utils.tcl	2006-11-12 14:49:36 UTC (rev 792)
+++ trunk/tkabber/utils.tcl	2006-11-15 20:33:05 UTC (rev 793)
@@ -428,3 +428,61 @@
     return $m
 }
 
+# Forces (string) $x to be interpreted as integer.
+# Useful to deal with strings representing decimal interegs and
+# containing leading zeroes (so, normaly they would be interpreted
+# by Tcl as octal integers).
+# Contributed on c.l.t. by Kevin Kenny, see http://wiki.tcl.tk/498
+proc force_integer {x} {
+    set count [scan $x %d%s n rest]
+    if { $count <= 0 || ( $count == 2 && ![string is space $rest] ) } {
+	return -code error "not an integer: $x"
+    }
+
+    return $n
+}
+
+# Excludes element $what from the list named $listVar:
+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:
+proc lfuse {args} {
+    lsort -unique [lconcat $args]
+}
+
+# Takes a list of lists and flattens them into one list.
+# NOTE that it takes ONE argument, which should be a list.
+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
+}
+
+# vim:ts=8:sw=4:sts=4:noet



More information about the Tkabber-dev mailing list