From: Pat Thoyts <patthoyts@users.sourceforge.net>
Date: Wed, 20 May 2009 21:41:54 +0000 (+0100)
Subject: Added simple images for user state representation and implemented ping
X-Git-Url: http://privyetmir.co.uk/gitweb?a=commitdiff_plain;h=ba800ca37c98a4f03cd000f393d82105820c6c40;p=Bullfrog

Added simple images for user state representation and implemented ping

Signed-off-by: Pat Thoyts <patthoyts@users.sourceforge.net>
---

diff --git a/bin/bf_xmpp.tcl b/bin/bf_xmpp.tcl
index ecda551..d27dca8 100644
--- a/bin/bf_xmpp.tcl
+++ b/bin/bf_xmpp.tcl
@@ -30,20 +30,24 @@ package require messagewidget
 source [file join [file dirname [info script]] history.tcl]
 
 namespace eval ::xmppplugin {
-    variable version 0.2
+    variable version 0.3
     variable uid; if {![info exists uid]} { set uid 0 }
     variable defaults {
         -server   "all.tclers.tk"
         -resource "Bullfrog"
         -port     5222
         -channel  "tcl@tach.tclers.tk"
-        callback ""
-        motd     {}
-        users    {}
+        -nick     ""
+        callback  ""
+        motd      {}
+        users     {}
     }
     namespace export connect send post splituri
 }
 
+#autosocks::config -proxy socks5 -proxyhost localhost -proxyport 9050
+
+
 proc ::xmppplugin::connect {callback args} {
     variable defaults
     variable uid
@@ -51,8 +55,9 @@ proc ::xmppplugin::connect {callback args} {
     upvar #0 $context xmpp
     array set xmpp $defaults
     array set xmpp $args         ;# see XmppLogin for the list of pairs
-
+    set xmpp(msgid) 0
     set xmpp(callback) $callback
+    if {$xmpp(-nick) eq ""} {set xmpp(-nick) $xmpp(-username)}
     set xmpp(jlib) [jlib::new [namespace origin OnNetwork] \
                         -messagecommand [namespace origin OnMessage] \
                         -presencecommand [namespace origin OnPresence] \
@@ -108,8 +113,8 @@ proc ::xmppplugin::connect {callback args} {
     } else {
         $xmpp(jlib) connect connect $xmpp(jid) $xmpp(-passwd) \
             -command [list [namespace origin OnConnect] $context] \
-            -secure 1 -method tlssasl \
-            -ip $xmpp(-server) -port $xmpp(-port)
+            -secure 1 -method tlssasl -transport tcp\
+            -ip $xmpp(-server) -port $xmpp(-port) -timeout 120000
     }
     return $context
 }
@@ -166,6 +171,11 @@ proc ::xmppplugin::post {ctx channel msg} {
                 return
             }
             "/me *" { }
+            "/ping *" {
+                set target [string trim [string range $msg 6 end]]
+                ping $ctx $target
+                return
+            }
             default {
                 Callback $ctx system $channel [mc "unrecognised chat command '%s'" $msg]
                 return
@@ -195,6 +205,11 @@ proc ::xmppplugin::post {ctx channel msg} {
     }
     set margs [list -type $type -body $msg -xlist $xlist]
     if {$thread ne ""} { lappend margs -thread $thread }
+    if {$type eq "chat"} {
+        # we _SHOULD_ only do this if we negotiated support with the remote client
+        lappend margs -id [incr xmpp(msgid)] -xlist \
+            [list [wrapper::createtag request -attrlist {xmlns urn:xmpp:receipts}]]
+    }
     eval [linsert $margs 0 $xmpp(jlib) send_message $channel]
     if {$type eq "chat"} {
         set mtype normal
@@ -287,10 +302,10 @@ proc ::xmppplugin::OnConnect {ctx jlib type args} {
         ok {
             Callback $ctx connect
             $jlib send_presence
-            $jlib send_presence -priority 2 -show available
+            $jlib send_presence -priority 2
             $jlib roster send_get -command [list [namespace origin OnRosterGet] $ctx]
             if {$xmpp(-autoconnect) && $xmpp(-channel) ne {}} {
-                Log $ctx "Attempting to join $xmpp(-channel)"
+                Log $ctx "Attempting to join '$xmpp(-channel)' as '$xmpp(-nick)'"
                 JoinMUC $ctx $xmpp(-channel) $jlib $xmpp(-nick)
             }
         }
@@ -303,6 +318,7 @@ proc ::xmppplugin::OnConnect {ctx jlib type args} {
 }
 
 proc ::xmppplugin::JoinMUC {ctx channel jlib nick} {
+    Log $ctx "JoinMUC '$channel' as '$nick'"
     #set t 1202713200
     #set since [list since [clock format $t -format {%Y-%m-%dT%T}]]
     set since [list maxstanzas 100]
@@ -539,7 +555,7 @@ proc ::xmppplugin::OnRosterGet {ctx args} {
 }
 
 proc ::xmppplugin::OnRosterChange {ctx jlib what {jid {}} args} {
-    #Log $ctx "Roster '$what' '$jid' '$args'"
+    Log $ctx "Roster '$what' '$jid' '$args'"
     #enterroster | exitroster | set jid args | remove jid | 
     #switch -exact -- $what {}
     return 0
@@ -581,6 +597,18 @@ proc ::xmppplugin::OnPresenceChange {ctx jlib xmldata} {
                                 [wrapper::getfirstchildwithtag $xmldata status]]
                 Callback $ctx traffic left $room $nick {} $time -status $status
             }
+        } else {
+            # chat or roster user - if we have an open chat for them, fix the icon
+            # FIX ME: move into callback and fix up session
+            set Session ::xmpp1
+            upvar #0 $Session session
+            array set a [linsert [wrapper::getattrlist $xmldata] 0 type available]
+            set w [XmppFindWindow $Session $a(from)]
+            if {[winfo exists $w] && $w ne $session(window)} {
+                set image [XmppGetPresenceImage $Session $a(from)]
+                $session(app).nb tab $w -image $image
+            }
+            #Callback $ctx presence $a(from)
         }
     } err]} { puts stderr "OnPresenceChange: $err" }
     return 0
@@ -589,7 +617,7 @@ proc ::xmppplugin::OnPresenceChange {ctx jlib xmldata} {
 proc ::xmppplugin::OnPresence {jlib xmldata} {
     set ctx [set [set jlib]::AppContext]
     if {[catch {OnPresence2 $ctx $jlib $xmldata} res]} {
-        Log $ctx "OnPresence: $err" error
+        Log $ctx "OnPresence: $res" error
         return 0
     }
     return $res
@@ -602,7 +630,7 @@ proc ::xmppplugin::OnPresence2 {ctx jlib xmldata} {
 proc ::xmppplugin::OnIq {jlib xmldata} {
     set ctx [set [set jlib]::AppContext]
     if {[catch {OnIq2 $ctx $jlib $xmldata} res]} {
-        Log $ctx "OnIq: $err" error
+        Log $ctx "OnIq: $res" error
         return 0
     }
     return $res
@@ -612,6 +640,31 @@ proc ::xmppplugin::OnIq2 {ctx jlib xmldata} {
     return 0
 }
 
+proc ::xmppplugin::ping {ctx jid} {
+    upvar #0 $ctx xmpp
+    set xmllist [wrapper::createtag ping -attrlist [list xmlns urn:xmpp:ping]]
+    $xmpp(jlib) send_iq get [list $xmllist] -to $jid \
+        -command [namespace code [list on_ping $ctx $jid \
+                                      [clock clicks -milliseconds]]]
+    return
+}
+proc ::xmppplugin::on_ping {ctx jid sent type args} {
+    switch -exact -- $type {
+        result {
+            set t [expr {[clock clicks -milliseconds] - $sent}]
+            Callback $ctx status "ping to $jid took $t ms"
+        }
+        error {
+            set t [expr {[clock clicks -milliseconds] - $sent}]
+            set msg [lindex [lindex $args 0] 0]
+            Callback $ctx status "ping to $jid failed in $t ms: $msg"
+        }
+        default {
+            Log $ctx "on_ping: $ctx $jid $sent ms $type '$args'"
+        }
+    }
+}
+    
 proc ::xmppplugin::OnMessage {jlib xmldata} {
     set ctx [set [set jlib]::AppContext]
     if {[catch {OnMessage2 $ctx $jlib $xmldata} err]} {
@@ -748,7 +801,7 @@ proc ::xmppplugin::OnMessage2 {ctx jlib xmldata} {
         }
         headline {
             Callback $ctx chat $a(to) $a(from) \
-                "header: [wrapper::etcdata [lindex $body 0]]" normal $time
+                "header: [wrapper::getcdata [lindex $body 0]]" normal $time
             Log $ctx "$a(from)->$a(to) headline $xmldata"
         }
         error {
@@ -1087,18 +1140,55 @@ proc XmppAddChannel {Session channel "-type" type} {
     }
     $chan(window) hook add post [list ::xmppplugin::post $chan(xmpp) $channel]
     bind $chan(window) <Destroy> "+unset -nocomplain $Channel"
-    
+    XmppAddTab $Session $chan(window) $channel
+    after idle [list $session(app).nb select $chan(window)]
+    return $chan(window)
+}
+
+proc XmppAddTab {Session window jid} {
+    upvar #0 $Session session
+    upvar #0 $session(xmpp) xmpp
     # If the channel domain is a muc then use the resource.
-    upvar #0 $chan(xmpp) xmpp
-    jlib::splitjidex $channel node domain resource
+    jlib::splitjidex $jid node domain resource
     if {[$xmpp(jlib) muc isroom $node@$domain]} {
         set title $resource
+        set image ::img::msgchat
+        $session(app).nb add $window -text $title -image $image -compound left
     } elseif {$node ne {}} {
         set title $node
-    } else { set title $domain }
-    $session(app).nb add $chan(window) -text $title
-    after idle [list $session(app).nb select $chan(window)]
-    return $chan(window)
+        set rs [dict create {*}[$xmpp(jlib) roster getpresence\
+                                    $node@$domain -resource $resource]]
+        set image [XmppGetPresenceImage $Session $jid]
+        $session(app).nb add $window -text $title -image $image -compound left
+    } else {
+        set title $domain
+        $session(app).nb add $window -text $title -compound none
+    }
+}
+
+proc XmppGetPresenceImage {Session jid} {
+    upvar #0 $Session session
+    upvar #0 $session(xmpp) xmpp
+    jlib::splitjidex $jid node domain resource
+    if {$resource eq {}} {
+        array set info [lindex [$xmpp(jlib) roster getpresence $node@$domain] 0]
+    } else {
+        array set info [$xmpp(jlib) roster getpresence $node@$domain -resource $resource]
+    }
+    if {[info exist info(-show)]} {set show $info(-show)} else {set show available}
+    if {$info(-type) eq "unavailable"} {set show unavailable}
+    switch -exact -- $show {
+        available { set image ::img::presence::available }
+        unavailable { set image ::img::presence::unavailable }
+        chat { set image ::img::presence::chat }
+        away { set image ::img::presence::away }
+        xa   { set image ::img::presence::xa }
+        dnd  { set image ::img::presence::dnd }
+        default {
+            return -code error "unknown presence type \"$show\""
+        }
+    }
+    return $image
 }
 
 proc XmppChatstate {Chat chatstate} {
@@ -1199,7 +1289,11 @@ proc XmppFindWindow {Session target} {
             if {$name eq $target} {
                 # check for detached window
                 if {[lsearch -exact [$session(app).nb tabs] $wid] == -1} {
-                    if {[wm state $wid] eq "withdrawn"} { wm deiconify $wid }
+                    if {[winfo toplevel $wid] eq $wid} {
+                        if {[wm state $wid] eq "withdrawn"} { wm deiconify $wid }
+                    } else {
+                        XmppAddTab $Session $wid $target
+                    }
                 } else {
                     if {[$session(app).nb tab $wid -state] eq "hidden"} {
                         $session(app).nb tab $wid -state normal
@@ -1425,6 +1519,9 @@ proc XmppCallback {Session context state args} {
             foreach {type line} $args break
             Debug $Session $line $type
         }
+        status {
+            Status $Session [lindex $args 0]
+        }
         version { return "" }
         default {
             puts stderr "*** unknown xmpp callback \"$state\": $args"
diff --git a/bin/bullfrog.tcl b/bin/bullfrog.tcl
index b469598..373fa27 100644
--- a/bin/bullfrog.tcl
+++ b/bin/bullfrog.tcl
@@ -15,7 +15,7 @@
 package require Tk 8.5
 package require chatwidget 1.1;  # tklib 
 package require tooltip 1.4;     # tklib 
-package require msgcat;          # tcl core 
+package require msgcat;          # tcl core
 namespace import ::msgcat::mc
 
 if {![catch {package require autoproxy}]} {
@@ -32,6 +32,16 @@ source [file join $root bf_irc.tcl]
 source [file join $root bf_xmpp.tcl]
 
 # -------------------------------------------------------------------------
+# Load images
+namespace eval ::img {
+    set imgdir [file join $root images]
+    image create photo ::img::presence::available -file $imgdir/usr_avail.gif
+    image create photo ::img::presence::chat -file $imgdir/usr_avail.gif
+    image create photo ::img::presence::away -file $imgdir/usr_away.gif
+    image create photo ::img::presence::xa -file $imgdir/usr_away.gif
+    image create photo ::img::presence::dnd -file $imgdir/usr_dnd.gif
+    image create photo ::img::presence::unavailable -file $imgdir/usr_unavail.gif
+}
 
 proc Main {args} {
     global env
@@ -382,8 +392,6 @@ proc GotoURL {w url} {
     $dlg configure -cursor {}
 }
 
-    
-
 # -------------------------------------------------------------------------
 
 if {![info exists initialized] && !$tcl_interactive} {
diff --git a/bin/images/chat.gif b/bin/images/chat.gif
index facea22..0b5d67f 100644
Binary files a/bin/images/chat.gif and b/bin/images/chat.gif differ
diff --git a/bin/images/rcptreq.gif b/bin/images/rcptreq.gif
new file mode 100644
index 0000000..d192deb
Binary files /dev/null and b/bin/images/rcptreq.gif differ
diff --git a/bin/images/rcptresp.gif b/bin/images/rcptresp.gif
new file mode 100644
index 0000000..7c1efea
Binary files /dev/null and b/bin/images/rcptresp.gif differ
diff --git a/bin/images/uparrow.gif b/bin/images/uparrow.gif
new file mode 100644
index 0000000..f874ec3
Binary files /dev/null and b/bin/images/uparrow.gif differ
diff --git a/bin/images/usr_avail.gif b/bin/images/usr_avail.gif
new file mode 100644
index 0000000..acc10f6
Binary files /dev/null and b/bin/images/usr_avail.gif differ
diff --git a/bin/images/usr_away.gif b/bin/images/usr_away.gif
new file mode 100644
index 0000000..f401511
Binary files /dev/null and b/bin/images/usr_away.gif differ
diff --git a/bin/images/usr_dnd.gif b/bin/images/usr_dnd.gif
new file mode 100644
index 0000000..d1241ef
Binary files /dev/null and b/bin/images/usr_dnd.gif differ
diff --git a/bin/images/usr_unavail.gif b/bin/images/usr_unavail.gif
new file mode 100644
index 0000000..7b30547
Binary files /dev/null and b/bin/images/usr_unavail.gif differ
diff --git a/bin/message.tcl b/bin/message.tcl
index 74a859a..405533c 100644
--- a/bin/message.tcl
+++ b/bin/message.tcl
@@ -35,9 +35,25 @@ namespace eval messagewidget {
             [font actual TkTextFont] -slant italic
     }
     namespace eval ::img {}
+
+
+    proc ImageSetTransparency {img} {
+        set clr [$img get 0 0]
+        set width [image width $img]
+        set height [image height $img]
+        for {set r 0} {$r < $height} {incr r} {
+            for {set c 0} {$c < $width} {incr c} {
+                if {[$img get $c $r] eq $clr} {
+                    $img transparency set $c $r 1
+                }
+            }
+        }
+    }
+    
     set imgdir [file join [file dirname [info script]] images]
     image create photo ::img::msgnorm -file [file join $imgdir mail.gif]
     image create photo ::img::msgchat -file [file join $imgdir chat.gif]
+    #ImageSetTransparency ::img::msgchat
 }
 
 proc messagewidget::messagewidget {w args} {
@@ -47,6 +63,7 @@ proc messagewidget::messagewidget {w args} {
     return $w
 }
 
+# widget method dispatch
 proc messagewidget::WidgetProc {self cmd args} {
     upvar #0 [namespace current]::$self state
     switch -exact -- $cmd {
@@ -63,6 +80,7 @@ proc messagewidget::WidgetProc {self cmd args} {
     }
 }
 
+# Accessor for the summary tree widget.
 proc messagewidget::Summary {self args} {
     upvar #0 [namespace current]::$self state
     if {[llength $args] == 0} {
@@ -71,6 +89,7 @@ proc messagewidget::Summary {self args} {
     return [uplevel 1 [list $state(mlist)] $args]
 }
 
+# Accessor for the body display widget.
 proc messagewidget::Body {self args} {
     upvar #0 [namespace current]::$self state
     if {[llength $args] == 0} {
@@ -145,7 +164,13 @@ proc messagewidget::DisplayTime {time} {
     return $r
 }
 
-# -date : date/time as clock seconds
+# Add --
+#	Add a new message item. Options are:
+#	 -from    jid
+#	 -to      jid
+#	 -subject string
+#	 -date    date/time as clock seconds
+#	 -body    data
 # 
 proc messagewidget::Add {self args} {
     upvar #0 [namespace current]::$self state
@@ -174,6 +199,11 @@ proc messagewidget::OnSummaryClick {self w x y} {
         "[dict get $M -body]\n" body
 }
 
+# -------------------------------------------------------------------------
+# Data store --
+#proc messagewidget::StoreItem
+#proc messagewidget::Store
+
 # -------------------------------------------------------------------------
 
 package provide messagewidget $messagewidget::version