chiark / gitweb /
reorganise debug etc.
authorIan Jackson <ijackson@chiark.greenend.org.uk>
Tue, 12 Jun 2012 17:04:46 +0000 (18:04 +0100)
committerIan Jackson <ijackson@chiark.greenend.org.uk>
Tue, 12 Jun 2012 17:04:46 +0000 (18:04 +0100)
applet.tcl
args.tcl
subproc.tcl
xbatmon-simple-tray

index 133eb13..0aa2b94 100644 (file)
@@ -1,13 +1,5 @@
 # General purpose code for being a tray applet
 
-proc manyset {list args} {
-    foreach val $list var $args {
-        upvar 1 $var my
-        set my $val
-    }
-}
-
-
 package require Tclx
 package require tktray
 
@@ -41,13 +33,6 @@ package require tktray
 #    menus, when an item is selected, call
 #      applet::msel
 #
-# Debug:
-# 
-#    Caller may call
-#       applet::setup-debug ON-DEBUG
-#    which will result in calls to [concat ON-DEBUG [list MESSAGE]]
-#    (or ON-DEBUG may be "" in which case messages are discarded)
-#
 # Icon:
 #
 #  Caller should call:
@@ -90,18 +75,6 @@ fconfigure stderr -buffering none
 
 namespace eval applet {
 
-variable debug {}
-
-proc debug {m} {
-    variable debug
-    if {![llength $debug]} return
-    uplevel #0 $debug [list $m]
-}
-
-proc setup-debug {d} {
-    variable debug $d
-}
-
 # used by both menus and tooltips
 variable posted 0
 
@@ -116,15 +89,15 @@ proc menubuttonpressed {b x y} {
     variable posted
     tooltip-cancel
     if {$posted == $b} {
-       debug "unpost $posted toggle"
+       debug::debug "unpost $posted toggle"
        .m$posted unpost
        set posted 0
     } elseif {[winfo exists .m$b]} {
        if {$posted} {
            .m$posted unpost
-           debug "unpost $posted other"
+           debug::debug "unpost $posted other"
        }
-       debug "post $b"
+       debug::debug "post $b"
        set posted $b
        .m$b post $x $y
     }
@@ -223,7 +196,7 @@ variable border_width 1
 
 proc subwindow-need-recreate {} {
     variable innerwindow_after
-    debug "IW-EVENT"
+    debug::debug "IW-EVENT"
     if {[info exists innerwindow_after]} return
     set innerwindow_after [after idle applet::innerwindow-resetup]
 }
@@ -237,7 +210,7 @@ proc innerwindow-resetup {} {
     variable deforient
     unset innerwindow_after
 
-    debug RESETUP
+    debug::debug RESETUP
 
     if {![winfo exists .i.i]} return
     destroy [frame .i.i.make-exist]
@@ -246,7 +219,7 @@ proc innerwindow-resetup {} {
     catch { destroy .i.i.b }
 
     set orientation [.i orientation]
-    debug "orientation $orientation"
+    debug::debug "orientation $orientation"
     if {![string compare $orientation unknown]} {
        set orientation $deforient
     }
@@ -289,7 +262,7 @@ proc setup-subproc {get_cmdline} {
 
 proc subproc-destroying {} {
     variable subproc
-    debug "DESTROYING $subproc"
+    debug::debug "DESTROYING $subproc"
 
     catch { destroy .i.i.b.c }
 
@@ -303,7 +276,7 @@ proc subproc-destroying {} {
 proc subproc-ready {orientation} {
     variable subproc
     variable subproc_orientation $orientation
-    debug "READY $subproc"
+    debug::debug "READY $subproc"
 
     frame .i.i.b.c -container 1 -background orange
     pack .i.i.b.c -fill both -side left -expand 1
@@ -319,7 +292,7 @@ proc subproc-ready {orientation} {
            error "unexpected state $subproc"
        }
     }
-    debug "READY-done $subproc"
+    debug::debug "READY-done $subproc"
 }
 
 proc run-child {} {
@@ -331,7 +304,7 @@ proc run-child {} {
     set id [winfo id .i.i.b.c]
     set cmd [uplevel #0 $subproc_get_cmdline [list $id $subproc_orientation]]
 
-    debug "RUN-CHILD $subproc"
+    debug::debug "RUN-CHILD $subproc"
     set now [clock seconds]
     lappend ratelimit $now
     while {[lindex $ratelimit 0] < {$now - 10}} {
@@ -346,11 +319,11 @@ proc run-child {} {
     set subproc [subproc::fork applet::child-died {
        execl [lindex $cmd 0] [lrange $cmd 1 end]
     }]
-    debug "FORKED $subproc"
+    debug::debug "FORKED $subproc"
 }
 
 proc child-died {how how2} {
-    debug "DIED $how $how2"
+    debug::debug "DIED $how $how2"
     variable subproc
     switch -exact $subproc {
        old {
index 248548b..c81118c 100644 (file)
--- a/args.tcl
+++ b/args.tcl
@@ -35,7 +35,7 @@ proc generalarg {arg} {
        -horizontal - -vertical { set applet::deforient $arg }
        -borderColour - -borderColor { set applet::border_colour [next] }
        -borderWidth { set applet::border_width [next_num] }
-       -debug { applet::setup-debug puts }
+       -debug { debug::setup puts }
        default { return 0 }
     }
     return 1
index 36d5465..c4cf975 100644 (file)
@@ -1,4 +1,6 @@
 
+package require Tclx
+
 namespace eval subproc {
 
 #----- general purpose subprocess handling -----
index e53945a..2a3948c 100755 (executable)
@@ -5,8 +5,8 @@
 #  xbatmon-simple-tray
 #    [WISH-OPTIONS... [-- TRAY-EMBED-OPTIONS... [-- XBATMON-SIMPLE-OPTIONS...]]]
 
-source applet.tcl
 source subproc.tcl
+source utils.tcl
 source args.tcl
 
 proc cmdline {id orientation} {
@@ -14,11 +14,125 @@ proc cmdline {id orientation} {
     return [concat [list xacpi-simple -into $id] $argv]
 }
 
+#----- tooltip generation -----
+
+proc tt-invisible {} {
+    tt-noafter
+    applet::tooltip-set {}
+}
+
+proc tt-noafter {} {
+    global ttafter
+    catch { after cancel $ttafter }
+    catch { unset ttafter }
+}
+
+proc tt-show {} {
+    global ttafter
+    tt-noafter
+    set ttafter [after 500 tt-show]
+    applet::tooltip-set [tt-string]
+}
+
+proc tt-string {} {
+    global errorInfo
+    set lines {}
+    if {[catch {
+       set dir /sys/class/power_supply
+       foreach f [glob -nocomplain -tails -directory $dir *] {
+           debug::debug "TT-INFO $f"
+           if {[catch { 
+               set chan [open $dir/$f/uevent]
+               tt-info $chan
+           } info]} {
+               set info "error: $info"
+               debug::debug "$f $errorInfo"
+           }
+           lappend lines "$f: $info"
+           catch { close $chan }
+           catch { unset chan }
+       }
+    } emsg]} {
+       lappend lines "error scanning: $emsg"
+       debug::debug "scanning $errorInfo"
+    }
+    if {![llength $lines]} {
+       lappend lines "no power information"
+    }
+    return [join $lines "\n"]
+}
+
+proc compute {power energy factor} {
+    upvar 1 a a
+    upvar 1 q q
+    debug::debug "COMPUTE $power $energy $factor"
+    foreach ent {energy NOW} {energy FULL} {energy FULL_DESIGN} {power NOW} {
+       manyset $ent pe k
+       set kv "[set $pe]_$k"
+       if {![info exists a($kv)]} { return 0 }
+       set q("${pe}_${k}") [expr {$a($kv) * $factor}]
+    }
+    return 1
+}
+
+proc tt-info {chan} {
+    while {[gets $chan l] >= 0} {
+       if {[regexp {^POWER_SUPPLY_([A-Z0-9_]+)=(.*)$} $l dummy k v]} {
+           debug::debug "  uevent ok  $l"
+           set a($k) $v
+       } else {
+           debug::debug "  uevent unk $l"
+       }
+    }
+    set o "$a(TYPE)"
+    switch -exact -- $a(TYPE) {
+       Mains {
+           switch -exact -- $a(ONLINE) {
+               0 { append o " Offline" }
+               1 { append o " Online" }
+               default { append o " ?$o" }
+           }
+       }
+       Battery {
+           switch -exact -- $a(PRESENT) {
+               0 { append o " Absent"; return $o }
+               1 { append o " Present" }
+               default { apend o " ?$o" }
+           }
+           append o " $a(STATUS)"
+           if {[compute POWER ENERGY 1.0] ||
+               [compute CURRENT CHARGE [expr {$a(VOLTAGE_NOW) * 1e-6}]]} {
+               debug::debug "COMPUTE OK"
+           } else {
+               append o " ?"
+           }
+       }
+    }
+}
+
+#----- modes -----
+
+proc mode/normal {} {
+    uplevel #0 source applet.tcl
+    applet::setup-subproc cmdline
+    applet::setup-tooltip tt-show tt-invisible
+}
+
+proc mode/-tooltip-string {} {
+    puts [tt-string]
+    exit 0
+}
+
+#----- command line parsing -----
+
+set mode normal
+
 while {[args::next_special arg]} {
     switch -exact -- $arg {
        -- { break }
+       -tooltip-string { set mode $arg }
        default { args::badoption }
     }
 }
 
-applet::setup-subproc cmdline
+mode/$mode