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