[Tkabber-dev] r1385 - in trunk/tkabber: . msgs plugins/iq plugins/pep

tkabber-svn at jabber.ru tkabber-svn at jabber.ru
Thu Mar 6 22:14:23 MSK 2008


Author: sergei
Date: 2008-03-06 22:14:22 +0300 (Thu, 06 Mar 2008)
New Revision: 1385

Added:
   trunk/tkabber/plugins/iq/time2.tcl
   trunk/tkabber/plugins/pep/user_location.tcl
Modified:
   trunk/tkabber/ChangeLog
   trunk/tkabber/datagathering.tcl
   trunk/tkabber/iq.tcl
   trunk/tkabber/msgs/de.msg
   trunk/tkabber/negotiate.tcl
   trunk/tkabber/privacy.tcl
Log:
	* iq.tcl: Fixed call of IQ handler if it is a command with arguments.

	* datagathering.tcl: Removed [cequal] and [cindex] calls.

	* negotiate.tcl: Adapted to a current version of XEP-0020.

	* privacy.tcl: Fixed possible race conditions with receiving/updating
	  privacy lists.

	* plugins/pep/user_location.tcl: Added user location support plugin
	  (XEP-0080).

	* plugins/iq/time2.tcl: Added entity time support plugin (XEP-0202).

	* msgs/de.msg: Updated German translation (thanks to Roger Sondermann).


Modified: trunk/tkabber/ChangeLog
===================================================================
--- trunk/tkabber/ChangeLog	2008-03-06 11:03:59 UTC (rev 1384)
+++ trunk/tkabber/ChangeLog	2008-03-06 19:14:22 UTC (rev 1385)
@@ -7,6 +7,22 @@
 	* plugins/general/caps.tcl: Implemented version 1.5 of XEP-0115 (only
 	  sending capabilities and replying to disco#info queries).
 
+	* iq.tcl: Fixed call of IQ handler if it is a command with arguments.
+
+	* datagathering.tcl: Removed [cequal] and [cindex] calls.
+
+	* negotiate.tcl: Adapted to a current version of XEP-0020.
+
+	* privacy.tcl: Fixed possible race conditions with receiving/updating
+	  privacy lists.
+
+	* plugins/pep/user_location.tcl: Added user location support plugin
+	  (XEP-0080).
+
+	* plugins/iq/time2.tcl: Added entity time support plugin (XEP-0202).
+
+	* msgs/de.msg: Updated German translation (thanks to Roger Sondermann).
+
 2008-03-04  Sergei Golovan  <sgolovan at nes.ru>
 
 	* msgs/ru.msg: Updated Russian translation.

Modified: trunk/tkabber/datagathering.tcl
===================================================================
--- trunk/tkabber/datagathering.tcl	2008-03-06 11:03:59 UTC (rev 1384)
+++ trunk/tkabber/datagathering.tcl	2008-03-06 19:14:22 UTC (rev 1385)
@@ -173,7 +173,7 @@
 	    set vars [list type $type]
 	    if {[info exists params(-var)]} {
 		lappend vars var $params(-var)
-	    } elseif {![cequal $type fixed]} {
+	    } elseif {![string equal $type fixed]} {
 		error "You must define -var"
 	    }
 	    if {[info exists params(-label)]} {
@@ -274,7 +274,7 @@
 	} else {
 	    set prefix ""
 	}
-	if {![string is punct [cindex $label end]]} {
+	if {![string is punct [string index $label end]]} {
 	    set suffix :
 	} else {
 	    set suffix ""
@@ -647,11 +647,11 @@
 }
 
 proc data::receive_data {connid xmlns jid node res child} {
-    if {[cequal $res DISCONNECT]} {
+    if {[string equal $res DISCONNECT]} {
 	return
     }
 
-    if {[cequal $res ERR]} {
+    if {[string equal $res ERR]} {
 	set ew .data_err
 	if {[winfo exists $ew]} {
 	    destroy $ew
@@ -716,7 +716,7 @@
 }
 
 proc data::test_error_res {w res child} {
-    if {[cequal $res OK]} {
+    if {[string equal $res OK]} {
 	destroy $w
 	return
     }

Modified: trunk/tkabber/iq.tcl
===================================================================
--- trunk/tkabber/iq.tcl	2008-03-06 11:03:59 UTC (rev 1384)
+++ trunk/tkabber/iq.tcl	2008-03-06 19:14:22 UTC (rev 1385)
@@ -50,7 +50,7 @@
 	set_status [format [::msgcat::mc "%s request from %s"] $xmlns_short $from]
     }
     if {[info exists h]} {
-	set res [$h $connid $from $lang $child]
+	set res [eval $h [list $connid $from $lang $child]]
 
 	if {$res != {}} {
 	    switch -- [lindex $res 0] {

Modified: trunk/tkabber/msgs/de.msg
===================================================================
--- trunk/tkabber/msgs/de.msg	2008-03-06 11:03:59 UTC (rev 1384)
+++ trunk/tkabber/msgs/de.msg	2008-03-06 19:14:22 UTC (rev 1385)
@@ -1,6 +1,6 @@
 
 # German messages file
-# Roger Sondermann 04.03.2008
+# Roger Sondermann 06.03.2008
 
 # .../chats.tcl
 ::msgcat::mcset de "%s has changed nick to %s."                             "%s hat seinen Nicknamen geändert in %s"
@@ -420,7 +420,7 @@
 
 # .../pep.tcl
 ::msgcat::mcset de "Personal eventing"                                      "Persönliche Ereignisse"
-::msgcat::mcset de "Personal eventing via pubsub plugins options."          "Optionen für die 'Persönliche Ereignisse'-Plugins."
+::msgcat::mcset de "Personal eventing via pubsub plugins options."          "Optionen für die 'Personal Eventing'-Plugins (XEP-0163)."
 
 # .../pixmaps.tcl
 ::msgcat::mcset de "Tkabber icon theme. To make new theme visible for Tkabber put it to some subdirectory of %s." "Tkabber Icon-Thema. Um es für Tkabber sichtbar zu machen, muß es in einem Unterordner von %s platziert werden."
@@ -1199,6 +1199,11 @@
 ::msgcat::mcset de "No avatar to store"                                     "Kein Avatar zu speichern"
 ::msgcat::mcset de "Send to server"                                         "An Server senden"
 
+# .../plugins/general/caps.tcl
+::msgcat::mcset de "Enable announcing entity capabilities in every outgoing presence." "Das Bekanntmachen von 'Entity Capabilities' in jeder ausgehenden Präsenz aktivieren."
+::msgcat::mcset de "Options for entity capabilities plugin."                "Optionen für das 'Entity Capabilities'-Plugin (XEP-0115)."
+::msgcat::mcset de "Use the specified function to hash supported features list." "Das ausgewählte Prüfsummenverfahren für das 'hashen' der unterstützten Eigenschaften benutzen."
+
 # .../plugins/general/clientinfo.tcl
 ::msgcat::mcset de "\n\tClient: %s"                                         "\n\tClient: %s"
 ::msgcat::mcset de "\n\tName: %s"                                           "\n\tName: %s"
@@ -1413,7 +1418,7 @@
 ::msgcat::mcset de "Activity"                                               "Aktivität"
 ::msgcat::mcset de "Activity:"                                              "Aktivität:"
 ::msgcat::mcset de "Auto-subscribe to other's user activity"                "Benutzer-Aktivität Anderer automatisch abonnieren"
-::msgcat::mcset de "Auto-subscribe to other's user activity notifications." "Benachrichtigungen über Benutzer-Aktivitäten Anderer automatisch abonnieren."
+::msgcat::mcset de "Auto-subscribe to other's user activity notifications." "Benachrichtigungen über die Benutzer-Aktivitäten Anderer automatisch abonnieren."
 ::msgcat::mcset de "Cannot publish empty activity"                          "Unausgefüllte Aktivität kann nicht veröffentlicht werden"
 ::msgcat::mcset de "Error"                                                  "Fehler"
 ::msgcat::mcset de "Publish user activity"                                  "Benutzer-Aktivität veröffentlichen"
@@ -1502,7 +1507,7 @@
 ::msgcat::mcset de "%s's mood changed to %s"                                "Gemütslage für %s geändert in %s"
 ::msgcat::mcset de "%s's mood is unset"                                     "Gemütslage für %s ist nicht gesetzt"
 ::msgcat::mcset de "Auto-subscribe to other's user mood"                    "Benutzer-Gemütslage Anderer automatisch abonnieren"
-::msgcat::mcset de "Auto-subscribe to other's user mood notifications."     "Benachrichtigungen über Benutzer-Gemütslagen Anderer automatisch abonnieren."
+::msgcat::mcset de "Auto-subscribe to other's user mood notifications."     "Benachrichtigungen über die Benutzer-Gemütslagen Anderer automatisch abonnieren."
 ::msgcat::mcset de "Cannot publish empty mood"                              "Unausgefüllte Gemütslage kann nicht veröffentlicht werden"
 ::msgcat::mcset de "Mood"                                                   "Gemütslage"
 ::msgcat::mcset de "Mood:"                                                  "Gemütslage:"
@@ -1587,7 +1592,7 @@
 ::msgcat::mcset de "%s's tune is unset"                                     "Musik für %s ist nicht gesetzt"
 ::msgcat::mcset de "Artist:"                                                "Interpret:"
 ::msgcat::mcset de "Auto-subscribe to other's user tune"                    "Benutzer-Musik Anderer automatisch abonnieren"
-::msgcat::mcset de "Auto-subscribe to other's user tune notifications."     "Benachrichtigungen über Benutzer-Musik Anderer automatisch abonnieren."
+::msgcat::mcset de "Auto-subscribe to other's user tune notifications."     "Benachrichtigungen über die Benutzer-Musik Anderer automatisch abonnieren."
 ::msgcat::mcset de "Length:"                                                "Länge:"
 ::msgcat::mcset de "Publish user tune"                                      "Benutzer-Musik veröffentlichen"
 ::msgcat::mcset de "Unpublish user tune"                                    "Benutzer-Musik zurückziehen"

Modified: trunk/tkabber/negotiate.tcl
===================================================================
--- trunk/tkabber/negotiate.tcl	2008-03-06 11:03:59 UTC (rev 1384)
+++ trunk/tkabber/negotiate.tcl	2008-03-06 19:14:22 UTC (rev 1385)
@@ -1,82 +1,90 @@
 # $Id$
 
 namespace eval negotiate {
+    set ::NS(negotiate) http://jabber.org/protocol/feature-neg
     set seq 0
 }
 
-proc negotiate::get_handler {connid from lang child} {
+proc negotiate::get_handler {type connid from lang child} {
     variable handler
 
-    debugmsg negotiate "get: [list $from $child]"
+    debugmsg negotiate "$type: [list $from $child]"
 
-    jlib::wrapper:splitxml $child tag vars isempty chdata children
+    jlib::wrapper:splitxml $child tag vars isempty cdata children
 
-    if {$tag == "query"} {
-	foreach item $children {
-	    jlib::wrapper:splitxml $item tag1 vars1 isempty1 chdata1 children1
-	    if {$tag1 == "feature"} {
-		set type [jlib::wrapper:getattr $vars1 type]
+    set error 1
+    set fields {}
+    foreach form $children {
+	jlib::wrapper:splitxml $form tag1 vars1 isempty1 cdata1 children1
+	if {$tag1 == "x" && \
+		[jlib::wrapper:getattr $vars1 xmlns] == $::NS(data) && \
+		[jlib::wrapper:getattr $vars1 type] == "submit"} {
 
-		if {![info exists handler($type)]} {
-		    
-		    return [list error cancel feature-not-implemented]
-		}
+		foreach field $children1 {
+		    jlib::wrapper:splitxml $field \
+			    tag2 vars2 isempty2 cdata2 children2
 
-		set opts {}
-		foreach item1 $children1 {
-		    jlib::wrapper:splitxml $item1 tag2 vars2 isempty2 \
-			chdata2 children2
-		    if {$tag2 == "option"} {
-			lappend opts $chdata2
-		    }
-		}
-		# TODO
-		set opts [$handler($type) $from $type $opts]
+		    if {$tag2 != "field"} continue
 
-		set opttags {}
-		foreach opt $opts {
-		    lappend opttags [jlib::wrapper:createtag option \
-					 -chdata $opt]
-		}
+		    set feature [jlib::wrapper:getattr $vars2 var]
 
-		set res [jlib::wrapper:createtag query \
-			     -vars {xmlns jabber:iq:negotiate} \
-			     -subtags [list [jlib::wrapper:createtag feature \
-						 -vars [list type $type] \
-						 -subtags $opttags]]]
-		return [list result $res]
+		    if {![info exists handler($feature)]} continue
+
+		    set error 0
+
+		    # TODO
+		    set opts [eval $handler($feature) \
+				   [list $type $connid $from $lang $children2]]
+
+		    lappend fields $opts
 	    }
 	}
     }
+    if {$error} {
+	return [list error cancel feature-not-implemented]
+    } else {
+	set res [jlib::wrapper:createtag feature \
+		     -vars [list xmlns $::NS(negotiate)] \
+		     -subtags [list [jlib::wrapper:createtag x \
+					 -vars [list xmlns $::NS(data) \
+						     type result] \
+					 -subtags $fields]]]
+	return [list result $res]
+    }
 }
 
-iq::register_handler get query jabber:iq:negotiate negotiate::get_handler
+iq::register_handler get feature $::NS(negotiate) \
+		     [list [namespace current]::negotiate::get_handler get]
+iq::register_handler set feature $::NS(negotiate) \
+		     [list [namespace current]::negotiate::get_handler set]
 
-proc negotiate::register_handler {type h} {
+proc negotiate::register_handler {feature h} {
     variable handler
 
-    set handler($type) $h
+    set handler($feature) $h
 }
 
-proc negotiate::send_request {connid to type {options {}}} {
+proc negotiate::send_request {connid to feature} {
     variable seq
     variable tmp
 
     set i [incr seq]
 
-    set opttags {}
-    foreach opt $options {
-	lappend opttags [jlib::wrapper:createtag option -chdata $opt]
+    set fieldtags {}
+    if {$feature != ""} {
+	lappend fieldtags [jlib::wrapper:createtag field \
+			       -vars [list var $feature]]
     }
 
     jlib::send_iq get \
-	[jlib::wrapper:createtag query \
-	     -vars {xmlns jabber:iq:negotiate} \
-	     -subtags [list [jlib::wrapper:createtag feature \
-				 -vars [list type $type] \
-				 -subtags $opttags]]] \
+	[jlib::wrapper:createtag feature \
+	     -vars [list xmlns $::NS(negotiate)] \
+	     -subtags [list [jlib::wrapper:createtag x \
+				 -vars [list xmlns $::NS(data) \
+					     type  submit] \
+				 -subtags $fieldtags]]] \
 	-to $to \
-	-command [list negotiate::recv_request_response $i] \
+	-command [list negotiate::recv_request_response $connid $to $i] \
 	-connection $connid
 
     vwait [namespace current]::tmp($i)
@@ -85,34 +93,39 @@
     return $res
 }
 
-proc negotiate::recv_request_response {seq res child} {
+proc negotiate::recv_request_response {connid jid seq res child} {
     variable tmp
 
     if {$res != "OK"} {
-	set tmp($seq) [list ERR $child]
+	set tmp($seq) [list $res $child]
 	return
     }
 
     jlib::wrapper:splitxml $child tag vars isempty chdata children
 
-    if {$tag == "query"} {
-	foreach item $children {
-	    jlib::wrapper:splitxml $item tag1 vars1 isempty1 chdata1 children1
-	    if {$tag1 == "feature"} {
-		set type [jlib::wrapper:getattr $vars1 type]
+    if {$tag == "feature"} {
+	jlib::wrapper:splitxml \
+	    [lindex $children 0] tag1 vars1 isempty1 chdata1 children1
 
-		set opts {}
-		foreach item1 $children1 {
-		    jlib::wrapper:splitxml $item1 tag2 vars2 isempty2 \
-			chdata2 children2
-		    if {$tag2 == "option"} {
-			lappend opts $chdata2
-		    }
-		}
-		set tmp($seq) [list OK $opts]
-	    }
-	}
+	data::draw_window $children1 \
+	    [list [namespace current]::send_negotiation_form $connid $jid]
     }
+
+    set tmp($seq) [list OK {}]
 }
 
+proc negotiate::send_negotiation_form {connid jid w restags} {
+    catch { destroy $w.error.msg }
+    $w.bbox itemconfigure 0 -state disabled
 
+    jlib::send_iq set [jlib::wrapper:createtag feature \
+			   -vars [list xmlns $::NS(negotiate)] \
+			   -subtags [jlib::wrapper:createtag x \
+					 -vars [list xmlns $::NS(data) \
+						     type  submit] \
+					 -subtags $restags]] \
+	-to $jid \
+	-connection $connid \
+	-command [list data::test_error_res $w]
+}
+

Added: trunk/tkabber/plugins/iq/time2.tcl
===================================================================
--- trunk/tkabber/plugins/iq/time2.tcl	                        (rev 0)
+++ trunk/tkabber/plugins/iq/time2.tcl	2008-03-06 19:14:22 UTC (rev 1385)
@@ -0,0 +1,48 @@
+# $Id$
+# Replies to XEP-0202 (Entity Time) queries
+
+custom::defvar options(reply_xmpp_time) 1 \
+    [::msgcat::mc "Reply to entity time (urn:xmpp:time) requests."] \
+    -group IQ -type boolean
+
+proc xmpp_time {connid from lang child} {
+    variable options
+
+    if {!$options(reply_xmpp_time)} {
+	return {error cancel service-unavailable}
+    }
+
+    jlib::wrapper:splitxml $child tag vars isempty chdata children
+
+    set curtime [clock seconds]
+    set restags \
+	[list [jlib::wrapper:createtag utc \
+		   -chdata [clock format $curtime \
+				  -format "%Y-%m-%dT%TZ" -gmt true]] \
+	      [jlib::wrapper:createtag tzo \
+		   -chdata [timezone_offset]]]
+    
+    set res [jlib::wrapper:createtag query \
+		 -vars {xmlns urn:xmpp:time} \
+		 -subtags $restags]
+    
+    return [list result $res]
+}
+
+proc timezone_offset {} {
+    set H [clock format 0 -format %H]
+    set M [clock format 0 -format %M]
+    set S +
+
+    if {$H > 12} {
+	set H [expr {24 - $H}]
+	set M [expr {60 - $M}]
+	set S -
+    }
+
+    return $S$H:$M
+}
+
+iq::register_handler get query urn:xmpp:time \
+    [namespace current]::xmpp_time
+

Added: trunk/tkabber/plugins/pep/user_location.tcl
===================================================================
--- trunk/tkabber/plugins/pep/user_location.tcl	                        (rev 0)
+++ trunk/tkabber/plugins/pep/user_location.tcl	2008-03-06 19:14:22 UTC (rev 1385)
@@ -0,0 +1,551 @@
+# $Id$
+# Implementation of XEP-0080 "User Location"
+
+namespace eval geoloc {
+    variable node http://jabber.org/protocol/geoloc
+    variable substatus
+    variable geoloc
+
+    custom::defvar options(auto-subscribe) 0 \
+	[::msgcat::mc "Auto-subscribe to other's user location notifications."] \
+	-command [namespace current]::register_in_disco \
+	-group PEP -type boolean
+
+    pubsub::register_event_notification_handler $node \
+	    [namespace current]::process_geoloc_notification
+    hook::add user_geoloc_notification_hook \
+	    [namespace current]::notify_via_status_message
+
+    hook::add finload_hook \
+	    [namespace current]::on_init 60
+    hook::add roster_jid_popup_menu_hook \
+	    [namespace current]::add_roster_pep_menu_item
+    hook::add roster_user_popup_info_hook \
+	    [namespace current]::provide_roster_popup_info
+    hook::add userinfo_hook \
+	    [namespace current]::provide_userinfo
+
+    disco::register_feature $node
+
+    variable fields [list alt area bearing building country datum \
+			  description error floor lat locality lon \
+			  postalcode region room speed street text \
+			  timestamp uri]
+
+    array set labels [list alt         [::msgcat::mc "Altitude:"] \
+			   area        [::msgcat::mc "Area:"] \
+			   bearing     [::msgcat::mc "Bearing:"] \
+			   building    [::msgcat::mc "Building:"] \
+			   country     [::msgcat::mc "Country:"] \
+			   datum       [::msgcat::mc "Datum:"] \
+			   description [::msgcat::mc "Description:"] \
+			   error       [::msgcat::mc "Error:"] \
+			   floor       [::msgcat::mc "Floor:"] \
+			   lat         [::msgcat::mc "Latitude:"] \
+			   locality    [::msgcat::mc "Locality:"] \
+			   lon         [::msgcat::mc "Longitude:"] \
+			   postalcode  [::msgcat::mc "Postalcode:"] \
+			   region      [::msgcat::mc "Region:"] \
+			   room        [::msgcat::mc "Room:"] \
+			   speed       [::msgcat::mc "Speed:"] \
+			   street      [::msgcat::mc "Street:"] \
+			   text        [::msgcat::mc "Text:"] \
+			   timestamp   [::msgcat::mc "Timestamp:"] \
+			   uri         [::msgcat::mc "URI:"]]
+}
+
+proc geoloc::register_in_disco {args} {
+    variable options
+    variable node
+
+    if {$options(auto-subscribe)} {
+       disco::register_feature $node+notify
+    } else {
+       disco::unregister_feature $node+notify
+    }
+}
+
+proc geoloc::add_roster_pep_menu_item {m connid jid} {
+    set rjid [roster::find_jid $connid $jid]
+
+    if {$rjid == ""} {
+ 	set rjid [node_and_server_from_jid $jid]
+    }
+
+    set pm [pep::get_roster_menu_pep_submenu $m $connid $rjid]
+
+    set mm [menu $pm.geoloc -tearoff no]
+    $pm add cascade -menu $mm \
+	    -label [::msgcat::mc "User location"]
+
+    $mm add command \
+	    -label [::msgcat::mc "Subscribe"] \
+	    -command [list [namespace current]::subscribe $connid $rjid]
+    $mm add command \
+	    -label [::msgcat::mc "Unsubscribe"] \
+	    -command [list [namespace current]::unsubscribe $connid $rjid]
+
+    hook::run roster_pep_user_geoloc_menu_hook $mm $connid $rjid
+}
+
+proc geoloc::subscribe {connid jid args} {
+    variable node
+    variable substatus
+
+    set to [node_and_server_from_jid $jid]
+    set cmd [linsert $args 0 [namespace current]::subscribe_result $connid $to]
+    pep::subscribe $to $node \
+	    -connection $connid \
+	    -command $cmd
+    set substatus($connid,$to) sent-subscribe
+}
+
+proc geoloc::unsubscribe {connid jid args} {
+    variable node
+    variable substatus
+
+    set to [node_and_server_from_jid $jid]
+    set cmd [linsert $args 0 [namespace current]::unsubscribe_result $connid $to]
+    pep::unsubscribe $to $node \
+	    -connection $connid \
+	    -command $cmd
+    set substatus($connid,$to) sent-unsubscribe
+}
+
+# Err may be one of: OK, ERR and DISCONNECT
+proc geoloc::subscribe_result {connid jid res child args} {
+    variable substatus
+
+    set cmd ""
+    foreach {opt val} $args {
+	switch -- $opt {
+	    -command {
+		set cmd $val
+	    }
+	    default {
+		return -code error "unknown option: $opt"
+	    }
+	}
+    }
+
+    switch -- $res {
+	OK {
+	    set substatus($connid,$jid) from
+	}
+	ERR {
+	    set substatus($connid,$jid) error
+	}
+	default {
+	    return
+	}
+    }
+
+    if {$cmd != ""} {
+	lappend cmd $jid $res $child
+	eval $cmd
+    }
+}
+
+proc geoloc::unsubscribe_result {connid jid res child args} {
+    variable substatus
+    variable geoloc
+    variable fields
+
+    set cmd ""
+    foreach {opt val} $args {
+	switch -- $opt {
+	    -command {
+		set cmd $val
+	    }
+	    default {
+		return -code error "unknown option: $opt"
+	    }
+	}
+    }
+    
+    if {[string equal $res OK]} {
+	set substatus($connid,$jid) none
+	foreach f $fields {
+	    catch {unset geoloc($f,$connid,$jid)}
+	}
+    }
+
+    if {$cmd != ""} {
+	lappend cmd $jid $res $child
+	eval $cmd
+    }
+}
+
+proc geoloc::provide_roster_popup_info {var connid user} {
+    variable substatus
+    variable geoloc
+
+    upvar 0 $var info
+
+    set jid [node_and_server_from_jid $user]
+
+    if {[info exists geoloc(title,$connid,$jid)]} {
+	append info [::msgcat::mc "\n\tLocation: %s : %s" \
+				  $geoloc(lat,$connid,$jid) \
+				  $geoloc(lon,$connid,$jid)]
+    } elseif {[info exists substatus($connid,$jid)]} {
+	append info [::msgcat::mc "\n\tUser's location subscription: %s" \
+				  $substatus($connid,$jid)]
+    } else {
+	return
+    }
+
+}
+
+proc geoloc::process_geoloc_notification {connid jid items} {
+    variable node
+    variable geoloc
+    variable fields
+
+    foreach f $fields {
+	set $f ""
+    }
+    set retract false
+    set parsed  false
+
+    foreach item $items {
+	jlib::wrapper:splitxml $item tag vars isempty chdata children
+
+	switch -- $tag {
+	    retract {
+		set retract true
+	    }
+	    default {
+		foreach igeoloc $children {
+		    jlib::wrapper:splitxml $igeoloc tag1 vars1 isempty1 chdata1 children1
+
+		    if {![string equal $tag1 geoloc]} continue
+		    set xmlns [jlib::wrapper:getattr $vars1 xmlns]
+		    if {![string equal $xmlns $node]} continue
+
+		    set parsed true
+
+		    foreach i $children1 {
+			jlib::wrapper:splitxml $i tag2 vars2 isempty2 chdata2 children2
+
+			if {[lsearch -exact $fields $tag2] >= 0} {
+			    set $tag2 $chdata2
+			}
+		    }
+		}
+	    }
+	}
+    }
+
+    if {$parsed} {
+	foreach f $fields {
+	    set geoloc($f,$connid,$jid) [set $f]
+	}
+	hook::run user_geoloc_notification_hook $connid $jid $lat $lon
+    } elseif {$retract} {
+	foreach f $fields {
+	    catch {unset geoloc($f,$connid,$jid)}
+	}
+	hook::run user_geoloc_notification_hook $connid $jid "" ""
+    }
+}
+
+proc geoloc::notify_via_status_message {connid jid lat lon} {
+    set contact [::roster::itemconfig $connid $jid -name]
+    if {$contact == ""} {
+	set contact $jid
+    }
+
+    if {$lat == "" && $lon == ""} {
+	set msg [::msgcat::mc "%s's location is unset" $contact]
+    } else {
+	set msg [::msgcat::mc "%s's location changed to %s : %s" \
+			      $contact $lat $lon]
+    }
+
+    set_status $msg
+}
+
+proc geoloc::publish {connid args} {
+    variable node
+    variable fields
+
+    foreach f $fields {
+	set $f ""
+    }
+    set callback ""
+    foreach {opt val} $args {
+	switch -- $opt {
+	    -command { set callback $val }
+	    default {
+		set opt [string trimleft $opt -]
+		if {[lsearch -exact $fields $opt] >= 0} {
+		    set $opt $val
+		}
+	    }
+	}
+    }
+
+    set content {}
+    foreach f $fields {
+	if {[set $f] != ""} {
+	    lappend content [jlib::wrapper:createtag $f -chdata [set $f]]
+	}
+    }
+
+    set cmd [list pep::publish_item $node geoloc \
+		  -connection $connid \
+		  -payload [list [jlib::wrapper:createtag geoloc \
+				      -vars [list xmlns $node] \
+				      -subtags $content]]]
+
+    if {$callback != ""} {
+	lappend cmd -command $callback
+    }
+
+    eval $cmd
+}
+
+proc geoloc::unpublish {connid args} {
+    variable node
+
+    set callback ""
+    foreach {opt val} $args {
+	switch -- $opt {
+	    -command { set callback $val }
+	}
+    }
+
+    set cmd [list pep::delete_item $node geoloc \
+		  -notify true \
+		  -connection $connid]
+
+    if {$callback != ""} {
+	lappend cmd -command $callback
+    }
+
+    eval $cmd
+}
+
+proc geoloc::on_init {} {
+    set m [pep::get_main_menu_pep_submenu]
+    set mm [menu $m.geoloc -tearoff $::ifacetk::options(show_tearoffs)]
+    $m add cascade -menu $mm \
+	   -label [::msgcat::mc "User location"]
+    $mm add command -label [::msgcat::mc "Publish user location"] \
+	    -command [namespace current]::show_publish_dialog
+    $mm add command -label [::msgcat::mc "Unpublish user location"] \
+	    -command [namespace current]::show_unpublish_dialog
+    $mm add checkbutton -label [::msgcat::mc "Auto-subscribe to other's user location"] \
+	    -variable [namespace current]::options(auto-subscribe)
+}   
+
+proc geoloc::show_publish_dialog {} {
+    variable fields
+    variable labels
+    variable myjid
+    foreach ff $fields {
+	variable geoloc$ff
+    }
+
+    set w .user_geoloc
+    if {[winfo exists $w]} {
+	destroy $w
+    }
+
+    set connids [jlib::connections]
+    if {[llength $connids] == 0} {
+	tk_messageBox -icon error -title [::msgcat::mc "Error"] \
+		-message [::msgcat::mc "Publishing is only possible\
+					while being online"]
+	return
+    }
+
+    Dialog $w -title [::msgcat::mc "User location"] \
+	    -modal none -separator 1 -anchor e -default 0 -cancel 1 -parent .
+    $w add -text [::msgcat::mc "Publish"] \
+	   -command [list [namespace current]::do_publish $w]
+    $w add -text [::msgcat::mc "Cancel"] -command [list destroy $w]
+
+    set f [$w getframe]
+
+    set connjids [list [::msgcat::mc "All"]]
+    foreach connid $connids {
+	lappend connjids [jlib::connection_jid $connid]
+    }
+    set myjid [lindex $connjids 0]
+
+    label $f.ccap -text [::msgcat::mc "Use connection:"]
+    ComboBox $f.conn -editable false \
+	    -values $connjids \
+	    -textvariable [namespace current]::myjid
+    if {[llength $connjids] > 1} {
+	grid $f.ccap   -row 0 -column 0 -sticky e
+	grid $f.conn   -row 0 -column 1 -sticky ew
+    }
+
+    set row 1
+    foreach ff $fields {
+	label $f.l$ff -text $labels($ff)
+	entry $f.$ff -textvariable [namespace current]::geoloc$ff
+	grid $f.l$ff  -row $row -column 0 -sticky e
+	grid $f.$ff   -row $row -column 1 -sticky ew
+	incr row
+    }
+
+    grid columnconfigure $f 1 -weight 1
+
+    $w draw
+}
+
+proc geoloc::do_publish {w} {
+    variable fields
+    variable myjid
+    foreach ff $fields {
+	variable geoloc$ff
+    }
+
+    set args {}
+    foreach ff $fields {
+	lappend args -$ff [set geoloc$ff]
+    }
+
+    foreach connid [jlib::connections] {
+	if {[string equal $myjid [jlib::connection_jid $connid]] || \
+		[string equal $myjid [::msgcat::mc "All"]]} {
+	    eval [list publish $connid \
+		       -command [namespace current]::publish_result] \
+		       $args
+	    break
+	}
+    }
+
+    foreach ff $fields {
+	unset geoloc$ff
+    }
+    unset myjid
+    destroy $w
+}
+
+# $res is one of: OK, ERR, DISCONNECT
+proc geoloc::publish_result {res child} {
+    switch -- $res {
+	ERR {
+	    set error [error_to_string $child]
+	}
+	default {
+	    return
+	}
+    }
+
+    tk_messageBox -icon error -title [::msgcat::mc "Error"] \
+	-message [::msgcat::mc "User location publishing failed: %s" $error]
+}
+
+proc geoloc::show_unpublish_dialog {} {
+    variable myjid
+
+    set w .user_geoloc
+    if {[winfo exists $w]} {
+	destroy $w
+    }
+
+    set connids [jlib::connections]
+    if {[llength $connids] == 0} {
+	tk_messageBox -icon error -title [::msgcat::mc "Error"] \
+		-message [::msgcat::mc "Unpublishing is only possible\
+					while being online"]
+	return
+    }
+
+    Dialog $w -title [::msgcat::mc "User location"] \
+	    -modal none -separator 1 -anchor e -default 0 -cancel 1 -parent .
+    $w add -text [::msgcat::mc "Unpublish"] \
+	   -command [list [namespace current]::do_unpublish $w]
+    $w add -text [::msgcat::mc "Cancel"] -command [list destroy $w]
+
+    set f [$w getframe]
+
+    set connjids [list [::msgcat::mc "All"]]
+    foreach connid $connids {
+	lappend connjids [jlib::connection_jid $connid]
+    }
+    set myjid [lindex $connjids 0]
+
+    label $f.ccap -text [::msgcat::mc "Use connection:"]
+    ComboBox $f.conn -editable false \
+	    -values $connjids \
+	    -textvariable [namespace current]::myjid
+
+    if {[llength $connjids] > 1} {
+	grid $f.ccap   -row 0 -column 0 -sticky e
+	grid $f.conn   -row 0 -column 1 -sticky ew
+    }
+
+    grid columnconfigure $f 1 -weight 1
+
+    if {[llength $connids] == 1} {
+	do_unpublish $w
+    } else {
+	$w draw
+    }
+}
+
+proc geoloc::do_unpublish {w} {
+    variable myjid
+
+    foreach connid [jlib::connections] {
+	if {[string equal $myjid [jlib::connection_jid $connid]] || \
+		[string equal $myjid [::msgcat::mc "All"]]} {
+	    unpublish $connid \
+		    -command [namespace current]::unpublish_result
+	    break
+	}
+    }
+
+    unset myjid
+    destroy $w
+}
+
+# $res is one of: OK, ERR, DISCONNECT
+proc geoloc::unpublish_result {res child} {
+    switch -- $res {
+	ERR {
+	    set error [error_to_string $child]
+	}
+	default {
+	    return
+	}
+    }
+
+    tk_messageBox -icon error -title [::msgcat::mc "Error"] \
+	-message [::msgcat::mc "User location unpublishing failed: %s" $error]
+}
+
+proc geoloc::provide_userinfo {notebook connid jid editable} {
+    variable geoloc
+    variable m2d
+    variable ::userinfo::userinfo
+    variable fields
+    variable labels
+
+    if {$editable} return
+
+    set barejid [node_and_server_from_jid $jid]
+    if {![info exists geoloc(alt,$connid,$barejid)]} return
+
+    foreach ff $fields {
+	set userinfo(geoloc$ff,$jid) $geoloc($ff,$connid,$barejid)
+    }
+
+    set f [pep::get_userinfo_dialog_pep_frame $notebook]
+    set mf [userinfo::pack_frame $f.geoloc [::msgcat::mc "User location"]]
+
+    set row 0
+    foreach ff $fields {
+	userinfo::pack_entry $jid $mf $row geoloc$ff $labels($ff)
+	incr row
+    }
+}
+
+# vim:ts=8:sw=4:sts=4:noet

Modified: trunk/tkabber/privacy.tcl
===================================================================
--- trunk/tkabber/privacy.tcl	2008-03-06 11:03:59 UTC (rev 1384)
+++ trunk/tkabber/privacy.tcl	2008-03-06 19:14:22 UTC (rev 1385)
@@ -5,6 +5,7 @@
 
 namespace eval privacy {
     variable options
+    variable seq 0
 
     array set req_messages \
 	[list ignore     [::msgcat::mc "Requesting ignore list: %s"] \
@@ -825,6 +826,7 @@
 }
 
 proc privacy::send_special_list {connid name items} {
+    variable seq
     variable special_list
     variable cboxes
 
@@ -892,13 +894,14 @@
 	incr i
     }
 
+    set s [incr seq]
     send_list_iq "$name-list" $items1 \
-	-command [list [namespace current]::get_answer $connid]\
+	-command [list [namespace current]::get_answer $s] \
 	-connection $connid
 
     # We have to vwait because all privacy lists should be updated
     # before sending next stanzas
-    lassign [wait_for_answer $connid] res child
+    lassign [wait_for_answer $s] res child
 
     update_tkabber_lists $connid $name $items $postitems $res $child
 }
@@ -906,6 +909,7 @@
 # subscription-list is responsible for blocking all messages
 # not from the roster.
 proc privacy::send_subscription_list {connid} {
+    variable seq
     variable accept_from_roster_only
 
     if {![is_supported $connid]} {
@@ -922,15 +926,16 @@
 	set items {}
     }
 
+    set s [incr seq]
     # If items aren't empty, we'll never send unavailable presence to
     # all users to whom directed presence was sent. Bug?
     send_list_iq "subscription-list" $items \
-	-command [list [namespace current]::get_answer $connid] \
+	-command [list [namespace current]::get_answer $s] \
 	-connection $connid
 
     # We have to vwait because all privacy lists should be updated
     # before sending next stanzas
-    lassign [wait_for_answer $connid] res child
+    lassign [wait_for_answer $s] res child
 
     update_tkabber_lists $connid subscription $items {} $res $child
 }
@@ -1172,15 +1177,18 @@
 #
 
 proc privacy::activate_privacy_list {depth connid} {
+    variable seq
     variable options
 
     set_status [::msgcat::mc "Waiting for activating privacy list"]
     debugmsg privacy "requested privacy list activation"
+
+    set s [incr seq]
     send_default_or_active_list "i-am-visible-list" active \
-	-command [list [namespace current]::get_answer $connid] \
+	-command [list [namespace current]::get_answer $s] \
 	-connection $connid
 
-    lassign [wait_for_answer $connid] res child
+    lassign [wait_for_answer $s] res child
 
     switch -- $res {
 	"OK" {
@@ -1214,12 +1222,13 @@
 		    set_status \
 			[::msgcat::mc "Creating default privacy list"]
 
+		    set s [incr seq]
 		    join_lists $connid "i-am-visible-list" \
 			{ignore-list invisible-list conference-list subscription-list} \
 			{allow {} {}} \
-			-command [list [namespace current]::get_answer $connid]
+			-command [list [namespace current]::get_answer $s]
 
-		    lassign [wait_for_answer $connid] res child
+		    lassign [wait_for_answer $s] res child
 
 		    switch -- $res {
 			"OK" {
@@ -1308,19 +1317,19 @@
 
 ##########################################################################
 
-proc privacy::get_answer {connid res child} {
+proc privacy::get_answer {seq res child} {
     variable answer
-    debugmsg privacy "got privacy list answer $connid $res $child"
+    debugmsg privacy "got privacy list answer $seq $res $child"
 
-    set answer($connid) [list $res $child]
+    set answer($seq) [list $res $child]
 }
 
-proc privacy::wait_for_answer {connid} {
+proc privacy::wait_for_answer {seq} {
     variable answer
 
-    vwait [namespace current]::answer($connid)
-    set res $answer($connid)
-    unset answer($connid)
+    vwait [namespace current]::answer($seq)
+    set res $answer($seq)
+    unset answer($seq)
     return $res
 }
 
@@ -1510,15 +1519,18 @@
 # Conference list should be loaded before any join group attempt is made
 
 proc privacy::get_conference_list {connid} {
+    variable seq
+
+    set s [incr seq]
     jlib::send_iq get \
 	[jlib::wrapper:createtag query \
 	     -vars [list xmlns $::NS(privacy)] \
 	     -subtags [list [jlib::wrapper:createtag list \
 				 -vars [list name "conference-list"]]]] \
-	-command [list [namespace current]::get_answer $connid] \
+	-command [list [namespace current]::get_answer $s] \
 	-connection $connid
 
-    lassign [wait_for_answer $connid] res child
+    lassign [wait_for_answer $s] res child
 
     if {($res == "OK") || \
 	    ($res == "ERR" && \



More information about the Tkabber-dev mailing list