[Tkabber-dev] r1209 - in trunk/tkabber-plugins: . jidlink jidlink/msgs jidlink/plugins

tkabber-svn at jabber.ru tkabber-svn at jabber.ru
Fri Aug 31 15:52:26 MSD 2007


Author: sergei
Date: 2007-08-31 15:52:26 +0400 (Fri, 31 Aug 2007)
New Revision: 1209

Added:
   trunk/tkabber-plugins/jidlink/
   trunk/tkabber-plugins/jidlink/README
   trunk/tkabber-plugins/jidlink/jidlink.tcl
   trunk/tkabber-plugins/jidlink/msgs/
   trunk/tkabber-plugins/jidlink/msgs/ru.msg
   trunk/tkabber-plugins/jidlink/plugins/
   trunk/tkabber-plugins/jidlink/plugins/dtcp.tcl
   trunk/tkabber-plugins/jidlink/plugins/filetransfer.tcl
   trunk/tkabber-plugins/jidlink/plugins/ibb.tcl
Modified:
   trunk/tkabber-plugins/ChangeLog
Log:
	* jidlink/*: New Jidlink support plugin. Jidlink support is removed
	  from main Tkabebr distribution because it is obsolete and
	  undocumented and superseeded by Stream Initiation.


Modified: trunk/tkabber-plugins/ChangeLog
===================================================================
--- trunk/tkabber-plugins/ChangeLog	2007-08-31 11:45:09 UTC (rev 1208)
+++ trunk/tkabber-plugins/ChangeLog	2007-08-31 11:52:26 UTC (rev 1209)
@@ -1,3 +1,9 @@
+2007-08-31  Sergei Golovan <sgolovan at nes.ru>
+
+	* jidlink/*: New Jidlink support plugin. Jidlink support is removed
+	  from main Tkabebr distribution because it is obsolete and
+	  undocumented and superseeded by Stream Initiation.
+
 2007-08-30  Sergei Golovan <sgolovan at nes.ru>
 
 	* browser/*: New Jabber Browser (XEP-0011) support plugin. It was

Added: trunk/tkabber-plugins/jidlink/README
===================================================================
--- trunk/tkabber-plugins/jidlink/README	                        (rev 0)
+++ trunk/tkabber-plugins/jidlink/README	2007-08-31 11:52:26 UTC (rev 1209)
@@ -0,0 +1,25 @@
+$Id$
+
+Jidlink is a simple negotiation protocol for setting up a bytestream
+between two JIDs.  With it you can specify what transports you can
+use, and via negotiation choose more appropriate one. There are
+three transport implementations:
+
+dtcp-active: that allows you to connect to any node that supports
+   "dtcp-passive";
+
+dtcp-passive: that allows any node that supports "dtcp-active" to
+   connect to you; and,
+
+inband-bytestream: that uses your "Jabber" connection to transmit the
+   data (which may slowdown other traffic to you).
+
+If your machine is behind a firewall, then you can't use the
+"dtcp-passive" transport, so you should disable it in a config file:
+
+    set jidlink::transport(allowed,dtcp-passive) 0
+
+Jidlink is undocumented and obsolete, but it may be useful for file
+transfer to old Tkabber clients which don't support Stream Initiation
+protocol.
+


Property changes on: trunk/tkabber-plugins/jidlink/README
___________________________________________________________________
Name: svn:keywords
   + Author Date Id Revision
Name: svn:eol-style
   + native

Copied: trunk/tkabber-plugins/jidlink/jidlink.tcl (from rev 1207, trunk/tkabber/jidlink.tcl)
===================================================================
--- trunk/tkabber-plugins/jidlink/jidlink.tcl	                        (rev 0)
+++ trunk/tkabber-plugins/jidlink/jidlink.tcl	2007-08-31 11:52:26 UTC (rev 1209)
@@ -0,0 +1,215 @@
+# $Id$
+
+package require msgcat
+
+namespace eval ::jidlink {
+
+    ::msgcat::mcload [file join [file dirname [info script]] msgs]
+
+    set transport(list) {}
+}
+
+proc ::jidlink::connect {connid jid {key {}}} {
+    variable connection
+
+    if {$key == ""} {
+	set key [rand 1000000000]
+    }
+
+    #set connection(sf,$key) $send_func
+    #set connection(rf,$key) $recv_func
+    set connection(connid,$key) $connid
+    set connection(jid,$key) $jid
+
+    set_status [::msgcat::mc "Opening Jidlink connection"]
+
+    jlib::send_iq set \
+	[jlib::wrapper:createtag query \
+	     -vars {xmlns jabber:iq:jidlink} \
+	     -subtags [list [jlib::wrapper:createtag key -chdata $key]]] \
+	-to $jid \
+	-command [list [namespace current]::connect_response $connid $jid $key] \
+	-connection $connid
+
+    vwait [namespace current]::connection(status,$key)
+    return connection(status,$key)
+}
+
+proc ::jidlink::connect_response {connid jid key res child} {
+    variable connection
+    variable transport
+
+    if {$res != "OK"} {
+	# TODO
+	set connection(status,$key) 0
+	return
+    }
+
+    set trans [lsort -unique -index 1 $transport(list)]
+    set options {}
+    foreach t $trans {
+	set name [lindex $t 0]
+	if {![info exists transport(allowed,$name)] || \
+		$transport(allowed,$name)} {
+	    lappend options $name
+	}
+    }
+
+    if {[llength $options] == 0} {
+	# TODO
+	set connection(status,$key) 0
+	return
+    }
+
+    lassign [negotiate::send_request $connid $jid jabber:iq:jidlink $options] res opts
+
+    if {[llength $opts] == 1 && [lcontain $options [lindex $opts 0]]} {
+	set name [lindex $opts 0]
+	set connection(transport,$key) $name
+	eval $transport(connect,$name) [list $connid $jid $key]
+	set connection(status,$key) 1
+	return
+    }
+    set connection(status,$key) 0
+}
+
+
+proc ::jidlink::set_readable_handler {key handler} {
+    variable connection
+    set connection(readable_handler,$key) $handler
+}
+
+proc ::jidlink::set_closed_handler {key handler} {
+    variable connection
+    set connection(closed_handler,$key) $handler
+}
+
+proc ::jidlink::send_data {key data} {
+    variable connection
+    variable transport
+    eval $transport(send,$connection(transport,$key)) [list $key $data]
+}
+
+proc ::jidlink::recv_data {key data} {
+    variable connection
+    debugmsg jidlink "RECV_DATA [list $key $data]"
+
+    append connection(data,$key) $data
+    if {[info exists connection(readable_handler,$key)]} {
+	eval $connection(readable_handler,$key) [list $key]
+    }
+}
+
+proc ::jidlink::read_data {key} {
+    variable connection
+
+    set data $connection(data,$key)
+    set connection(data,$key) {}
+    return $data
+}
+
+proc ::jidlink::close {key} {
+    variable connection
+    variable transport
+    eval $transport(close,$connection(transport,$key)) [list $key]
+    set_status [::msgcat::mc "Jidlink connection closed"]
+}
+
+proc ::jidlink::closed {key} {
+    variable connection
+    if {[info exists connection(closed_handler,$key)]} {
+	eval $connection(closed_handler,$key) [list $key]
+    }
+}
+
+
+# TODO: connid
+proc ::jidlink::negotiate_handler {from type options} {
+    variable transport
+
+    set trans [lsort -unique -index 1 $transport(list)]
+    set myoptions {}
+    foreach t $trans {
+	set name [lindex $t 0]
+	if {![info exists transport(allowed,$name)] || \
+		$transport(allowed,$name)} {
+	    lappend myoptions $transport(oppos,$name)
+	}
+    }
+
+    if {$options == {}} {
+	return $myoptions
+    }
+
+    foreach opt $options {
+	if {[lcontain $myoptions $opt]} {
+	    return [list $opt]
+	}
+    }
+    return {}
+}
+
+negotiate::register_handler jabber:iq:jidlink ::jidlink::negotiate_handler
+
+
+proc ::jidlink::set_handler {connid from lang child} {
+    debugmsg jidlink "set: [list $from $child]"
+
+    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 == "key"} {
+		set key $chdata1
+		debugmsg jidlink "KEY: $key"
+	    }
+	}
+
+	if {[info exists key]} {
+	    return [list result $child]
+
+	} else {
+	    # TODO
+	}
+    } else {
+	# TODO
+    }
+}
+
+iq::register_handler set query jabber:iq:jidlink ::jidlink::set_handler
+
+
+proc ::jidlink::register_transport {name oppos prio connect send close} {
+    variable transport
+
+    lappend transport(list) [list $name $prio]
+    set transport(oppos,$name) $oppos
+    set transport(connect,$name) $connect
+    set transport(send,$name) $send
+    set transport(close,$name) $close
+}
+
+# Loading jidlink plugins
+foreach file [lsort [glob -nocomplain \
+		    [file join [file dirname [info script]] plugins]/*.tcl]] {
+    debugmsg jidlink "Loading plugin from $file"
+    source $file
+}
+
+proc ::jidlink::setup_customize {} {
+    variable transport
+
+    set trans [lsort -unique -index 1 $transport(list)]
+
+    foreach t $trans {
+	lassign $t name prio
+
+	custom::defvar transport(allowed,$name) 1 \
+	[format [::msgcat::mc "Enable Jidlink transport %s."] $name] \
+	-type boolean -group Jidlink
+    }
+}
+
+hook::add finload_hook ::jidlink::setup_customize 40
+

Added: trunk/tkabber-plugins/jidlink/msgs/ru.msg
===================================================================
--- trunk/tkabber-plugins/jidlink/msgs/ru.msg	                        (rev 0)
+++ trunk/tkabber-plugins/jidlink/msgs/ru.msg	2007-08-31 11:52:26 UTC (rev 1209)
@@ -0,0 +1,22 @@
+$Id$
+::msgcat::mcset ru "Browse..." "Выбрать..."
+::msgcat::mcset ru "Cancel" "Отменить"
+::msgcat::mcset ru "Connection closed" "Соединение закрыто"
+::msgcat::mcset ru "Description:" "Описание:"
+::msgcat::mcset ru "Enable Jidlink transport %s." "Разрешить использование Jidlink-транспорта %s"
+::msgcat::mcset ru "Jidlink connection closed" "Соединение Jidlink закрыто"
+::msgcat::mcset ru "Jidlink connection failed" "Соединиться по Jidlink не удалось"
+::msgcat::mcset ru "Jidlink options." "Параметры Jidlink-транспорта."
+::msgcat::mcset ru "Jidlink transfer failed" "Передать файл по Jidlink не удалось"
+::msgcat::mcset ru "Name:" "Имя:"
+::msgcat::mcset ru "Opening DTCP active connection" "Открываем соединение DTCP"
+::msgcat::mcset ru "Opening DTCP passive connection" "Соединение DTCP закрыто"
+::msgcat::mcset ru "Opening IBB connection" "Открываем соединение IBB"
+::msgcat::mcset ru "Opening Jidlink connection" "Открываем соединение Jidlink"
+::msgcat::mcset ru "Receive" "Получить"
+::msgcat::mcset ru "Receive file from %s" "Получение файла от %s"
+::msgcat::mcset ru "Receiving file failed: %s" "Получение файла не удалось: %s"
+::msgcat::mcset ru "Request failed: %s" "Запрос не удался: %s"
+::msgcat::mcset ru "Save as:" "Сохранить как:"
+::msgcat::mcset ru "Size:" "Размер:"
+::msgcat::mcset ru "Transferring..." "Передача файла..."


Property changes on: trunk/tkabber-plugins/jidlink/msgs/ru.msg
___________________________________________________________________
Name: svn:keywords
   + Author Date Id Revision
Name: svn:eol-style
   + native

Copied: trunk/tkabber-plugins/jidlink/plugins/dtcp.tcl (from rev 1207, trunk/tkabber/plugins/jidlink/dtcp.tcl)
===================================================================
--- trunk/tkabber-plugins/jidlink/plugins/dtcp.tcl	                        (rev 0)
+++ trunk/tkabber-plugins/jidlink/plugins/dtcp.tcl	2007-08-31 11:52:26 UTC (rev 1209)
@@ -0,0 +1,379 @@
+# $Id$
+
+namespace eval ::dtcp {}
+namespace eval ::dtcp::active {}
+namespace eval ::dtcp::passive {}
+
+proc ::dtcp::active::connect {connid jid key} {
+    variable connection
+
+    set_status [::msgcat::mc "Opening DTCP active connection"]
+
+    jlib::send_iq set \
+	[jlib::wrapper:createtag query \
+	     -vars {xmlns jabber:iq:dtcp} \
+	     -subtags [list \
+			   [jlib::wrapper:createtag key \
+				-chdata $key] \
+			   [jlib::wrapper:createtag comment \
+				-subtags [list [jlib::wrapper:createtag key \
+						    -chdata $key]]]]] \
+	-to $jid \
+	-command [list ::dtcp::active::recv_connect_response $connid $jid $key] \
+	-connection $connid
+	 
+    vwait [namespace current]::connection(status,$key)
+}
+
+proc ::dtcp::active::recv_connect_response {connid jid key res child} {
+    variable connection
+
+    if {$res != "OK"} {
+	# TODO
+	set connection(status,$key) 0
+	return
+    }
+
+    jlib::wrapper:splitxml $child tag vars isempty chdata children
+
+    if {$tag == "query"} {
+	set hosts {}
+	foreach item $children {
+	    jlib::wrapper:splitxml $item tag1 vars1 isempty1 chdata1 children1
+	    switch -- $tag1 {
+		verify {
+		    set verify $chdata1
+		    debugmsg jidlink "VERIFY: $verify"
+		}
+		host {
+		    lappend hosts [list $chdata1 \
+				       [jlib::wrapper:getattr $vars1 port]]
+		}
+	    }
+	}
+
+	if {[info exists verify]} {
+	    variable verify_key
+	    variable key_verify
+
+	    set verify_key($verify) $key
+	    set key_verify($key) $verify
+
+	    set connection(connid,$key) $connid
+	    set connection(jid,$key) $jid
+
+	    foreach host $hosts {
+		lassign $host addr port
+		debugmsg jidlink "CONNECTING TO $addr:$port..."
+		if {[catch {set sock [socket $addr $port]}]} continue
+		debugmsg jidlink "CONNECTED"
+		fconfigure $sock -encoding binary
+		set connection(sock,$key) $sock
+		puts $sock "key:$key"
+		flush $sock
+
+		fileevent $sock readable \
+		    [list ::dtcp::active::wait_for_verify $key $sock]
+		return
+	    }
+	    
+	    debugmsg jidlink "FAILED"
+
+	    set connection(status,$key) 0
+	    return
+	} else {
+	    # TODO
+	}
+    } else {
+	# TODO
+    }
+    set connection(status,$key) 0
+}
+
+proc ::dtcp::active::sock_connect {key hosts} {
+    variable connection
+    variable verify_key
+    variable key_verify
+
+
+    foreach host $hosts {
+	lassign $host addr port
+	debugmsg jidlink "CONNECTING TO $addr:$port..."
+	if {[catch {set sock [socket $addr $port]}]} continue
+	debugmsg jidlink "CONNECTED"
+	fconfigure $sock -encoding binary
+	set connection(sock,$key) $sock
+	puts $sock "key:$key"
+	flush $sock
+	
+	fileevent $sock readable \
+	    [list ::dtcp::active::wait_for_verify $key $sock]
+	return
+    }
+
+    debugmsg jidlink "FAILED"
+    
+    set connection(status,$key) 0
+
+}
+
+proc ::dtcp::active::send_data {key data} {
+    variable connection
+    variable key_stream
+
+    puts -nonewline $connection(sock,$key) $data
+    flush $connection(sock,$key)
+
+    return 1
+}
+
+proc ::dtcp::active::close {key} {
+    variable connection
+    variable key_stream
+
+    ::close $connection(sock,$key)
+}
+
+
+proc ::dtcp::active::wait_for_verify {key chan} {
+    variable connection
+    variable key_verify
+
+    set s [gets $chan]
+    debugmsg jidlink "WFV: [list $s]"
+
+    if {[crange $s 0 6] == "verify:"} {
+	set verify [crange $s 7 end]
+	if {$verify == $key_verify($key)} {
+	    fconfigure $chan -translation binary -blocking no
+	    fileevent $chan readable \
+		[list ::dtcp::readable $key $chan]
+	    set connection(status,$key) 1
+	    return
+	}
+    }
+    ::close $chan
+    jidlink::closed $key
+}
+
+jidlink::register_transport dtcp-active dtcp-passive 25 \
+    ::dtcp::active::connect ::dtcp::active::send_data ::dtcp::active::close
+
+proc ::dtcp::passive::connect {connid jid key} {
+    variable connection
+
+    set_status [::msgcat::mc "Opening DTCP passive connection"]
+
+    set servsock [socket -server [list ::dtcp::passive::accept $key] 0]
+    lassign [fconfigure $servsock -sockname] addr hostname port
+    set ip [lindex [fconfigure $jlib::lib($connid,sck) -sockname] 0]
+
+    jlib::send_iq set \
+	[jlib::wrapper:createtag query \
+	     -vars {xmlns jabber:iq:dtcp} \
+	     -subtags [list \
+			   [jlib::wrapper:createtag key \
+				-chdata $key] \
+			   [jlib::wrapper:createtag host \
+				-vars [list port $port] \
+				-chdata $ip] \
+			   [jlib::wrapper:createtag comment \
+				-subtags [list [jlib::wrapper:createtag key \
+						    -chdata $key]]]]] \
+	-to $jid \
+	-command [list ::dtcp::passive::recv_connect_response $connid $jid $key] \
+	-connection $connid
+	 
+    vwait [namespace current]::connection(status,$key)
+}
+
+proc ::dtcp::passive::recv_connect_response {connid jid key res child} {
+    variable connection
+
+    if {$res != "OK"} {
+	# TODO
+	set connection(status,$key) 0
+	return
+    }
+
+    jlib::wrapper:splitxml $child tag vars isempty chdata children
+
+    if {$tag == "query"} {
+	set hosts {}
+	foreach item $children {
+	    jlib::wrapper:splitxml $item tag1 vars1 isempty1 chdata1 children1
+	    switch -- $tag1 {
+		verify {
+		    set verify $chdata1
+		    debugmsg jidlink "VERIFY: $verify"
+		}
+		host {
+		    lappend hosts [list $chdata1 \
+				       [jlib::wrapper:getattr $vars port]]
+		}
+	    }
+	}
+
+	if {[info exists verify]} {
+	    variable verify_key
+	    variable key_verify
+
+	    set verify_key($verify) $key
+	    set key_verify($key) $verify
+
+	    set connection(connid,$key) $connid
+	    set connection(jid,$key) $jid
+
+	    #set connection(status,$key) 1
+	    return
+	} else {
+	    # TODO
+	}
+    } else {
+	# TODO
+    }
+    set connection(status,$key) 0
+}
+
+proc ::dtcp::passive::send_data {key data} {
+    variable connection
+    variable key_stream
+
+    puts -nonewline $connection(sock,$key) $data
+    flush $connection(sock,$key)
+
+    return 1
+}
+
+proc ::dtcp::passive::close {key} {
+    variable connection
+    variable key_stream
+
+    ::close $connection(sock,$key)
+}
+
+proc ::dtcp::passive::accept {key chan addr port} {
+    variable connection
+    variable key_verify
+
+    debugmsg jidlink "CONNECT FROM $addr:$port"
+
+    set connection(sock,$key) $chan
+
+    fileevent $chan readable \
+	[list ::dtcp::passive::wait_for_key $key $chan]
+}
+
+proc ::dtcp::passive::wait_for_key {key chan} {
+    variable connection
+    variable key_verify
+
+    set s [gets $chan]
+
+    if {[crange $s 0 3] == "key:"} {
+	set key2 [crange $s 4 end]
+	if {$key == $key2} {
+	    debugmsg jidlink [array get key_verify]
+	    puts $chan "verify:$key_verify($key)"
+	    flush $chan
+	    fconfigure $chan -translation binary -blocking no
+	    fileevent $chan readable \
+		[list ::dtcp::readable $key $chan]
+	    set connection(status,$key) 1
+	    return
+	}
+    }
+    puts $chan error
+    flush $chan
+}
+
+proc ::dtcp::readable {key chan} {
+    if {![eof $chan]} {
+	set buf [read $chan 4096]
+	jidlink::recv_data $key $buf
+    } else {
+	fileevent $chan readable {}
+	jidlink::closed $key
+    }
+}
+
+proc ::dtcp::iq_set_handler {connid from lang child} {
+    jlib::wrapper:splitxml $child tag vars isempty chdata children
+
+    if {$tag == "query"} {
+	set hosts {}
+	foreach item $children {
+	    jlib::wrapper:splitxml $item tag1 vars1 isempty1 chdata1 children1
+	    switch -- $tag1 {
+		comment {
+		    foreach item1 $children1 {
+			jlib::wrapper:splitxml $item1 tag2 vars2 isempty2 \
+			    chdata2 children2
+			if {$tag2 == "key"} {
+			    set key $chdata2
+			    debugmsg jidlink "KEY: $key"
+			}
+		    }
+		}
+		key {
+		    set key $chdata1
+		    debugmsg jidlink "KEY: $key"
+		}
+		host {
+		    lappend hosts [list $chdata1 \
+				       [jlib::wrapper:getattr $vars1 port]]
+		}
+	    }
+	}
+
+	if {[info exists key]} {
+	    set verify [rand 1000000000]
+
+	    if {$hosts == {}} {
+		variable passive::verify_key
+		variable passive::key_verify
+		set passive::verify_key($verify) $key
+		set passive::key_verify($key) $verify
+
+		set servsock \
+		    [socket -server \
+			 [list ::dtcp::passive::accept $key] 0]
+		lassign [fconfigure $servsock -sockname] addr hostname port
+		set ip [lindex [fconfigure $jlib::lib($connid,sck) -sockname] 0]
+
+		
+		set res [jlib::wrapper:createtag query \
+			     -vars {xmlns jabber:iq:dtcp} \
+			     -subtags [list \
+					   [jlib::wrapper:createtag verify \
+						-chdata $verify] \
+					   [jlib::wrapper:createtag host \
+						-vars [list port $port] \
+						-chdata $ip]]]
+	    } else {
+		variable active::verify_key
+		variable active::key_verify
+		set active::verify_key($verify) $key
+		set active::key_verify($key) $verify
+
+		debugmsg jidlink [list $hosts]
+		after idle [list ::dtcp::active::sock_connect $key $hosts]
+		set res [jlib::wrapper:createtag query \
+			     -vars {xmlns jabber:iq:dtcp} \
+			     -subtags [list [jlib::wrapper:createtag verify \
+						 -chdata $verify]]]
+	    }
+	    return [list result $res]
+	} else {
+	    # TODO
+	}
+    } else {
+	# TODO
+    }
+}
+
+iq::register_handler set query jabber:iq:dtcp ::dtcp::iq_set_handler
+
+jidlink::register_transport dtcp-passive dtcp-active 50 \
+    ::dtcp::passive::connect ::dtcp::passive::send_data ::dtcp::passive::close
+

Copied: trunk/tkabber-plugins/jidlink/plugins/filetransfer.tcl (from rev 1207, trunk/tkabber/plugins/filetransfer/jidlink.tcl)
===================================================================
--- trunk/tkabber-plugins/jidlink/plugins/filetransfer.tcl	                        (rev 0)
+++ trunk/tkabber-plugins/jidlink/plugins/filetransfer.tcl	2007-08-31 11:52:26 UTC (rev 1209)
@@ -0,0 +1,423 @@
+# $Id$
+
+###############################################################################
+# File transfer via Jidlink
+
+namespace eval ftjl {
+    set winid 0
+    set id 0
+    set chunk_size 1024
+    
+    variable options
+
+    custom::defgroup Jidlink \
+	[::msgcat::mc "Jidlink options."] \
+	-group {File Transfer}
+}
+
+###############################################################################
+
+proc ftjl::send_file {token} {
+    upvar #0 $token state
+    variable id
+    variable files
+
+    if {![info exists state(fd)]} return
+
+    incr id
+    set state(id) $id
+    set files(token,$id) $token
+
+    jlib::send_iq set \
+	[jlib::wrapper:createtag query \
+	     -vars {xmlns jabber:iq:filexfer} \
+	     -subtags [list [jlib::wrapper:createtag file \
+				 -vars [list id $id \
+					    name $state(name) \
+					    size $state(size)] \
+				 -chdata $state(desc)]]] \
+	-to $state(jid) \
+	-command [list [namespace current]::send_file_result $token] \
+	-connection $state(connid)
+}
+
+###############################################################################
+
+proc ftjl::send_file_result {token res child} {
+    upvar #0 $token state
+
+    if {![info exists state(fd)]} return
+
+    if {[cequal $res OK]} return
+
+    eval $state(command) ERR \
+	 [list [::msgcat::mc "Request failed: %s" [error_to_string $child]]]
+}
+
+###############################################################################
+
+proc ftjl::send_file_request {connid from lang id offset} {
+    variable files
+
+    if {![info exists files(token,$id)]} {
+	return [list error cancel not-allowed \
+		     -text [::trans::trans $lang "Invalid file ID"]]
+    }
+
+    set token $files(token,$id)
+    upvar #0 $token state
+
+    if {![info exists state(fd)]} {
+	return [list error cancel not-allowed \
+		     -text [::trans::trans $lang "Transfer is expired"]]
+    }
+
+    if {$state(connid) != $connid || $state(jid) != $from} {
+	return [list error cancel not-allowed \
+		     -text [::trans::trans $lang "Invalid file ID"]]
+    }
+
+    set state(key) [rand 1000000000]
+    set state(offset) $offset
+    set res \
+	[jlib::wrapper:createtag query \
+	     -vars {xmlns jabber:iq:filexfer} \
+	     -subtags [list [jlib::wrapper:createtag file \
+				 -vars [list id $id] \
+				 -subtags [list [jlib::wrapper:createtag key \
+						     -chdata $state(key)]]]]]
+    after idle [list [namespace current]::send_file_setup_connection $token]
+    return [list result $res]
+}
+
+###############################################################################
+
+proc ftjl::send_file_setup_connection {token} {
+    upvar #0 $token state
+    variable chunk_size
+
+    if {![info exists state(fd)]} return
+
+    set res [jidlink::connect $state(connid) $state(jid) $state(key)]
+
+    if {$res == 0} {
+	if {[info exists state(command)]} {
+	    eval $state(command) ERR [::msgcat::mc "Jidlink connection failed"]
+	}
+	return
+    }
+
+    set_status [::msgcat::mc "Transferring..."]
+
+    # Transfer window may be destroyed during jidlink::connect
+    if {![info exists state(fd)]} return
+
+    set chunk [read $state(fd) $chunk_size]
+    if {[catch {
+	     while {$chunk != ""} {
+		 jidlink::send_data $state(key) $chunk
+		 update idletasks
+		 eval $state(command) [list PROGRESS [tell $state(fd)]]
+		 after 1000
+		 set chunk [read $state(fd) $chunk_size]
+	     }
+	 }]} {
+	if {[info exists state(command)]} {
+	    eval $state(command) ERR [::msgcat::mc "Jidlink transfer failed"]
+	}
+	return
+    }
+
+    eval $state(command) OK
+}
+
+###############################################################################
+
+proc ftjl::send_file_close {token} {
+    upvar #0 $token state
+    variable files
+
+    if {![info exists state(fd)]} return
+
+    catch {unset files(token,$state(id))}
+    catch {jidlink::close $state(key)}
+}
+
+###############################################################################
+###############################################################################
+
+proc ftjl::recv_file_dialog {connid from lang id name size date hash desc} {
+    variable winid
+    variable files
+    variable result
+
+    set w .rfd$winid
+
+    while {[winfo exists $w]} {
+	incr winid
+	set w .rfd$winid
+    }
+
+    Dialog $w -title [format [::msgcat::mc "Receive file from %s"] $from] \
+	-separator 1 -anchor e \
+	-modal none -default 0 -cancel 1
+
+
+    set f [$w getframe]
+
+    label $f.lname -text [::msgcat::mc "Name:"]
+    label $f.name -text $name
+
+    label $f.lsize -text [::msgcat::mc "Size:"]
+    label $f.size -text $size
+
+    label $f.ldesc -text [::msgcat::mc "Description:"]
+    message $f.desc -width 10c -text $desc
+
+    set dir $ft::options(download_dir)
+    label $f.lsaveas -text [::msgcat::mc "Save as:"]
+    entry $f.saveas -textvariable [namespace current]::saveas$winid
+    variable saveas$winid [file join $dir $name]
+    button $f.browsefile -text [::msgcat::mc "Browse..."] \
+	-command [list [namespace current]::set_receive_file_name $winid $dir $name]
+
+    set pbvar [namespace current]::progress$f.pb
+    ProgressBar $f.pb -variable $pbvar
+    $f.pb configure -maximum $size
+    set $pbvar 0
+
+    grid $f.lname   -row 0 -column 0 -sticky e
+    grid $f.name    -row 0 -column 1 -sticky w
+    
+    grid $f.lsize   -row 1 -column 0 -sticky e
+    grid $f.size    -row 1 -column 1 -sticky w
+    
+    grid $f.ldesc   -row 2 -column 0 -sticky en
+    grid $f.desc    -row 2 -column 1 -sticky ewns -columnspan 2 -pady 1m
+
+    grid $f.lsaveas -row 3 -column 0 -sticky e
+    grid $f.saveas  -row 3 -column 1 -sticky ew
+    grid $f.browsefile  -row 3 -column 2 -sticky ew
+
+    grid $f.pb      -row 4 -column 0 -sticky ew -columnspan 3 -pady 2m
+
+    grid columnconfigure $f 1 -weight 1 -minsize 8c
+    grid rowconfigure $f 2 -weight 1
+    
+    $w add -text [::msgcat::mc "Receive"] -command \
+	[list [namespace current]::recv_file_start $winid $size $pbvar $connid $from $lang $id]
+    $w add -text [::msgcat::mc "Cancel"] -command \
+	[list [namespace current]::recv_file_cancel $winid $lang]
+    bind .rfd$winid <Destroy> \
+            [list [namespace current]::recv_file_failed $winid $lang]
+
+    $w draw
+    vwait [namespace current]::result($winid)
+    set res $result($winid)
+    unset result($winid)
+    incr winid
+    return $res
+}
+
+###############################################################################
+
+proc ftjl::set_receive_file_name {winid dir fname} {
+    variable saveas$winid
+
+    set file [tk_getSaveFile -initialdir $dir -initialfile $fname]
+    if {$file != ""} {
+	set saveas$winid $file
+    }
+}
+
+###############################################################################
+
+proc ftjl::recv_file_start {winid size pbvar connid user lang id} {
+    variable saveas$winid
+    variable files
+
+    set filename [set saveas$winid]
+
+    .rfd$winid itemconfigure 0 -state disabled
+    set $pbvar 0
+
+    #set files(filename,$key) $filename
+
+    jlib::send_iq set \
+	[jlib::wrapper:createtag query \
+	     -vars {xmlns jabber:iq:filexfer} \
+	     -subtags [list [jlib::wrapper:createtag file \
+				 -vars [list id $id]]]] \
+	-to $user \
+	-command [list [namespace current]::recv_file_reply \
+		       $winid $size $pbvar $user $lang $id $filename] \
+	-connection $connid
+}
+
+###############################################################################
+
+proc ftjl::recv_file_reply {winid size pbvar user lang id filename res child} {
+    variable files
+
+    if {$res != "OK"} {
+	recv_file_failed $winid $lang
+	after idle \
+	    [list MessageDlg .auth_err -aspect 50000 -icon error \
+		  -message [format [::msgcat::mc "Receiving file failed: %s"] \
+			        [error_to_string $child]] -type user \
+		  -buttons ok -default 0 -cancel 0]
+	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 == "file"} {
+		foreach item1 $children1 {
+		    jlib::wrapper:splitxml $item1 tag2 vars2 isempty2 \
+			chdata2 children2
+		    if {$tag2 == "key"} {
+			set key $chdata2
+			set files(filename,$key) $filename
+			debugmsg filetransfer "RECV KEY: $key"
+
+			set fd [open $filename w]
+			fconfigure $fd -translation binary
+
+			set files(fd,$key) $fd
+
+			jidlink::set_readable_handler \
+			    $key [list [namespace current]::recv_file_chunk $pbvar]
+			jidlink::set_closed_handler \
+			    $key [list [namespace current]::recv_file_finish $winid $size]
+		    }
+		}
+	    }
+	}
+    }
+}
+
+###############################################################################
+
+proc ftjl::recv_file_chunk {pbvar key} {
+    variable files
+
+    if {[info exists files(filename,$key)]} {
+	set data [jidlink::read_data $key]
+
+	debugmsg filetransfer \
+	    "RECV into $files(filename,$key) data length [string length $data]"
+
+	puts -nonewline $files(fd,$key) $data
+
+	incr $pbvar [string length $data]
+	debugmsg filetransfer [set $pbvar]
+    }
+
+}
+
+###############################################################################
+
+proc ftjl::recv_file_failed {winid lang} {
+    variable result
+
+    bind .rfd$winid <Destroy> {}
+    set result($winid) \
+	[list error modify undefined-condition \
+	      -text [::trans::trans $lang "File transfer is failed"]]
+}
+
+###############################################################################
+
+proc ftjl::recv_file_finish {winid size key} {
+    variable files
+    variable result
+
+    if {[info exists files(filename,$key)]} {
+	debugmsg filetransfer CLOSE
+	catch { close $files(fd,$key) }
+	set fsize [file size $files(filename,$key)]
+	unset files(filename,$key)
+	set_status [::msgcat::mc "Connection closed"]
+    }
+    if {[winfo exists .rfd$winid]} {
+	bind .rfd$winid <Destroy> {}
+	destroy .rfd$winid
+	
+	if {$fsize != $size} {
+	    if {$fsize < $size} {
+		set msg "Transfer interrupted (File size is too small)"
+	    } else {
+		set msg "File size is too large"
+	    }
+	    after idle \
+		[list MessageDlg .auth_err -aspect 50000 -icon error \
+		      -message [format [::msgcat::mc "Receiving file failed: %s"] \
+				    $msg] \
+		      -type user \
+		      -buttons ok -default 0 -cancel 0]
+	}
+    }
+    set result($winid) {result {}}
+}
+
+###############################################################################
+
+proc ftjl::recv_file_cancel {winid lang} {
+    variable result
+
+    catch {
+	bind .rfd$winid <Destroy> {}
+	destroy .rfd$winid
+    }
+    set result($winid) \
+	[list error cancel not-allowed \
+	      -text [::trans::trans $lang "File transfer is refused"]]
+}
+
+###############################################################################
+
+proc ftjl::iq_set_handler {connid from lang child} {
+    debugmsg filetransfer "FTJL set: [list $from $child]"
+
+    jlib::wrapper:splitxml $child tag vars isempty chdata children
+
+    if {$tag != "query"} {
+	return {error modify bad-request}
+    }
+
+    foreach item $children {
+	jlib::wrapper:splitxml $item tag1 vars1 isempty1 chdata1 children1
+	if {$tag1 == "file"} {
+	    if {[jlib::wrapper:getattr $vars1 name] != ""} {
+		return [recv_file_dialog $connid $from $lang \
+		       [jlib::wrapper:getattr $vars1 id] \
+		       [jlib::wrapper:getattr $vars1 name] \
+		       [jlib::wrapper:getattr $vars1 size] \
+		       [jlib::wrapper:getattr $vars1 date] \
+		       [jlib::wrapper:getattr $vars1 hash] \
+		       $chdata1]
+	    } else {
+		return [send_file_request $connid $from $lang \
+			    [jlib::wrapper:getattr $vars1 id] \
+			    [jlib::wrapper:getattr $vars1 offset]]
+	    }
+	}
+    }
+}
+
+iq::register_handler set query jabber:iq:filexfer \
+    [namespace current]::ftjl::iq_set_handler
+
+###############################################################################
+
+ft::register_protocol jidlink \
+    -priority 20 \
+    -label "Jidlink" \
+    -send [namespace current]::ftjl::send_file \
+    -close [namespace current]::ftjl::send_file_close
+
+###############################################################################
+

Copied: trunk/tkabber-plugins/jidlink/plugins/ibb.tcl (from rev 1207, trunk/tkabber/plugins/jidlink/ibb.tcl)
===================================================================
--- trunk/tkabber-plugins/jidlink/plugins/ibb.tcl	                        (rev 0)
+++ trunk/tkabber-plugins/jidlink/plugins/ibb.tcl	2007-08-31 11:52:26 UTC (rev 1209)
@@ -0,0 +1,202 @@
+# $Id$
+
+namespace eval ::ibb {}
+
+proc ::ibb::connect {connid jid key} {
+    variable connection
+
+    set_status [::msgcat::mc "Opening IBB connection"]
+
+    jlib::send_iq set \
+	[jlib::wrapper:createtag query \
+	     -vars {xmlns jabber:iq:ibb} \
+	     -subtags [list [jlib::wrapper:createtag comment \
+				 -subtags [list [jlib::wrapper:createtag key \
+						     -chdata $key]]]]] \
+	-to $jid -command [list ibb::recv_connect_response $connid $jid $key] \
+	-connection $connid
+	 
+    vwait [namespace current]::connection(status,$key)
+}
+
+proc ::ibb::recv_connect_response {connid jid key res child} {
+    variable connection
+
+    if {$res != "OK"} {
+	# TODO
+	set connection(status,$key) 0
+	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 == "streamid"} {
+		set streamid $chdata1
+		debugmsg jidlink "STREAMID: $streamid"
+	    }
+	}
+
+	if {[info exists streamid]} {
+	    variable stream_key
+	    variable key_stream
+
+	    set stream_key($streamid) $key
+	    set key_stream($key) $streamid
+
+	    set connection(connid,$key) $connid
+	    set connection(jid,$key) $jid
+	    set connection(status,$key) 1
+
+	} else {
+	    # TODO
+	}
+    } else {
+	# TODO
+    }
+    set connection(status,$key) 0
+}
+
+package require base64
+
+proc ::ibb::send_data {key data} {
+    variable connection
+    variable key_stream
+
+    debugmsg jidlink [array get stream_key]
+
+    jlib::send_iq set \
+	[jlib::wrapper:createtag query \
+	     -vars {xmlns jabber:iq:inband} \
+	     -subtags [list [jlib::wrapper:createtag streamid \
+				 -chdata $key_stream($key)] \
+			   [jlib::wrapper:createtag data \
+				-chdata [base64::encode $data]]]] \
+	-to $connection(jid,$key) \
+	-command [list ibb::send_data_ack $key] \
+	-connection $connection(connid,$key)
+
+    vwait [namespace current]::connection(ack,$key)
+
+    return $connection(ack,$key)
+}
+
+proc ::ibb::send_data_ack {key res child} {
+    variable connection
+    if {$res != "OK"} {
+	# TODO
+	set connection(ack,$key) 0
+	return
+    }
+    set connection(ack,$key) 1
+}
+
+proc ::ibb::close {key} {
+    variable connection
+    variable key_stream
+
+    jlib::send_iq set \
+	[jlib::wrapper:createtag query \
+	     -vars {xmlns jabber:iq:inband} \
+	     -subtags [list [jlib::wrapper:createtag streamid \
+				 -chdata $key_stream($key)] \
+			   [jlib::wrapper:createtag close]]] \
+	-to $connection(jid,$key) \
+	-connection $connection(connid,$key)
+
+}
+
+proc ::ibb::iq_set_handler {connid from lang child} {
+    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 == "comment"} {
+		foreach item1 $children1 {
+		    jlib::wrapper:splitxml $item1 tag2 vars2 isempty2 \
+			chdata2 children2
+		    if {$tag2 == "key"} {
+			set key $chdata2
+			debugmsg jidlink "KEY: $key"
+		    }
+		}
+	    }
+	}
+
+	if {[info exists key]} {
+	    variable stream_key
+	    variable key_stream
+
+	    set streamid [rand 1000000000]
+	    set stream_key($streamid) $key
+	    set key_stream($key) $streamid
+
+	    set res [jlib::wrapper:createtag query \
+			 -vars {xmlns jabber:iq:ibb} \
+			 -subtags [list [jlib::wrapper:createtag streamid \
+					     -chdata $streamid]]]
+	    return [list result $res]
+	} else {
+	    # TODO
+	}
+    } else {
+	# TODO
+    }
+}
+
+iq::register_handler set query jabber:iq:ibb ibb::iq_set_handler
+
+proc ::ibb::iq_inband_set_handler {connid from lang child} {
+    variable stream_key
+
+    jlib::wrapper:splitxml $child tag vars isempty chdata children
+
+    if {$tag == "query"} {
+	foreach item $children {
+	    jlib::wrapper:splitxml $item tag1 vars1 isempty1 chdata1 children1
+	    switch -- $tag1 {
+		streamid {
+		    set streamid $chdata1
+		}
+		data {
+		    set data $chdata1
+		}
+		close {
+		    set close 1
+		}
+	    }
+	}
+
+	if {[info exists streamid] && [info exists stream_key($streamid)]} {
+	    if {[info exists data]} {
+		if {[catch {set decoded [base64::decode $data]}]} {
+		    # TODO
+		    debugmsg jidlink "IBB: WRONG DATA"
+		} else {
+		    debugmsg jidlink "IBB: RECV DATA [list $data]"
+		    jidlink::recv_data $stream_key($streamid) $decoded
+		}
+		
+	    }
+	    
+	    if {[info exists close]} {
+		jidlink::closed $stream_key($streamid)
+	    }
+
+	    return [list result ""]
+	} else {
+	    # TODO
+	}
+    } else {
+	# TODO
+    }
+}
+
+iq::register_handler set query jabber:iq:inband ibb::iq_inband_set_handler
+
+jidlink::register_transport inband-bytestream inband-bytestream 75 \
+    ibb::connect ibb::send_data ibb::close
+



More information about the Tkabber-dev mailing list