[Tkabber-dev] [tclxmpp commit] r94 - * xmpp/negotiate.tcl: Added the possibility of unregistering features.

codesite-noreply at google.com codesite-noreply at google.com
Sun Mar 22 19:38:26 MSK 2009


Author: sgolovan
Date: Sun Mar 22 09:37:19 2009
New Revision: 94

Modified:
    trunk/ChangeLog
    trunk/xmpp/negotiate.tcl
    trunk/xmpp/pconnect.tcl
    trunk/xmpp/poll.tcl

Log:
	* xmpp/negotiate.tcl: Added the possibility of unregistering features.

	* xmpp/pconnect.tcl, xmpp/poll.tcl: Added -proxyfilter option for a
	  callback which is invoked if a connecting routine needs info on which
	  proxy to use for a particular host.


Modified: trunk/ChangeLog
==============================================================================
--- trunk/ChangeLog	(original)
+++ trunk/ChangeLog	Sun Mar 22 09:37:19 2009
@@ -1,3 +1,11 @@
+2009-03-22  Sergei Golovan  <sgolovan at nes.ru>
+
+	* xmpp/negotiate.tcl: Added the possibility of unregistering features.
+
+	* xmpp/pconnect.tcl, xmpp/poll.tcl: Added -proxyfilter option for a
+	  callback which is invoked if a connecting routine needs info on which
+	  proxy to use for a particular host.
+
  2009-03-17  Sergei Golovan  <sgolovan at nes.ru>

  	* xmpp/disco.tcl: Cache negative answers to info and items queries

Modified: trunk/xmpp/negotiate.tcl
==============================================================================
--- trunk/xmpp/negotiate.tcl	(original)
+++ trunk/xmpp/negotiate.tcl	Sun Mar 22 09:37:19 2009
@@ -27,6 +27,14 @@
      set CallBack($feature) $command
  }

+# ::xmpp::negotiate::unregister --
+
+proc ::xmpp::negotiate::unregister {feature} {
+    variable CallBack
+
+    catch {unset CallBack($feature)}
+}
+
  # ::xmpp::negotiate::sendOptions --

  proc ::xmpp::negotiate::sendOptions {xlib to feature options args} {

Modified: trunk/xmpp/pconnect.tcl
==============================================================================
--- trunk/xmpp/pconnect.tcl	(original)
+++ trunk/xmpp/pconnect.tcl	Sun Mar 22 09:37:19 2009
@@ -76,6 +76,11 @@
  #       port             the peer's port number
  #       args
  #           -domain      inet (default) | inet6
+#           -proxyfilter A callback which takes host and port as its  
arguments
+#                        and returns a proxy to connect in form of a list
+#                        {type host port username password}. This option  
takes
+#                        precedence over -proxy, -host, -port, -usermname,  
and
+#                        -password options
  #           -proxy       "" (default) | socks4 | socks5 | https
  #           -host        proxy hostname (required if -proxy isn't "")
  #           -port        port number (required if -proxy isn't "")
@@ -93,15 +98,28 @@
  proc ::pconnect::socket {host port args} {
      variable packs

-    array set Args {-domain    inet
-                    -proxy     ""
-                    -host      ""
-                    -port      ""
-                    -username  ""
-                    -password  ""
-                    -useragent ""
-                    -command   ""}
+    array set Args {-domain      inet
+                    -proxyfilter ""
+                    -proxy       ""
+                    -host        ""
+                    -port        ""
+                    -username    ""
+                    -password    ""
+                    -useragent   ""
+                    -command     ""}
      array set Args $args
+
+    set proxyfilter $Args(-proxyfilter)
+
+    if {[string length $proxyfilter] > 0 && \
+                ![catch {eval $proxyfilter $host $port} answer]} {
+        array set Args [list -proxy    [lindex $answer 0] \
+                             -host     [lindex $answer 1] \
+                             -port     [lindex $answer 2] \
+                             -username [lindex $answer 3] \
+                             -password [lindex $answer 4]]
+    }
+
      set proxy $Args(-proxy)

      if {[string length $proxy] > 0 && ![info exists packs($proxy)]} {
@@ -115,7 +133,8 @@
              set aport $Args(-port)
          } else {
              return -code error [::msgcat::mc "Options \"-host\" and  
\"-port\"\
-                                              are required"]
+                                              are required (or your proxy  
filter\
+                                              hasn't returned them)"]
          }
      } else {
          set ahost $host

Modified: trunk/xmpp/poll.tcl
==============================================================================
--- trunk/xmpp/poll.tcl	(original)
+++ trunk/xmpp/poll.tcl	Sun Mar 22 09:37:19 2009
@@ -115,17 +115,18 @@
              -stanzacommand        {set state(stanzaCmd)        $val}
              -eofcommand           {set state(eofCmd)           $val}
              -command              {set cmd                     $val}
-            -timeout   -
-            -min       -
-            -max       -
-            -url       -
-            -usekeys   -
-            -numkeys   {set state($key)    $val}
-            -host      {set proxyHost      $val}
-            -port      {set proxyPort      $val}
-            -username  {set proxyUsername  $val}
-            -password  {set proxyPassword  $val}
-            -useragent {set proxyUseragent $val}
+            -timeout     -
+            -min         -
+            -max         -
+            -url         -
+            -usekeys     -
+            -numkeys     {set state($key)    $val}
+            -proxyfilter {set proxyFilter    $val}
+            -host        {set proxyHost      $val}
+            -port        {set proxyPort      $val}
+            -username    {set proxyUsername  $val}
+            -password    {set proxyPassword  $val}
+            -useragent   {set proxyUseragent $val}
          }
      }

@@ -141,15 +142,46 @@
          ::http::config -useragent $proxyUseragent
      }

+    if {[info exists proxyFilter]} {
+        # URLmatcher is borrowed from http package.
+        set URLmatcher {(?x)                    # this is _expanded_ syntax
+            ^
+            (?: (\w+) : ) ?                     # <protocol scheme>
+            (?: //
+                (?:
+                    (
+                        [^@/\#?]+               # <userinfo part of  
authority>
+                    ) @
+                )?
+                ( [^/:\#?]+ )                   # <host part of authority>
+                (?: : (\d+) )?                  # <port part of authority>
+            )?
+            ( / [^\#?]* (?: \? [^\#?]* )?)?     # <path> (including query)
+            (?: \# (.*) )?                      # <fragment>
+            $
+        }
+
+        if {[regexp -- $URLmatcher $state(-url) -> \
+                       proto user host port srvurl]} {
+            if {![catch {eval $proxyFilter $host} answer]} {
+                foreach {phost pport proxyUsername proxyPassword} $answer {
+                    break
+                }
+            }
+        }
+
+        ::http::config -proxyfilter $proxyFilter
+    }
+
      if {[info exists proxyHost] && [info exists proxyPort]} {
          ::http::config -proxyhost $proxyHost -proxyport $proxyPort
+    }

-        if {[info exists proxyUsername] && [info exists proxyPassword]} {
-            set auth \
-                [base64::encode \
-                        [encoding convertto $proxyUsername:$proxyPassword]]
-            set state(proxyAuth) [list Proxy-Authorization "Basic $auth"]
-        }
+    if {[info exists proxyUsername] && [info exists proxyPassword]} {
+        set auth \
+            [base64::encode \
+                    [encoding convertto $proxyUsername:$proxyPassword]]
+        set state(proxyAuth) [list Proxy-Authorization "Basic $auth"]
      }

      if {$state(-usekeys)} {


More information about the Tkabber-dev mailing list