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
  56     listbox .time -width 5 -height $height -borderwidth 0 -background black
  57     listbox .pirate -width 14 -height $height -borderwidth 0 -background black
  58     listbox .msg -width 80 -height $height -borderwidth 0
  59     eval pack $lw_ws -side left
  60     label .overlay -relief raised -foreground white
  61 }
  62
  63 proc shownotice {colour message} {
  64     .overlay configure -text $message -background $colour
  65     place .overlay -relx 0.5 -rely 0.5 -anchor center
  66 }
  67 proc hidenotice {} {
  68     place forget .overlay
  69 }
  70
  71 proc newfile {} {
  72     global currentfile defaultfile
  73
  74     set newfile [tk_getOpenFile -multiple 0 -initialfile $currentfile \
  75                      -title "Select YPP log to track"]
  76     if {![string length $newfile]} return
  77
  78     set currentfile $newfile
  79     set newdefaults [open $defaultfile.new w]
  80     puts $newdefaults "[list set currentfile $currentfile]"
  81     close $newdefaults
  82     file rename -force $defaultfile.new $defaultfile
  83
  84     clearlists
  85     pollfile
  86 }
  87
  88 proc for_lw {body} {
  89     global lw_ls lw_ws
  90     uplevel 1 [list \
  91                    foreach l $lw_ls \
  92                            w $lw_ws \
  93                        $body]
  94 }
  95
  96 set e_life 120
  97 set tint_switch 90
  98 set tint_switched [expr { exp( -($tint_switch+0.0) / $e_life ) }]
  99
 100 proc retint {} {
 101     global times e_life retint_after otherevent
 102     catch { after cancel $retint_after }
 103     set i 0
 104     set now [clock seconds]
 105     set latest $otherevent
 106     foreach time $times {
 107         set latest [expr { $time > $latest ? $time : $latest }]
 108         set tint [expr {
 109                         exp( -($now >= $time ? $now-$time : 0) / $e_life )
 110                     }]
 111         tintentries .msg $i $tint
 112         incr i
 113     }
 114     set next [expr { ($now - $latest < 10 ? 10 :
 115                       $now - $latest > 3000 ? 3000 :
 116                       $now - $latest
 117                       ) * 10 }]
 118 #puts "nexting $latest $now $next"
 119     set retint_after [after $next retint]
 120 }
 121
 122 proc tintentries {ws y tint} {
 123     global tint_switched
 124     #puts "$tint $tint_switched"
 125     set yellow [format "%02x" [expr {round( 255 *
 126         ( $tint >= $tint_switched ? $tint : 0 )
 127                                             )}]]
 128     set black [format "%02x" [expr {round( 255 *
 129         ( $tint >= $tint_switched ? 0 : ($tint / $tint_switched)*0.75 + 0.25 )
 130                                            )}]]
 131     set fg [format "#${black}${black}${black}"]
 132     set bg [format "#${yellow}${yellow}00"]
 133     foreach w $ws { $w itemconfigure $y -foreground $fg -background $bg }
 134 }
 135
 136 proc clearlists {} {
 137     global height otherevent
 138     global times pirates messages
 139     set currentfile {}
 140
 141     for_lw { $w delete 0 end; set $l {} }
 142     set ntimes {}
 143     for {set i 0} {$i<$height} {incr i} {
 144         for_lw { lappend $l {}; $w insert end {} }
 145         lappend ntimes 0
 146     }
 147     set times $ntimes
 148     set otherevent [clock seconds]
 149     retint
 150 }
 151
 152 proc showtints {} {
 153     global e_life
 154     set divs 20
 155     listbox .tints -width 60 -height [expr {$divs+1}]
 156     for {set y 0} {$y <= $divs} {incr y} {
 157         set tint [expr {($y+0.0)/$divs}]
 158         .tints insert end \
 159             "[format "#%2d   %6f   %4ds" $y $tint [expr {round(
 160                 $tint > 0 ? -log($tint) * $e_life : "9999"
 161             )}]]  The quick brown fox jumped over the lazy dog"
 162         tintentries .tints $y $tint
 163     }
 164     pack .tints -side bottom
 165 }
 166
 167 proc file-read-lines {lvar body} {
 168     upvar 1 $lvar l
 169     global logfile poll_after lastactivity bufdata
 170
 171     if {![info exists logfile]} {
 172         return
 173     }
 174     while 1 {
 175         if {[catch { read $logfile } got]} {
 176             file-error $got
 177             return
 178         }
 179         if {[eof $logfile]} {
 180             set ago [expr { [clock seconds] - $lastactivity }]
 181             set poll_after [after [expr {( $ago < 10 ? 10 :
 182                                            $ago > 3000 ? 3000 :
 183                                            $ago ) * 100}] \
 184                                 pollfile]
 185             return
 186         }
 187         set lastactivity [clock seconds]
 188
 189         global bufdata
 190         if {![regexp {^(.*?)[\r\n]+(.*)$} $got dummy lhs rhs]} {
 191             append bufdata $got
 192             return
 193         }
 194
 195         set l "$bufdata$lhs"
 196         set bufdata $rhs
 197 puts ">>$l<<"
 198         uplevel 1 $body
 199     }
 200 }
 201
 202 proc with-file {body} {
 203     global errorInfo errorCode
 204     set rc [catch { uplevel 1 $body } result]
 205     switch -exact $rc {
 206         0 {
 207             # ok
 208             return $result
 209         }
 210         1 {
 211             # error
 212             shownotice red "Error reading logfile $currentfile:\n$emsg"
 213             catch { close $logfile }
 214             set logfile {}
 215         }
 216         default {
 217             # 2 - 3 - 4   return, break, continue
 218             return -code $rc $errorInfo $errorCode $result
 219         }
 220         4 {
 221             #
 222         }
 223
 224
 225 proc pollfile {} {
 226     global poll_after logfile currentfile
 227     global errorCode errorInfo bufdata lastactivity
 228
 229     catch { after cancel $poll_after }
 230     if {![string length $currentfile]} {
 231         shownotice red "No log file selected.  Use File / Open."
 232         return
 233     }
 234     if {![info exists logfile]} {
 235         set bufdata {}
 236         set lastactivity [clock seconds]
 237         if {[catch { set logfile [open $currentfile r] } emsg]} {
 238             shownotice red "Error opening logfile $currentfile:\n$emsg"
 239             return
 240         }
 241         shownotice \#000080 "Reading $currentfile"
 242         if {[catch {
 243             seek $logfile -1024 end
 244         } emsg]} {
 245             if {![string match {POSIX EINVAL *} $errorCode]} {
 246                 file-error $emsg
 247             }
 248         }
 249         file-read-lines l { }
 250     }
 251     file-read-lines l {
 252         process-line $l
 253     }
 254
 255         with-file {
 256
 257         }
 258
 259             while 1 {
 260                 set data read
 261     }
 262 }
 263
 264 proc parseargs {} {
 265     global argv
 266     foreach arg $argv {
 267         if {![string compare $arg --test-tints]} {
 268             showtints
 269         } else {
 270             error "unknown option $arg"
 271         }
 272     }
 273 }
 274
 275 menus
 276 nonportability
 277 parseargs
 278 widgets
 279 clearlists
 280
 281 if {[file exists $defaultfile]} {
 282     source $defaultfile
 283 }
 284
 285 pollfile