[Tkabber-dev] r1593 - in trunk/tkabber: . plugins/filetransfer plugins/general plugins/si

tkabber-svn at jabber.ru tkabber-svn at jabber.ru
Sat Nov 1 23:07:15 MSK 2008


Author: sergei
Date: 2008-11-01 23:07:14 +0300 (Sat, 01 Nov 2008)
New Revision: 1593

Modified:
   trunk/tkabber/ChangeLog
   trunk/tkabber/datagathering.tcl
   trunk/tkabber/disco.tcl
   trunk/tkabber/plugins/filetransfer/si.tcl
   trunk/tkabber/plugins/general/caps.tcl
   trunk/tkabber/plugins/general/remote.tcl
   trunk/tkabber/plugins/si/socks5.tcl
   trunk/tkabber/search.tcl
   trunk/tkabber/si.tcl
Log:
	* datagathering.tcl: Removed support for undocumented XMLNS
	  jabber:iq:data which was used ages ago for administering ejabberd
	  server.

	* datagathering.tcl, disco.tcl, plugins/general/caps.tcl,
	  plugins/general/remote.tcl, search.tcl: Switched to parsing
	  jabber:x:data forms using xmpp::data package.

	* plugins/si/socks5.tcl: Turned all work into asynchronous mode.

	* plugins/filetransfer/si.tcl, si.tcl: Got rid of unnecessary vwait.


Modified: trunk/tkabber/ChangeLog
===================================================================
--- trunk/tkabber/ChangeLog	2008-11-01 08:26:27 UTC (rev 1592)
+++ trunk/tkabber/ChangeLog	2008-11-01 20:07:14 UTC (rev 1593)
@@ -6,6 +6,18 @@
 	* doc/tkabber.html, doc/tkabber.xml, README: Changed notes about tDOM
 	  parser usage (it is default if it is installed currently).
 
+	* datagathering.tcl: Removed support for undocumented XMLNS
+	  jabber:iq:data which was used ages ago for administering ejabberd
+	  server.
+
+	* datagathering.tcl, disco.tcl, plugins/general/caps.tcl,
+	  plugins/general/remote.tcl, search.tcl: Switched to parsing
+	  jabber:x:data forms using xmpp::data package.
+
+	* plugins/si/socks5.tcl: Turned all work into asynchronous mode.
+
+	* plugins/filetransfer/si.tcl, si.tcl: Got rid of unnecessary vwait.
+
 2008-10-29  Sergei Golovan  <sgolovan at nes.ru>
 
 	* login.tcl, presence.tcl: Fixed resetting user status if all Tkabber

Modified: trunk/tkabber/datagathering.tcl
===================================================================
--- trunk/tkabber/datagathering.tcl	2008-11-01 08:26:27 UTC (rev 1592)
+++ trunk/tkabber/datagathering.tcl	2008-11-01 20:07:14 UTC (rev 1593)
@@ -3,6 +3,8 @@
 # Data Forms (XEP-0004) support
 #
 
+package require xmpp::data
+
 namespace eval data {
     set winid 0
 
@@ -32,80 +34,57 @@
 
 proc data::fill_fields {g items} {
     variable data
-    variable field_labels
 
     set row 0
     set data(varlist,$g) {}
     
     grid columnconfig $g 1 -weight 1 -minsize 0
 
-    foreach item $items {
-	::xmpp::xml::split $item tag xmlns attrs cdata subels
-	if {$xmlns == "jabber:x:data" || $xmlns == "jabber:iq:data"} {
-	    return [fill_fields_x $g $subels]
-	}
+    lassign [::xmpp::data::findForm $items] type form
+
+    if {[string equal $type form]} {
+	set fields [::xmpp::data::parseForm $form]
+    } else {
+	set fields [parse_fields $items]
     }
 
-    set focus ""
-    set fields {}
+    return [fill_fields_x $g $fields]
+}
+
+
+proc data::parse_fields {items} {
+    variable field_labels
+
+    set res {}
     foreach item $items {
 	::xmpp::xml::split $item tag xmlns attrs cdata subels
 
 	switch -- $tag {
 	    instructions {
-		message $g.instructions$row -text $cdata -width 10c
-		grid $g.instructions$row -row $row -column 0 -columnspan 2 \
-		    -sticky w -pady 2m
-		incr row
+		set res [linsert $res 0 instructions $cdata]
 	    }
-	    registered -
 	    x {}
 	    default {
-                lappend fields $tag $cdata
-	    }
-	}
-    }
-    foreach {tag cdata} $fields {
-	lappend data(varlist,$g) $tag
+		switch -- $tag {
+		    key -
+		    registered {set type hidden}
+		    password   {set type text-private}
+		    default    {set type text-single}
+		}
 
-	if {[info exists field_labels($tag)]} {
-	    label $g.l$row -text $field_labels($tag)
-	} else {
-	    label $g.l$row -text $tag
-	}
-	switch -- $tag {
-	    key {
-		entry $g.$row \
-		    -textvariable [namespace current]::data(var,$tag,$g) \
-		    -state disabled
-	    }
-	    password {
-		entry $g.$row \
-		    -textvariable [namespace current]::data(var,$tag,$g) \
-		    -show *
-		if {$focus == ""} {
-		    set focus $g.$row
+		if {[info exists field_labels($tag)]} {
+		    set label $field_labels($tag)
+		} else {
+		    set label $tag
 		}
+
+                lappend res field \
+			[list $tag $type $label "" false {} [list $cdata] {}]
 	    }
-	    default {
-		entry $g.$row \
-		    -textvariable [namespace current]::data(var,$tag,$g)
-		if {$focus == ""} {
-		    set focus $g.$row
-		}
-	    }
 	}
-
-	if {$cdata != {}} {
-	    set data(var,$tag,$g) $cdata
-	}
-
-	grid $g.l$row -row $row -column 0 -sticky e
-	grid $g.$row  -row $row -column 1 -sticky we
-
-	incr row
     }
-    return $focus
+
+    return $res
 }
 
 proc data::cleanup {g} {
@@ -228,42 +207,6 @@
     }   
 }
 
-# parse_result
-proc data::parse_xdata_results {items args} {
-    set report_hidden 0
-    foreach {key val} $args {
-	switch -- $key {
-	    -hidden { set report_hidden $val }
-	}
-    }
-
-    set result {}
-    foreach item $items {
-	::xmpp::xml::split $item tag xmlns attrs cdata subels
-	if {$tag != "field"} {
-	    continue
-	}
-	set type [::xmpp::xml::getAttr $attrs type]
-	if {!$report_hidden && $type == "hidden"} {
-	    continue
-	}
-	set var [::xmpp::xml::getAttr $attrs var]
-	if {$var == ""} {
-	    continue
-	}
-	set label [::xmpp::xml::getAttr $attrs label]
-	set values {}
-	foreach subel $subels {
-	    ::xmpp::xml::split $subel stag sxmlns sattrs scdata ssubels
-	    if {$stag == "value"} {
-		lappend values $scdata
-	    }
-	}
-	lappend result [list $var $type $label $values]
-    }
-    return $result
-}
-
 proc data::add_label {g row label {required 0}} {
     if {$label != ""} {
 	if {$required} {
@@ -329,31 +272,28 @@
     set data(allvarlist,$g) {}
     set focus ""
 
-    foreach item $items {
-	::xmpp::xml::split $item tag xmlns attrs cdata subels
-
+    foreach {tag item} $items {
 	switch -- $tag {
 	    instructions {
-		#add_label $g $row [::msgcat::mc "Instructions"]
-		message $g.instructions$row -text $cdata -width 15c
+		message $g.instructions$row -text $item -width 15c
 		grid $g.instructions$row -row $row -column 0 \
 		    -columnspan 2 -sticky w -pady 2m
 		incr row
 	    }
+	    title {
+		set top [winfo toplevel $g]
+		if {$top != "."} {
+		    wm title $top $item
+		    wm iconname $top $item
+		}
+	    }
 	    field {
-		set widget [fill_field_x $g $row $tag $attrs $cdata $subels]
+		set widget [fill_field_x $g $row $item]
 		if {$focus == ""} {
 		    set focus $widget
 		}
 		incr row
 	    }
-	    title {
-		set top [winfo toplevel $g]
-		if {$top != "."} {
-		    wm title $top $cdata
-		    wm iconname $top $cdata
-		}
-	    }
 	    default {
 		debugmsg filetransfer "XDATA: unknown tag $tag"
 	    }
@@ -367,51 +307,17 @@
 }
 
 
-proc data::fill_field_x {g row tag attrs cdata subels} {
+proc data::fill_field_x {g row item} {
     variable data
 
-    set required 0
-    set desc {}
-    set options {}
-    set vals {}
-    set var   [::xmpp::xml::getAttr $attrs var]
-    set type  [::xmpp::xml::getAttr $attrs type]
+    lassign $item var type label desc required options vals media_list
+
     if {$type == ""} {
 	set type text-single
     }
-    set label [::xmpp::xml::getAttr $attrs label]
-    set data(var,$var,$g) ""
+    set data(var,$var,$g) [lindex $vals 0]
     set widget ""
-    set media_list {}
 
-    foreach item $subels {
-	::xmpp::xml::split $item stag sxmlns sattrs scdata ssubels
-	switch -- $stag {
-	    required {set required 1}
-	    value {
-		set data(var,$var,$g) $scdata
-		lappend vals $scdata
-	    }
-	    desc {set desc $scdata}
-	    option {
-		set lab [::xmpp::xml::getAttr $sattrs label]
-		foreach item $ssubels {
-		    ::xmpp::xml::split $item \
-			sstag ssxmlns ssattrs sscdata sssubels
-		    switch -- $sstag {
-			value {set val $sscdata}
-		    }
-		}
-		lappend options $lab $val
-	    }
-	    media {
-		if {$sxmlns == $::NS(media-element)} {
-		    lappend media_list $item
-		}
-	    }
-	}
-    }
-
     switch -- $type {
 	jid-single -
 	text-single -
@@ -439,7 +345,7 @@
 	    bind $g.text$row <Control-Key-Return> { }
 	    bind $g.text$row <Return> "[bind Text <Return>]\nbreak"
 	    set data(var,$var,$g) [join $vals \n]
-	    catch { $g.text$row insert end $data(var,$var,$g) }
+	    $g.text$row insert end $data(var,$var,$g)
 	    grid $sw -row $row -column 1 -sticky we
 	    set data(text,$var,$g) $g.text$row
 	    set widget $g.text$row
@@ -479,7 +385,7 @@
 	fixed {
 	    add_label $g $row $label $required
 	    set row [render_media $g $row $media_list]
-	    catch { message $g.m$row -text [join $vals \n] -width 10c }
+	    message $g.m$row -text [join $vals \n] -width 10c
 	    grid $g.m$row -row $row -column 1 -sticky w
 	    set dont_report 1
 	    if {$desc != ""} {
@@ -708,14 +614,7 @@
 	return
     }
 
-    switch -- $xmlns {
-	jabber:iq:data {
-	    set subels [list $child]
-	}
-	default {
-	    ::xmpp::xml::split $child tag xmlns attrs cdata subels
-	}
-    }
+    ::xmpp::xml::split $child tag xmlns attrs cdata subels
 
     data::draw_window $subels \
 	[list [namespace current]::send_data $xlib $xmlns $jid $node] \
@@ -730,15 +629,8 @@
 }
 
 proc data::send_data {xlib xmlns jid node w restags} {
-    switch -- $xmlns {
-	jabber:iq:data {
-	    ::xmpp::xml::split [lindex $restags 0] tag xmlns1 attrs cdata subels
-	}
-	default {
-	    set subels $restags
-	    set attrs {}
-	}
-    }
+    set subels $restags
+    set attrs {}
 
     if {$node != ""} {
         lappend attrs node $node
@@ -772,10 +664,6 @@
     pack $m
 }
 
-disco::browser::register_feature_handler jabber:iq:data \
-    [list [namespace current]::data::request_data jabber:iq:data] -node 1 \
-    -desc [list * [::msgcat::mc "Data form"]]
-
 disco::browser::register_feature_handler ejabberd:config \
     [list [namespace current]::data::request_data ejabberd:config] -node 1 \
     -desc [list * [::msgcat::mc "Configure service"]]

Modified: trunk/tkabber/disco.tcl
===================================================================
--- trunk/tkabber/disco.tcl	2008-11-01 08:26:27 UTC (rev 1592)
+++ trunk/tkabber/disco.tcl	2008-11-01 20:07:14 UTC (rev 1593)
@@ -206,9 +206,9 @@
 		}
 	    }
 	    default {
-		if {$sxmlns == $::NS(data) && \
-			[::xmpp::xml::getAttr $sattrs type] == "result"} {
-		    lappend extras [data::parse_xdata_results $ssubels -hidden 1]
+		lassign [::xmpp::data::findForm [list $ch]] type form
+		if {[string equal $type result]} {
+		    lappend extras [::xmpp::data::parseResult $form]
 		}
 	    }
 	}
@@ -697,7 +697,7 @@
     set extranodes {}
     
     foreach eform $extras {
-	foreach extra $eform {
+	foreach {etag extra} $eform {
 	    lassign $extra var type label values
 	    if {$type == "hidden"} continue
 	    set tnode [jid_to_tag "extra $var $jid $node"]

Modified: trunk/tkabber/plugins/filetransfer/si.tcl
===================================================================
--- trunk/tkabber/plugins/filetransfer/si.tcl	2008-11-01 08:26:27 UTC (rev 1592)
+++ trunk/tkabber/plugins/filetransfer/si.tcl	2008-11-01 20:07:14 UTC (rev 1593)
@@ -101,7 +101,7 @@
 ###############################################################################
 ###############################################################################
 
-proc si::recv_file_dialog {xlib from lang id name size date hash desc} {
+proc si::recv_file_dialog {xlib from iqid lang id name size date hash desc} {
     variable winid
 
     set token [namespace current]::[incr winid]
@@ -174,23 +174,14 @@
     grid rowconfigure $f 3 -weight 1
     
     $w add -text [::msgcat::mc "Receive"] -command \
-	[list [namespace current]::recv_file_start $token]
+	[namespace code [list recv_file_start $token $w $iqid]]
     $w add -text [::msgcat::mc "Cancel"] -command \
-	[list [namespace current]::recv_file_cancel $token]
+	[namespace code [list recv_file_cancel $token $w $iqid]]
     
-    bind $w <Destroy> [list [namespace current]::recv_file_close $token $w %W]
+    bind $w <Destroy> [namespace code [list recv_file_cancel $token $w $iqid]]
 
     $w draw
-
-    # Can't avoid vwait, because this procedure must return result or error
-    vwait ${token}(result)
-
-    lassign $state(result) destroy result
-    if {$destroy} {
-	destroy $state(w)
-    }
-
-    return $result
+    return
 }
 
 proc si::set_receive_file_name {token} {
@@ -205,21 +196,22 @@
 
 ###############################################################################
 
-proc si::recv_file_cancel {token} {
+proc si::recv_file_cancel {token w iqid} {
     upvar #0 $token state
 
-    if {![info exists state(result)]} {
-	set state(result) [list 1 [list error cancel not-allowed \
-					-text [::trans::trans $state(lang) \
-						   "File transfer is refused"]]]
-    } elseif {[info exists state(w)] && [winfo exists $state(w)]} {
-	destroy $state(w)
-    }
+    destroy $w
+    ::xmpp::sendIQ $state(xlib) error \
+	    -error [::xmpp::stanzaerror::error cancel not-allowed \
+			    -text [::trans::trans $state(lang) \
+						  "File transfer is refused"]] \
+	    -to $state(jid) \
+	    -id $iqid
+    return
 }
 
 ###############################################################################
 
-proc si::recv_file_start {token} {
+proc si::recv_file_start {token w iqid} {
     upvar #0 $token state
 
     ft::hide_error_msg $state(f)
@@ -233,15 +225,20 @@
     fconfigure $fd -translation binary
 
     $state(w) itemconfigure 0 -state disabled
+    $state(w) itemconfigure 1 -command [namespace code [list recv_file_close $token $w %W]]
+    bind $w <Destroy> [namespace code [list recv_file_close $token $w %W]]
 
     if {[catch {si::newin $state(xlib) $state(jid) $state(id)} stream]} {
 	# Return error to the sender but leave transfer window with disabled
 	# 'Receive' button and error message.
-	set state(result) [list 0 [list error modify bad-request \
-					    -text [::trans::trans $state(lang) \
-						       "Stream ID is in use"]]]
+	::xmpp::sendIQ $state(xlib) error \
+	    -error [::xmpp::stanzaerror::error modify bad-request \
+			    -text [::trans::trans $state(lang) \
+						  "Stream ID is in use"]] \
+	    -to $state(jid) \
+	    -id $iqid
 	ft::report_error $state(f) \
-	    [error_to_string [::msgcat::mc "Receive error: Stream ID is in use"]]
+		[::msgcat::mc "Receive error: Stream ID is in use"]
 	return
     }
 
@@ -254,7 +251,10 @@
     si::set_closed_handler \
 	$stream [list [namespace current]::closed $token]
 
-    set state(result) [list 0 {}]
+    ::xmpp::sendIQ $state(xlib) result \
+	    -to $state(jid) \
+	    -id $iqid
+    return
 }
 
 ###############################################################################
@@ -304,7 +304,7 @@
 ###############################################################################
 ###############################################################################
 
-proc si::si_handler {xlib from lang id mimetype child} {
+proc si::si_handler {xlib from iqid lang id mimetype child} {
     debugmsg filetransfer "SI set: [list $from $child]"
 
     ::xmpp::xml::split $child tag xmlns attrs cdata subels
@@ -322,6 +322,7 @@
 	recv_file_dialog \
 	    $xlib \
 	    $from \
+	    $iqid \
 	    $lang \
 	    $id \
 	    [::xmpp::xml::getAttr $attrs name] \

Modified: trunk/tkabber/plugins/general/caps.tcl
===================================================================
--- trunk/tkabber/plugins/general/caps.tcl	2008-11-01 08:26:27 UTC (rev 1592)
+++ trunk/tkabber/plugins/general/caps.tcl	2008-11-01 20:07:14 UTC (rev 1593)
@@ -43,7 +43,7 @@
     set binextra {}
     foreach eform $extras {
 	set bineform {}
-	foreach extra $eform {
+	foreach {etag extra} $eform {
 	    lassign $extra var type label values
 	    switch -- $var/$type {
 		FORM_TYPE/hidden {
@@ -125,10 +125,9 @@
 		}
 	    }
 	    x {
-		if {[string equal $xmlns $::NS(data)] && \
-		    [string equal [::xmpp::xml::getAttr $sattrs type] result]} {
-		    lappend extras \
-			    [data::parse_xdata_results $ssubels -hidden 1]
+		lassign [::xmpp::data::findForm [list $subel]] type form
+		if {[string equal $type result]} {
+		    lappend extras [::xmpp::data::parseResult $form]
 		}
 	    }
 	}

Modified: trunk/tkabber/plugins/general/remote.tcl
===================================================================
--- trunk/tkabber/plugins/general/remote.tcl	2008-11-01 08:26:27 UTC (rev 1592)
+++ trunk/tkabber/plugins/general/remote.tcl	2008-11-01 20:07:14 UTC (rev 1593)
@@ -354,24 +354,22 @@
 # Parse 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 {
-	::xmpp::xml::split $child tag xmlns attrs cdata subels
 
-	set type [::xmpp::xml::getAttr $attrs type]
-	if {![cequal $tag x] || ![cequal $xmlns $::NS(data)]} {
-	    continue
-	}
-	if {![cequal $type submit]} {
-	    return [::remote::get_error modify bad-request bad-payload]
-	}
+    lassign [::xmpp::data::findForm $children_b] type form
 
-	foreach field [::data::parse_xdata_results $subels -hidden 1] {
-	    lassign $field var type label values
-	    if {[cequal $var FORM_TYPE]} {
-		if {![cequal [lindex $values 0] $form_type]} {
+    if {![string equal $type submit]} {
+	return [::remote::get_error modify bad-request bad-payload]
+    }
+
+    foreach {tag field} [::xmpp::data::parseSubmit $form] {
+	lassign $field var type label values
+	switch -- $var {
+	    FORM_TYPE {
+		if {![string equal [lindex $values 0] $form_type]} {
 		    return [::remote::get_error modify bad-request bad-payload]
 		}
-	    } else {
+	    }
+	    default {
 		lappend result $var $values
 	    }
 	}

Modified: trunk/tkabber/plugins/si/socks5.tcl
===================================================================
--- trunk/tkabber/plugins/si/socks5.tcl	2008-11-01 08:26:27 UTC (rev 1592)
+++ trunk/tkabber/plugins/si/socks5.tcl	2008-11-01 20:07:14 UTC (rev 1593)
@@ -23,60 +23,106 @@
 
 ###############################################################################
 
-proc socks5::target::sock_connect {stream hosts lang} {
+proc socks5::target::sock_connect {stream iqid hosts lang} {
     upvar #0 $stream state
 
-    foreach host $hosts {
-	lassign $host addr port streamhost
-	debugmsg si "CONNECTING TO $addr:$port..."
+    if {[llength $hosts] == 0} {
+	sock_finish $stream $iqid $lang error ""
+    }
 
-	if {[catch {set sock [socket -async $addr $port]}]} continue
+    set tail [lassign $hosts host]
+    lassign $host addr port streamhost
+    debugmsg si "CONNECTING TO $addr:$port..."
 
-	fconfigure $sock -translation binary -blocking no
+    set sock [socket -async $addr $port]
 
-	puts -nonewline $sock "\x05\x01\x00"
-	if {[catch {flush $sock}]} continue
+    fconfigure $sock -translation binary -blocking no
 
-	set state(sock) $sock
+    fileevent $sock writable \
+	      [namespace code [list sock_writable $sock $stream $iqid $lang $streamhost $tail]]
+    return
+}
 
-	fileevent $sock readable \
-	    [list [namespace current]::wait_for_method $sock $stream]
+proc socks5::target::sock_writable {sock stream iqid lang streamhost hosts} {
+    upvar #0 $stream state
 
-	# Can't avoid vwait, because this procedure must return result or error
-	vwait ${stream}(status)
+    if {![info exists state(id)]} {
+	::close $sock
+	sock_finish $stream $iqid $lang error ""
+	return
+    }
 
-	if {$state(status) == 0} continue
+    fileevent $sock writable {}
 
-	set res [::xmpp::xml::create query \
-			-xmlns $::NS(bytestreams) \
-			-subelement [::xmpp::xml::create streamhost-used \
-					    -attrs [list jid $streamhost]]]]
+    if {[catch {fconfigure $sock -peername}]} {
+	::close $sock
+	sock_connect $stream $iqid $hosts $lang
+	return
+    }
 
-	return [list result $res]
+    puts -nonewline $sock "\x05\x01\x00"
+    if {[catch {flush $sock}]} {
+	::close $sock
+	sock_connect $stream $iqid $hosts $lang
+	return
     }
 
-    debugmsg si "FAILED"
+    set state(sock) $sock
 
-    return [list error cancel item-not-found \
-		 -text [::trans::trans \
-			    $lang \
-			    "Cannot connect to any of the streamhosts"]]
+    fileevent $sock readable \
+	      [namespace code [list wait_for_method $sock $stream $iqid $lang $streamhost $hosts]]
+    return
 }
 
+proc socks5::target::sock_finish {stream iqid lang status streamhost} {
+    upvar #0 $stream state
+
+    if {$status == "ok"} {
+	debugmsg si "SUCCEDED ($streamhost)"
+
+	::xmpp::sendIQ $state(xlib) result \
+		-query [::xmpp::xml::create query \
+			    -xmlns $::NS(bytestreams) \
+			    -subelement [::xmpp::xml::create streamhost-used \
+						-attrs [list jid \
+							     $streamhost]]] \
+		-id $iqid \
+		-to $state(jid)
+    } else {
+	debugmsg si "FAILED"
+
+	::xmpp::sendIQ $state(xlib) error \
+		-error [::xmpp::stanzaerror::error cancel item-not-found \
+				-text [::trans::trans \
+					    $lang \
+					    "Cannot connect to any\
+					     of the streamhosts"]] \
+		-id $iqid \
+		-to $state(jid)
+    }
+    return
+}
+
 ###############################################################################
 
-proc socks5::target::wait_for_method {sock stream} {
+proc socks5::target::wait_for_method {sock stream iqid lang streamhost hosts} {
     upvar #0 $stream state
 
+    if {![info exists state(id)]} {
+	::close $sock
+	sock_finish $stream $iqid $lang error ""
+	return
+    }
+
     if {[catch {set data [read $sock]}]} {
 	::close $sock
-	set state(status) 0
+	sock_connect $stream $iqid $hosts $lang
 	return
     }
 
     if {[eof $sock]} {
 	::close $sock
-	set state(status) 0
+	sock_connect $stream $iqid $hosts $lang
 	return
     }
 
@@ -84,7 +130,7 @@
 
     if {$ver != 5 || $method != 0} {
 	::close $sock
-	set state(status) 0
+	sock_connect $stream $iqid $hosts $lang
 	return
     }
 
@@ -99,20 +145,27 @@
     flush $sock
 
     fileevent $sock readable \
-	[list [namespace current]::wait_for_reply $sock $stream]
+	[list [namespace current]::wait_for_reply $sock $stream $iqid $lang $streamhost $hosts]
 }
 
-proc socks5::target::wait_for_reply {sock stream} {
+proc socks5::target::wait_for_reply {sock stream iqid lang streamhost hosts} {
     upvar #0 $stream state
 
+    if {![info exists state(id)]} {
+	::close $sock
+	sock_finish $stream $iqid $lang error ""
+	return
+    }
+
     if {[catch {set data [read $sock]}]} {
 	::close $sock
-	set state(status) 0
+	sock_connect $stream $iqid $hosts $lang
 	return
     }
 
     if {[eof $sock]} {
-	set state(status) 0
+	::close $sock
+	sock_connect $stream $iqid $hosts $lang
 	return
     }
 
@@ -120,13 +173,14 @@
 
     if {$ver != 5 || $rep != 0} {
 	::close $sock
-	set state(status) 0
+	sock_connect $stream $iqid $hosts $lang
 	return
     }
 
-    set state(status) 1
     fileevent $sock readable \
 	[list [namespace parent]::readable $stream $sock]
+
+    sock_finish $stream $iqid $lang ok $streamhost
 }
 
 ###############################################################################
@@ -176,7 +230,7 @@
     if {!$options(enable_mediated_connection)} {
 	request $stream $streamhosts $command
     } else {
-	set proxies [split $options(proxy_servers) " "]
+	set proxies [split $options(proxy_servers)]
 	set proxies1 {}
 	foreach p $proxies {
 	    if {$p != ""} {
@@ -189,10 +243,11 @@
 
 ###############################################################################
 
-proc socks5::initiator::request_proxy {stream streamhosts proxies command} {
+proc socks5::initiator::request_proxy \
+		    {stream streamhosts proxies command} {
     upvar #0 $stream state
 
-    if {[lempty $proxies]} {
+    if {[llength $proxies] == 0} {
 	request $stream $streamhosts $command
     } else {
 	::xmpp::sendIQ $state(xlib) get \
@@ -206,8 +261,13 @@
 }
 
 proc socks5::initiator::recv_request_proxy_response \
-     {stream streamhosts proxies command res child} {
+		    {stream streamhosts proxies command res child} {
+    upvar #0 $stream state
 
+    if {![info exists state(id)]} {
+	return
+    }
+
     if {$res == "abort"} {
 	uplevel #0 $command [list [list 0 [::msgcat::mc "Aborted"]]]
 	return
@@ -245,9 +305,13 @@
 }
 
 proc socks5::initiator::recv_request_response \
-     {stream streamhosts command res child} {
+			{stream streamhosts command res child} {
     upvar #0 $stream state
 
+    if {![info exists state(id)]} {
+	return
+    }
+
     if {$res != "ok"} {
 	uplevel #0 $command [list [list 0 [error_to_string $child]]]
 	return
@@ -294,25 +358,45 @@
     upvar #0 $stream state
 
     debugmsg si "CONNECTING TO PROXY $host:$port..."
-    if {[catch {socket -async $host $port} sock]} {
+
+    set sock [socket -async $host $port]
+
+    fconfigure $sock -translation binary -blocking no
+
+    fileevent $sock writable \
+	      [namespace code [list sock_writable $sock $stream $jid $command]]
+    return
+}
+
+proc socks5::initiator::sock_writable {sock stream jid command} {
+    upvar #0 $stream state
+
+    fileevent $sock writable {}
+
+    if {[catch {fconfigure $sock -peername}]} {
 	debugmsg si "CONNECTION FAILED"
 	uplevel #0 $command [list [list 0 [::msgcat::mc \
 					       "Cannot connect to proxy"]]]
 	return
     }
+
     debugmsg si "CONNECTED"
-    fconfigure $sock -translation binary -blocking no
+
     set state(sock) $sock
 
     puts -nonewline $sock "\x05\x01\x00"
     flush $sock
     fileevent $sock readable \
-	[list [namespace current]::proxy_wait_for_method $sock $stream]
+	[list [namespace current]::proxy_wait_for_method $sock $stream $jid $command]
+    return
+}
 
-    vwait ${stream}(status)
+proc socks5::initiator::sock_finish {sock stream jid command status} {
+    upvar #0 $stream state
 
-    if {$state(status) == 0} {
+    if {$status != "ok"} {
 	debugmsg si "SOCKS5 NEGOTIATION FAILED"
+	::close $sock
 	uplevel #0 $command \
 		[list [list 0 [::msgcat::mc \
 				   "Cannot negotiate proxy connection"]]]
@@ -336,6 +420,10 @@
 proc socks5::initiator::proxy_activate_response {stream command res child} {
     upvar #0 $stream state
 
+    if {![info exists state(id)]} {
+	return
+    }
+
     if {$res != "ok"} {
 	uplevel #0 $command [list [list 0 [error_to_string $child]]]
 	return
@@ -346,26 +434,27 @@
 
 ###############################################################################
 
-proc socks5::initiator::proxy_wait_for_method {sock stream} {
+proc socks5::initiator::proxy_wait_for_method {sock stream jid command} {
     upvar #0 $stream state
 
+    if {![info exists state(id)]} {
+	return
+    }
+
     if {[catch {set data [read $sock]}]} {
-	::close $sock
-	set state(status) 0
+	sock_finish $sock $stream $jid $command error
 	return
     }
 
     if {[eof $sock]} {
-	::close $sock
-	set state(status) 0
+	sock_finish $sock $stream $jid $command error
 	return
     }
 
     binary scan $data cc ver method
 
     if {$ver != 5 || $method != 0} {
-	::close $sock
-	set state(status) 0
+	sock_finish $sock $stream $jid $command error
 	return
     }
 
@@ -380,32 +469,35 @@
     flush $sock
 
     fileevent $sock readable \
-	[list [namespace current]::proxy_wait_for_reply $sock $stream]
+	[list [namespace current]::proxy_wait_for_reply $sock $stream $jid $command]
 }
 
-proc socks5::initiator::proxy_wait_for_reply {sock stream} {
+proc socks5::initiator::proxy_wait_for_reply {sock stream jid command} {
     upvar #0 $stream state
 
+    if {![info exists state(id)]} {
+	return
+    }
+
     if {[catch {set data [read $sock]}]} {
-	::close $sock
-	set state(status) 0
+	sock_finish $sock $stream $jid $command error
 	return
     }
 
     if {[eof $sock]} {
-	set state(status) 0
+	sock_finish $sock $stream $jid $command error
 	return
     }
 
     binary scan $data cc ver rep
 
     if {$ver != 5 || $rep != 0} {
-	::close $sock
-	set state(status) 0
+	sock_finish $sock $stream $jid $command error
 	return
     }
 
-    set state(status) 1
+    sock_finish $sock $stream $jid $command ok
+    return
 }
 
 ###############################################################################
@@ -447,21 +539,19 @@
 
     if {[catch {set data [read $sock]}]} {
 	::close $sock
-	set state(status) 0
 	return
     }
 
     if {[eof $sock]} {
-	set state(status) 0
+	::close $sock
 	return
     }
 
     binary scan $data ccc* ver nmethods methods
 
-    if {$ver != 5 || ![lcontain $methods 0]} {
+    if {$ver != 5 || [lsearch -exact $methods 0] < 0} {
 	puts -nonewline $sock "\x05\xff"
 	::close $sock
-	set state(status) 0
 	return
     }
 
@@ -478,12 +568,11 @@
 
     if {[catch {set data [read $sock]}]} {
 	::close $sock
-	set state(status) 0
 	return
     }
 
     if {[eof $sock]} {
-	set state(status) 0
+	::close $sock
 	return
     }
 
@@ -493,7 +582,6 @@
 	set reply [string replace $data 1 1 \x07]
 	puts -nonewline $sock $reply
 	::close $sock
-	set state(status) 0
 	return
     }
 
@@ -512,7 +600,6 @@
 	set reply [string replace $data 1 1 \x02]
 	puts -nonewline $sock $reply
 	::close $sock
-	set state(status) 0
     }
 }
 
@@ -533,6 +620,7 @@
 proc socks5::iq_set_handler {xlib from child args} {
     ::xmpp::xml::split $child tag xmlns attrs cdata subels
 
+    set iqid [::xmpp::xml::getAttr $args -id]
     set lang [::xmpp::xml::getAttr $args -lang en]
 
     if {$tag != "query"} {
@@ -559,7 +647,7 @@
     }
 
     debugmsg si [list $hosts]
-    [namespace current]::target::sock_connect $stream $hosts $lang
+    [namespace current]::target::sock_connect $stream $iqid $hosts $lang
 }
 
 ::xmpp::iq::register set * $::NS(bytestreams) \

Modified: trunk/tkabber/search.tcl
===================================================================
--- trunk/tkabber/search.tcl	2008-11-01 08:26:27 UTC (rev 1592)
+++ trunk/tkabber/search.tcl	2008-11-01 20:07:14 UTC (rev 1593)
@@ -173,7 +173,16 @@
     ::xmpp::xml::split $xml tag xmlns attrs cdata subels
 
     if {[string equal $xmlns jabber:iq:search]} {
-	set rows [fill_mclistbox $rw $jid $sww.listbox $reported_fields $subels]
+	lassign [::xmpp::data::findForm $subels] type form
+	if {[string equal $type result]} {
+	    set parsedItems [::xmpp::data::parseResult $form]
+	} else {
+	    set reported_fields [linsert $reported_fields 0 jid]
+	    set parsedItems [parse_items $subels]
+	}
+
+	set rows [fill_mclistbox $rw $jid $sww.listbox $reported_fields \
+				 $parsedItems]
     }
 
     if {$rows <= 0} {
@@ -196,7 +205,7 @@
     }
 }
 
-proc search::fill_mclistbox_x {sw jid w reported_fields items} {
+proc search::fill_mclistbox {sw jid w reported_fields items} {
     variable show_all
 
     set width(0) 3
@@ -206,65 +215,52 @@
     set row 0
     set col 1
 
-    foreach item $items {
-	::xmpp::xml::split $item tag xmlns attrs cdata subels
-
+    foreach {tag item} $items {
 	switch -- $tag {
 	    title {
-		if {$cdata != ""} {
-		    wm title $sw $cdata
-		    wm iconname $sw $cdata
+		if {$item != ""} {
+		    wm title $sw $item
+		    wm iconname $sw $item
 		}
 	    }
 	    reported {
 		set reported_fields {}
-		foreach field $subels {
-		    ::xmpp::xml::split $field stag sxmlns sattrs scdata ssubels
-
-		    set lname [::xmpp::xml::getAttr $sattrs "var"]
-		    set label_name($lname) [::xmpp::xml::getAttr $sattrs "label"]
-		    lappend reported_fields $lname
+		foreach {var label} $item {
+		    lappend reported_fields $var
+		    set label_name($var) $label
 		}
 	    }
 	    item {
-		foreach field $subels {
-		    ::xmpp::xml::split $field stag sxmlns sattrs scdata ssubels
-
-		    if {$stag == "field"} {
-			set var [::xmpp::xml::getAttr $sattrs "var"]
-
-			foreach value $ssubels {
-			    ::xmpp::xml::split $value sstag ssxmlns ssattrs sscdata sssubels
-			    
-			    if {($sstag == "value") && ($sscdata != "")} {
-				if {$show_all || ([lsearch -exact $reported_fields $var] != -1)} {
-				    if {![info exists fieldcol($var)]} {
-					set fieldcol($var) $col
-					if {[info exists label_name($var)]} {
-					    set l $label_name($var)
-					} else {
-					    set l $var
-					}
-					set width($col) [string length " $l "]
-					set name($col) $var
-					$w column add $var -label " $l "
-					$w label bind $var <ButtonPress-1> "[namespace current]::sort %W $var"
-					set lasttag $var
-
-					incr col
+		foreach {var values} $item {
+		    foreach value $values {
+			if {![string equal $value ""]} {
+			    if {$show_all || ([lsearch -exact $reported_fields $var] >= 0)} {
+				if {![info exists fieldcol($var)]} {
+				    set fieldcol($var) $col
+				    if {[info exists label_name($var)]} {
+					set l $label_name($var)
+				    } else {
+					set l $var
 				    }
-				    set data($fieldcol($var),$row) $sscdata
+				    set width($col) [string length " $l "]
+				    set name($col) $var
+				    $w column add $var -label " $l "
+				    $w label bind $var <ButtonPress-1> "[namespace current]::sort %W $var"
+				    set lasttag $var
 
-				    debugmsg search "$var $sscdata"
+				    incr col
 				}
+				set data($fieldcol($var),$row) $value
+
+				debugmsg search "$var $value"
 			    }
 			}
 		    }
 		}
+
 		set data(0,$row) [expr {$row + 1}]
 		incr row
 	    }
-	    default {}
 	}	
     }
 
@@ -302,66 +298,27 @@
     return $row
 }
 
-proc search::fill_mclistbox {sw jid w reported_fields items} {
-    variable show_all
+proc search::parse_items {items} {
+    set res {}
 
     foreach item $items {
 	::xmpp::xml::split $item tag xmlns attrs cdata subels
-	if {$tag == "x" && $xmlns == "jabber:x:data"} {
-	    return [fill_mclistbox_x $sw $jid $w $reported_fields $subels]
-	}
-    }
 
-    set width(0) 3
-    set name(0) N
-    $w column add N -label " [::msgcat::mc #] "
-
-    set fieldcol(jid) 1
-    set width(1) 5
-    set name(1) jid
-    $w column add jid -label " jid "
-    $w label bind jid <ButtonPress-1> "[namespace current]::sort %W jid"
- 
-    set row 0
-    set col 2
-
-    foreach item $items {
-	::xmpp::xml::split $item tag xmlns attrs cdata subels
-
 	switch -- $tag {
 	    item {
 		set itemjid [::xmpp::xml::getAttr $attrs jid]
-		set data(1,$row) $itemjid
+		set fields [list jid $itemjid]
 
 		foreach field $subels {
-		    ::xmpp::xml::split $fiels stag sxmlns sattrs scdata ssubels
-
-		    if {$scdata != ""} {
-			if {$show_all || ([lsearch -exact $reported_fields $tag] != -1)} {
-			    if {![info exists fieldcol($tag)]} {
-				set fieldcol($tag) $col
-				set width($col) [string length " $tag "]
-				set name($col) $tag
-				$w column add $tag -label " $tag "
-				$w label bind $tag <ButtonPress-1> "[namespace current]::sort %W $tag"
-				set lasttag $tag
-
-				incr col
-			    }
-			    set data($fieldcol($tag),$row) $scdata
-
-			    debugmsg search "$tag $scdata"
-			}
-		    }
+		    ::xmpp::xml::split $field stag sxmlns sattrs scdata ssubels
+		    lappend fields $stag $scdata
 		}
-		set data(0,$row) [expr {$row + 1}]
-		incr row
 	    }
-	    default {}
-	}	
+	}
+	lappend res item $fields
     }
 
-    finalize_mclistbox $w $row $col name data width
+    return $res
 }
 
 proc search::sort {w tag} {

Modified: trunk/tkabber/si.tcl
===================================================================
--- trunk/tkabber/si.tcl	2008-11-01 08:26:27 UTC (rev 1592)
+++ trunk/tkabber/si.tcl	2008-11-01 20:07:14 UTC (rev 1593)
@@ -322,6 +322,7 @@
 
     ::xmpp::xml::split $xml tag xmlns attrs cdata subels
 
+    set iqid [::xmpp::xml::getAttr $args -id]
     set id [::xmpp::xml::getAttr $attrs id]
     set mimetype [::xmpp::xml::getAttr $attrs mime-type]
     set profile [::xmpp::xml::getAttr $attrs profile]
@@ -335,7 +336,7 @@
 	    ::xmpp::xml::split $item stag sxmlns sattrs scdata ssubels
 	    if {[string equal $sxmlns $profile]} {
 		set profile_res [$profiledata($profile) \
-				     $xlib $from $lang $id $mimetype $item]
+				     $xlib $from $iqid $lang $id $mimetype $item]
 	    } elseif {[string equal $sxmlns \
 			   http://jabber.org/protocol/feature-neg]} {
 		set options [parse_negotiation $item]



More information about the Tkabber-dev mailing list