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

codesite-noreply at google.com codesite-noreply at google.com
Wed Feb 11 20:24:56 MSK 2009


Author: sgolovan
Date: Wed Feb 11 09:23:11 2009
New Revision: 71

Added:
    trunk/xmpp/annotations.tcl   (contents, props changed)
    trunk/xmpp/delimiter.tcl   (contents, props changed)
    trunk/xmpp/metacontacts.tcl   (contents, props changed)
    trunk/xmpp/private.tcl   (contents, props changed)
Modified:
    trunk/ChangeLog
    trunk/xmpp/pkgIndex.tcl

Log:
	* xmpp/private.tcl: Added simple interface to private XML storage
	  (XEP-0049).

	* xmpp/annotations.tcl: Added storing/retieving roster notes
	  (XEP-0145).

	* xmpp/delimiter.tcl: Added storing/retrieving nested groups delimiter
	  (XEP-0083).

	* xmpp/metacontacts.tcl: Added storing/retrieving roster metacontacts
	  (XEP-0209).

	* xmpp/pkgIndex.tcl: Added the above packages.


Modified: trunk/ChangeLog
==============================================================================
--- trunk/ChangeLog	(original)
+++ trunk/ChangeLog	Wed Feb 11 09:23:11 2009
@@ -1,3 +1,19 @@
+2009-02-11  Sergei Golovan  <sgolovan at nes.ru>
+
+	* xmpp/private.tcl: Added simple interface to private XML storage
+	  (XEP-0049).
+
+	* xmpp/annotations.tcl: Added storing/retieving roster notes
+	  (XEP-0145).
+
+	* xmpp/delimiter.tcl: Added storing/retrieving nested groups delimiter
+	  (XEP-0083).
+
+	* xmpp/metacontacts.tcl: Added storing/retrieving roster metacontacts
+	  (XEP-0209).
+
+	* xmpp/pkgIndex.tcl: Added the above packages.
+
  2009-02-10  Sergei Golovan  <sgolovan at nes.ru>

  	* xmpp/tls.tcl: Changed -password option to -passwordcommand to avoid

Added: trunk/xmpp/annotations.tcl
==============================================================================
--- (empty file)
+++ trunk/xmpp/annotations.tcl	Wed Feb 11 09:23:11 2009
@@ -0,0 +1,158 @@
+# annotations.tcl --
+#
+#       This file is a part of the XMPP library. It implements storing
+#       and retieving roster notes (XEP-0145).
+#
+# Copyright (c) 2009 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::private
+
+package provide xmpp::roster::annotations 0.1
+
+namespace eval ::xmpp::roster::annotations {}
+
+proc ::xmpp::roster::annotations::retrieve {xlib args} {
+    set commands {}
+    set timeout 0
+
+    foreach {key val} $args {
+        switch -- $key {
+            -timeout {
+                set timeout $val
+            }
+            -command {
+                set commands [list $val]
+            }
+            default {
+                return -code error \
+                       -errorcode [::msgcat::mc "Illegal option \"%s\""  
$key]
+            }
+        }
+    }
+
+    set id \
+        [::xmpp::private::retrieve \
+                    $xlib \
+                    [list [::xmpp::xml::create storage \
+                                               -xmlns  
storage:rosternotes]] \
+                    -command [namespace code [list ProcessRetrieveAnswer  
$commands]] \
+                    -timeout $timeout]
+    return $id
+}
+
+proc ::xmpp::roster::annotations::ProcessRetrieveAnswer {commands status  
xml} {
+    if {[llength $commands] == 0} return
+
+    if {![string equal $status ok]} {
+        uplevel #0 [lindex $commands 0] [list $status $xml]
+    }
+
+    set notes {}
+
+    foreach xmldata $xml {
+        ::xmpp::xml::split $xmldata tag xmlns attrs cdata subels
+
+        if {[string equal $xmlns storage:rosternotes]} {
+            foreach note $subels {
+                ::xmpp::xml::split $note stag sxmlns sattrs scdata ssubels
+
+                set jid   [::xmpp::xml::getAttr $sattrs jid]
+                set cdate [::xmpp::xml::getAttr $sattrs cdate]
+                set mdate [::xmpp::xml::getAttr $sattrs mdate]
+
+                if {[catch { ScanTime $cdate } cdate]} {
+                    set cdate [clock seconds]
+                }
+                if {[catch { ScanTime $mdate } mdate]} {
+                    set mdate [clock seconds]
+                }
+
+                lappend notes [list jid $jid cdate $cdate mdate $mdate  
note $scdata]
+            }
+        }
+    }
+
+    uplevel #0 [lindex $commands 0] [list ok $notes]
+    return
+}
+
+proc ::xmpp::roster::annotations::ScanTime {timestamp} {
+    if {[regexp {(.*)T(.*)Z} $timestamp -> date time]} {
+        return [clock scan "$date $time" -gmt true]
+    } else {
+        return [clock scan $timestamp -gmt true]
+    }
+}
+
+proc ::xmpp::roster::annotations::SerializeNotes {notes} {
+    variable notes
+
+    set tags {}
+    foreach note $notes {
+        array unset n
+        array set n $note
+        if {[string equal $n(note) ""]} continue
+
+        set vars [list jid $n(jid)]
+
+        if {![catch {clock format $n(cdate) \
+                                  -format "%Y-%m-%dT%TZ" -gmt true}  
cdate]} {
+            lappend vars cdate $cdate
+        }
+
+        if {![catch {clock format $n(mdate) \
+                                  -format "%Y-%m-%dT%TZ" -gmt true}  
mdate]} {
+            lappend vars mdate $mdate
+        }
+
+        lappend tags [::xmpp::xml::create note \
+                                          -attrs $vars \
+                                          -cdata $n(note)]
+    }
+
+    return [::xmpp::xml::create storage \
+                                -xmlns storage:rosternotes \
+                                -subelements $tags]
+}
+
+proc ::xmpp::roster::annotations::store {xlib notes args} {
+    set commands {}
+    set timeout 0
+
+    foreach {key val} $args {
+        switch -- $key {
+            -timeout {
+                set timeout $val
+            }
+            -command {
+                set commands [list $val]
+            }
+            default {
+                return -code error \
+                       -errorcode [::msgcat::mc "Illegal option \"%s\""  
$key]
+            }
+        }
+    }
+
+    set id \
+        [::xmpp::private::retrieve \
+                    $xlib \
+                    [list [SerializeNotes $notes]] \
+                    -command [namespace code [list ProcessStoreAnswer  
$commands]] \
+                    -timeout $timeout]
+    return $id
+}
+
+proc ::xmpp::roster::annotations::ProcessStoreAnswer {commands status xml}  
{
+    if {[llength $commands] > 0} {
+        uplevel #0 [lindex $commands 0] [list $status $xml]
+    }
+    return
+}
+
+# vim:ts=8:sw=4:sts=4:et

Added: trunk/xmpp/delimiter.tcl
==============================================================================
--- (empty file)
+++ trunk/xmpp/delimiter.tcl	Wed Feb 11 09:23:11 2009
@@ -0,0 +1,114 @@
+# delimiter.tcl --
+#
+#       This file is a part of the XMPP library. It implements nested  
roster
+#       groups server-side delimiter storing (XEP-0083).
+#
+# Copyright (c) 2009 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::private
+
+package provide xmpp::roster::delimiter 0.1
+
+namespace eval ::xmpp::roster::delimiter {}
+
+#
+# Retrieving nested groups delimiter
+#
+
+proc ::xmpp::roster::delimiter::retrieve {xlib fallback args} {
+    set commands {}
+    set timeout 0
+
+    foreach {key val} $args {
+        switch -- $key {
+            -timeout {
+                set timeout $val
+            }
+            -command {
+                set commands [list $val]
+            }
+            default {
+                return -code error \
+                       -errorcode [::msgcat::mc "Illegal option \"%s\""  
$key]
+            }
+        }
+    }
+
+    set id \
+        [::xmpp::private::retrieve \
+                    $xlib \
+                    [list [::xmpp::xml::create roster \
+                                               -xmlns roster:delimiter]] \
+                    -command [namespace code [list ParseRetrieveResult \
+                                                   $fallback \
+                                                   $commands] \
+                    -timeout $timeout]
+    return $id
+}
+
+proc ::xmpp::roster::delimiter::ParseRetireveResult {fallback commands  
status xml} {
+    if {[llength $commands] == 0} return
+
+    set delimiter $fallback
+
+    if {[string equal $status ok]} {
+        foreach item $xml {
+            ::xmpp::xml::split $item tag xmlns attrs cdata subels
+
+            if {[string equal $xmlns roster:delimiter]} {
+                set delimiter $cdata
+            }
+        }
+    }
+
+    uplevel #0 [lindex $commands 0] [list $delimiter]
+    return
+}
+
+#
+# Storing nested groups delimiter
+#
+
+proc ::xmpp::roster::delimiter::store {xlib delimiter args} {
+    set commands {}
+    set timeout 0
+
+    foreach {key val} $args {
+        switch -- $key {
+            -timeout {
+                set timeout $val
+            }
+            -command {
+                set commands [list $val]
+            }
+            default {
+                return -code error \
+                       -errorcode [::msgcat::mc "Illegal option \"%s\""  
$key]
+            }
+        }
+    }
+
+    set id \
+        [::xmpp::private::store \
+                    $xlib \
+                    [list [::xmpp::xml::create roster \
+                                               -xmlns roster:delimiter \
+                                               -cdata $delimiter]] \
+                    -command [namespace code [list ParseStoreResult  
$commands]] \
+                    -timeout $timeout]
+    return $id
+}
+
+proc ::xmpp::roster::delimiter::ParseStoreResult {commands status xml} {
+    if {[llength $commands] > 0} {
+        uplevel #0 [lindex $commands 0] [list $status $xml]
+    }
+    return
+}
+
+# vim:ts=8:sw=4:sts=4:et

Added: trunk/xmpp/metacontacts.tcl
==============================================================================
--- (empty file)
+++ trunk/xmpp/metacontacts.tcl	Wed Feb 11 09:23:11 2009
@@ -0,0 +1,125 @@
+# metacontacts.tcl --
+#
+#       This file is a part of the XMPP library. It implements storing and
+#       retieving metacontacts information (XEP-0209).
+#
+# Copyright (c) 2009 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::private
+
+package provide xmpp::roster::metacontacts 0.1
+
+namespace eval ::xmpp::roster::metacontacts {}
+
+proc ::xmpp::roster::metacontacts::retrieve {xlib args} {
+    set commands {}
+    set timeout 0
+
+    foreach {key val} $args {
+        switch -- $key {
+            -timeout {
+                set timeout $val
+            }
+            -command {
+                set commands [list $val]
+            }
+            default {
+                return -code error \
+                       -errorcode [::msgcat::mc "Illegal option \"%s\""  
$key]
+            }
+        }
+    }
+
+    set id \
+        [::xmpp::private::retrieve \
+                    $xlib \
+                    [list [::xmpp::xml::create storage \
+                                               -xmlns  
storage:metacontacts]] \
+                    -command [namespace code [list ProcessRetrieveAnswer  
$commands]] \
+                    -timeout $timeout]
+    return $id
+}
+
+proc ::xmpp::roster::metacontacts::ProcessRetrieveAnswer {commands status  
xml} {
+    if {[llength $commands] == 0} return
+
+    if {![string equal $status ok]} {
+        uplevel #0 [lindex $commands 0] [list $status $xml]
+    }
+
+    set contacts {}
+
+    foreach xmldata $xml {
+        ::xmpp::xml::split $xmldata tag xmlns attrs cdata subels
+
+        if {[string equal $xmlns storage:metacontacts]} {
+            foreach meta $subels {
+                ::xmpp::xml::split $meta stag sxmlns sattrs scdata ssubels
+
+                set jid   [::xmpp::xml::getAttr $sattrs jid]
+                set tag   [::xmpp::xml::getAttr $sattrs tag]
+                set order [::xmpp::xml::getAttr $sattrs order]
+
+                lappend contacts [list jid $jid tag $tag order $order]
+            }
+        }
+    }
+
+    uplevel #0 [lindex $commands 0] [list ok $contacts]
+    return
+}
+
+proc ::xmpp::roster::metacontacts::store {xlib contacts args} {
+    set commands {}
+    set timeout 0
+
+    foreach {key val} $args {
+        switch -- $key {
+            -timeout {
+                set timeout $val
+            }
+            -command {
+                set commands [list $val]
+            }
+            default {
+                return -code error \
+                       -errorcode [::msgcat::mc "Illegal option \"%s\""  
$key]
+            }
+        }
+    }
+
+    set tags {}
+    foreach meta $contacts {
+        array unset n
+        array set n $meta
+
+        set attrs [list jid $n(jid) tag $n(tag) order $n(order)]
+
+        lappend tags [::xmpp::xml::create meta \
+                                          -attrs $vars]
+    }
+
+    set id \
+        [::xmpp::private::retrieve \
+                    $xlib \
+                    [list [::xmpp::xml::create storage \
+                                        -xmlns storage:metacontacts \
+                                        -subelements $tags]] \
+                    -command [namespace code [list ProcessStoreAnswer  
$commands]] \
+                    -timeout $timeout]
+    return $id
+}
+
+proc ::xmpp::roster::metacontacts::ProcessStoreAnswer {commands status  
xml} {
+    if {[llength $commands] > 0} {
+        uplevel #0 [lindex $commands 0] [list $status $xml]
+    }
+    return
+}
+
+# vim:ts=8:sw=4:sts=4:et

Modified: trunk/xmpp/pkgIndex.tcl
==============================================================================
--- trunk/xmpp/pkgIndex.tcl	(original)
+++ trunk/xmpp/pkgIndex.tcl	Wed Feb 11 09:23:11 2009
@@ -10,34 +10,38 @@
  #
  # $Id$

-package ifneeded ntlm 1.0                  [list source [file join $dir  
ntlm.tcl]]
-package ifneeded pconnect 0.1              [list source [file join $dir  
pconnect.tcl]]
-package ifneeded pconnect::https 0.1       [list source [file join $dir  
https.tcl]]
-package ifneeded pconnect::socks4 0.1      [list source [file join $dir  
socks4.tcl]]
-package ifneeded pconnect::socks5 0.1      [list source [file join $dir  
socks5.tcl]]
-package ifneeded xmpp 0.1                  [list source [file join $dir  
xmpp.tcl]]
-package ifneeded xmpp::auth 0.1            [list source [file join $dir  
auth.tcl]]
-package ifneeded xmpp::component 0.1       [list source [file join $dir  
component.tcl]]
-package ifneeded xmpp::compress 0.1        [list source [file join $dir  
compress.tcl]]
-package ifneeded xmpp::data 0.1            [list source [file join $dir  
data.tcl]]
-package ifneeded xmpp::delay 0.1           [list source [file join $dir  
delay.tcl]]
-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]]
-package ifneeded xmpp::search 0.1          [list source [file join $dir  
search.tcl]]
-package ifneeded xmpp::stanzaerror 0.1     [list source [file join $dir  
stanzaerror.tcl]]
-package ifneeded xmpp::starttls 0.1        [list source [file join $dir  
starttls.tcl]]
-package ifneeded xmpp::streamerror 0.1     [list source [file join $dir  
streamerror.tcl]]
-package ifneeded xmpp::transport 0.1       [list source [file join $dir  
transport.tcl]]
-package ifneeded xmpp::transport::poll 0.1 [list source [file join $dir  
poll.tcl]]
-package ifneeded xmpp::transport::tcp 0.1  [list source [file join $dir  
tcp.tcl]]
-package ifneeded xmpp::transport::tls 0.1  [list source [file join $dir  
tls.tcl]]
-package ifneeded xmpp::transport::zlib 0.1 [list source [file join $dir  
zlib.tcl]]
-package ifneeded xmpp::xml 0.1             [list source [file join $dir  
xml.tcl]]
+package ifneeded ntlm 1.0                       [list source [file join  
$dir ntlm.tcl]]
+package ifneeded pconnect 0.1                   [list source [file join  
$dir pconnect.tcl]]
+package ifneeded pconnect::https 0.1            [list source [file join  
$dir https.tcl]]
+package ifneeded pconnect::socks4 0.1           [list source [file join  
$dir socks4.tcl]]
+package ifneeded pconnect::socks5 0.1           [list source [file join  
$dir socks5.tcl]]
+package ifneeded xmpp 0.1                       [list source [file join  
$dir xmpp.tcl]]
+package ifneeded xmpp::auth 0.1                 [list source [file join  
$dir auth.tcl]]
+package ifneeded xmpp::component 0.1            [list source [file join  
$dir component.tcl]]
+package ifneeded xmpp::compress 0.1             [list source [file join  
$dir compress.tcl]]
+package ifneeded xmpp::data 0.1                 [list source [file join  
$dir data.tcl]]
+package ifneeded xmpp::delay 0.1                [list source [file join  
$dir delay.tcl]]
+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::private 0.1              [list source [file join  
$dir private.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::roster::annotations 0.1  [list source [file join  
$dir annotations.tcl]]
+package ifneeded xmpp::roster::delimiter 0.1    [list source [file join  
$dir delimiter.tcl]]
+package ifneeded xmpp::roster::metacontacts 0.1 [list source [file join  
$dir metacontacts.tcl]]
+package ifneeded xmpp::sasl 0.1                 [list source [file join  
$dir sasl.tcl]]
+package ifneeded xmpp::search 0.1               [list source [file join  
$dir search.tcl]]
+package ifneeded xmpp::stanzaerror 0.1          [list source [file join  
$dir stanzaerror.tcl]]
+package ifneeded xmpp::starttls 0.1             [list source [file join  
$dir starttls.tcl]]
+package ifneeded xmpp::streamerror 0.1          [list source [file join  
$dir streamerror.tcl]]
+package ifneeded xmpp::transport 0.1            [list source [file join  
$dir transport.tcl]]
+package ifneeded xmpp::transport::poll 0.1      [list source [file join  
$dir poll.tcl]]
+package ifneeded xmpp::transport::tcp 0.1       [list source [file join  
$dir tcp.tcl]]
+package ifneeded xmpp::transport::tls 0.1       [list source [file join  
$dir tls.tcl]]
+package ifneeded xmpp::transport::zlib 0.1      [list source [file join  
$dir zlib.tcl]]
+package ifneeded xmpp::xml 0.1                  [list source [file join  
$dir xml.tcl]]

  package ifneeded xmpp::full 0.1 {
      package require pconnect::https 0.1
@@ -50,6 +54,9 @@
      package require xmpp::delay 0.1
      package require xmpp::dns 0.1
      package require xmpp::roster 0.1
+    package require xmpp::roster::annotations 0.1
+    package require xmpp::roster::delimiter 0.1
+    package require xmpp::roster::metacontacts 0.1
      package require xmpp::starttls 0.1
      package require xmpp::transport::poll 0.1
      package require xmpp::transport::tls 0.1

Added: trunk/xmpp/private.tcl
==============================================================================
--- (empty file)
+++ trunk/xmpp/private.tcl	Wed Feb 11 09:23:11 2009
@@ -0,0 +1,98 @@
+# private.tcl --
+#
+#       This file is part of the XMPP library. It provides support for the
+#       Private XML Storage (XEP-0049).
+#
+# Copyright (c) 2009 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::private 0.1
+
+namespace eval ::xmpp::private {}
+
+proc ::xmpp::private::store {xlib query args} {
+    set commands {}
+    set timeout 0
+
+    foreach {key val} $args {
+        switch -- $key {
+            -timeout {
+                set timeout $val
+            }
+            -command {
+                set commands [list $val]
+            }
+            default {
+                return -code error \
+                       -errorcode [::msgcat::mc "Illegal option \"%s\""  
$key]
+            }
+        }
+    }
+
+    set id \
+        [::xmpp::sendIQ $xlib set \
+                   -query [::xmpp::xml::create query \
+                                               -xmlns jabber:iq:private \
+                                               -subelements $query] \
+                   -command [namespace code [list ParseStoreAnswer  
$commands]] \
+                   -timeout $timeout]
+    return $id
+}
+
+proc ::xmpp::private::ParseStoreAnswer {commands status xml} {
+    if {[llength $commands] > 0} {
+        uplevel #0 [lindex $commands 0] [list $status $xml]
+    }
+    return
+}
+
+proc ::xmpp::private::retrieve {xlib query args} {
+    set commands {}
+    set timeout 0
+
+    foreach {key val} $args {
+        switch -- $key {
+            -timeout {
+                set timeout $val
+            }
+            -command {
+                set commands [list $val]
+            }
+            default {
+                return -code error \
+                       -errorcode [::msgcat::mc "Illegal option \"%s\""  
$key]
+            }
+        }
+    }
+
+    set id \
+        [::xmpp::sendIQ $xlib get \
+                   -query [::xmpp::xml::create query \
+                                               -xmlns jabber:iq:private \
+                                               -subelements $query] \
+                   -command [namespace code [list ParseRetrieveAnswer  
$commands]] \
+                   -timeout $timeout]
+    return $id
+}
+
+proc ::xmpp::private::ParseRetrieveAnswer {commands status xml} {
+    if {[llength $commands] == 0} return
+
+    if {![string equal $status ok]} {
+        uplevel #0 [lindex $commands 0] [list $status $xml]
+        return
+    }
+
+    ::xmpp::xml::split $xml tag xmlns attrs cdata subels
+
+    uplevel #0 [lindex $commands 0] [list ok $subels]
+    return
+}
+
+# vim:ts=8:sw=4:sts=4:et


More information about the Tkabber-dev mailing list