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 fb080f5e741b8da04e45c2ed35be98103bd3bd50..ecda551a7529617b3735e296b3bddb272a7f8986 100644 (file)
--- 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 4578cc48a17f0cd163ca09f060531bd081269011..455a99a4763bb91fe9d57bcb44025b8a01ad4905 100644 (file)
--- 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 de02b40c127734e54a053702bb21595e58d61aa0..2ed271abb94834321bf734f3d4a4ddb67d9126e1 100644 (file)
--- 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
 }