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

tkabber-svn at jabber.ru tkabber-svn at jabber.ru
Fri Nov 24 23:54:48 MSK 2006


Author: sergei
Date: 2006-11-24 23:54:41 +0300 (Fri, 24 Nov 2006)
New Revision: 804

Modified:
   trunk/tkabber/ChangeLog
   trunk/tkabber/plugins/richtext/urls.tcl
Log:
	* plugins/richtext/urls.tcl: Add URL prefixes ftp:// or
	  http:// to URLs without them.


Modified: trunk/tkabber/ChangeLog
===================================================================
--- trunk/tkabber/ChangeLog	2006-11-24 20:40:31 UTC (rev 803)
+++ trunk/tkabber/ChangeLog	2006-11-24 20:54:41 UTC (rev 804)
@@ -1,5 +1,8 @@
 2006-11-24  Sergei Golovan  <sgolovan at nes.ru>
 
+	* plugins/richtext/urls.tcl: Add URL prefixes ftp:// or
+	  http:// to URLs without them.
+
 	* custom.tcl: Do not store loginconf automatically.
 
 	* contrib/extract-translations/extract.tcl: Changed the only

Modified: trunk/tkabber/plugins/richtext/urls.tcl
===================================================================
--- trunk/tkabber/plugins/richtext/urls.tcl	2006-11-24 20:40:31 UTC (rev 803)
+++ trunk/tkabber/plugins/richtext/urls.tcl	2006-11-24 20:54:41 UTC (rev 804)
@@ -71,8 +71,12 @@
 		lappend out [string range $s $ix [expr {$us - 1}]] $type $tags
 	    }
 
-	    lappend out [string range $s $us $ue] url $tags
+	    set title [string range $s $us $ue]
+	    set url [make_url $title]
 
+	    lappend out $url url $tags
+            ::richtext::property_update url:title,$url $title
+
 	    set ix [expr {$ue + 1}]
 	}
 
@@ -98,6 +102,16 @@
     return true
 }
 
+proc urls::make_url {title} {
+    if {[regexp {^(ftp|https?)://} $title]} {
+	return $title
+    }
+    if {[regexp {^ftp} $title]} {
+	return "ftp://$title"
+    }
+    return "http://$title"
+}
+
 proc urls::encode_url {url} {
     set utf8_url [encoding convertto utf-8 $url]
     set len [string length $utf8_url]



More information about the Tkabber-dev mailing list