From: Ian Jackson <ian@liberator.relativity.greenend.org.uk>
Date: Sun, 3 Oct 2010 23:35:46 +0000 (+0100)
Subject: ypp-chatlog-alerter: wip seems to work ish
X-Git-Tag: 6.7.0~7
X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~yarrgweb/git?p=ypp-sc-tools.main.git;a=commitdiff_plain;h=8c922073541253600527d52e13a50ecc7b32df65

ypp-chatlog-alerter: wip seems to work ish
---

diff --git a/ypp-chatlog-alerter b/ypp-chatlog-alerter
index 925031d..fb6bba7 100755
--- a/ypp-chatlog-alerter
+++ b/ypp-chatlog-alerter
@@ -52,10 +52,15 @@ set lw_ls {times pirates messages}
 set lw_ws {.time .pirate .msg}
 
 proc widgets {} {
-    global height lw_ws
-    listbox .time -width 5 -height $height -borderwidth 0 -background black
-    listbox .pirate -width 14 -height $height -borderwidth 0 -background black
-    listbox .msg -width 80 -height $height -borderwidth 0
+    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
 }
@@ -85,12 +90,15 @@ proc newfile {} {
     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
@@ -98,19 +106,28 @@ set tint_switch 90
 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 < 120} {
+	    lappend newprtimes [format "%3ds" $age]
+	} else {
+	    lappend newprtimes [format "%3dm" [expr {$age/120}]]
+	}
 	set latest [expr { $time > $latest ? $time : $latest }]
-	set tint [expr {
-			exp( -($now >= $time ? $now-$time : 0) / $e_life )
-		    }]
+	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
@@ -135,14 +152,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 {} }
     set ntimes {}
+    set prtimes {}
     for {set i 0} {$i<$height} {incr i} {
 	for_lw { lappend $l {}; $w insert end {} }
 	lappend ntimes 0
+	lappend prtimes {}
     }
     set times $ntimes
     set otherevent [clock seconds]
@@ -168,6 +187,7 @@ 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
     }
@@ -176,51 +196,36 @@ proc file-read-lines {lvar body} {
 	    file-error $got
 	    return
 	}
-	if {[eof $logfile]} {
+#puts "f-r-l [string length $got]"
+        if {![string length $got] && [eof $logfile]} {
 	    set ago [expr { [clock seconds] - $lastactivity }]
-	    set poll_after [after [expr {( $ago < 10 ? 10 :
-					   $ago > 3000 ? 3000 :
-					   $ago ) * 100}] \
-				pollfile]
+	    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]
 
-	global bufdata
-	if {![regexp {^(.*?)[\r\n]+(.*)$} $got dummy lhs rhs]} {
-	    append bufdata $got
-	    return
-	}
-	
-	set l "$bufdata$lhs"
-	set bufdata $rhs
+	while {[regexp {^(.*?)[\r\n]+(.*)$} $got dummy lhs rhs]} {
+	    set l "$bufdata$lhs"
+	    set bufdata {}
+	    set got $rhs
 puts ">>$l<<"
-	uplevel 1 $body
+	    uplevel 1 $body
+	}
+	append bufdata $got
     }
 }
 
-proc with-file {body} {
-    global errorInfo errorCode
-    set rc [catch { uplevel 1 $body } result]
-    switch -exact $rc {
-	0 {
-	    # ok
-	    return $result
-	}
-	1 {
-	    # error
-	    shownotice red "Error reading logfile $currentfile:\n$emsg"
-	    catch { close $logfile }
-	    set logfile {}
-	}
-	default {
-	    # 2 - 3 - 4   return, break, continue
-	    return -code $rc $errorInfo $errorCode $result
-	}
-	4 {
-	    # 
-	}
-	
+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
@@ -249,16 +254,46 @@ proc pollfile {} {
 	file-read-lines l { }
     }
     file-read-lines l {
-	process-line $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
     }
+}
 
-	with-file {
-	    
+proc message {pirate msg} {
+    global times pirates messages
+    global lw_ls lw_ws
+    
+    set ix [lsearch -exact $pirates $pirate]
+    set now [clock seconds]
+    if {$ix < 0} {
+	set cix 0
+	set oldest $now
+	foreach time $times {
+	    if {$time < $oldest} {
+		set oldest $time
+		set ix $cix
+	    }
+	    incr cix
 	}
-	
-	    while 1 {
-		set data read
     }
+    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 {} {