[Tkabber-dev] [tclxmpp commit] r60 - in trunk: . xmpp

codesite-noreply at google.com codesite-noreply at google.com
Mon Nov 3 15:28:56 MSK 2008


Author: sgolovan
Date: Mon Nov  3 04:27:47 2008
New Revision: 60

Added:
    trunk/xmpp/negotiate.tcl   (contents, props changed)
Modified:
    trunk/ChangeLog
    trunk/xmpp/pkgIndex.tcl
    trunk/xmpp/tcp.tcl
    trunk/xmpp/zlib.tcl

Log:
	* xmpp/tcp.tcl, xmpp/zlib.tcl: Fixed typo in a procedure which returns
	  connection socket IP address.

	* xmpp/negotiate.tcl, pkgIndex.tcl: Added a package which implements
	  feature negotiation protocol (XEP-0020).


Modified: trunk/ChangeLog
==============================================================================
--- trunk/ChangeLog	(original)
+++ trunk/ChangeLog	Mon Nov  3 04:27:47 2008
@@ -1,3 +1,11 @@
+2008-11-03  Sergei Golovan  <sgolovan at nes.ru>
+
+	* xmpp/tcp.tcl, xmpp/zlib.tcl: Fixed typo in a procedure which returns
+	  connection socket IP address.
+
+	* xmpp/negotiate.tcl, pkgIndex.tcl: Added a package which implements
+	  feature negotiation protocol (XEP-0020).
+
  2008-11-02  Sergei Golovan  <sgolovan at nes.ru>

  	* xmpp/data.tcl: Added a procedure which fills in form fields for

Added: trunk/xmpp/negotiate.tcl
==============================================================================
--- (empty file)
+++ trunk/xmpp/negotiate.tcl	Mon Nov  3 04:27:47 2008
@@ -0,0 +1,208 @@
+# negotiate.tcl --
+#
+#       This file is a part of the XMPP library. It implements support for
+#       feature negotiation (XEP-0020).
+#
+# Copyright (c) 2008 Sergei Golovan <sgolovan at nes.ru>
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAMER OF ALL WARRANTIES.
+#
+# $Id$
+
+package require xmpp
+
+package provide xmpp::negotiate 0.1
+
+namespace eval ::xmpp::negotiate {
+    ::xmpp::iq::register get feature  
http://jabber.org/protocol/feature-neg \
+                         ::xmpp::negotiate::ParseQuery
+}
+
+# ::xmpp::negotiate::register --
+
+proc ::xmpp::negotiate::register {feature command} {
+    variable CallBack
+
+    set CallBack($feature) $command
+}
+
+# ::xmpp::negotiate::sendOptions --
+
+proc ::xmpp::negotiate::sendOptions {xlib to feature options args} {
+    set command #
+    foreach {key val} $args {
+        switch -- $key {
+            -command {
+                set command $val
+            }
+        }
+    }
+
+    set opts {}
+    foreach o $options {
+        lappend opts "" $o
+    }
+
+    set fields [::xmpp::data::formField field -var $feature \
+                                              -type list-single \
+                                              -options $opts]
+    ::xmpp::sendIQ $xlib get \
+        -query [::xmpp::xml::create feature \
+                        -xmlns http://jabber.org/protocol/feature-neg \
+                        -subelement [::xmpp::data::form $fields]] \
+        -to $to \
+        -command [namespace code [list RecvOptionsResponse $xlib $to  
$command]]
+}
+
+# ::xmpp::negotiate::RecvOptionsResponse --
+
+proc ::xmpp::negotiate::RecvOptionsResponse {xlib jid command status xml} {
+    variable tmp
+
+    if {![string equal $status ok]} {
+        uplevel #0 $command [list $status $xml]
+        return
+    }
+
+    ::xmpp::xml::split $xml tag xmlns attrs cdata subels
+
+    foreach {type form} [::xmpp::data::findForm $subels] break
+    set fields [::xmpp::data::parseSubmit $form]
+
+    uplevel #0 $command [list ok $fields]
+    return
+}
+
+# ::xmpp::negotiate::sendRequest --
+
+proc ::xmpp::negotiate::sendRequest {xlib to feature args} {
+    set command #
+    foreach {key val} $args {
+        switch -- $key {
+            -command {
+                set command $val
+            }
+        }
+    }
+
+    set fields [list $feature {}]
+
+    ::xmpp::sendIQ $xlib get \
+        -query [::xmpp::xml::create feature \
+                        -xmlns http://jabber.org/protocol/feature-neg \
+                        -subelement [::xmpp::data::submitForm $fields]] \
+        -to $to \
+        -command [namespace code [list RecvRequestResponse $xlib $to  
$command]]
+}
+
+# ::xmpp::negotiate::RecvRequestResponse --
+
+proc ::xmpp::negotiate::RecvRequestResponse {xlib jid command status xml} {
+    variable tmp
+
+    if {![string equal $status ok]} {
+        uplevel #0 $command [list $status $xml]
+        return
+    }
+
+    ::xmpp::xml::split $xml tag xmlns attrs cdata subels
+
+    foreach {type form} [::xmpp::data::findForm $subels] break
+    set fields [::xmpp::data::parseForm $form]
+
+    uplevel #0 $command [list ok $fields]
+    return
+}
+
+# ::xmpp::negotiate::ParseQuery --
+
+proc ::xmpp::negotiate::ParseQuery {xlib from xml args} {
+    variable CallBack
+
+    ::xmpp::xml::split $xml tag xmlns attrs cdata subels
+
+    set lang [::xmpp::xml::getAttr $args -lang en]
+
+    foreach {type form} [::xmpp::data::findForm $subels] break
+
+    switch -- $type {
+        form {
+            # Options offer
+
+            set sfields {}
+            set fields [::xmpp::data::parseForm $form]
+
+            foreach {tag item} $fields {
+                if {![string equal $tag field]} continue
+
+                foreach {var type label desc required options values}  
$item {
+                    break
+                }
+
+                switch -- $type {
+                    hidden {
+                        lappend sfields $var $values
+                    }
+                    default {
+                        if {![info exists CallBack($var)]} continue
+
+                        set vals [eval $CallBack($var) \
+                                       [list $xlib $from $options] $args]
+
+                        if {[llength $vals] > 0} {
+                            lappend sfields $var $vals
+                        }
+                    }
+                }
+            }
+
+            if {[llength $sfields] > 0} {
+                return [list result \
+                             [::xmpp::xml::create feature \
+                                    -xmlns \
+                                      
http://jabber.org/protocol/feature-neg \
+                                    -subelement \
+                                     [::xmpp::data::submitForm $sfields]]]
+            }
+        }
+        submit {
+            # Options request
+
+            set sfields {}
+            set fields [::xmpp::data::parseSubmit $form]
+
+            foreach {tag item} $fields {
+                if {![string equal $tag field]} continue
+
+                foreach {var type label values} $item break
+
+                if {![info exists CallBack($var)]} continue
+
+                set opts [eval $CallBack($var) [list $xlib $from {}] $args]
+
+                if {[llength $opts] == 0} continue
+
+                set oopts {}
+                foreach o $opts {
+                    lappend oopts "" $o
+                }
+                lappend sfields [::xmpp::data::formField field \
+                                        -var $var \
+                                        -options $oopts]
+            }
+
+            if {[llength $sfields] > 0} {
+                return [list result \
+                             [::xmpp::xml::create feature \
+                                    -xmlns \
+                                      
http://jabber.org/protocol/feature-neg \
+                                    -subelement [::xmpp::data::form  
$sfields]]]
+            }
+        }
+    }
+
+    return [list error cancel feature-not-implemented]
+}
+
+# vim:ft=tcl:ts=8:sw=4:sts=4:et

Modified: trunk/xmpp/pkgIndex.tcl
==============================================================================
--- trunk/xmpp/pkgIndex.tcl	(original)
+++ trunk/xmpp/pkgIndex.tcl	Mon Nov  3 04:27:47 2008
@@ -24,6 +24,7 @@
  package ifneeded xmpp::dns 0.1             [list source [file join $dir  
dns.tcl]]
  package ifneeded xmpp::iq 0.1              [list source [file join $dir  
iq.tcl]]
  package ifneeded xmpp::jid 0.1             [list source [file join $dir  
jid.tcl]]
+package ifneeded xmpp::negotiate 0.1       [list source [file join $dir  
negotiate.tcl]]
  package ifneeded xmpp::register 0.1        [list source [file join $dir  
register.tcl]]
  package ifneeded xmpp::roster 0.1          [list source [file join $dir  
roster.tcl]]
  package ifneeded xmpp::sasl 0.1            [list source [file join $dir  
sasl.tcl]]

Modified: trunk/xmpp/tcp.tcl
==============================================================================
--- trunk/xmpp/tcp.tcl	(original)
+++ trunk/xmpp/tcp.tcl	Mon Nov  3 04:27:47 2008
@@ -352,7 +352,7 @@
      variable $token
      upvar 0 $token state

-    return [lindex [fconfigure $state(sock)) -sockname] 0]
+    return [lindex [fconfigure $state(sock) -sockname] 0]
  }

  # ::xmpp::transport::tcp::close --

Modified: trunk/xmpp/zlib.tcl
==============================================================================
--- trunk/xmpp/zlib.tcl	(original)
+++ trunk/xmpp/zlib.tcl	Mon Nov  3 04:27:47 2008
@@ -394,7 +394,7 @@
      variable $token
      upvar 0 $token state

-    return [lindex [fconfigure $state(sock)) -sockname] 0]
+    return [lindex [fconfigure $state(sock) -sockname] 0]
  }

  # ::xmpp::transport::zlib::close --


More information about the Tkabber-dev mailing list