rework history package to be a bit more callable

diff --git a/bin/history.tcl b/bin/history.tcl
index d80edaedd2aa926e2e46021a0166aca99ad12f16..6cc87a15944fd55592e1ee61a782c098a9732827 100644 (file)
--- a/bin/history.tcl
+++ b/bin/history.tcl
@@ -7,40 +7,44 @@
 package require Tcl 8.5 ;# uses dict and {*}
 source [file join [file dirname [info script]] httpredir.tcl]
 if {![catch {package require autoproxy}]} {
-    autoproxy::init
+#    autoproxy::init
 }
 
 namespace eval ::tclers.tk {
-    #variable url_base http://tclers.tk/conferences
-    variable url_base http://localhost/conferences
+    variable url_base http://tclers.tk/conferences
+    variable uid; if {![info exists uid]} {set uid 0}
 }
 
 proc ::tclers.tk::gethistory {room args} {
-    # -messagecommand
-    # -progress
-}
-
-proc ::tclers.tk::Progress {tok total current} {
-    .htest.f.status.progress configure -value $current -maximum $total
+    set state [dict create -room $room -progress {} -command {}]
+    while {[string match -* [set option [lindex $args 0]]]} {
+        if {$option in {-command -progress}} {
+            dict set state $option [Pop args 1]
+        } else {
+            return -code error "invalid option \"$option\""
+        }
+        Pop args
+    }
+    GetIndex $room $state
 }
 
-proc ::tclers.tk::GetIndex {room} {
+proc ::tclers.tk::GetIndex {room state} {
     variable url_base
-    set url ${url_base}/$room
+    dict set state -url [set url ${url_base}/${room}/]
     set headers [list Accept-Charset utf-8 Cache-control no-cache]
     ::http::geturl2 $url -headers $headers \
         -timeout 120000 \
-        -progress [namespace code [list Progress]] \
-        -command [namespace code [list GotIndex $url]]
+        -progress [dict get $state -progress] \
+        -command [namespace code [list GotIndex $state]]
 }
 
-proc ::tclers.tk::GotIndex {url tok} {
+proc ::tclers.tk::GotIndex {state tok} {
     if {[catch {
         set ncode [::http::ncode $tok]
         set status [string tolower [::http::status $tok]]
         array set ::TOK [array get $tok]
         if {$status eq "ok" && $ncode < 300} {
-            after idle [namespace code [list ProcessIndex $url [::http::data $tok]]]
+            after idle [namespace code [list ProcessIndex $state [::http::data $tok]]]
         } else {
             puts stderr "GotIndex Failure: [http::status $tok] [http::code $tok]"
             if {$status eq "error"} { puts stderr [http::error $tok] }
@@ -49,7 +53,7 @@ proc ::tclers.tk::GotIndex {url tok} {
     } err]} { puts stderr $err }
 }
 
-proc ::tclers.tk::ProcessIndex {url data} {
+proc ::tclers.tk::ProcessIndex {state data} {
     set RE {<A HREF="([0-9\-%d]+\.tcl)">.*\s([0-9]+) bytes}
     foreach line [split $data \n] {
        if { [regexp -- $RE $line -> logname size] } {
@@ -63,28 +67,31 @@ proc ::tclers.tk::ProcessIndex {url data} {
     set loglist [lrange $loglist end-13 end]
     #after idle [list after 0 ::tkchat::LoadHistoryFromIndex $loglist]
     #foreach {name size} $loglist {}
-    GetLog $url/[lindex $loglist end-1]
+    set url [dict get $state -url]
+    GetLog $state $url/[lindex $loglist end-1]
 }
 
-proc ::tclers.tk::GetLog {url} {
+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 [namespace code Progress] \
-                 -command [namespace code GotLog]]
+                 -progress [dict get $state -progress] \
+                 -command [namespace code [list GotLog $state]]]
 }
 
-proc ::tclers.tk::GotLog {tok} {
-    upvar #0 $tok state
+proc ::tclers.tk::GotLog {state tok} {
+    upvar #0 $tok http
     if {[catch {
         set ncode [::http::ncode $tok]
         set status [string tolower [::http::status $tok]]
         if {$status eq "ok" && $ncode < 300} {
-            if {$state(charset) eq "iso8859-1"} {
+            if {$http(charset) eq "iso8859-1"} {
                 set data [encoding convertfrom utf-8 [::http::data $tok]]
             } else {
                 set data [::http::data $tok]
             }
-            after idle [namespace code [list ProcessLog $data]]
+            #after idle [list [dict get $state -command] $data]
+            after idle [namespace code [list ProcessLog $state $data]]
         } else {
             puts stderr "GotIndex Failure: [http::status $tok] [http::code $tok]"
             if {$status eq "error"} { puts stderr [http::error $tok] }
@@ -93,11 +100,11 @@ proc ::tclers.tk::GotLog {tok} {
     } err]} { puts stderr $err }
 }
 
-proc ::tclers.tk::ProcessLog {data} {
+proc ::tclers.tk::ProcessLog {state data} {
     if {[catch {
-        #.htest.f.txt delete 1.0 end
         set interp [interp create -safe]
-        interp alias $interp m {} [namespace origin Message]
+        #interp alias $interp m {} [namespace origin TestMessage] $txt
+        interp alias $interp m {} {*}[dict get $state -command]
         interp eval $interp $data
         interp delete $interp
     } err]} {
@@ -105,29 +112,48 @@ proc ::tclers.tk::ProcessLog {data} {
     }
 }
 
-proc ::tclers.tk::Message {when nick msg {opts ""} args} {
+# -------------------------------------------------------------------------
+
+proc ::tclers.tk::TestMessage {w when nick msg {opts ""} args} {
     if {[catch {clock scan $when -format "%Y-%m-%dT%H:%M:%S%Z" -gmt 1} s]} {
         set s [clock scan $when -format "%Y%m%dT%H:%M:%S" -gmt 1]
     }
-    set ts [clock format $s -format "%H:%M"]
+    set ts [clock format $s -format "%a %H:%M"]
     if {$opts ne ""} {puts stderr "OPTS: '$opts'"}
-    .htest.f.txt insert history "$ts " TIMESTAMP "$nick\t$msg\n" [list NICK-$nick MSG]
+    $w insert history "$ts " TIMESTAMP "$nick\t$msg\n" [list NICK-$nick MSG]
+}
+
+proc ::tclers.tk::TestProgress {w tok total current} {
+    $w configure -value $current -maximum $total
+}
+
+proc ::tclers.tk::TestGet {room wprogress txt} {
+    catch {$txt delete 1.0 "history + 1 line"}
+    $txt mark set history 1.0 
+    $txt mark gravity history left
+    $txt insert history "--- end of history ---\n" {}
+    $txt mark gravity history right
+    gethistory $room \
+        -progress [namespace code [list TestProgress $wprogress]] \
+        -command [namespace code [list TestMessage $txt]]
 }
 
 # testing
-proc ::tclers.tk::TestGUI {} {
+proc ::tclers.tk::Test {} {
     set dlg [toplevel .htest -class Dialog]
     wm withdraw $dlg
     wm title $dlg "Test history fetch"
     set f [ttk::frame $dlg.f]
-    text $f.txt -background white -height 8 -width 30 \
+    text $f.txt -background white -height 8 -width 40 \
         -yscrollcommand [list $f.vs set] -font TkDefaultFont
     ttk::scrollbar $f.vs -command [list $f.txt yview]
     set status [ttk::frame $f.status]
     ttk::label $status.pane0
     ttk::progressbar $status.progress
+    ttk::button $status.go -text Fetch \
+        -command [namespace code [list TestGet tcl $status.progress $f.txt]]
     ttk::sizegrip $status.sg
-    grid $status.pane0 $status.progress $status.sg -sticky news
+    grid $status.pane0 $status.progress $status.go $status.sg -sticky news
     grid rowconfigure $status 0 -weight 1
     grid columnconfigure $status 0 -weight 1
     grid $f.txt $f.vs -sticky news
@@ -139,3 +165,25 @@ proc ::tclers.tk::TestGUI {} {
     grid columnconfigure $dlg 0 -weight 1
     wm deiconify $dlg
 }
+
+proc ::tclers.tk::TestX {room chatwidget} {
+    proc ::tclers.tk::HistoryMessage {w when nick msg {opts ""} args} {
+        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'"}
+        #$w insert history "$ts " TIMESTAMP "$nick\t$msg\n" [list NICK-$nick MSG]
+        $w message $msg -mark history -nick $nick -time $time ;#-type $type 
+    }
+    
+    $chatwidget chat configure -state normal
+    catch {$chatwidget chat delete 1.0 "history + 1 line"}
+    $chatwidget chat mark set history 1.0 
+    $chatwidget chat mark gravity history left
+    $chatwidget chat insert history "--- end of history ---\n" HISTORYMARK
+    $chatwidget chat mark gravity history right
+    $chatwidget chat configure -state disabled
+    gethistory $room \
+        -progress [namespace code [list TestProgress .htest.f.status.progress]] \
+        -command [namespace code [list HistoryMessage $chatwidget]]
+}