From ba800ca37c98a4f03cd000f393d82105820c6c40 Mon Sep 17 00:00:00 2001 From: Pat Thoyts Date: Wed, 20 May 2009 22:41:54 +0100 Subject: [PATCH] Added simple images for user state representation and implemented ping Signed-off-by: Pat Thoyts --- bin/bf_xmpp.tcl | 139 +++++++++++++++++++++++++++++++------ bin/bullfrog.tcl | 14 +++- bin/images/chat.gif | Bin 855 -> 174 bytes bin/images/rcptreq.gif | Bin 0 -> 847 bytes bin/images/rcptresp.gif | Bin 0 -> 857 bytes bin/images/uparrow.gif | Bin 0 -> 861 bytes bin/images/usr_avail.gif | Bin 0 -> 72 bytes bin/images/usr_away.gif | Bin 0 -> 72 bytes bin/images/usr_dnd.gif | Bin 0 -> 68 bytes bin/images/usr_unavail.gif | Bin 0 -> 68 bytes bin/message.tcl | 32 ++++++++- 11 files changed, 160 insertions(+), 25 deletions(-) create mode 100644 bin/images/rcptreq.gif create mode 100644 bin/images/rcptresp.gif create mode 100644 bin/images/uparrow.gif create mode 100644 bin/images/usr_avail.gif create mode 100644 bin/images/usr_away.gif create mode 100644 bin/images/usr_dnd.gif create mode 100644 bin/images/usr_unavail.gif 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) "+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 facea22f38f127c63ffcc9f754cdb8a6086b3aa3..0b5d67f955339cba7ae16327148e11995c83a41b 100644 GIT binary patch literal 174 zcmZ?wbhEHb6kyUIPdmIB?)UQ2al`e=r54fh;nB;!hSvE(SgZ z9iU+hAUhdYwHGM&rDS$FaLq~nwa34TsX%u6me}=c_dVV>o3r4?$ABlxa< J6k%ep1_0~ST`~Xw literal 855 zcmb`GF^ZIN48K$C2d@rwO@HOsuFrNowq#q!ZnqnLAI*C3gO3{jOF+-WkQnqs3TcJu-saiE2?NFz>)U7sCO=wb6nufN44Gk8< zbdUEqGNK|nV!W0tGqNH(a?FBaWmH9V)R+{#ozWHD(E~?DV=|^U$ zLRbR^X(pis4;F(B^!P;Xrc6!@7sE*Ov6igYOJ-l!y$ap@~&@{5Jc)p#3vl-#>Zs?aQOLI=Zsi-2e6d$O-=u(PmBr*CkA53pim zk(bfNGXCcO3g1lW$L7KEMCqe5jiKm0zL_29`jg5UmM zgp^WA?M-A6id2-M72{%tGL@xl<+!&(m8w#;YCPJZPIakUZKj&gq^2|tZ37z`EQaYG z?{Q>AMRde?Em>w{MRw$v1;xs!it4B_DSA7jE4rfxj*P}+OvQ8zTVV|tq+tmyYAgmD zXs{R_3vy0WW@nD|v6ieVtFy*(VL`DgyR!%NkfJxIaykcj_yJ9(u><{(Kq0IFgETB@ zg$Ikl1{$ofb1st;T{SimeXJ$xt{!|vE-Wb4bPYb@GzP$nc8o?XR^kUVnZ^z{AsB_Q z1`N_nLJJ-&1{>({iQG+@oER>Kk?3PBS+AGOzOH+_xK3!B*HzrRjJE5`JC80qe1xUY zNQ<;@vUnJHLGwCrCCoz;t4{nj`@f*gJ-yxBdU5&X$NSB-YzDTFwXjjdbm|HA02aI2 zSmY3bhp>#l_dkPy;hRj7m-k-2dH861`_79!?dh)^yY<)4y40;UQ%z`6Q<{dhfej57 z!*q}LI5MIlI%2$*EHknqJ95l|Vr5iCb<~&?y`9k&-O&R_Mq@IjVmgMcum%j$u!I&h z7K05mSPYK^IVUQ!GspT^OIDTDS!21dpxBk&*@JpW(VJ5_or665fF{$}fqqD!5Y~V} z8kV%egT-J24c6E>m&u8)8XJi|){=Es556K778Gl`1|M-61K>qFMxz!h@dKJnV+WiN zj6zrg25Bat1rHX34fOa#?xsvm3>U*l^s$z#*Gpz!*S%d_C$!D$D(+oI+x6w0N0%Kw z!cu6YMcOx6JPf>`c^$YC=AnsIxBNEyzo5;1z1dtnJo$2Vw7GQS`LC0&Ki{4|r&pWb uXGg~uZ$A6}`N^N{`wQ3iFCQQ5|9GeEw|lRjzI^=Y+Jh?}4?pCA?*0Q(PH|%Z literal 0 HcmV?d00001 diff --git a/bin/images/uparrow.gif b/bin/images/uparrow.gif new file mode 100644 index 0000000000000000000000000000000000000000..f874ec321be314d2d3f801edc245eb83578a08fe GIT binary patch literal 861 zcmb`Gu}+n748==Ahzda-z+eai3?`7&M3jldD2_0(vUDR6W`@g%gRAML1~v!76WkD; z?8pl^;UnNwe&_!TG`ab1Z`;#zPQUy9!@I55hfB6(w@;0jjL&2|CS()EbUJN*Z|m{k z$v1-E9xmK0%+jp1iOk(R%+tKgTg7mTut^U%kMt;y77L0Qp6OYhEmHJWc%@f)H5?iB4)63XZ??i3 zFi67^TGUt!Hqc-(+!Cam$cTz)>0>QfW@JUSLEpMbVgS+^6&$iOk)T7 zA%Q|z0|seW(h3h2gAFuTE$37wCn~dLB>GrOR+ZKGidTRSPVAMtrMx6GC9#)3?tFUTCy51nS34hR&ktAHjk^QcNi_# zhj$tscIXI0p^ye?-DL0(@POuZ;7XW>CRVNdpPkXm_d;*A{uB1-jrHSayFb6~oUJb| zzdc<2c73*R^z!s>OU}s;oTcYh YHQTN*p|t0TxmM;i({SeF-i!>^02B5RvH$=8 literal 0 HcmV?d00001 diff --git a/bin/images/usr_away.gif b/bin/images/usr_away.gif new file mode 100644 index 0000000000000000000000000000000000000000..f40151142de073f22d728483c5b6be7cfbb75d88 GIT binary patch literal 72 zcmZ?wbhEHb6krfwXkcJqR|6r%pDc`A42%pq3_t*qVPKN)>0f!8{lcBuxlt?Lot?F4 XpXYhQb9*&VTuCtJQcrNzo%4FKou64C$w literal 0 HcmV?d00001 diff --git a/bin/images/usr_unavail.gif b/bin/images/usr_unavail.gif new file mode 100644 index 0000000000000000000000000000000000000000..7b30547533da88511e602ff9a84b2f4b1f3056fd GIT binary patch literal 68 zcmZ?wbhEHb6krfwXkcWpwY6neV^I9b!pOzI$e_aj1Rxm(Ch4C3m8Z`#BzKFfi4t8_ Vb@*N5?2g#SlPzDJ(qd(>1_0={64?L% literal 0 HcmV?d00001 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 -- 2.23.0