From: Pat Thoyts Date: Fri, 20 Jun 2008 16:16:23 +0000 (+0100) Subject: rework history package to be a bit more callable X-Git-Url: http://privyetmir.co.uk/gitweb?a=commitdiff_plain;h=eef99dc1d83f014f39000632d35e1c5c65b22528;p=Bullfrog rework history package to be a bit more callable --- diff --git a/bin/history.tcl b/bin/history.tcl index d80edae..6cc87a1 100644 --- 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 {.*\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]] +}