[Tkabber-dev] r1182 - in trunk/tkabber: . jabberlib-tclxml jabberlib-tclxml/tclxml plugins/general

tkabber-svn at jabber.ru tkabber-svn at jabber.ru
Sat Aug 11 15:38:14 MSD 2007


Author: sergei
Date: 2007-08-11 15:38:13 +0400 (Sat, 11 Aug 2007)
New Revision: 1182

Added:
   trunk/tkabber/plugins/general/caps.tcl
Modified:
   trunk/tkabber/ChangeLog
   trunk/tkabber/jabberlib-tclxml/jabberlib.tcl
   trunk/tkabber/jabberlib-tclxml/tclxml/xml-8.1.tcl
Log:
	* jabberlib-tclxml/tclxml/xml-8.1.tcl: Fixed parsing XML attributes
	  which end by an equal sign.

	* jabberlib-tclxml/jabberlib.tcl: Add any tags (not only <x/>) to a
	  presence extensions list.

	* plugins/general/caps.tcl: Added entitiy capabilities support
	  (XEP-0115, version 1.4).


Modified: trunk/tkabber/ChangeLog
===================================================================
--- trunk/tkabber/ChangeLog	2007-08-10 22:48:07 UTC (rev 1181)
+++ trunk/tkabber/ChangeLog	2007-08-11 11:38:13 UTC (rev 1182)
@@ -1,3 +1,14 @@
+2007-08-11  Sergei Golovan  <sgolovan at nes.ru>
+
+	* jabberlib-tclxml/tclxml/xml-8.1.tcl: Fixed parsing XML attributes
+	  which end by an equal sign.
+
+	* jabberlib-tclxml/jabberlib.tcl: Add any tags (not only <x/>) to a
+	  presence extensions list.
+
+	* plugins/general/caps.tcl: Added entitiy capabilities support
+	  (XEP-0115, version 1.4).
+
 2007-08-10  Sergei Golovan  <sgolovan at nes.ru>
 
 	* plugins/general/rawxml.tcl: Fixed bug with pretty-printing tags with

Modified: trunk/tkabber/jabberlib-tclxml/jabberlib.tcl
===================================================================
--- trunk/tkabber/jabberlib-tclxml/jabberlib.tcl	2007-08-10 22:48:07 UTC (rev 1181)
+++ trunk/tkabber/jabberlib-tclxml/jabberlib.tcl	2007-08-11 11:38:13 UTC (rev 1182)
@@ -1116,7 +1116,6 @@
 		    icon     {lappend param -icon     $cchdata}
 		    show     {lappend param -show     $cchdata}
 		    loc      {lappend param -loc      $cchdata}
-		    x        {lappend x $child}
 		    error {
 			if {$type == "error"} {
 			    set errcode [wrapper:getattr $cvars code]
@@ -1130,6 +1129,7 @@
 			    lappend param -error [lrange [stanzaerror::error_to_list $err] 0 1]
 			}
 		    }
+		    default {lappend x $child}
 		}
 	    }
 

Modified: trunk/tkabber/jabberlib-tclxml/tclxml/xml-8.1.tcl
===================================================================
--- trunk/tkabber/jabberlib-tclxml/tclxml/xml-8.1.tcl	2007-08-10 22:48:07 UTC (rev 1181)
+++ trunk/tkabber/jabberlib-tclxml/tclxml/xml-8.1.tcl	2007-08-11 11:38:13 UTC (rev 1182)
@@ -80,7 +80,7 @@
 
     # Expressions for pulling things apart
     #variable tokExpr <(/?)([::xml::cl ^$::xml::Wsp>/]+)([::xml::cl $::xml::Wsp]*[::xml::cl ^>]*)>
-    variable tokExpr {<(/?)([^\s>/]+)((\s*([^'\"\s]+\s*=\s*'[^']*'|[^'\"\s]+\s*=\s*\"[^\"]*\")|[^>])*\s*[?/]?)>}
+    variable tokExpr {<(/?)([^\s>/]+)((\s*([^'\"\s]+\s*=\s*'[^']*'|[^'\"\s]+\s*=\s*\"[^\"]*\")*|[^>]*)\s*[?/]?)>}
     variable substExpr "\}\n{\\2} {\\1} {\\3} \{"
 
 }

Added: trunk/tkabber/plugins/general/caps.tcl
===================================================================
--- trunk/tkabber/plugins/general/caps.tcl	                        (rev 0)
+++ trunk/tkabber/plugins/general/caps.tcl	2007-08-11 11:38:13 UTC (rev 1182)
@@ -0,0 +1,185 @@
+# $Id$
+# Entity capabilities support (XEP-0115)
+
+package require sha1
+package require md5
+package require base64
+
+namespace eval caps {
+    set ::NS(caps) http://jabber.org/protocol/caps
+    variable hash md5
+}
+
+proc caps::hash {identities features {hash sha-1}} {
+
+    set binidentities {}
+    foreach id $identities {
+	lappend binidentities [encoding convertto utf-8 $id]
+    }
+
+    set binfeatures {}
+    foreach fe $features {
+	lappend binfeatures [encoding convertto utf-8 $fe]
+    }
+
+    set binstr [join [concat [lsort -ascii $binidentities] \
+			     [lsort -ascii $binfeatures]] "<"]
+
+    if {[string equal $binstr ""]} {
+	return ""
+    }
+
+    append binstr "<"
+
+    switch -- $hash {
+	md5 {
+	    if {[catch {::md5::md5 -hex $binstr} hex]} {
+		# Old md5 package.
+		set hex [::md5::md5 $binstr]
+	    }
+	    set binhash [binary format H32 $hex]
+	}
+	sha-1 {
+	    set binhash [binary format H40 [::sha1::sha1 $binstr]]
+	}
+	default {
+	    # Unsupported hash type
+	    return ""
+	}
+    }
+    return [base64::encode $binhash]
+}
+
+proc caps::info_to_hash {child {hash sha-1}} {
+    set identities {}
+    set features {}
+
+    jlib::wrapper:splitxml $child tag vars isempty chdata children
+
+    foreach ch $children {
+	jlib::wrapper:splitxml $ch tag1 vars1 isempty1 chdata1 children1
+	switch -- $tag1 {
+	    identity {
+		set category [jlib::wrapper:getattr $vars1 category]
+		set type [jlib::wrapper:getattr $vars1 type]
+		if {![string equal $category ""] && ![string equal $type ""]} {
+		    lappend identities $category/$type
+		}
+	    }
+	    feature {
+		set var [jlib::wrapper:getattr $vars1 var]
+		if {![string equal $var ""]} {
+		    lappend features $var
+		}
+	    }
+	}
+    }
+    return [hash $identities $features $hash]
+}
+
+proc caps::get_presence_x {varname connid status} {
+    variable hash
+    upvar 2 $varname var
+
+    lassign [disco::info_query_get_handler \
+		    $connid "" \
+		    [jlib::get_lang] \
+		    [jlib::wrapper:createtag query \
+			    -vars [list xmlns $::NS(disco_info)]]] \
+	    res child
+
+    if {![string equal $res result]} return
+
+    set ver [info_to_hash $child $hash]
+    if {[string equal $ver ""]} return
+
+    set vars [list xmlns $::NS(caps)]
+    if {![string equal $hash sha-1]} {
+	lappend vars hash $hash
+    }
+    lappend vars ver $ver
+
+    lappend var [jlib::wrapper:createtag c -vars $vars]
+    return
+}
+
+hook::add presence_xlist_hook [namespace current]::caps::get_presence_x
+
+# TODO match caps hash to a set of features
+proc caps::process_presence {connid from type x args} {
+    variable htype
+    variable hver
+
+    switch -- $type {
+	unavailable {
+	    catch {unset htype($connid,$from)}
+	    catch {unset hver($connid,$from)}
+	}
+	available {
+	    foreach xs $x {
+		jlib::wrapper:splitxml $xs tag vars isempty chdata children
+		if {[jlib::wrapper:getattr $vars xmlns] == $::NS(caps)} {
+		    set hash [jlib::wrapper:getattr $vars hash]
+		    if {[string equal $hash ""]} {
+			set hash sha-1
+		    }
+		    set htype($connid,$from) $hash
+		    set hver($connid,$from) [jlib::wrapper:getattr $vars ver]
+		    return
+		}
+	    }
+	    # Unset caps if they aren't included in <presence/>
+	    catch {unset htype($connid,$from)}
+	    catch {unset hver($connid,$from)}
+	}
+    }
+}
+
+hook::add client_presence_hook [namespace current]::caps::process_presence
+
+proc caps::clean {connid} {
+    variable htype
+    variable hver
+
+    array unset htype $connid,*
+    array unset hver $connid,*
+}
+
+hook::add disconnected_hook [namespace current]::caps::clean
+
+proc caps::info_receive \
+     {connid jid node res identities features extras featured_nodes} {
+    variable hidentities
+    variable hfeatures
+    variable htype
+    variable hver
+
+    if {![string equal $res OK]} return
+    if {![info exists hver($connid,$jid)]} return
+
+    set ids {}
+    foreach id $identities {
+	set category [jlib::wrapper:getattr $id category]
+	set type [jlib::wrapper:getattr $id type]
+	if {![string equal $category ""] && ![string equal $type ""]} {
+	    lappend ids $category/$type
+	}
+    }
+    set fes {}
+    foreach fe $features {
+	set var [jlib::wrapper:getattr $fe var]
+	if {![string equal $var ""]} {
+	    lappend fes $var
+	}
+    }
+    if {![string equal [hash $ids $fes $htype($connid,$jid)] \
+		       $hver($connid,$jid)]} {
+	return
+    }
+
+    set hidentities($hver($connid,$jid)) $ids
+    set hfeatures($hver($connid,$jid)) $fes
+}
+
+hook::add disco_info_hook [namespace current]::caps::info_receive
+


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



More information about the Tkabber-dev mailing list