From: Pat Thoyts Date: Sat, 21 Jun 2008 02:19:02 +0000 (+0100) Subject: history: load the last 2 days when connecting to a room on tclers.tk X-Git-Url: http://privyetmir.co.uk/gitweb.cgi?a=commitdiff_plain;h=7a180e5563afa4bfe76a195d07215b87076727ce;p=Bullfrog history: load the last 2 days when connecting to a room on tclers.tk --- diff --git a/bin/bf_xmpp.tcl b/bin/bf_xmpp.tcl index fb080f5..ecda551 100644 --- a/bin/bf_xmpp.tcl +++ b/bin/bf_xmpp.tcl @@ -27,6 +27,7 @@ package require jlib::vcard package require uuid package require messagewidget +source [file join [file dirname [info script]] history.tcl] namespace eval ::xmppplugin { variable version 0.2 @@ -1279,7 +1280,8 @@ proc XmppCallback {Session context state args} { State $Session disconnected } close { - foreach {target} $args break + #foreach {target} $args break + set target [lindex $args 0] Debug $Session [mc "closing %s" $target] XmppRemoveWindow $Session $target } @@ -1393,7 +1395,13 @@ proc XmppCallback {Session context state args} { set w [XmppFindWindow $Session $target] if {[winfo class $w] ne "Chatwidget"} {return} switch -exact -- $action { - joining { XmppCreateWindow $Session $target -type groupchat} + joining { + XmppCreateWindow $Session $target -type groupchat + jlib::splitjidex $target node domain resource + if {$domain eq "tach.tclers.tk"} { + after idle [namespace code [list XmppHistoryFetch $node $w]] + } + } entered { $w name add $nick {*}$args $w message [mc "%s entered" $nick] -nick $nick -time $time -type system diff --git a/bin/history.tcl b/bin/history.tcl index 4578cc4..455a99a 100644 --- a/bin/history.tcl +++ b/bin/history.tcl @@ -65,18 +65,26 @@ proc ::tclers.tk::ProcessIndex {state data} { ## Only show 7 days worth. set loglist [lrange $loglist end-13 end] + puts $loglist #after idle [list after 0 ::tkchat::LoadHistoryFromIndex $loglist] - #foreach {name size} $loglist {} - set url [dict get $state -url] - GetLog $state $url/[lindex $loglist end-1] + set url [string trimright [dict get $state -url] /] + dict set state -urls {} + foreach {name size} [lrange $loglist end-3 end] { + dict lappend state -urls $url/$name + } + GetLog $state } -proc ::tclers.tk::GetLog {state url} { - puts stderr "GetLog $url" - set headers [list Accept-Charset utf-8 Cache-control no-cache] - set tok [::http::geturl2 $url -headers $headers -timeout 120000 \ - -progress [dict get $state -progress] \ - -command [namespace code [list GotLog $state]]] +proc ::tclers.tk::GetLog {state} { + set url [lindex [dict get $state -urls] 0] + dict set state -urls [lrange [dict get $state -urls] 1 end] + if {$url ne {}} { + puts stderr "GetLog $url" + set headers [list Accept-Charset utf-8 Cache-control no-cache] + set tok [::http::geturl2 $url -headers $headers -timeout 120000 \ + -progress [dict get $state -progress] \ + -command [namespace code [list GotLog $state]]] + } } proc ::tclers.tk::GotLog {state tok} { @@ -98,6 +106,7 @@ proc ::tclers.tk::GotLog {state tok} { } ::http::cleanup $tok } err]} { puts stderr $err } + GetLog $state } proc ::tclers.tk::ProcessLog {state data} { @@ -166,32 +175,37 @@ proc ::tclers.tk::Test {} { wm deiconify $dlg } -proc ::tclers.tk::TestX {room chatwidget} { - proc ::tclers.tk::HistoryMessage {w when nick msg {opts ""} args} { - if {$nick eq {}} {return} - if {$nick eq "ijchain" && [string match {\*\*\* *} $msg]} { return } - if {[catch {clock scan $when -format "%Y-%m-%dT%H:%M:%S%Z" -gmt 1} time]} { - set time [clock scan $when -format "%Y%m%dT%H:%M:%S" -gmt 1] - } - if {$opts ne ""} {puts stderr "OPTS: '$opts'"} - set type normal - if {$nick eq "ijchain"} { - if {![regexp {^(<.*?>) (.*)$} $msg -> nick msg]} { - if {[regexp {^\* ([^ ]+) (.*)$} $msg -> nick msg]} { - set type action - set nick <${nick}> - } +# ------------------------------------------------------------------------- + +proc XmppHistoryMessage {w when nick msg {opts ""} args} { + if {$nick eq {}} {return} + if {$nick eq "ijchain" && [string match {\*\*\* *} $msg]} { return } + if {[catch {clock scan $when -format "%Y-%m-%dT%H:%M:%S%Z" -gmt 1} time]} { + set time [clock scan $when -format "%Y%m%dT%H:%M:%S" -gmt 1] + } + if {$opts ne ""} {puts stderr "OPTS: '$opts'"} + set type normal + if {$nick eq "ijchain"} { + if {![regexp {^(<.*?>) (.*)$} $msg -> nick msg]} { + if {[regexp {^\* ([^ ]+) (.*)$} $msg -> nick msg]} { + set type action + set nick <${nick}> } - } elseif {[string match "/me *" $msg]} { - set msg [string range $msg 4 end] - set type action } - - $w chat configure -state normal - $w message $msg -mark history -nick $nick -time $time -type $type -tags HISTORY - $w chat configure -state normal + } elseif {[string match "/me *" $msg]} { + set msg [string range $msg 4 end] + set type action } + $w chat configure -state normal + $w message $msg -mark history -nick $nick -time $time -type $type -tags HISTORY + $w chat configure -state normal +} + +proc XmppHistoryProgress {args} { +} + +proc XmppHistoryFetch {room chatwidget} { $chatwidget chat configure -state normal $chatwidget chat tag configure HISTORYMARK -background black -foreground white $chatwidget chat tag configure HISTORY -background "#eee" @@ -200,7 +214,7 @@ proc ::tclers.tk::TestX {room chatwidget} { "+++++++++++++++++++++ Loading History +++++++++++++++++++++\n" HISTORYMARK $chatwidget chat mark set history 1.0 $chatwidget chat configure -state disabled - gethistory $room \ - -progress [namespace code [list TestProgress .htest.f.status.progress]] \ - -command [namespace code [list HistoryMessage $chatwidget]] + ::tclers.tk::gethistory $room \ + -progress [namespace code [list XmppHistoryProgress]] \ + -command [namespace code [list XmppHistoryMessage $chatwidget]] } diff --git a/lib/jabberlib/saslmd5.tcl b/lib/jabberlib/saslmd5.tcl index de02b40..2ed271a 100644 --- a/lib/jabberlib/saslmd5.tcl +++ b/lib/jabberlib/saslmd5.tcl @@ -247,7 +247,7 @@ proc saslmd5::method_step {token args} { if {![iscapable $token]} { return [list 1 "missing one or more callbacks"] } - array set challarr [parse_challenge $challenge] + array set challarr [parse_challengePT $challenge] if {![::info exists challarr(nonce)]} { return [list 1 "challenge missing 'nonce' attribute"] } @@ -439,18 +439,37 @@ proc saslmd5::process_challenge {token challenge} { # Parses a clear text challenge string into a challenge list. proc saslmd5::parse_challenge {str} { - # RFC 2831 2.1 - # Char categories as per spec... - # Build up a regexp for splitting the challenge into key value pairs. - - set sep "\\\]\\\[\\\\()<>@,;:\\\"\\\?=\\\{\\\} \t" - set tok {0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz\-\|\~\!\#\$\%\&\*\+\.\^\_\`} - set sqot {(?:\'(?:\\.|[^\'\\])*\')} - set dqot {(?:\"(?:\\.|[^\"\\])*\")} - set parameters {} - regsub -all "(\[${tok}\]+)=(${dqot}|(?:\[${tok}\]+))(?:\[${sep}\]+|$)" \ - $str {\1 \2 } parameters - return $parameters + + # this takes a bit of low level processing... + # 'split' does not work here since = may be used inside quotes. + set challenge [list] + set idx 0 + while {1} { + set n [string first = $str $idx] + if {$n == -1} break + set key [string range $str $idx [expr $n-1]] + set idx [expr $n+1] + if {[string index $str $idx] eq "\""} { + incr idx + set n [string first "\"" $str $idx] + if {$n == -1} break + set value [string range $str $idx [expr $n-1]] + set idx [incr n] + } else { + set n [string first , $str $idx] + if {$n == -1} { + set value [string range $str $idx end] + set idx [expr [string length $str] - 1] + } else { + set value [string range $str $idx [expr $n-1]] + set idx $n + } + } + lappend challenge $key $value + if {[string index $str $idx] ne ","} break + incr idx + } + return $challenge } # RFC 2831 2.1 @@ -458,16 +477,13 @@ proc saslmd5::parse_challenge {str} { # Build up a regexp for splitting the challenge into key value pairs. proc saslmd5::parse_challengePT {str} { - puts "str=$str" - - set sep "\\\]\\\[\\\\()<>@,;:\\\"\\\?= \\\{\\\} \t" - set tok {0123456789ABCDEFGHIJKLMNOPQRS TUVWXYZabcdefghijklmnopqrstuvw xyz\-\|\~\!\#\$\%\&\*\+\.\^\_\ `} + set sep "\\\]\\\[\\\\()<>@,;:\\\"\\\?=\\\{\\\} \t" + set tok {0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz\-\|\~\!\#\$\%\&\*\+\.\^\_\`} set sqot {(?:\'(?:\\.|[^\'\\])*\')} set dqot {(?:\"(?:\\.|[^\"\\])*\")} set parameters {} - regsub -all "(\[${tok}\]+)=(${dqot}|(?:\[$ {tok}\]+))(?:\[${sep}\]+|$)" \ - $str {\1 \2 } parameters - puts "parameters=$parameters" + regsub -all "(\[${tok}\]+)=(${dqot}|(?:\[${tok}\]+))(?:\[${sep}\]+|$)" \ + $str {\1 \2 } parameters return $parameters }