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=396d69e4c9f2fd8627aea2ca4a82a6794610bd07;hb=HEAD;hpb=c9e9cc60807876413c150c24f8971b4c01c25214 diff --git a/ypp-chatlog-alerter b/ypp-chatlog-alerter index 396d69e..05a9c20 100755 --- a/ypp-chatlog-alerter +++ b/ypp-chatlog-alerter @@ -48,57 +48,101 @@ 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 + 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 agescale [expr { - exp( -($now >= $time ? $now-$time : 0) / $e_life ) - }] + 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( (-($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" + set retint_after [after $next retint] } -proc tintentry {w y tint} { +proc tintentries {ws y tint} { global tint_switched #puts "$tint $tint_switched" set yellow [format "%02x" [expr {round( 255 * @@ -107,20 +151,27 @@ proc tintentry {w y tint} { set black [format "%02x" [expr {round( 255 * ( $tint >= $tint_switched ? 0 : ($tint / $tint_switched)*0.75 + 0.25 ) )}]] - $w itemconfigure $y \ - -foreground [format "#${black}${black}${black}"] \ - -background [format "#${yellow}${yellow}00"] + set fg [format "#${black}${black}${black}"] + set bg [format "#${yellow}${yellow}00"] + foreach w $ws { $w itemconfigure $y -foreground $fg -background $bg } } proc clearlists {} { - global height - global times pirates messages + global height otherevent + 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] + retint } proc showtints {} { @@ -129,21 +180,147 @@ proc showtints {} { listbox .tints -width 60 -height [expr {$divs+1}] for {set y 0} {$y <= $divs} {incr y} { set tint [expr {($y+0.0)/$divs}] - puts "$y $tint" .tints insert end \ "[format "#%2d %6f %4ds" $y $tint [expr {round( $tint > 0 ? -log($tint) * $e_life : "9999" )}]] The quick brown fox jumped over the lazy dog" - tintentry .tints $y $tint + tintentries .tints $y $tint } 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" } @@ -160,4 +337,4 @@ if {[file exists $defaultfile]} { source $defaultfile } -#fixme refresh +pollfile