[Tkabber-dev] r720 - in trunk/tkabber: . pixmaps/default pixmaps/default/tkabber plugins/general plugins/iq

tkabber-svn at jabber.ru tkabber-svn at jabber.ru
Sun Sep 17 23:58:56 MSD 2006


Author: sergei
Date: 2006-09-17 23:58:46 +0400 (Sun, 17 Sep 2006)
New Revision: 720

Added:
   trunk/tkabber/pixmaps/default/tkabber/xaddress.gif
   trunk/tkabber/plugins/general/remote.tcl
   trunk/tkabber/plugins/general/xaddress.tcl
Modified:
   trunk/tkabber/ChangeLog
   trunk/tkabber/datagathering.tcl
   trunk/tkabber/disco.tcl
   trunk/tkabber/pixmaps/default/icondef.xml
   trunk/tkabber/plugins/iq/version.tcl
Log:
	* plugins/iq/version.tcl: Added code for reporting Arch Linux
	  version (thanks to Pavel Borzenkov).

	* datagathering.tcl: Added server-side x:data processing routine
	  which creates x:data field tag (thanks to Artem Borodin).

	* disco.tcl: Added subnodes registering (second level nodes only,
	  tnaks to Artem Borodin).

	* plugins/general/xaddress.tcl, pixmaps/default/icondef.xml,
	  pixmaps/default/tkabber/xaddress.gif: Implemented Extended Stanza
	  Addressing (JEP-0033, thanks to Artem Borodin).

	* plugins/general/remote.tcl: Implemented Remote Controlling
	  Clients (JEP-0146) via Ad-hoc commands. Includes status
	  change, messages forwarding, and leaving conference rooms (thanks
	  to Artem Borodin).


Modified: trunk/tkabber/ChangeLog
===================================================================
--- trunk/tkabber/ChangeLog	2006-09-16 20:18:40 UTC (rev 719)
+++ trunk/tkabber/ChangeLog	2006-09-17 19:58:46 UTC (rev 720)
@@ -1,3 +1,23 @@
+2006-09-17  Sergei Golovan  <sgolovan at nes.ru>
+
+	* plugins/iq/version.tcl: Added code for reporting Arch Linux
+	  version (thanks to Pavel Borzenkov).
+
+	* datagathering.tcl: Added server-side x:data processing routine
+	  which creates x:data field tag (thanks to Artem Borodin).
+
+	* disco.tcl: Added subnodes registering (second level nodes only,
+	  tnaks to Artem Borodin).
+
+	* plugins/general/xaddress.tcl, pixmaps/default/icondef.xml,
+	  pixmaps/default/tkabber/xaddress.gif: Implemented Extended Stanza
+	  Addressing (JEP-0033, thanks to Artem Borodin).
+
+	* plugins/general/remote.tcl: Implemented Remote Controlling
+	  Clients (JEP-0146) via Ad-hoc commands. Includes status
+	  change, messages forwarding, and leaving conference rooms (thanks
+	  to Artem Borodin).
+
 2006-09-16  Sergei Golovan  <sgolovan at nes.ru>
 
 	* jabberlib-tclxml/jabberlib.tcl, jabberlib-tclxml/pkgIndex.tcl,

Modified: trunk/tkabber/datagathering.tcl
===================================================================
--- trunk/tkabber/datagathering.tcl	2006-09-16 20:18:40 UTC (rev 719)
+++ trunk/tkabber/datagathering.tcl	2006-09-17 19:58:46 UTC (rev 720)
@@ -141,6 +141,94 @@
 # x:data processing
 ###############################################################################
 
+# create field tag
+
+proc ::data::createfieldtag {type args}  {
+    array set params $args
+
+    switch -- $type {
+	instructions -
+	title {
+	    if {[info exists params(-value)]} {
+		return [jlib::wrapper:createtag $type \
+			    -chdata $params(-value)]
+	    } else {
+		error "You must define -value"
+	    }
+	}
+
+	fixed - 
+	hidden -
+	list-single -
+	list-multi -
+	text-single - 
+	text-multi -
+	text-private -
+	jid-multi -
+	jid-single -
+	boolean {
+	    set vars [list type $type]
+	    if {[info exists params(-var)]} {
+		lappend vars var $params(-var)
+	    } elseif {![cequal $type fixed]} {
+		error "You must define -var"
+	    }
+	    if {[info exists params(-label)]} {
+		lappend vars label $params(-label)
+	    }
+
+	    set subtags  {}
+	    if {[info exists params(-descr)]} {
+		lappend subtags [jlib::wrapper:createtag descr \
+				     -chdata $params(-descr)]
+	    }
+	    if {[info exists params(-required)] && $params(-required)} {
+		lappend subtags [jlib::wrapper:createtag required]
+	    }
+	    if {[lcontain {jid-multi text-multi hidden fixed} $type]} {
+		if {[info exists params(-values)]} {
+		    foreach value $params(-values) {
+			lappend subtags [jlib::wrapper:createtag value \
+					     -chdata $value]
+		    }
+		} else {
+		    error "You must define -values"
+		}
+	    } else {
+		if {[info exists params(-value)]} {
+		    lappend subtags [jlib::wrapper:createtag value \
+					 -chdata $params(-value)]
+		}
+		
+		if {[lcontain {list-multi list-single} $type]} {
+		    if {[info exists params(-options)]} {
+			foreach option $params(-options) {
+			    lassign $option name label
+			    lappend subtags \
+				    [jlib::wrapper:createtag option \
+					 -vars [list label $label] \
+					 -subtags \
+					     [list [jlib::wrapper:createtag value \
+							-chdata $name]]]
+			}
+		    } else {
+			error "You must define -options"
+		    }
+		}
+	    }
+	    
+	    return [jlib::wrapper:createtag field \
+			-vars $vars \
+			-subtags $subtags]	    
+	}
+	
+	default {
+	    error "Unknown type $type"
+	}
+    }   
+}
+
+# parse_result
 proc data::parse_xdata_results {items args} {
     set report_hidden 0
     foreach {key val} $args {
@@ -172,9 +260,7 @@
 		set value $chdata1
 	    }
 	}
-	if {$value != ""} {
-	    lappend result [list $var $label $value]
-	}
+	lappend result [list $var $label $value]
     }
     return $result
 }

Modified: trunk/tkabber/disco.tcl
===================================================================
--- trunk/tkabber/disco.tcl	2006-09-16 20:18:40 UTC (rev 719)
+++ trunk/tkabber/disco.tcl	2006-09-17 19:58:46 UTC (rev 720)
@@ -11,6 +11,7 @@
 namespace eval disco {
     variable supported_nodes
     variable supported_features {}
+    variable root_nodes {}
 }
 
 proc disco::request_items {jid node args} {
@@ -293,6 +294,7 @@
 proc disco::items_query_get_handler {connid from child} {
     variable supported_nodes
     variable node_handlers
+    variable root_nodes
 
     jlib::wrapper:splitxml $child tag vars isempty chdata children
     set node [jlib::wrapper:getattr $vars node]
@@ -321,7 +323,7 @@
 	    set myjid [jlib::connection_jid $connid]
 	}
 
-	foreach node [array names supported_nodes] {
+	foreach node $root_nodes {
 	    set vars [list jid $myjid]
 	    if {![cequal $supported_nodes($node) ""]} {
 		lappend vars name $supported_nodes($node)
@@ -356,6 +358,15 @@
 ###############################################################################
 
 proc disco::register_node {node handler {name ""}} {
+    variable root_nodes
+
+    lappend root_nodes $node
+    register_subnode $node $handler $name
+}
+
+###############################################################################
+
+proc disco::register_subnode {node handler {name ""}} {
     variable supported_nodes
     variable node_handlers
 

Modified: trunk/tkabber/pixmaps/default/icondef.xml
===================================================================
--- trunk/tkabber/pixmaps/default/icondef.xml	2006-09-16 20:18:40 UTC (rev 719)
+++ trunk/tkabber/pixmaps/default/icondef.xml	2006-09-17 19:58:46 UTC (rev 720)
@@ -438,5 +438,10 @@
     <image xmlns='tkimage'>chat/bookmark</image>
     <object mime="image/gif">tkabber/chat-bookmark.gif</object>
   </icon>
+  <!-- Extended address icon -->
+  <icon>
+    <image xmlns='tkimage'>xaddress/info</image>
+    <object mime="image/gif">tkabber/xaddress.gif</object>
+  </icon>
 </icondef>
 

Added: trunk/tkabber/pixmaps/default/tkabber/xaddress.gif
===================================================================
(Binary files differ)


Property changes on: trunk/tkabber/pixmaps/default/tkabber/xaddress.gif
___________________________________________________________________
Name: svn:mime-type
   + application/octet-stream

Added: trunk/tkabber/plugins/general/remote.tcl
===================================================================
--- trunk/tkabber/plugins/general/remote.tcl	                        (rev 0)
+++ trunk/tkabber/plugins/general/remote.tcl	2006-09-17 19:58:46 UTC (rev 720)
@@ -0,0 +1,866 @@
+# $Id$
+# Implementation of JEP-146 (Remote Controlling Clients) for Tkabber.
+# http://www.jabber.org/jeps/jep-0146.html
+# http://www.jabber.org/jeps/jep-0050.html
+
+namespace eval ::remote {
+    array set commands {}
+    array set sessions {}
+
+    custom::defgroup {Remote Control} \
+	[::msgcat::mc "Remote control options"] -group Tkabber
+
+    custom::defvar options(enable) 1 \
+	[::msgcat::mc "Enable remote control."] \
+	-type boolean -group {Remote Control}
+
+    custom::defvar options(accept_from_myjid) 1 \
+	[::msgcat::mc "Accept connections from my own JID."] \
+	-type boolean -group {Remote Control}
+
+    custom::defvar options(accept_list) "" \
+	[::msgcat::mc "Accept connections from the listed JIDs."] \
+	-type string -group {Remote Control}
+
+    custom::defvar options(show_my_resources) 1 \
+	[::msgcat::mc "Show my own resources in the roster."] \
+	-type boolean -group {Remote Control}
+}
+
+############################################
+
+proc ::remote::allow_remote_control {connid from} {
+    variable options
+
+    if {!$options(enable)} {
+	return 0
+    }
+
+    set from [string tolower $from]
+    set myjid [string tolower \
+		      [node_and_server_from_jid \
+			   [jlib::connection_jid $connid]]]
+    set bare_from [string tolower [node_and_server_from_jid $from]]
+
+    if {$options(accept_from_myjid) && [cequal $myjid $bare_from]} {
+	return 1
+    }
+
+    set accept_list [split [string tolower $options(accept_list)] " "]
+    if {$bare_from != "" && [lsearch -exact $accept_list $bare_from] >= 0} {
+	return 1
+    }
+
+    return 0
+}
+
+############################################
+# Register and announce commands via disco
+
+proc ::remote::register_command {node command name args} {
+    variable commands
+      
+    set commands(command,$node) $command
+    set commands(name,$node) $name
+    lappend commands(nodes) $node
+
+    ::disco::register_subnode $node \
+	[namespace current]::common_command_infoitems_handler $name
+}
+
+proc ::remote::common_command_infoitems_handler {type connid from xmllist} {
+    variable commands
+
+    if {![allow_remote_control $connid $from]} {
+	return {error auth forbidden}
+    }
+
+    jlib::wrapper:splitxml $xmllist tag vars isempty chdata children
+    set node [jlib::wrapper:getattr $vars node]
+
+    if {![cequal $node ""] && [info exists commands(command,$node)]} {
+	if {[cequal $type info]} {
+	    return \
+		[list [jlib::wrapper:createtag identity \
+			   -vars [list category automation \
+				       type command-node \
+				       name $commands(name,$node)]] \
+		      [jlib::wrapper:createtag feature \
+			   -vars [list var $::NS(commands)]]]
+	} else {
+	    return {}
+	}
+    } else { 
+	return {error modify bad-request} 
+    }
+}
+
+proc ::remote::commands_list_handler {type connid from xmllist} {
+    variable commands
+
+    if {![allow_remote_control $connid $from]} {
+	return {error auth forbidden}
+    }
+
+    set myjid [jlib::connection_jid $connid]
+    
+    switch -- $type {
+	items {
+	    set items {}	    
+	    foreach node $commands(nodes) {
+		lappend items [jlib::wrapper:createtag item \
+				   -vars [list jid $myjid \
+					       node $node \
+					       name $commands(name,$node)]]
+	    }
+	    return $items
+	}
+	info {
+	    return [list [jlib::wrapper:createtag identity \
+			      -vars [list category automation \
+					  type command-list \
+					  name "Remote control"]]]
+	}
+    }
+    return {} 
+}
+
+::disco::register_feature $::NS(commands) {return ""}
+::disco::register_node $::NS(commands) \
+		       ::remote::commands_list_handler "Remote control"
+
+#######################################
+# Base engine.
+
+proc ::remote::clear_session {sid node} {
+    variable commands 
+    variable sessions 
+
+    if {![info exists commands(command,$node)]} return
+    
+    $commands(command,$node) $sid cancel {} 
+
+    catch {unset sessions(node,$sid)}
+    catch {unset sessions(connid,$sid)}
+    catch {unset sessions(from,$sid)}	                
+}
+
+proc ::remote::create_session {node connid from} {
+    variable commands    
+    variable sessions
+    
+    if {![info exists commands(command,$node)]} return
+    
+    set cur_time [clock seconds]
+    set rnd [random 1000]
+
+    while {[info exists sessions(node,"$cur_time-$rnd")]} {
+	set cur_time [clock seconds]
+	set rnd [random 1000]
+    }
+    
+    set sid "$cur_time-$rnd"
+
+    set sessions(node,$sid) $node
+    set sessions(connid,$sid) $connid
+    set sessions(from,$sid) $from
+
+    return $sid
+}
+
+proc ::remote::command_set_handler {connid from child} {   
+    variable commands    
+    variable sessions
+
+    if {![allow_remote_control $connid $from]} {
+	return {error auth forbidden}
+    }
+
+    jlib::wrapper:splitxml $child tag vars isempty chdata children
+
+    set node [jlib::wrapper:getattr $vars node] 
+    set action [jlib::wrapper:getattr $vars action] 
+    set sid [jlib::wrapper:getattr $vars sessionid] 
+
+    if {![info exists commands(command,$node)]} { 
+	return {error cancel item-not-found}
+    }
+       
+    if {[cequal $sid ""]} {
+	set sid [create_session $node $connid $from]
+    } else {
+	if { ![info exists sessions(node,$sid)] } {
+	    return [list error cancel bad-request \
+			 -application-specific \
+			     [jlib::wrapper:createtag session-expired \
+				  -vars [list xmlns $::NS(commands)]]]
+	}
+
+	if {![cequal $sessions(node,$sid) $node] || \
+	    ![cequal $sessions(connid,$sid) $connid] || \
+	    ![cequal $sessions(from,$sid) $from]} {
+	    return [list error cancel bad-request \
+			 -application-specific \
+			     [jlib::wrapper:createtag bad-sessionid \
+				  -vars [list xmlns $::NS(commands)]]]
+	}
+    } 
+
+    if {[cequal $action cancel]} {
+	clear_session $sid $node
+	return [list result [jlib::wrapper:createtag command \
+				 -vars [list xmlns $::NS(commands) \
+					     sessionid $sid \
+					     node $node \
+					     status canceled]]]
+    }
+
+    set result [$commands(command,$node) $sid $action $children]
+    
+    set status [lindex $result 0]
+    switch -- $status {
+	error { 
+	    clear_session $sid $node
+	    return $result
+	}
+	completed {
+	    clear_session $sid $node
+	}
+	executing {}
+	default {
+	    clear_session $sid $node
+	    return {error wait internal-server-error}
+	}
+    }            
+
+    return [list result [jlib::wrapper:createtag command \
+			     -vars [list xmlns $::NS(commands) \
+					 sessionid $sid \
+					 node $node \
+					 status $status] \
+			     -subtags [lrange $result 1 end]]]
+} 
+iq::register_handler set command $::NS(commands) ::remote::command_set_handler
+
+# ##########################################
+# Common functions for command implementations. 
+
+# Scheduler for one-step dialogs and wizards
+proc ::remote::standart_scheduler {steps prefix sid action children} {
+    variable sessions
+     
+    if {[cequal $action cancel]} {
+	catch { unset sessions($prefix,step,$sid) }
+	for {set i 1} {$i <= $steps} {incr i} {
+	    $prefix:clear_step$i $sid
+	}
+	return
+    }
+
+    if {![info exists sessions($prefix,step,$sid)] } {
+	# First step
+
+	if {![cequal $action execute] && ![cequal $action ""]} {
+	    return [list error cancel bad-request \
+			 -application-specific \
+			     [jlib::wrapper:createtag bad-action \
+				  -vars [list xmlns $::NS(commands)]]]
+	}
+
+	set sessions($prefix,step,$sid) 1
+	return [$prefix:get_step$sessions($prefix,step,$sid) $sid]
+	
+    } elseif {$sessions($prefix,step,$sid) < $steps} {
+	# Inner step
+
+	if {![cequal $action execute] && ![cequal $action ""]} {
+	    return [list error cancel bad-request \
+			 -application-specific \
+			     [jlib::wrapper:createtag bad-action \
+				  -vars [list xmlns $::NS(commands)]]]
+	}
+	
+	set res [$prefix:set_step$sessions($prefix,step,$sid) $sid $children]
+	if {[cequal [lindex $res 0] error]} {
+	    return $res
+	}
+	
+	incr sessions($prefix,step,$sid) 	
+	return [$prefix:get_step$sessions($prefix,step,$sid) $sid]
+	
+    } else {
+	# Last step
+	if {![cequal $action complete] && ![cequal $action ""]} {	    
+	    return [list error cancel bad-request \
+			 -application-specific \
+			     [jlib::wrapper:createtag bad-action \
+				  -vars [list xmlns $::NS(commands)]]]
+	}
+	
+	set res [$prefix:set_step$sessions($prefix,step,$sid) $sid $children]
+	if {[cequal [lindex $res 0] error]} {
+	    return $res
+	}
+	
+	return [$prefix:get_finish $sid]
+    }
+}
+
+# Parses form result and returns array with values, check for correct form type
+proc ::remote::standart_parseresult {children_b form_type} {
+    set result {}
+    foreach child $children_b {
+	jlib::wrapper:splitxml $child tag vars isempty chdata children
+
+	set xmlns  [jlib::wrapper:getattr $vars xmlns]
+	set type  [jlib::wrapper:getattr $vars type]
+	if {![cequal $tag x] || ![cequal $xmlns $::NS(data)]} {
+	    continue
+	}
+	if {![cequal $type submit]} {
+	    return [list error cancel bad-request \
+			 -application-specific \
+			     [jlib::wrapper:createtag bad-payload \
+				  -vars [list xmlns $::NS(commands)]]]
+	}
+	
+	foreach field [::data::parse_xdata_results $children -hidden 1] {
+	    lassign $field var label value
+	    if {[cequal $var FORM_TYPE]} {
+		if {![cequal $value $form_type]} {
+		    return [list error cancel bad-request \
+				 -application-specific \
+				     [jlib::wrapper:createtag bad-payload \
+					  -vars [list xmlns $::NS(commands)]]] 
+		}
+	    } else {
+		lappend result $var $value
+	    }
+	}
+    }
+
+    return $result
+}
+
+############################
+#Change status
+proc ::remote::change_status {sid action children} {
+	return [standart_scheduler 1 change_status $sid $action $children]
+}
+::remote::register_command "http://jabber.org/protocol/rc#set-status" \
+			   ::remote::change_status "Change status"
+
+# step1: 
+# send standart form
+proc ::remote::change_status:get_step1 {sid} {
+    global userstatus
+    global textstatus
+    global userpriority
+
+    set fields {}
+
+    lappend fields [data::createfieldtag hidden \
+			-var FORM_TYPE \
+			-values "http://jabber.org/protocol/rc"]
+
+    lappend fields [data::createfieldtag title \
+			-value "Change Status"]
+    lappend fields [data::createfieldtag instructions \
+			-value "Choose the status and status message"]
+    
+    set options {}
+    foreach status {available chat away xa dnd unavailable} {
+	lappend options [list $status $::statusdesc($status)]
+    }
+    lappend fields [data::createfieldtag list-single \
+			-var status \
+			-label "Status" \
+			-required 1 \
+			-value $userstatus \
+			-options $options]
+    lappend fields [data::createfieldtag text-single \
+			-var status-priority \
+			-label "Priority" \
+			-value $userpriority \
+			-required 1]
+    lappend fields [data::createfieldtag text-multi \
+			-var status-message \
+			-label "Message" \
+			-values [split $textstatus "\n"]]
+    
+    return [list executing [jlib::wrapper:createtag x \
+				-vars [list xmlns $::NS(data) \
+					    type form] \
+				-subtags $fields]]
+
+}
+
+proc ::remote::change_status:set_step1 {sid children} {
+    variable sessions
+    
+    set result [remote::standart_parseresult $children \
+					     "http://jabber.org/protocol/rc"]
+
+    if {[cequal [lindex $result 0] error]} {
+	return $result
+    }
+    array set params $result
+    
+    if {![info exists params(status)] || \
+	![info exists params(status-priority)]} {
+	return [list error cancel bad-request \
+		     -application-specific \
+			 [jlib::wrapper:createtag bad-payload \
+			      -vars [list xmlns $::NS(commands)]]]
+    }
+    
+    set sessions(change_status,textstatus,$sid) {}
+    catch {
+	set sessions(change_status,textstatus,$sid) \
+	    [join $params(status-message) "\n"]
+    }
+    set sessions(change_status,userstatus,$sid) \
+	[lindex $params(status) 0]
+    set sessions(change_status,userpriority,$sid) \
+	[lindex $params(status-priority) 0]
+    
+    return {}
+}
+
+proc ::remote::change_status:clear_step1 {sid} {
+    variable sessions 
+    
+    catch { unset sessions(change_status,textstatus,$sid) }
+    catch { unset sessions(change_status,userstatus,$sid) }
+    catch { unset sessions(change_status,userpriority,$sid) }
+}
+
+# finish:
+# change status
+# report
+proc ::remote::change_status:get_finish {sid} {
+    variable sessions
+    global userstatus
+    global textstatus 
+    global userpriority 
+
+    set textstatus $sessions(change_status,textstatus,$sid)
+    set userpriority $sessions(change_status,userpriority,$sid)
+    set userstatus $sessions(change_status,userstatus,$sid)
+
+    return [list completed [jlib::wrapper:createtag note \
+				-vars {type info} \
+				-chdata "Status was changed successfully"]]
+}
+
+
+############################
+# Leave groupchats
+proc ::remote::leave_groupchats {sid action children} {
+    return [standart_scheduler 1 leave_groupchats $sid $action $children]
+}
+::remote::register_command "http://jabber.org/protocol/rc#leave-groupchats" \
+			   ::remote::leave_groupchats "Leave groupchats"
+
+# step1: 
+# allow users to choose which chats to leave
+proc ::remote::leave_groupchats:get_step1 {sid} {
+    variable sessions
+
+    set options {}
+    set connid $sessions(connid,$sid)
+    foreach chatid [chat::opened] {
+	set jid [chat::get_jid $chatid]
+
+	if {![cequal [chat::get_connid $chatid] $connid]} continue
+	if {![chat::is_groupchat $chatid]} continue
+	if {[cequal [get_jid_presence_info show $connid $jid] ""]} continue
+
+	set nick [get_our_groupchat_nick $chatid]
+
+	lappend options [list $jid [format "%s at %s" $nick $jid]]
+    }
+    if {[expr [llength $options] == 0]} {
+	return [list completed [jlib::wrapper:createtag note \
+				    -vars {type info} \
+				    -chdata "No groupchats to leave"]]
+    }
+    
+    set fields {}
+
+    lappend fields [data::createfieldtag hidden \
+			-var FORM_TYPE \
+			-values "http://jabber.org/protocol/rc"]
+    lappend fields [data::createfieldtag title \
+			-value "Leave Groupchats"]
+    lappend fields [data::createfieldtag instructions \
+			-value "Choose the groupchats you want to leave"]
+
+    lappend fields [data::createfieldtag boolean \
+			-var x-all \
+			-label "Leave all groupchats" -value 0]
+    lappend fields [data::createfieldtag list-multi \
+			-var groupchats \
+			-label "Groupchats" \
+			-required 1 \
+			-options $options]
+    lappend fields [data::createfieldtag text-single \
+			-var x-reason \
+			-label "Reason"]
+    
+    return [list executing [jlib::wrapper:createtag x \
+				-vars [list xmlns $::NS(data) \
+					    type form] \
+				-subtags $fields]]
+}
+
+proc ::remote::leave_groupchats:set_step1 {sid children} {
+    variable sessions
+
+    set result [remote::standart_parseresult $children \
+					     "http://jabber.org/protocol/rc"]
+    if {[cequal [lindex $result 0] error]} {
+	return $result
+    }
+    array set params $result
+    
+    if {![info exists params(groupchats)]} {
+	return [list error cancel bad-request \
+		     -application-specific \
+			 [jlib::wrapper:createtag bad-payload \
+			      -vars [list xmlns $::NS(commands)]]]
+    }
+    
+    set sessions(leave_groupchats,all,$sid) $params(all)
+    set sessions(leave_groupchats,groupchats,$sid) $params(groupchats)
+    set sessions(leave_groupchats,reason,$sid) ""
+    catch {
+	set sessions(leave_groupchats,reason,$sid) [lindex $params(reason) 0]
+    }
+    return {}
+
+}
+
+proc ::remote::leave_groupchats:clear_step1 {sid} {
+    catch {unset sessions(leave_groupchats,groupchats,$sid)}
+    catch {unset sessions(leave_groupchats,reason,$sid)}
+    catch {unset sessions(leave_groupchats,all,$sid)}
+}
+
+# finish step 
+# leave groupchats.
+# report 
+proc ::remote::leave_groupchats:get_finish {sid} {
+    variable sessions
+
+    set args [list  -connection $sessions(connid,$sid)]
+
+    if {![cequal $sessions(leave_groupchats,reason,$sid) ""]} {
+	lappend args -stat $sessions(leave_groupchats,reason,$sid)
+    }
+
+    # "all" workaround, will be removed soon
+    if $sessions(leave_groupchats,all,$sid) {
+	set connid $sessions(connid,$sid)
+	set sessions(leave_groupchats,groupchats,$sid) ""
+	
+	foreach chatid [chat::opened] {
+	    set jid [chat::get_jid $chatid]
+
+	    if {![cequal [chat::get_connid $chatid] $connid]} continue
+	    if {![chat::is_groupchat $chatid]} continue
+	    if {[cequal [get_jid_presence_info show $connid $jid] ""]} continue
+	    
+	    lappend sessions(leave_groupchats,groupchats,$sid) $jid
+	}
+    }
+    
+    foreach jid $sessions(leave_groupchats,groupchats,$sid) {
+	eval [list send_presence unavailable -to $jid] $args
+    }
+
+    return [list completed [jlib::wrapper:createtag note \
+				-vars {type info} \
+				-chdata "Groupchats was leaved successfully"]]
+}
+
+################################
+# Forward unread messages
+
+proc ::remote::forward {sid action children} {
+    return [standart_scheduler 1 forward $sid $action $children]
+}
+::remote::register_command "http://jabber.org/protocol/rc#forward" \
+			   ::remote::forward "Forward unread messages"
+
+# step1: 
+# form with list of unreaded correspondence
+proc ::remote::forward:get_step1 {sid} {
+    variable sessions
+
+    set options {}
+    set connid $sessions(connid,$sid)
+    foreach id [array names ::remote::forward::unread] {
+	lassign $id type chatid
+	if {![cequal [chat::get_connid $chatid] $connid]} continue
+
+	set jid [chat::get_jid $chatid]
+	set name [::roster::itemconfig $connid \
+				       [::roster::find_jid $connid $jid] \
+				       -name]
+	if {![cequal $name ""]} {
+	    set name [format "%s (%s)" $name $jid]
+	} else {
+	    set name $jid
+	}
+
+	set count [llength $::remote::forward::unread($id)]
+
+	lappend options [list $id \
+			      [format "%s: %s %s message(s)" $name $count $type]]
+    }
+    if {[expr [llength $options] == 0]} {
+	return [list completed [jlib::wrapper:createtag note \
+				    -vars {type info} \
+				    -chdata "There is no unread messages"]]
+    }
+    
+    set fields {}
+
+    lappend fields [data::createfieldtag hidden \
+    			-var FORM_TYPE \
+    			-values "tkabber:plugins:remote:forward_form"]
+    lappend fields [data::createfieldtag title \
+			-value "Forward Unread Messages"]
+    lappend fields [data::createfieldtag instructions \
+			-value "Choose from wich chats or groupchats you want to"]
+    
+    lappend fields [data::createfieldtag boolean \
+			-var all \
+			-label "Forward all messages" \
+			-value 0]
+    lappend fields [data::createfieldtag list-multi \
+			-var chats -label "Forward messages from" \
+			-required 1 \
+			-options $options]
+    
+    return [list executing [jlib::wrapper:createtag x \
+				-vars [list xmlns $::NS(data) \
+					    type form] \
+				-subtags $fields]]
+}
+
+proc ::remote::forward:set_step1 {sid children} {
+    variable sessions
+    
+    set result [remote::standart_parseresult $children \
+					     "plugins:remote:forward_form"]
+    if {[cequal [lindex $result 0] error]} {
+	return $result
+    }
+    array set params $result
+    
+    if {![info exists params(chats)]} {
+	return [list error cancel bad-request \
+		     -application-specific \
+			 [jlib::wrapper:createtag bad-payload \
+			      -vars [list xmlns $::NS(commands)]]]
+    }
+
+    set sessions(forward,all,$sid) $params(all)
+    set sessions(forward,chats,$sid) $params(chats)
+    return {}
+}
+
+proc ::remote::forward:clear_step1 {sid} {
+    catch {unset sessions(forward,chats,$sid)}
+    catch {unset sessions(forward,all,$sid)}
+}
+
+# finish: 
+# forward selected unread messages
+# report
+proc ::remote::forward:get_finish {sid} {
+    variable sessions
+
+    set connid $sessions(connid,$sid)
+    set oto [jlib::connection_jid $connid]
+    set target $sessions(from,$sid)
+    
+    # "all" workaround, will be removed soon
+    if $sessions(forward,all,$sid) {
+	set sessions(forward,chats,$sid) {}
+	
+	foreach id [array names forward::unread] {
+	    lassign $id type chatid	    
+	    if {![cequal [chat::get_connid $chatid] $connid]} continue
+	    lappend sessions(forward,chats,$sid) $id
+	}
+    }
+
+    foreach id $sessions(forward,chats,$sid) {
+	forward::forward_messages $id $connid $oto $target
+    }
+
+    return [list completed \
+		 [jlib::wrapper:createtag note \
+		      -vars {type info} \
+		      -chdata "Unread messages was forwarded successfully"]]
+}
+
+#############################
+# Forward namespace
+namespace eval ::remote::forward {
+    array set unread {}
+}
+
+# forwards messages
+# leaves marks that they was forwarded. 
+# cleanup arrays
+proc ::remote::forward::forward_messages {id connid oto target} {
+    variable unread
+    variable msgdata
+
+    lassign $id type chatid
+    
+    foreach elem $unread($id) {
+	
+	switch -- $type {
+	    groupchat -
+	    chat {
+		lassign $elem date ofrom body x
+	    }
+	    normal {
+		lassign $msgdata($elem) date ofrom body x
+	    }
+	}
+	
+	lappend x [jlib::wrapper:createtag addresses \
+		       -vars [list xmlns $::NS(xaddress)] \
+		       -subtags [list [jlib::wrapper:createtag address \
+					   -vars [list type ofrom \
+						       jid $ofrom]] \
+				      [jlib::wrapper:createtag address \
+					   -vars [list type oto \
+						       jid $oto]]]]
+	
+	lappend x [jlib::wrapper:createtag x \
+		       -vars [list xmlns "jabber:x:delay" \
+				   stamp $date]]
+	
+	jlib::send_msg $target -body $body \
+			       -type $type \
+			       -xlist $x \
+			       -connection $connid
+
+	switch -- $type {
+	    normal {
+		set lab \
+		    [Label $elem.forwlab \
+			   -text [::msgcat::mc \
+				      "This message was forwarded to %s" \
+				      $target]]
+		pack $lab -anchor w -fill none -expand no -before $elem.title
+		
+		catch {unset msgdata($elem)}
+	    }
+	}
+    }
+
+    catch {unset unread($id)}
+    switch -- $type {
+	groupchat -
+	chat {   
+	    after idle \
+		  [list ::chat::add_message $chatid $ofrom info \
+			[::msgcat::mc "All unread messages was forwarded to %s." \
+			     $target] \
+			{}]
+	}
+    }
+}
+
+# store message into the unread if type == chat
+proc ::remote::forward::draw_message_handler {chatid from type body extras} {
+    variable unread
+    
+    if {[ifacetk::chat_window_is_active $chatid]} return 
+
+    if {![lcontain {chat groupchat} $type]} return
+#    if {![cequal chat $type]} return
+
+    set date [clock format [clock seconds] -format "%Y%m%dT%H:%M:%S" -gmt 1]
+
+    set message [list $date $from $body $extras]
+    set id [list $type $chatid]
+    lappend unread($id) $message
+
+    return 0
+}
+
+hook::add draw_message_hook ::remote::forward::draw_message_handler 19
+
+# clear list of unread messages with type == chat
+proc ::remote::forward::trace_number_msg {var1 chatid mode} {
+    variable unread
+    
+    if { $::ifacetk::number_msg($chatid) == 0 } {
+	set type $::chat::chats(type,$chatid)
+	set id [list $type $chatid]
+	catch {unset unread($id)}
+    }
+    
+}
+
+trace variable ::ifacetk::number_msg r ::remote::forward::trace_number_msg
+
+# store message with type == normal
+proc ::remote::forward::message_process_x \
+     {rowvar bodyvar f x connid from type replyP} {
+    upvar 2 $rowvar row
+    upvar 2 $bodyvar body
+    variable unread
+    variable msgdata
+   
+    if {!$replyP || [cequal $type error]} {
+	return
+    }
+    
+    set id [list normal [chat::chatid $connid $from]]
+
+    if {![info exists unread($id)]} {
+	set unread($id) {}
+    }
+
+    set msgwin [winfo toplevel $f]
+
+    bindtags $msgwin [concat [bindtags $msgwin] tag$msgwin]
+    bind tag$msgwin <Destroy> \
+	 +[list [namespace current]::on_msgwin_destroy $msgwin $id]
+    lappend unread($id) $msgwin
+
+    set date [clock format [clock seconds] -format "%Y%m%dT%H:%M:%S" -gmt 1]
+    set msgdata($msgwin) [list $date $from $body $x]
+
+    return
+}
+
+hook::add message_process_x_hook ::remote::forward::message_process_x
+
+# clear chat message with type == normal if it was closed
+proc ::remote::forward::on_msgwin_destroy {msgwin id} {
+    variable unread
+    variable msgdata
+    
+    if {![info exists unread($id)]} return
+
+    if {[set index [lsearch -exact $unread($id) $msgwin]] >= 0} {
+	set unread($id) [lreplace $unread($id) $index $index]
+	catch {unset msgdata($msgwin)}
+    }    
+
+    if { [llength $unread($id)] == 0 } {
+	catch {unset unread($id)}
+    }
+}
+


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

Added: trunk/tkabber/plugins/general/xaddress.tcl
===================================================================
--- trunk/tkabber/plugins/general/xaddress.tcl	                        (rev 0)
+++ trunk/tkabber/plugins/general/xaddress.tcl	2006-09-17 19:58:46 UTC (rev 720)
@@ -0,0 +1,272 @@
+# $Id$
+# Implementation of JEP-0033: Extended Stanza Addressing
+
+set ::NS(xaddress) "http://jabber.org/protocol/address"
+set ::NS(xaddress_store) "tkabber:xaddress:store"
+
+namespace eval ::xaddress {
+    set xaddrinfoid 0
+    
+    array set names [list \
+			 ofrom     [::msgcat::mc "Original from"]     \
+			 oto       [::msgcat::mc "Original to"]       \
+			 replyto   [::msgcat::mc "Reply to"]          \
+			 replyroom [::msgcat::mc "Reply to room"]     \
+			 noreply   [::msgcat::mc "No reply"]          \
+			 to        [::msgcat::mc "To"]                \
+			 cc        [::msgcat::mc "Carbon copy"]       \
+			 bcc       [::msgcat::mc "Blind carbon copy"] \
+			]   
+}
+
+#######################################################
+# Common procs
+
+proc ::xaddress::parse_xaddress_fields {xe {elems {}}} {
+
+    jlib::wrapper:splitxml $xe tag vars isempty chdata children
+
+    if {![cequal [jlib::wrapper:getattr $vars xmlns] $::NS(xaddress)]} {
+	return {}
+    }
+    if {![cequal $tag addresses]} {
+	return {}
+    }
+
+    set res {}
+    
+    foreach child $children {
+	jlib::wrapper:splitxml $child tag1 vars1 isempty1 chdata1 children1
+		
+	if {![cequal $tag1 address]} continue
+
+	set type [jlib::wrapper:getattr $vars1 type] 
+	if {![lempty $elems] && ![lcontain $elems $type]} continue
+
+	set params {}
+	foreach elem {jid node uri descr delivered} {
+	    set value [jlib::wrapper:getattr $vars1 $elem]
+	    if {![cequal $value ""]} {
+		lappend params $elem $value
+	    }
+	}
+
+	lappend res $type $params
+    }        
+    return $res
+}
+
+proc ::xaddress::format_addressinfo_tooltip {type from real_from reason fields} {
+    variable names
+    set lines {}
+
+    switch -- $reason {
+	ofrom {
+	    lappend lines \
+		    [::msgcat::mc "This message was forwarded by %s\n" \
+				  $real_from]
+	}
+	#replyto -
+	#replyroom {
+	#    lappend lines \
+	#	    [::msgcat::mc "This message was sent by %s\n" $real_from]
+	#}
+    }
+
+    lappend lines [::msgcat::mc "Extended addressing fields:"]
+    foreach {type params} $fields {
+	array set arparams $params
+	
+	if {[info exists names($type)]} {
+	    set line " $names($type):"
+	} else {
+	    set line " $type:"
+	}
+
+	if {[info exists arparams(descr)]} {
+	    append line " <$arparams(descr)>"
+	}
+	
+	if {[info exists arparams(jid)]} {
+	    append line " $arparams(jid)"
+	    if {[info exists arparams(node)]} {	
+		append line " [$arparams(node)]"
+	    }    
+	} elseif {[info exists arparams(uri)]} {
+	    append line " $arparams(uri)"
+	}
+
+	lappend lines $line
+	array unset arparams
+    }
+    return [join $lines "\n"]
+}
+
+######################################################
+# Replace original jid. Read README.xaddress
+proc ::xaddress::modify_from \
+     {connid from id type is_subject subject body err thread priority x} {
+
+    # those types are supported at now.
+    if {![lcontain {chat normal groupchat ""} $type]} return
+
+    foreach xe $x {
+	jlib::wrapper:splitxml $xe tag vars isempty chdata children
+	
+	if {[cequal [jlib::wrapper:getattr $vars xmlns] $::NS(xaddress_store)]} {
+	    # this message already was changed by this proc => exit
+	    return
+	}
+
+	if {[cequal [set res [parse_xaddress_fields $xe {ofrom}]] {}]} continue
+
+	# FIX: now we get only first but is there can be several ofrom fields?
+	lassign $res reason vars1
+	set ofrom [jlib::wrapper:getattr $vars1 jid]
+	if {[cequal $ofrom ""]} return
+
+	set x [linsert $x 0 [jlib::wrapper:createtag x \
+				 -vars [list xmlns $::NS(xaddress_store) \
+					     real_from $from \
+					     reason $reason]]]
+	set from $ofrom
+	hook::run process_message_hook \
+		  $connid $from $id $type $is_subject $subject $body \
+		  $err $thread $priority $x
+
+	return stop
+    }
+}
+
+hook::add process_message_hook ::xaddress::modify_from 1
+
+#####################################################################
+# Draw special icon and tooltip for xaddress messages in the chat.
+
+proc ::xaddress::draw_xaddress {chatid from type body x} {
+    variable xaddrinfoid
+
+    set chatw [chat::chat_win $chatid]
+
+    set real_from ""
+    set reason ""
+
+    foreach xe $x {
+        jlib::wrapper:splitxml $xe tag vars isempty chdata children
+	set xmlns [jlib::wrapper:getattr $vars xmlns]
+	
+	if {[cequal  $xmlns $::NS(xaddress_store)] && [cequal $tag x]} {
+	    set real_from [jlib::wrapper:getattr $vars real_from]
+	    set reason [jlib::wrapper:getattr $vars reason]
+	    continue
+	}
+
+	if {[cequal [set fields [parse_xaddress_fields $xe]] {}]} continue
+	
+	incr xaddrinfoid
+	set label \
+	    [Label $chatw.xaddrinfo$xaddrinfoid \
+		   -image xaddress/info \
+		   -helptext [format_addressinfo_tooltip \
+				  $type $from $real_from $reason $fields] \
+		   -helptype balloon]
+	$chatw window create end -window $label
+
+	break
+    }
+}
+
+hook::add draw_message_hook  ::xaddress::draw_xaddress 6
+
+##########################################################
+# Draw xaddress fields in the new message dialog
+
+proc ::xaddress::process_x_data {rowvar bodyvar f x connid from type replyP} {
+    upvar 2 $rowvar row
+    upvar 2 $bodyvar body
+    variable names
+
+    if {!$replyP || [cequal $type error]} {
+        return
+    }
+
+    set title [join [lrange [split $f .] 0 end-1] .].title
+    
+    foreach xe $x {
+        jlib::wrapper:splitxml $xe tag vars isempty chdata children
+	set xmlns [jlib::wrapper:getattr $vars xmlns]
+
+	# if "from" was modified draw reason and real_from
+	if {[cequal  $xmlns $::NS(xaddress_store)] && [cequal $tag x]} {
+	    set real_from [jlib::wrapper:getattr $vars real_from]
+	    set reason [jlib::wrapper:getattr $vars reason]
+
+	    switch -- $reason {
+		ofrom {
+		    grid [Label $title.flabel \
+				-text [::msgcat::mc "Forwarded by:"]] \
+			 -column 0 -row 2 -sticky e
+		    grid [Label $title.fjid -text $real_from] \
+			 -column 1 -row 2 -sticky w
+		}
+	    }
+	    continue
+	}
+	
+	if {[cequal [set fields [parse_xaddress_fields $xe]] {}]} continue
+		
+	# draw most important xaddress fields
+	set other_fields {}
+	foreach {type params} $fields {
+	    array unset aparams
+	    array set aparams $params
+	    switch -- $type {
+		noreply -
+		replyroom -
+		replyto {		    
+		    if {![info exist aparams(jid)]} {
+			lappend other_fields $type $params	    
+			continue
+		    }
+		    
+		    set text ""
+		    if {[info exists aparams(descr)]} {
+			append text "<$aparams(descr)> "
+		    }
+		    append text $aparams(jid)
+		    if {[info exists aparams(node)]} {
+			append text " [$aparams(node)]"
+		    }
+		    
+		    grid [Label $f.lxaddr${row} \
+				-text [::msgcat::mc $names($type):]] \
+			-column 0 -row $row -sticky e
+		    grid [Label $f.xaddr${row} -text $text] \
+			-column 1 -row $row -sticky w
+		    
+		    incr row
+		}
+		default {
+		    lappend other_fields $type $params
+		}
+	    }
+	}
+	
+	# draw rest in tooltip
+	if {[expr [llength $other_fields] > 0]} {
+	    
+	    set label \
+		[Label $title.xaddrinfo \
+		       -image xaddress/info \
+		       -helptext [format_addressinfo_tooltip \
+				      $type $from "" "" $other_fields] \
+		       -helptype balloon]
+	    grid $label -row 1 -column 4 -sticky e                                                                    
+
+	}
+    }
+    return
+}
+
+hook::add message_process_x_hook ::xaddress::process_x_data
+


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

Modified: trunk/tkabber/plugins/iq/version.tcl
===================================================================
--- trunk/tkabber/plugins/iq/version.tcl	2006-09-16 20:18:40 UTC (rev 719)
+++ trunk/tkabber/plugins/iq/version.tcl	2006-09-17 19:58:46 UTC (rev 720)
@@ -48,7 +48,8 @@
 	"Mandrake Linux"    /etc/mandrake-release   file \
 	"RedHat Linux"	    /etc/redhat-release	    file \
 	"Conectiva Linux"   /etc/conectiva-release  file \
-	"Slackware Linux"   /etc/slackware-version  append } {
+	"Slackware Linux"   /etc/slackware-version  append \
+	"Arch Linux"	    /etc/arch-release	    file} {
 
 	try_linux_version $distr $file $flag
 



More information about the Tkabber-dev mailing list