chiark / gitweb /
increase maximum distance
[ypp-sc-tools.db-live.git] / ypp-chatlog-alerter
index 71a05bb..05a9c20 100755 (executable)
 #!/usr/bin/wish
 
+proc manyset {list args} {
+    foreach val $list var $args {
+        upvar 1 $var my
+        set my $val
+    }
+}
+
 set progname ypp-chatlog-alerter
+set height 5
 
-menu .mbar -tearoff 0
-foreach w {file edit} l {File Edit} {
-    menu .mbar.$w -tearoff 0
-    .mbar add cascade -menu .mbar.$w -label $l
-}
 proc menuent {w l a x} {
     set c [list .mbar.$w add command -label $l -command $x]
     if {[string length $a]} { lappend c -accel Command-$a }
     eval $c
 }
-foreach l {Open Quit} a {O Q} x {newfile exit} {
-    menuent file $l $a $x
-}
-foreach l {Cut Copy Paste Clear} a {X C V {}} {
-    menuent edit $l $a [list event generate {[focus]} <<$l>>]]
+proc menus {} {
+    global height
+    
+    menu .mbar -tearoff 0
+    foreach w {file edit} l {File Edit} {
+       menu .mbar.$w -tearoff 0
+       .mbar add cascade -menu .mbar.$w -label $l
+    }
+    foreach l {Open Quit} a {O Q} x {newfile exit} {
+       menuent file $l $a $x
+    }
+    foreach l {Cut Copy Paste Clear} a {X C V {}} {
+       menuent edit $l $a [list event generate {[focus]} <<$l>>]]
+    }
+    . configure -menu .mbar
 }
-. configure -menu .mbar
 
-switch -exact [tk windowingsystem] {
-    aqua {
-       set defaultfile ~/Library/Preferences/$progname.prefs
-    }
-    x11 {
-       set defaultfile ~/.$progname.rc
+proc nonportability {} {
+    global progname defaultfile
+    
+    switch -exact [tk windowingsystem] {
+       aqua {
+           set defaultfile ~/Library/Preferences/$progname.prefs
+       }
+       x11 {
+           set defaultfile ~/.$progname.rc
+       }
+       default {
+           error ?
+       }
     }
-    default {
-       error ?
+}
+
+set lw_ls {times pirates messages}
+set lw_ws {.time .pirate .msg}
+
+proc widgets {} {
+    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 -title "Select YPP log to track"]
+    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
-    refresh
+
+    clearlists
+    pollfile
 }
 
-set currentfile {}
+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] \
+                          $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 refresh {} {
+proc retint {} {
+    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( (-($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 tintentries {ws y tint} {
+    global tint_switched
+    #puts "$tint $tint_switched"
+    set yellow [format "%02x" [expr {round( 255 *
+        ( $tint >= $tint_switched ? $tint : 0 )
+                                           )}]]
+    set black [format "%02x" [expr {round( 255 *
+       ( $tint >= $tint_switched ? 0 : ($tint / $tint_switched)*0.75 + 0.25 )
+                                          )}]]
+    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 otherevent
+    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]
+    retint
+}
+
+proc showtints {} {
+    global e_life
+    set divs 20
+    listbox .tints -width 60 -height [expr {$divs+1}]
+    for {set y 0} {$y <= $divs} {incr y} {
+       set tint [expr {($y+0.0)/$divs}]
+       .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"
+       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"
+       }
+    }
+}
+
+menus
+nonportability
+parseargs
+widgets
+clearlists
+
 if {[file exists $defaultfile]} {
     source $defaultfile
 }
 
-listbox .l
+pollfile