X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~yarrgweb/git?p=ypp-sc-tools.web-live.git;a=blobdiff_plain;f=ypp-chatlog-alerter;h=05a9c2001c7e516b8a8292db51ac0d11313c9194;hp=9db7bc61e7b3763050a653eb79a0ce5281a3bc58;hb=HEAD;hpb=3fd5e41be6f4b6949e6284c08eb7059b303ccd78 diff --git a/ypp-chatlog-alerter b/ypp-chatlog-alerter index 9db7bc6..05a9c20 100755 --- a/ypp-chatlog-alerter +++ b/ypp-chatlog-alerter @@ -48,64 +48,97 @@ proc nonportability {} { } } +set lw_ls {times pirates messages} +set lw_ws {.time .pirate .msg} + proc widgets {} { - global height - listbox .t -width 5 -height $height -borderwidth 0 - listbox .p -width 14 -height $height -borderwidth 0 - listbox .m -width 80 -height $height -borderwidth 0 - pack .t .p .m -side left + global height lw_ws prtimes + listbox .time -width 5 -background black \ + -listvariable prtimes -foreground white + listbox .pirate -width 14 -background black + listbox .msg -width 80 + for_lw { + $w configure -height $height -borderwidth 0 -activestyle none \ + -highlightthickness 0 + } + eval pack $lw_ws -side left + label .overlay -relief raised -foreground white +} + +proc shownotice {colour message} { + .overlay configure -text $message -background $colour + place .overlay -relx 0.5 -rely 0.5 -anchor center +} +proc hidenotice {} { + place forget .overlay } proc newfile {} { - global currentfile defaultfile + global currentfile defaultfile logfile set newfile [tk_getOpenFile -multiple 0 -initialfile $currentfile \ -title "Select YPP log to track"] if {![string length $newfile]} return + catch { close $logfile } + catch { unset logfile } + set currentfile $newfile set newdefaults [open $defaultfile.new w] puts $newdefaults "[list set currentfile $currentfile]" close $newdefaults file rename -force $defaultfile.new $defaultfile - - #fixme refresh -} -set lw_ls {times pirates messages} -set lw_ws {t p m} + clearlists + pollfile +} -proc for_lw {body} { +proc for_lw {args} { global lw_ls lw_ws + set body [lindex $args end] + set args [lreplace $args end end] uplevel 1 [list \ foreach l $lw_ls \ - w $lw_ws \ - $body] + w $lw_ws] \ + $args \ + [list $body] } set e_life 120 set tint_switch 90 +set bell_again 60 set tint_switched [expr { exp( -($tint_switch+0.0) / $e_life ) }] proc retint {} { - global times e_life retint_after otherevent + global times e_life retint_after otherevent prtimes catch { after cancel $retint_after } set i 0 set now [clock seconds] set latest $otherevent + set newprtimes {} foreach time $times { + set age [expr {$now-$time}] + if {!$time} { + lappend newprtimes {} + } elseif {$age < 60} { + lappend newprtimes [format "%3ds" $age] + } elseif {$age < 3600} { + lappend newprtimes [format "%3dm" [expr {$age/60}]] + } else { + lappend newprtimes [format "%3dh" [expr {$age/3600}]] + } set latest [expr { $time > $latest ? $time : $latest }] - set tint [expr { - exp( -($now >= $time ? $now-$time : 0) / $e_life ) - }] - tintentries .t $i $tint + set tint [expr { exp( (-($age >= 0 ? $age : 0) + 0.0) / $e_life ) }] +#puts "AGE $age LA $latest TI $tint" + tintentries .msg $i $tint incr i } + set prtimes $newprtimes set next [expr { ($now - $latest < 10 ? 10 : $now - $latest > 3000 ? 3000 : $now - $latest ) * 10 }] -puts "nexting $latest $now $next" +#puts "nexting $latest $now $next" set retint_after [after $next retint] } @@ -125,14 +158,16 @@ proc tintentries {ws y tint} { proc clearlists {} { global height otherevent - global times pirates messages + global times prtimes pirates messages set currentfile {} - for_lw { .$w delete 0 end; set $l {} } + for_lw { $w delete 0 end; set $l {} } set ntimes {} + set prtimes {} for {set i 0} {$i<$height} {incr i} { - for_lw { lappend $l {}; .$w insert end {} } + for_lw { lappend $l {}; $w insert end {} } lappend ntimes 0 + lappend prtimes {} } set times $ntimes set otherevent [clock seconds] @@ -154,11 +189,138 @@ proc showtints {} { pack .tints -side bottom } +proc file-read-lines {lvar body} { + upvar 1 $lvar l + global logfile poll_after lastactivity bufdata + +#puts f-r-l + if {![info exists logfile]} { + return + } + while 1 { + if {[catch { read $logfile } got]} { + file-error $got + return + } +#puts "f-r-l [string length $got]" + if {![string length $got] && [eof $logfile]} { + set ago [expr { [clock seconds] - $lastactivity }] + set interval [expr {( $ago < 10 ? 10 : + $ago > 3000 ? 3000 : + $ago ) * 10}] +#puts "requeue filepoll $interval" + set poll_after [after $interval pollfile] + return + } + set lastactivity [clock seconds] + + while {[regexp {^(.*?)[\r\n]+(.*)$} $got dummy lhs rhs]} { + set l "$bufdata$lhs" + set bufdata {} + set got $rhs +#puts ">>$l<<" + uplevel 1 $body + } + append bufdata $got + } +} + +proc file-error {emsg} { + global logfile + + shownotice red "Error reading logfile $currentfile:\n$emsg" + catch { close $logfile } + catch { unset logfile } +} + +proc pollfile {} { + global poll_after logfile currentfile + global errorCode errorInfo bufdata lastactivity + + catch { after cancel $poll_after } + if {![string length $currentfile]} { + shownotice red "No log file selected. Use File / Open." + return + } + if {![info exists logfile]} { + set bufdata {} + set lastactivity [clock seconds] + if {[catch { set logfile [open $currentfile r] } emsg]} { + shownotice red "Error opening logfile $currentfile:\n$emsg" + return + } + shownotice \#000080 "Reading $currentfile" + if {[catch { + seek $logfile -1024 end + } emsg]} { + if {![string match {POSIX EINVAL *} $errorCode]} { + file-error $emsg + } + } + file-read-lines l { } + } + file-read-lines l { + hidenotice + if {[regexp {^\[\d+:\d+:\d+\] (.*)} $l dummy rhs]} { +#puts PROCLINE + process-line $rhs + } + } +} + +proc process-line {l} { + if {[regexp {^(\w+) tells ye, \"(.*)\"$} $l dummy pirate msg]} { +#puts "MESSAGE $l" + message $pirate $msg + } +} + +proc message {pirate msg} { + global times pirates messages height + global lw_ls lw_ws bell_again + + set ix [lsearch -exact $pirates $pirate] + set now [clock seconds] + + if {$bell_again > -2 && + ($ix<0 || [lindex $times $ix] < $now-$bell_again)} { + bell -nice + } + if {$ix < 0} { + set cix 0 + set oldest $now + foreach time $times { + if {$time < $oldest} { + set oldest $time + set ix $cix + } + incr cix + } + for_lw { + set $l [lreplace [set $l] $ix $ix] + lappend $l {} + $w delete $ix + $w insert end {} + } + set ix [expr {$height-1}] + } + for_lw new [list $now $pirate $msg] { + set $l [lreplace [set $l] $ix $ix $new] + $w delete $ix + $w insert $ix $new + } +#puts "TIMES $times" + .pirate itemconfigure $ix -foreground white + retint +} + proc parseargs {} { global argv foreach arg $argv { if {![string compare $arg --test-tints]} { showtints + } elseif {![string compare $arg --no-bell]} { + set bell_again -2 } else { error "unknown option $arg" } @@ -175,4 +337,4 @@ if {[file exists $defaultfile]} { source $defaultfile } -#fixme refresh +pollfile