[Tkabber-dev] r1747 - in trunk/tkabber: . ifacetk plugins/chat plugins/filetransfer plugins/general plugins/si sounds/default

tkabber-svn at jabber.ru tkabber-svn at jabber.ru
Fri Mar 27 19:08:05 MSK 2009


Author: sergei
Date: 2009-03-27 19:08:04 +0300 (Fri, 27 Mar 2009)
New Revision: 1747

Added:
   trunk/tkabber/plugins/chat/shuffle.tcl
   trunk/tkabber/plugins/general/sigh.tcl
   trunk/tkabber/proxy.tcl
   trunk/tkabber/sounds/default/sigh.wav
Modified:
   trunk/tkabber/ChangeLog
   trunk/tkabber/custom.tcl
   trunk/tkabber/ifacetk/iface.tcl
   trunk/tkabber/ifacetk/ilogin.tcl
   trunk/tkabber/login.tcl
   trunk/tkabber/plugins/filetransfer/http.tcl
   trunk/tkabber/plugins/si/socks5.tcl
   trunk/tkabber/splash.tcl
   trunk/tkabber/tkabber.tcl
Log:
	* custom.tcl: Run commands associated with customizable variables on
	  Tkabber start even if custom.tcl doesn't exist. Otherwise Tkabber
	  pixmaps theme can't be loaded.

	* plugins/si/socks5.tcl: Fixed bug with forgotten return in case when
	  connection to all received smarthosts failed.

	* ifacetk/iface.tcl, ifacetk/ilogin.tcl, login.tcl,
	  plugins/filetransfer/http.tcl, plugins/si/socks5.tcl, proxy.tcl,
	  splash.tcl, tkabber.tcl: Separated proxy servers management from
	  login and loginconf array. Made choosing proxy depending from a
	  hostname to connect to. Use proxy if necessary in file transfers.

	* Added two temporary plugins.


Modified: trunk/tkabber/ChangeLog
===================================================================
--- trunk/tkabber/ChangeLog	2009-03-26 19:17:54 UTC (rev 1746)
+++ trunk/tkabber/ChangeLog	2009-03-27 16:08:04 UTC (rev 1747)
@@ -1,3 +1,18 @@
+2009-03-27  Sergei Golovan  <sgolovan at nes.ru>
+
+	* custom.tcl: Run commands associated with customizable variables on
+	  Tkabber start even if custom.tcl doesn't exist. Otherwise Tkabber
+	  pixmaps theme can't be loaded.
+
+	* plugins/si/socks5.tcl: Fixed bug with forgotten return in case when
+	  connection to all received smarthosts failed.
+
+	* ifacetk/iface.tcl, ifacetk/ilogin.tcl, login.tcl,
+	  plugins/filetransfer/http.tcl, plugins/si/socks5.tcl, proxy.tcl,
+	  splash.tcl, tkabber.tcl: Separated proxy servers management from
+	  login and loginconf array. Made choosing proxy depending from a
+	  hostname to connect to. Use proxy if necessary in file transfers.
+
 2009-03-20  Sergei Golovan  <sgolovan at nes.ru>
 
 	* messages.tcl: Put messages in the message archive only if they have

Modified: trunk/tkabber/custom.tcl
===================================================================
--- trunk/tkabber/custom.tcl	2009-03-26 19:17:54 UTC (rev 1746)
+++ trunk/tkabber/custom.tcl	2009-03-27 16:08:04 UTC (rev 1747)
@@ -800,22 +800,19 @@
 
     set custom_loaded 0
 
-    if {![file readable $options(customfile)]} {
-	set custom_loaded 1
-	return
-    }
+    if {[file readable $options(customfile)]} {
+	set fd [open $options(customfile) r]
+	fconfigure $fd -encoding utf-8
 
-    set fd [open $options(customfile) r]
-    fconfigure $fd -encoding utf-8
+	set opts [read $fd]
+	close $fd
 
-    set opts [read $fd]
-    close $fd
+	foreach opt $opts {
+	    lassign $opt varname value
 
-    foreach opt $opts {
-	lassign $opt varname value
-
-	set saved($varname) $value
-	catch {set $varname $value}
+	    set saved($varname) $value
+	    catch {set $varname $value}
+	}
     }
 
     foreach idx [array names var default,*] {

Modified: trunk/tkabber/ifacetk/iface.tcl
===================================================================
--- trunk/tkabber/ifacetk/iface.tcl	2009-03-26 19:17:54 UTC (rev 1746)
+++ trunk/tkabber/ifacetk/iface.tcl	2009-03-27 16:08:04 UTC (rev 1747)
@@ -372,6 +372,8 @@
 		    {separator} \
 		  ]] \
 		  {separator} \
+		  [list command [::msgcat::mc "Manage proxy servers"] {} {} {} \
+		       -command {proxy::open}] \
 		  [list command [::msgcat::mc "Customize"] {} {} {} \
 		       -command {custom::open_window Tkabber}] \
 		  {separator} \

Modified: trunk/tkabber/ifacetk/ilogin.tcl
===================================================================
--- trunk/tkabber/ifacetk/ilogin.tcl	2009-03-26 19:17:54 UTC (rev 1746)
+++ trunk/tkabber/ifacetk/ilogin.tcl	2009-03-27 16:08:04 UTC (rev 1747)
@@ -285,7 +285,7 @@
 	grid columnconfigure $httppoll_page 1 -weight 1
     }
     
-    if {$have_proxy} {
+    if {0 && $have_proxy} {
 	set proxy_page [$nb insert end proxy_page -text [::msgcat::mc "Proxy"]]
 
 	label $l.lproxy -text [::msgcat::mc "Proxy type:"]

Modified: trunk/tkabber/login.tcl
===================================================================
--- trunk/tkabber/login.tcl	2009-03-26 19:17:54 UTC (rev 1746)
+++ trunk/tkabber/login.tcl	2009-03-27 16:08:04 UTC (rev 1747)
@@ -21,17 +21,6 @@
     set have_sasl 1
 }
 
-set have_proxy 0
-if {![catch {package require pconnect::socks4}]} {
-    set have_proxy 1
-}
-if {![catch {package require pconnect::socks5}]} {
-    set have_proxy 1
-}
-if {![catch {package require pconnect::https}]} {
-    set have_proxy 1
-}
-
 if {[catch {package require xmpp::transport::poll}]} {
     set have_http_poll 0
 } else {
@@ -114,40 +103,6 @@
 	-group Login -type file
 }
 
-if {$have_proxy} {
-    set values [list none [::msgcat::mc "None"]]
-    if {![catch {package present pconnect::https}]} {
-	lappend values https [::msgcat::mc "HTTPS"]
-    }
-    if {![catch {package present pconnect::socks4}]} {
-	lappend values socks4 [::msgcat::mc "SOCKS4a"]
-    }
-    if {![catch {package present pconnect::socks5}]} {
-	lappend values socks5 [::msgcat::mc "SOCKS5"]
-    }
-    custom::defvar loginconf(proxy) none \
-	[::msgcat::mc "Proxy type to connect."] \
-	-group Login -type options \
-	-values $values
-    custom::defvar loginconf(proxyhost) "localhost" \
-	[::msgcat::mc "HTTP proxy address."] \
-	-group Login -type string
-    custom::defvar loginconf(proxyport) 3128 \
-	[::msgcat::mc "HTTP proxy port."] \
-	-group Login -type integer
-    custom::defvar loginconf(proxyusername) "" \
-	[::msgcat::mc "HTTP proxy username."] \
-	-group Login -type string
-    custom::defvar loginconf(proxypassword) "" \
-	[::msgcat::mc "HTTP proxy password."] \
-	-group Login -type password
-    custom::defvar loginconf(proxyuseragent) \
-	"Mozilla/4.0 (compatible; MSIE 6.0;\
-	 $::tcl_platform(os) $::tcl_platform(osVersion))" \
-	[::msgcat::mc "User-Agent string."] \
-	-group Login -type string
-}
-
 custom::defvar loginconf(usealtserver) 0 \
     [::msgcat::mc "Use explicitly-specified server address and port."] \
     -group Login -type boolean
@@ -501,7 +456,7 @@
 }
 
 proc login_connect {logindata} {
-    global use_tls have_compress have_sasl have_http_poll have_proxy
+    global use_tls have_compress have_sasl have_http_poll
     global tls_warning_info
     global reconnect
 
@@ -518,21 +473,8 @@
 
     set ascii_server [idna::domain_toascii $lc(server)]
 
-    set args {}
+    set args {-proxyfilter ::proxy::proxyfilter}
 
-    if {$have_proxy} {
-	if {($lc(proxy) != "none")} {
-	    lappend args -proxy     $lc(proxy)
-	    lappend args -host      $lc(proxyhost)
-	    lappend args -port      $lc(proxyport)
-	    lappend args -username  $lc(proxyusername)
-	    lappend args -password  $lc(proxypassword)
-	    lappend args -useragent $lc(proxyuseragent)
-	} else {
-	    lappend args -proxy ""
-	}
-    }
-
     if {$have_http_poll && $lc(usehttppoll)} {
 	if {$lc(pollurl) != ""} {
 	    set url $lc(pollurl)

Added: trunk/tkabber/plugins/chat/shuffle.tcl
===================================================================
--- trunk/tkabber/plugins/chat/shuffle.tcl	                        (rev 0)
+++ trunk/tkabber/plugins/chat/shuffle.tcl	2009-03-27 16:08:04 UTC (rev 1747)
@@ -0,0 +1,236 @@
+# Written by Ruslan Rakhmanin <rakhmaninr at gmail.com>
+# Thanks to Serge Yudin xmpp:bigote at jabber.ru
+
+namespace eval text_shuffler {
+    variable testing 0
+    variable nicks_collection
+    variable url_regexp {
+        (^|\s)
+        ([^\w\d]*)
+        (
+        (?:
+        (?: ftp|https?)://[-\w]+(\.\w[-\w]*)*
+        |
+        (?: [a-z0-9][-a-z0-9]* \. )+
+        (?: com
+        | edu
+        | biz
+        | gov
+        | in(?:t|fo)
+        | mil
+        | net
+        | org
+        | name
+        | aero
+        | arpa
+        | coop
+        | museum
+        | pro
+        | travel
+        | asia
+        | [a-z][a-z]
+        )
+        )
+        (?: : \d+ )?
+        (?:
+        (?:
+        /
+        [^.,?!:;"'<>()\[\]{}\s\x7F-\xFF]*
+        )?
+        (?:
+        [.,?!:;]+ [^.,?!:;"'<>()\[\]{}\s\x7F-\xFF]+
+        )*
+        )?
+        )
+        ([^\w\d]*)
+        (\s|$)
+    }
+}
+
+# --------------------------------------------------
+# Procedure for collecting nicks in groupchars
+# Thanks to Alexey Smirnov <alexey.smirnov at gmx.com>
+# --------------------------------------------------
+proc text_shuffler::collecting_nicks {xlib jid type x args} {
+    variable nicks_collection
+
+    if {$type != "available" && $type != "unavailable"} {
+        return
+    }
+
+    set group [::xmpp::jid::stripResource $jid]
+    set chatid [::chat::chatid $xlib $group]
+
+    if {[::chat::is_opened $chatid]} {
+        if {[::chat::is_groupchat $chatid]} {
+            if {[::xmpp::jid::resource $jid] == ""} {
+                return
+            }
+            set nick [::chat::get_nick $xlib $jid groupchat]
+            if {[info exists nicks_collection($group)]} {
+		set idx [lsearch -exact $nicks_collection($group) $nick]
+                if {$idx >= 0} {
+		    if {$type == "unavailable"} {
+			set nicks_collection($group) \
+			    [lreplace $nicks_collection($group) $idx $idx]
+		    }
+                } else {
+		    if {$type == "available"} {
+			lappend nicks_collection($group) $nick
+		    }
+		}
+            } else {
+		if {$type == "available"} {
+		    lappend nicks_collection($group) $nick
+		}
+	    }
+        }
+    }
+}
+hook::add client_presence_hook \
+        [namespace current]::text_shuffler::collecting_nicks 99
+
+proc text_shuffler::shuffle_message {chatid user body type} {
+    variable testing
+    set group [chat::get_jid $chatid]
+    set seconds [clock seconds]
+    if {$testing || ([clock format $seconds -format %m/%d] == "04/01" && rand() < 0.05)} {
+        upvar args margs
+        set body [shuffle_text [lindex $margs 2] $group]
+        set margs [lreplace $margs 2 2 $body]
+    }
+}
+
+hook::add chat_send_message_hook \
+        [namespace current]::text_shuffler::shuffle_message 55
+
+
+proc text_shuffler::shuffle_text {text {group ""}} {
+    set shtext ""
+    variable url_regexp
+    set at 0
+    while {1} {
+        set matched [regexp -expanded -nocase -indices \
+                -start $at -- $url_regexp $text -> _ _ bounds]
+        if {$matched} {
+            lassign $bounds ub ue
+            if {$at != $ub} {
+                append shtext [shuffle_subtext [string range $text $at [expr $ub - 1]] $group]
+            }
+            append shtext [string range $text $ub $ue]
+            set at [expr $ue + 1]
+        } else {
+            append shtext [shuffle_subtext [string range $text $at end] $group]
+            set at [string length $text]
+        }
+        if {$at == [string length $text]} {
+            break
+        }
+    }
+    return $shtext
+}
+
+
+proc text_shuffler::shuffle_subtext {text_part {group ""}} {
+    variable nicks_collection
+    set nicks ""
+    if {[info exists nicks_collection($group)]} {
+        set nicks $nicks_collection($group)
+    }
+    set tindex [list -1 [string length $text_part]]
+    foreach nick $nicks {
+        set startindex 0
+        set nicklen [string length $nick]
+        while {[set index [string first $nick $text_part $startindex]] != -1} {
+            set startindex [expr $index + $nicklen]
+            set first 1
+            for {set i 0} {$i < [llength $tindex]} {incr i} {
+                if {$first} {
+                    if {[lindex $tindex $i] >= $index} {
+                        set tindex [linsert $tindex $i $index]
+                        set first 0
+                    }
+                } else {
+                    if {[lindex $tindex $i] <= $index} {
+                        set tindex [lreplace $tindex $i $i]
+                        incr i -1
+                    } else {
+                        set tindex [linsert $tindex $i [expr $index + $nicklen]]
+                        break
+                    }
+                }
+            }
+        }
+    }
+    set shtext ""
+    set previ 0
+    foreach {ib ie} $tindex {
+        if {$ie == [llength $tindex]} {
+            set ie [incr [llength $tindex] -1]
+        }
+        if {$previ != $ib} {
+            append shtext [string range $text_part $previ $ib]
+        }
+        set previ $ie
+        if {$ib != $ie} {
+            set substring [string range $text_part [expr $ib + 1]  [expr $ie - 1]]
+
+            foreach subpart [regexp -inline -all {[[:alpha:]]+|[^[:alpha:]]} $substring] {
+                if {[regexp {[[:alpha:]]} $subpart]} {
+                    set subpart [shuffle_word $subpart]
+                }
+                append shtext $subpart
+            }
+        }
+    }
+    if {$previ != [expr [llength $tindex] - 1]} {
+        append shtext [string range $text_part $previ [expr [llength $tindex] - 1]]
+    }
+    return $shtext
+}
+
+
+proc text_shuffler::shuffle_word {nick} {
+    set snick $nick
+    if {[string length $snick] > 3} {
+        if {[string length $snick] == 4} {
+            set c1 [string index $snick 1]
+            set c2 [string index $snick 2]
+            set snick [string replace $snick 1 1 $c2]
+            set snick [string replace $snick 2 2 $c1]
+        } elseif {[string length $snick] == 5} {
+            set c3 [string index $snick 3]
+            set c2 [string index $snick 2]
+            set snick [string replace $snick 3 3 $c2]
+            set snick [string replace $snick 2 2 $c3]
+        } elseif {[string length $snick] == 6} {
+            set c3 [string index $snick 3]
+            set c2 [string index $snick 2]
+            set snick [string replace $snick 3 3 $c2]
+            set snick [string replace $snick 2 2 $c3]
+        } else {
+            set ss [string range $snick 2 end-2]
+            set ns ""
+            set count 4
+            while {[string length $ss] > 1} {
+                set slen [string length $ss]
+                if {$count < $slen} {
+                    set slen $count
+                }
+                set n [expr int(rand() * $slen)]
+                append ns [string index $ss $n]
+                set ss [string replace $ss $n $n]
+                if {$count == 0} {
+                    set count 4
+                } else  {
+                    incr count -1
+                }
+            }
+            append ns $ss
+            set snick [string replace $snick 2 end-2 $ns]
+        }
+    }
+
+    return $snick
+}
+


Property changes on: trunk/tkabber/plugins/chat/shuffle.tcl
___________________________________________________________________
Added: svn:keywords
   + Author Date Id Revision
Added: svn:eol-style
   + native

Modified: trunk/tkabber/plugins/filetransfer/http.tcl
===================================================================
--- trunk/tkabber/plugins/filetransfer/http.tcl	2009-03-26 19:17:54 UTC (rev 1746)
+++ trunk/tkabber/plugins/filetransfer/http.tcl	2009-03-27 16:08:04 UTC (rev 1747)
@@ -258,7 +258,7 @@
     set fds($winid) $fd
 
     set geturl \
-	[list ::http::geturl $url -channel $fd \
+	[list ::proxy::http::geturl $url -channel $fd \
 	      -blocksize $chunk_size \
 	      -progress [list [namespace current]::recv_file_progress $f.pb] \
 	      -command [list [namespace current]::recv_file_finish $winid $lang]]

Added: trunk/tkabber/plugins/general/sigh.tcl
===================================================================
--- trunk/tkabber/plugins/general/sigh.tcl	                        (rev 0)
+++ trunk/tkabber/plugins/general/sigh.tcl	2009-03-27 16:08:04 UTC (rev 1747)
@@ -0,0 +1,83 @@
+# Written by Ruslan Rakhmanin <rakhmaninr at gmail.com>
+# Sound and testing by Serge Yudin xmpp:bigote at jabber.ru
+
+namespace eval sigh {
+    # Maximum number of animation steps
+    variable steps_num 20
+    # Step duration in mc
+    variable step_duration 100
+    variable testing 0
+}
+
+proc sigh::setup {} {
+    set ::sound::options(sigh_sound) [fullpath sounds default sigh.wav]
+    ::sound::load_sound_file sigh
+    after 1000 [namespace current]::is_sigh
+}
+
+hook::add finload_hook [namespace current]::sigh::setup
+
+proc sigh::is_sigh {} {
+    variable testing
+    # Every 15 seconds try random number
+    after 300000 [namespace current]::is_sigh
+    set seconds [clock seconds]
+    if {$testing || [clock format $seconds -format %m/%d] == "04/01"} {
+        # Probability of sigh is 5% at every 5 minutes
+        if {$testing || rand() < 0.05} {
+            regexp -- {([0-9]+)x([0-9]+)\+?([0-9-]+)\+?([0-9-]+)} \
+                    [wm geometry .] -> x y kx ky
+            ::sound::play $::sound::sounds(sigh)
+            [namespace current]::make_step 1 $x $y $kx $ky
+        }
+    }
+}
+
+
+proc sigh::make_step {step x y kx ky} {
+    variable step_duration
+    variable steps_num
+    # Geometry of window could be changed maximum in 5%
+    set dif_w [expr {($x / 100 * 5) * sin(3.1415926 / $steps_num * $step)} ]
+    set dif_h [expr {($y / 100 * 5) * sin(3.1415926 / $steps_num * $step)} ]
+
+    set newgeometry [expr round($dif_w + $x)]x[expr round($dif_h + $y)]
+
+    if {$kx >= 0} {
+	set sx [expr round(-$dif_w/2 + $kx)]
+	if {$sx < 0} {
+	    set sx 0
+	}
+	append newgeometry +$sx
+    } else {
+	set sx [expr round(-$dif_w/2 - $kx)]
+	if {$sx < 0} {
+	    set sx 0
+	}
+	append newgeometry -$sx
+    }
+    if {$ky >= 0} {
+	set sy [expr round(-$dif_h/2 + $ky)]
+	if {$sy < 0} {
+	    set sy 0
+	}
+	append newgeometry +$sy
+    } else {
+	set sy [expr round(-$dif_h/2 - $ky)]
+	if {$sy < 0} {
+	    set sy 0
+	}
+	append newgeometry -$sy
+    }
+    wm geometry . $newgeometry
+    if {$step == 0} {
+        return
+    }
+    incr step
+    if {$step <= $steps_num} {
+        after $step_duration [namespace current]::make_step $step $x $y $kx $ky
+    } else {
+        after $step_duration [namespace current]::make_step 0 $x $y $kx $ky
+    }
+}
+


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

Modified: trunk/tkabber/plugins/si/socks5.tcl
===================================================================
--- trunk/tkabber/plugins/si/socks5.tcl	2009-03-26 19:17:54 UTC (rev 1746)
+++ trunk/tkabber/plugins/si/socks5.tcl	2009-03-27 16:08:04 UTC (rev 1747)
@@ -26,28 +26,33 @@
 proc socks5::target::sock_connect {stream iqid hosts lang} {
     upvar #0 $stream state
 
-    if {[llength $hosts] == 0} {
+    if {![info exists state(id)] || [llength $hosts] == 0} {
 	sock_finish $stream $iqid $lang error ""
+	return
     }
 
     set tail [lassign $hosts host]
     lassign $host addr port streamhost
     debugmsg si "CONNECTING TO $addr:$port..."
 
-    set sock [socket -async $addr $port]
-
-    fconfigure $sock -translation binary -blocking no
-
-    fileevent $sock writable \
-	      [namespace code [list sock_writable $sock $stream $iqid $lang $streamhost $tail]]
+    set token [::pconnect::socket $addr $port \
+		    -proxyfilter ::proxy::proxyfilter \
+		    -command [namespace code [list sock_writable \
+						   $stream $iqid $lang \
+						   $streamhost $tail]]]
     return
 }
 
-proc socks5::target::sock_writable {sock stream iqid lang streamhost hosts} {
+proc socks5::target::sock_writable {stream iqid lang streamhost hosts status sock} {
     upvar #0 $stream state
 
-    fileevent $sock writable {}
+    if {$status != "ok"} {
+	sock_connect $stream $iqid $hosts $lang
+	return
+    }
 
+    fconfigure $sock -translation binary -blocking no
+
     if {![info exists state(id)]} {
 	::close $sock
 	sock_finish $stream $iqid $lang error ""
@@ -70,7 +75,8 @@
     set state(sock) $sock
 
     fileevent $sock readable \
-	      [namespace code [list wait_for_method $sock $stream $iqid $lang $streamhost $hosts]]
+	      [namespace code [list wait_for_method $sock $stream $iqid \
+						    $lang $streamhost $hosts]]
     return
 }
 
@@ -145,7 +151,8 @@
     flush $sock
 
     fileevent $sock readable \
-	[list [namespace current]::wait_for_reply $sock $stream $iqid $lang $streamhost $hosts]
+	[list [namespace current]::wait_for_reply $sock $stream $iqid \
+						  $lang $streamhost $hosts]
 }
 
 proc socks5::target::wait_for_reply {sock stream iqid lang streamhost hosts} {
@@ -357,23 +364,18 @@
 proc socks5::initiator::proxy_connect {stream jid host port command} {
     upvar #0 $stream state
 
-    debugmsg si "CONNECTING TO PROXY $host:$port..."
+    debugmsg si "CONNECTING TO SOCKS5 PROXY $host:$port..."
 
-    set sock [socket -async $host $port]
-
-    fconfigure $sock -translation binary -blocking no
-
-    fileevent $sock writable \
-	      [namespace code [list sock_writable $sock $stream $jid $command]]
+    set token [::pconnect::socket $host $port \
+		    -proxyfilter ::proxy::proxyfilter \
+		    -command [namespace code [list sock_writable $stream $jid $command]]]
     return
 }
 
-proc socks5::initiator::sock_writable {sock stream jid command} {
+proc socks5::initiator::sock_writable {stream jid command status sock} {
     upvar #0 $stream state
 
-    fileevent $sock writable {}
-
-    if {[catch {fconfigure $sock -peername}]} {
+    if {$status != "ok"} {
 	debugmsg si "CONNECTION FAILED"
 	uplevel #0 $command [list [list 0 [::msgcat::mc \
 					       "Cannot connect to proxy"]]]
@@ -382,6 +384,7 @@
 
     debugmsg si "CONNECTED"
 
+    fconfigure $sock -translation binary -blocking no
     set state(sock) $sock
 
     puts -nonewline $sock "\x05\x01\x00"

Added: trunk/tkabber/proxy.tcl
===================================================================
--- trunk/tkabber/proxy.tcl	                        (rev 0)
+++ trunk/tkabber/proxy.tcl	2009-03-27 16:08:04 UTC (rev 1747)
@@ -0,0 +1,512 @@
+# $Id$
+
+package require pconnect::socks4
+package require pconnect::socks5
+package require pconnect::https
+package require http
+
+namespace eval proxy {
+    set cproxies {}
+    set hproxies {}
+    foreach varname [lsort -dictionary [info vars ::proxy*]] {
+	upvar #0 $varname p
+	if {![info exists p(type)] || \
+		[lsearch -exact {none http https socks4 socks5} $p(type)] < 0} {
+	    continue
+	}
+	set proxy [list type $p(type)]
+	if {[info exists p(host)]} {
+	    lappend proxy host $p(host)
+	} elseif {$p(type) != "none"} {
+	    continue
+	}
+	if {[info exists p(port)]} {
+	    lappend proxy port $p(port)
+	} elseif {$p(type) != "none"} {
+	    continue
+	}
+	if {[info exists p(username)]} {
+	    lappend proxy username $p(username)
+	}
+	if {[info exists p(password)]} {
+	    lappend proxy password $p(password)
+	}
+	if {[info exists p(match)]} {
+	    lappend proxy match $p(match)
+	}
+	if {[info exists p(exclude)]} {
+	    lappend proxy exclude $p(exclude)
+	}
+	switch -- $p(type) {
+	    none {
+		lappend cproxies $proxy
+		lappend hproxies $proxy
+	    }
+	    http {
+		lappend hproxies $proxy
+	    }
+	    default {
+		lappend cproxies $proxy
+	    }
+	}
+    }
+
+    if {[llength $cproxies] > 0 || [llength $hproxies] > 0} {
+	# There are proxies defined in the config file
+
+	variable proxylist [list connect $cproxies http $hproxies]
+    }
+
+    custom::defvar proxylist \
+	{connect {{type none match "localhost* 127.0.0.* 192.168.* 10.*"}}\
+	 http {{type none match "localhost* 127.0.0.* 192.168.* 10.*"}}} \
+	[::msgcat::mc "Serialized array of proxy servers to connect via."] \
+	-type string -group Hidden
+
+    ::http::config -proxyfilter [namespace current]::proxyfilter
+}
+
+namespace eval proxy::http {}
+
+# proxy::http::geturl --
+#
+#	A wrapper around http::geturl which adds proxy authorization header
+#	if necessary.
+
+proc proxy::http::geturl {url args} {
+    # 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>
+        $
+    }
+
+    set auth {}
+    if {[regexp -- $URLmatcher $url -> \
+                   proto user host port srvurl]} {
+        if {![catch {eval ::proxy::proxyfilter $host} answer]} {
+            lassign $answer phost pport pusername ppassword
+            if {[info exists pusername] && [info exists ppassword]} {
+		set auth [list Proxy-Authorization \
+			       "Basic [base64::encode \
+					    [encoding convertto \
+						      $pusername:$ppassword]]"]
+	    }
+        }
+    }
+
+    set newArgs {}
+    set q 0
+    foreach {key val} $args {
+	switch -- $key {
+	    -headers {
+		lappend newArgs $key [concat $val $auth]
+		set q 1
+	    }
+	    default {
+		lappend newArgs $key $val
+	    }
+	}
+    }
+    if {!$q} {
+	lappend newArgs -headers $auth
+    }
+
+    eval [list ::http::geturl $url] $newArgs
+}
+
+proc proxy::open {} {
+    variable proxylist
+
+    set w .proxy
+
+    if {[winfo exists $w]} {
+	destroy $w
+    }
+
+    Dialog $w -title [::msgcat::mc "Manage proxy servers"] \
+	      -separator 1 -anchor e \
+	      -default 0 -cancel 1 \
+	      -modal none
+
+    $w add -text [::msgcat::mc "Save"] \
+	   -command [namespace code [list save_proxies $w]]
+    $w add -text [::msgcat::mc "Cancel"] -command [list destroy $w]
+
+    set f [$w getframe]
+
+    set nb [NoteBook $f.nb]
+
+    set connect_page [$nb insert end connect_page -text [::msgcat::mc "Connect proxies"]]
+    customize_frame $connect_page connect
+
+    set http_page [$nb insert end http_page -text [::msgcat::mc "HTTP proxies"]]
+    customize_frame $http_page http
+
+    $nb compute_size
+    $nb raise connect_page
+    grid $nb -row 0 -column 0 -sticky nswe
+    grid columnconfigure $f 0 -weight 1
+    grid rowconfigure $f 0 -weight 1
+
+    $w draw
+}
+
+proc proxy::customize_frame {frame type} {
+    variable data
+    variable proxylist
+
+    switch -- $type {
+	connect -
+	http {}
+	default {
+	    return -code error
+	}
+    }
+
+    array set Proxy $proxylist
+
+    set tools [frame $frame.tools]
+    pack $tools -side bottom -fill x -padx 1m
+    
+    set sw [ScrolledWindow $frame.sw -scrollbar vertical]
+    set sf [ScrollableFrame $frame.fields -constrainedwidth yes]
+    pack $sw -side bottom -expand yes -fill both -pady 1m -padx 1m
+    $sw setwidget $sf
+    set f [$sf getframe]
+
+    bind $f <Destroy> [namespace code [list cleanup $f $type]]
+
+    set add [button $tools.add \
+		    -text [::msgcat::mc "Add proxy"] \
+		    -command [namespace code [list add_proxy $f $type none "" "" "" "" * ""]]]
+    pack $add -side right -padx 1m
+
+    set data($type,counter) 0
+
+    foreach proxy $Proxy($type) {
+	array unset Args
+	array set Args $proxy
+
+	set add_args {}
+	foreach idx {type host port username password match exclude} {
+	    if {[info exists Args($idx)]} {
+		lappend add_args $Args($idx)
+	    } else {
+		lappend add_args ""
+	    }
+	}
+
+	eval [list add_proxy $f $type] $add_args
+    }
+
+    update idletasks
+    $tools configure \
+	   -width [expr {[winfo reqwidth $f] + [winfo pixels $f 1c]}]
+}
+
+proc proxy::cleanup {f type} {
+    variable data
+
+    array unset data $type,*
+}
+
+proc proxy::save_proxies {w} {
+    variable data
+    variable proxylist
+
+    foreach type {connect http} {
+	set proxies($type) {}
+	for {set i 1} {$i <= $data($type,counter)} {incr i} {
+	    if {$data($type,type,$i) == "remove"} continue
+
+	    if {[lsearch {none http https socks4 socks5} $data($type,type,$i)] < 0} {
+		continue
+	    }
+
+	    lappend proxies($type) [list type $data($type,type,$i) \
+					 host $data($type,host,$i) \
+					 port $data($type,port,$i) \
+					 username $data($type,username,$i) \
+					 password $data($type,password,$i) \
+					 match $data($type,match,$i) \
+					 exclude $data($type,exclude,$i)] 
+	}
+    }
+
+    destroy $w
+
+    set proxylist [list connect $proxies(connect) http $proxies(http)]
+}
+
+proc proxy::add_proxy {f type ptype host port username password match exclude} {
+    variable data
+
+    set i [incr data($type,counter)]
+
+    set data($type,type,$i) $ptype
+    set data($type,host,$i) $host
+    set data($type,port,$i) $port
+    set data($type,username,$i) $username
+    set data($type,password,$i) $password
+    set data($type,match,$i) $match
+    set data($type,exclude,$i) $exclude
+
+    set erow [lindex [grid size $f] 1]
+
+    set ff [frame $f.p$i -borderwidth 2 -relief groove -padx 2m -pady 2m]
+    grid $ff -row $erow -column 0 -rowspan 3 -sticky nwes
+
+    set row 0
+
+    label $ff.lproxy$i -text [::msgcat::mc "Proxy type:"]
+    grid $ff.lproxy$i -row $row -column 0 -sticky e
+    frame $ff.proxy$i
+    grid $ff.proxy$i -row $row -column 1 -columnspan 3 -sticky w
+
+    set col 0
+
+    radiobutton $ff.proxy$i.none -text [::msgcat::mc "None"] \
+		-variable [namespace current]::data($type,type,$i) -value none \
+		-command [list [namespace current]::update_proxy $f $type $i]
+    grid $ff.proxy$i.none -row 0 -column [incr col] -sticky w
+
+    if {$type == "connect"} {
+	radiobutton $ff.proxy$i.https -text [::msgcat::mc "HTTPS"] \
+		    -variable [namespace current]::data($type,type,$i) -value https \
+		    -command [list [namespace current]::update_proxy $f $type $i]
+	grid $ff.proxy$i.https -row 0 -column [incr col] -sticky w
+
+	radiobutton $ff.proxy$i.socks4 -text [::msgcat::mc "SOCKS4a"] \
+		    -variable [namespace current]::data($type,type,$i) -value socks4 \
+		    -command [list [namespace current]::update_proxy $f $type $i]
+	grid $ff.proxy$i.socks4 -row 0 -column [incr col] -sticky w
+
+	radiobutton $ff.proxy$i.socks5 -text [::msgcat::mc "SOCKS5"] \
+		    -variable [namespace current]::data($type,type,$i) -value socks5 \
+		    -command [list [namespace current]::update_proxy $f $type $i]
+	grid $ff.proxy$i.socks5 -row 0 -column [incr col] -sticky w
+    } else {
+	radiobutton $ff.proxy$i.https -text [::msgcat::mc "HTTP"] \
+		    -variable [namespace current]::data($type,type,$i) -value http \
+		    -command [list [namespace current]::update_proxy $f $type $i]
+	grid $ff.proxy$i.https -row 0 -column [incr col] -sticky w
+    }
+
+    incr row
+
+    label $ff.lhost$i -text [::msgcat::mc "Host:"]
+    entry $ff.host$i -textvariable [namespace current]::data($type,host,$i)
+    label $ff.lport$i -text [::msgcat::mc "Port:"]
+    Spinbox $ff.port$i 0 65535 1 [namespace current]::data($type,port,$i)
+
+    grid $ff.lhost$i -row $row -column 0 -sticky e
+    grid $ff.host$i  -row $row -column 1 -sticky ew
+    grid $ff.lport$i -row $row -column 2 -sticky e
+    grid $ff.port$i  -row $row -column 3 -sticky ew
+
+    incr row
+
+    label $ff.lusername$i -text [::msgcat::mc "Username:"]
+    entry $ff.username$i -textvariable [namespace current]::data($type,username,$i)
+    label $ff.lpassword$i -text [::msgcat::mc "Password:"]
+    entry $ff.password$i -show * -textvariable [namespace current]::data($type,password,$i)
+
+    grid $ff.lusername$i -row $row -column 0 -sticky e
+    grid $ff.username$i  -row $row -column 1 -sticky ew
+    grid $ff.lpassword$i -row $row -column 2 -sticky e
+    grid $ff.password$i  -row $row -column 3 -sticky ew
+
+    incr row
+
+    label $ff.lmatch$i -text [::msgcat::mc "Match:"]
+    entry $ff.match$i \
+	  -textvariable [namespace current]::data($type,match,$i)
+
+    grid $ff.lmatch$i -row $row -column 0 -sticky e
+    grid $ff.match$i  -row $row -column 1 -columnspan 3 -sticky ew
+
+    incr row
+
+    label $ff.lexclude$i -text [::msgcat::mc "Exclude:"]
+    entry $ff.exclude$i \
+	  -textvariable [namespace current]::data($type,exclude,$i)
+
+    grid $ff.lexclude$i -row $row -column 0 -sticky e
+    grid $ff.exclude$i  -row $row -column 1 -columnspan 3 -sticky ew
+
+    grid columnconfigure $ff 1 -weight 3
+    grid columnconfigure $ff 2 -weight 1
+    grid columnconfigure $ff 3 -weight 3
+
+    button $f.moveup$i -text [::msgcat::mc "Move up"] \
+	   -command [namespace code [list move_proxy_up $f $type $i]]
+    button $f.movedown$i -text [::msgcat::mc "Move down"] \
+	   -command [namespace code [list move_proxy_down $f $type $i]]
+    button $f.remov$i -text [::msgcat::mc "Remove"] \
+	   -command [namespace code [list remove_proxy $f $type $i]]
+
+    grid $f.moveup$i -row $erow -column 1 -sticky ews
+    grid $f.movedown$i -row [expr {$erow+1}] -column 1 -sticky ewns
+    grid $f.remov$i -row [expr {$erow+2}] -column 1 -sticky ewn
+
+    grid rowconfigure $f $erow -weight 1
+    grid rowconfigure $f [expr {$erow+2}] -weight 1
+}
+
+proc proxy::update_proxy {f type i} {
+    # TODO
+}
+
+proc proxy::remove_proxy {f type i} {
+    variable data
+
+    destroy $f.p$i
+    destroy $f.moveup$i
+    destroy $f.movedown$i
+    destroy $f.remov$i
+
+    set data($type,type,$i) remove
+}
+
+proc proxy::move_proxy_up {f type i} {
+    variable data
+
+    set j $i
+    incr j -1
+    while {$j > 0 && $data($type,type,$j) == "remove"} {
+	incr j -1
+    }
+
+    if {$j > 0} {
+	switch_proxies $f $type $i $j
+    }
+}
+
+
+proc proxy::move_proxy_down {f type i} {
+    variable data
+
+    set j $i
+    incr j 1
+    while {$j <= $data($type,counter) && $data($type,type,$j) == "remove"} {
+	incr j 1
+    }
+
+    if {$j <= $data($type,counter)} {
+	switch_proxies $f $type $i $j
+    }
+}
+
+
+proc proxy::switch_proxies {f type i j} {
+    variable data
+
+    set ptype    $data($type,type,$i)
+    set host     $data($type,host,$i)
+    set port     $data($type,port,$i)
+    set username $data($type,username,$i)
+    set password $data($type,password,$i)
+    set match    $data($type,match,$i)
+    set exclude  $data($type,exclude,$i)
+    
+    set data($type,type,$i)     $data($type,type,$j)
+    set data($type,host,$i)     $data($type,host,$j)
+    set data($type,port,$i)     $data($type,port,$j)
+    set data($type,username,$i) $data($type,username,$j)
+    set data($type,password,$i) $data($type,password,$j)
+    set data($type,match,$i)    $data($type,match,$j)
+    set data($type,exclude,$i)  $data($type,exclude,$j)
+
+    set data($type,type,$j)     $ptype
+    set data($type,host,$j)     $host
+    set data($type,port,$j)     $port
+    set data($type,username,$j) $username
+    set data($type,password,$j) $password
+    set data($type,match,$j)    $match
+    set data($type,exclude,$j)  $exclude
+}
+
+proc proxy::proxyfilter {host {port -1}} {
+    variable proxylist
+
+    array set Proxy $proxylist
+
+    if {$port < 0} {
+	# HTTP proxy
+
+	set plist $Proxy(http)
+    } else {
+	# Connect proxy
+
+	set plist $Proxy(connect)
+    }
+
+    foreach proxy $plist {
+	array unset Args
+	array set Args $proxy
+
+	if {$Args(type) != "none"} {
+	    if {![info exists Args(host)] || [string length $Args(host)] == 0} {
+		continue
+	    }
+
+	    if {![info exists Args(port)] || ![string is integer -strict $Args(port)] || \
+		    $Args(port) < 0 || $Args(port) >= 65536} {
+		continue
+	    }
+	}
+
+	set m 0
+	if {[info exists Args(match)]} {
+	    foreach pattern [split $Args(match)] {
+		if {[string match -nocase $pattern $host]} {
+		    set m 1
+		    break
+		}
+	    }
+	}
+
+	set x 0
+	if {[info exists Args(exclude)]} {
+	    foreach pattern [split $Args(exclude)] {
+		if {[string match -nocase $pattern $host]} {
+		    set x 1
+		    break
+		}
+	    }
+	}
+
+	if {$m && !$x} {
+	    if {$Args(type) == "none"} {
+		return {}
+	    }
+
+	    if {$port < 0} {
+		set res [list $Args(host) $Args(port)]
+	    } else {
+		set res [list $Args(type) $Args(host) $Args(port)]
+	    }
+
+	    if {[info exists Args(username)] && [info exists Args(password)]} {
+		lappend res $Args(username) $Args(password)
+	    }
+
+	    return $res
+	}
+    }
+
+    return {}
+}
+


Property changes on: trunk/tkabber/proxy.tcl
___________________________________________________________________
Added: svn:keywords
   + Author Date Id Revision
Added: svn:mergeinfo
   + 
Added: svn:eol-style
   + native

Added: trunk/tkabber/sounds/default/sigh.wav
===================================================================
(Binary files differ)


Property changes on: trunk/tkabber/sounds/default/sigh.wav
___________________________________________________________________
Added: svn:mime-type
   + application/octet-stream

Modified: trunk/tkabber/splash.tcl
===================================================================
--- trunk/tkabber/splash.tcl	2009-03-26 19:17:54 UTC (rev 1746)
+++ trunk/tkabber/splash.tcl	2009-03-27 16:08:04 UTC (rev 1747)
@@ -55,6 +55,7 @@
         emoticons            [::msgcat::mc "emoticons"]            \
         aniemoticons         [::msgcat::mc "emoticons"]            \
         login                [::msgcat::mc "connections"]          \
+        proxy                [::msgcat::mc "connections"]          \
         browser              [::msgcat::mc "browsing"]             \
         disco                [::msgcat::mc "service discovery"]    \
         userinfo             [::msgcat::mc "presence"]             \

Modified: trunk/tkabber/tkabber.tcl
===================================================================
--- trunk/tkabber/tkabber.tcl	2009-03-26 19:17:54 UTC (rev 1746)
+++ trunk/tkabber/tkabber.tcl	2009-03-27 16:08:04 UTC (rev 1747)
@@ -233,6 +233,7 @@
 load_source joingrdialog.tcl
 load_source muc.tcl
 load_source login.tcl
+load_source proxy.tcl
 load_source userinfo.tcl
 load_source datagathering.tcl
 load_source mclistbox mclistbox.tcl



More information about the Tkabber-dev mailing list