chiark / gitweb /
ypp-chart-memshow: adjust watch timeout to 300ms
[ypp-sc-tools.db-live.git] / ypp-chatlog-alerter
1 #!/usr/bin/wish
2
3 proc manyset {list args} {
4     foreach val $list var $args {
5         upvar 1 $var my
6         set my $val
7     }
8 }
9
10 set progname ypp-chatlog-alerter
11 set height 5
12
13 proc menuent {w l a x} {
14     set c [list .mbar.$w add command -label $l -command $x]
15     if {[string length $a]} { lappend c -accel Command-$a }
16     eval $c
17 }
18 proc menus {} {
19     global height
20     
21     menu .mbar -tearoff 0
22     foreach w {file edit} l {File Edit} {
23         menu .mbar.$w -tearoff 0
24         .mbar add cascade -menu .mbar.$w -label $l
25     }
26     foreach l {Open Quit} a {O Q} x {newfile exit} {
27         menuent file $l $a $x
28     }
29     foreach l {Cut Copy Paste Clear} a {X C V {}} {
30         menuent edit $l $a [list event generate {[focus]} <<$l>>]]
31     }
32     . configure -menu .mbar
33 }
34
35 proc nonportability {} {
36     global progname defaultfile
37     
38     switch -exact [tk windowingsystem] {
39         aqua {
40             set defaultfile ~/Library/Preferences/$progname.prefs
41         }
42         x11 {
43             set defaultfile ~/.$progname.rc
44         }
45         default {
46             error ?
47         }
48     }
49 }
50
51 set lw_ls {times pirates messages}
52 set lw_ws {.time .pirate .msg}
53
54 proc widgets {} {
55     global height lw_ws prtimes
56     listbox .time   -width  5 -background black \
57         -listvariable prtimes -foreground white
58     listbox .pirate -width 14 -background black
59     listbox .msg    -width 80
60     for_lw {
61         $w configure -height $height -borderwidth 0 -activestyle none \
62             -highlightthickness 0
63     }
64     eval pack $lw_ws -side left
65     label .overlay -relief raised -foreground white
66 }
67
68 proc shownotice {colour message} {
69     .overlay configure -text $message -background $colour
70     place .overlay -relx 0.5 -rely 0.5 -anchor center
71 }
72 proc hidenotice {} {
73     place forget .overlay
74 }
75
76 proc newfile {} {
77     global currentfile defaultfile logfile
78     
79     set newfile [tk_getOpenFile -multiple 0 -initialfile $currentfile \
80                      -title "Select YPP log to track"]
81     if {![string length $newfile]} return
82
83     catch { close $logfile }
84     catch { unset logfile }
85
86     set currentfile $newfile
87     set newdefaults [open $defaultfile.new w]
88     puts $newdefaults "[list set currentfile $currentfile]"
89     close $newdefaults
90     file rename -force $defaultfile.new $defaultfile
91
92     clearlists
93     pollfile
94 }
95
96 proc for_lw {args} {
97     global lw_ls lw_ws
98     set body [lindex $args end]
99     set args [lreplace $args end end]
100     uplevel 1 [list \
101                    foreach l $lw_ls \
102                            w $lw_ws] \
103                            $args \
104                          [list $body]
105 }
106
107 set e_life 120
108 set tint_switch 90
109 set bell_again 60
110 set tint_switched [expr { exp( -($tint_switch+0.0) / $e_life ) }]
111
112 proc retint {} {
113     global times e_life retint_after otherevent prtimes
114     catch { after cancel $retint_after }
115     set i 0
116     set now [clock seconds]
117     set latest $otherevent
118     set newprtimes {}
119     foreach time $times {
120         set age [expr {$now-$time}]
121         if {!$time} {
122             lappend newprtimes {}
123         } elseif {$age < 60} {
124             lappend newprtimes [format "%3ds" $age]
125         } elseif {$age < 3600} {
126             lappend newprtimes [format "%3dm" [expr {$age/60}]]
127         } else {
128             lappend newprtimes [format "%3dh" [expr {$age/3600}]]
129         }
130         set latest [expr { $time > $latest ? $time : $latest }]
131         set tint [expr { exp( (-($age >= 0 ? $age : 0) + 0.0) / $e_life ) }]
132 #puts "AGE $age LA $latest TI $tint"
133         tintentries .msg $i $tint
134         incr i
135     }
136     set prtimes $newprtimes
137     set next [expr { ($now - $latest < 10 ? 10 :
138                       $now - $latest > 3000 ? 3000 :
139                       $now - $latest
140                       ) * 10 }]
141 #puts "nexting $latest $now $next"
142     set retint_after [after $next retint]
143 }
144
145 proc tintentries {ws y tint} {
146     global tint_switched
147     #puts "$tint $tint_switched"
148     set yellow [format "%02x" [expr {round( 255 *
149         ( $tint >= $tint_switched ? $tint : 0 )
150                                             )}]]
151     set black [format "%02x" [expr {round( 255 *
152         ( $tint >= $tint_switched ? 0 : ($tint / $tint_switched)*0.75 + 0.25 )
153                                            )}]]
154     set fg [format "#${black}${black}${black}"]
155     set bg [format "#${yellow}${yellow}00"]
156     foreach w $ws { $w itemconfigure $y -foreground $fg -background $bg }
157 }
158
159 proc clearlists {} {
160     global height otherevent
161     global times prtimes pirates messages
162     set currentfile {}
163     
164     for_lw { $w delete 0 end; set $l {} }
165     set ntimes {}
166     set prtimes {}
167     for {set i 0} {$i<$height} {incr i} {
168         for_lw { lappend $l {}; $w insert end {} }
169         lappend ntimes 0
170         lappend prtimes {}
171     }
172     set times $ntimes
173     set otherevent [clock seconds]
174     retint
175 }
176
177 proc showtints {} {
178     global e_life
179     set divs 20
180     listbox .tints -width 60 -height [expr {$divs+1}]
181     for {set y 0} {$y <= $divs} {incr y} {
182         set tint [expr {($y+0.0)/$divs}]
183         .tints insert end \
184             "[format "#%2d   %6f   %4ds" $y $tint [expr {round(
185                 $tint > 0 ? -log($tint) * $e_life : "9999"
186             )}]]  The quick brown fox jumped over the lazy dog"
187         tintentries .tints $y $tint
188     }
189     pack .tints -side bottom
190 }
191
192 proc file-read-lines {lvar body} {
193     upvar 1 $lvar l
194     global logfile poll_after lastactivity bufdata
195     
196 #puts f-r-l
197     if {![info exists logfile]} {
198         return
199     }
200     while 1 {
201         if {[catch { read $logfile } got]} {
202             file-error $got
203             return
204         }
205 #puts "f-r-l [string length $got]"
206         if {![string length $got] && [eof $logfile]} {
207             set ago [expr { [clock seconds] - $lastactivity }]
208             set interval [expr {( $ago < 10 ? 10 :
209                                   $ago > 3000 ? 3000 :
210                                   $ago ) * 10}]
211 #puts "requeue filepoll $interval"
212             set poll_after [after $interval pollfile]
213             return
214         }
215         set lastactivity [clock seconds]
216
217         while {[regexp {^(.*?)[\r\n]+(.*)$} $got dummy lhs rhs]} {
218             set l "$bufdata$lhs"
219             set bufdata {}
220             set got $rhs
221 #puts ">>$l<<"
222             uplevel 1 $body
223         }
224         append bufdata $got
225     }
226 }
227
228 proc file-error {emsg} {
229     global logfile
230     
231     shownotice red "Error reading logfile $currentfile:\n$emsg"
232     catch { close $logfile }
233     catch { unset logfile }
234 }       
235
236 proc pollfile {} {
237     global poll_after logfile currentfile
238     global errorCode errorInfo bufdata lastactivity
239
240     catch { after cancel $poll_after }
241     if {![string length $currentfile]} {
242         shownotice red "No log file selected.  Use File / Open."
243         return
244     }
245     if {![info exists logfile]} {
246         set bufdata {}
247         set lastactivity [clock seconds] 
248         if {[catch { set logfile [open $currentfile r] } emsg]} {
249             shownotice red "Error opening logfile $currentfile:\n$emsg"
250             return
251         }
252         shownotice \#000080 "Reading $currentfile"
253         if {[catch {
254             seek $logfile -1024 end
255         } emsg]} {
256             if {![string match {POSIX EINVAL *} $errorCode]} {
257                 file-error $emsg
258             }
259         }
260         file-read-lines l { }
261     }
262     file-read-lines l {
263         hidenotice
264         if {[regexp {^\[\d+:\d+:\d+\] (.*)} $l dummy rhs]} {
265 #puts PROCLINE
266             process-line $rhs
267         }
268     }
269 }
270
271 proc process-line {l} {
272     if {[regexp {^(\w+) tells ye, \"(.*)\"$} $l dummy pirate msg]} {
273 #puts "MESSAGE $l"
274         message $pirate $msg
275     }
276 }
277
278 proc message {pirate msg} {
279     global times pirates messages height
280     global lw_ls lw_ws bell_again
281     
282     set ix [lsearch -exact $pirates $pirate]
283     set now [clock seconds]
284     
285     if {$bell_again > -2 &&
286         ($ix<0 || [lindex $times $ix] < $now-$bell_again)} {
287         bell -nice
288     }
289     if {$ix < 0} {
290         set cix 0
291         set oldest $now
292         foreach time $times {
293             if {$time < $oldest} {
294                 set oldest $time
295                 set ix $cix
296             }
297             incr cix
298         }
299         for_lw {
300             set $l [lreplace [set $l] $ix $ix]
301             lappend $l {}
302             $w delete $ix
303             $w insert end {}
304         }
305         set ix [expr {$height-1}]
306     }
307     for_lw new [list $now $pirate $msg] {
308         set $l [lreplace [set $l] $ix $ix $new]
309         $w delete $ix
310         $w insert $ix $new
311     }
312 #puts "TIMES $times"
313     .pirate itemconfigure $ix -foreground white
314     retint
315 }
316
317 proc parseargs {} {
318     global argv
319     foreach arg $argv {
320         if {![string compare $arg --test-tints]} {
321             showtints
322         } elseif {![string compare $arg --no-bell]} {
323             set bell_again -2
324         } else {
325             error "unknown option $arg"
326         }
327     }
328 }
329
330 menus
331 nonportability
332 parseargs
333 widgets
334 clearlists
335
336 if {[file exists $defaultfile]} {
337     source $defaultfile
338 }
339
340 pollfile