bugfixes

diff --git a/irccore.tcl b/irccore.tcl
index 34836e2a7c7a01468e6e06e8cb0d63bc77bfc2f8..545446cac3e464c1dd99a4c26d5ca64dc59983e3 100644 (file)
--- a/irccore.tcl
+++ b/irccore.tcl
@@ -5,6 +5,7 @@ proc defset {varname val} {
 
 # must set host
 defset port 6667
 
 # must set host
 defset port 6667

+defset socketargs {}

 
 defset nick testbot
 defset ident blight
 
 defset nick testbot
 defset ident blight

diff --git a/ledconfig.tcl b/ledconfig.tcl
index 3d0a6b423024c0572b4ceb5ad88095a38cb2e674..2896afeee9e2a765d274b11cb03138df781b0462 100644 (file)
--- a/ledconfig.tcl
+++ b/ledconfig.tcl
@@ -4,10 +4,5 @@ set host chiark-tunnel.greenend.org.uk
 set nick ledctrl
 set ownfullname "activity LEDs"
 set ownmailaddr ijackson@chiark.greenend.org.uk
 set nick ledctrl
 set ownfullname "activity LEDs"
 set ownmailaddr ijackson@chiark.greenend.org.uk

-set socketargs {}
-set errchan #$nick
-set retry_after 300000
-set chan_after 3000
-set chans_retry 3600000

 
 source ledmodule.tcl
 
 source ledmodule.tcl

diff --git a/ledmodule.tcl b/ledmodule.tcl
index 3986863885124a08d7ee0031583eba2589f4f284..250f600f9b43f51ccd674e60c9ed032c5027f202 100644 (file)
--- a/ledmodule.tcl
+++ b/ledmodule.tcl
@@ -39,22 +39,33 @@ source parsecmd.tcl
 source stdhelp.tcl
 source userv.tcl
 
 source stdhelp.tcl
 source userv.tcl
 

+defset errchan #$nick
+defset retry_after 900000
+defset chan_after 3000
+defset chans_retry 3600000
+defset debug_reset_after 86400000
+
+defset debugusers {}
+

 # variables
 #
 #   monitor/$monname(chans)           -> [list $chan1 $chan2 ...]
 #   monitor/$monname(ignore)          -> [list $regexp ...]
 #   monitor/$monname(prefer)          -> [list $regexp ...]
 # variables
 #
 #   monitor/$monname(chans)           -> [list $chan1 $chan2 ...]
 #   monitor/$monname(ignore)          -> [list $regexp ...]
 #   monitor/$monname(prefer)          -> [list $regexp ...]

-#   monitor/$monname(present)         -> [list $lnick ...]
+#   monitor/$monname(present-$chan)   -> [list $lnick ...]

 #   monitor/$monname(last-talk)       -> $time_t
 #   monitor/$monname(last-talkpref)   -> $time_t
 #   monitor/$monname(time-recent)     -> $seconds
 #   monitor/$monname(time-recentnow)  -> $seconds
 #   monitor/$monname(last-talk)       -> $time_t
 #   monitor/$monname(last-talkpref)   -> $time_t
 #   monitor/$monname(time-recent)     -> $seconds
 #   monitor/$monname(time-recentnow)  -> $seconds

+#   monitor/$monname(talkchange)      -> [after ...]    or unset

 #
 #   deviceset/$username:$lno(monname)  -> $monname
 #   deviceset/$username:$lno(group)    -> $led_group
 #   deviceset/$username:$lno(username) -> $username
 #
 #   deviceset/$username:$lno(monname)  -> $monname
 #   deviceset/$username:$lno(group)    -> $led_group
 #   deviceset/$username:$lno(username) -> $username

+#   deviceset/$username:$lno(values)   -> $valuestring

 #   deviceset/$username:$lno(states)   -> [list $state1 $value1 $state2 ...]
 #   deviceset/$username:$lno(states)   -> [list $state1 $value1 $state2 ...]

-#   deviceset/$username:$lno(fchan)    -> [open remoteleds ... |]  or unset
+#   deviceset/$username:$lno(ochan)    -> [open remoteleds ... | r]  or unset
+#   deviceset/$username:$lno(ichan)    -> fifo for remoteleds input  or unset

 #   deviceset/$username:$lno(retry)    -> [after ... ]             or unset
 #
 #   onchans($chan)        [list mustleave]                 # in config_chane
 #   deviceset/$username:$lno(retry)    -> [after ... ]             or unset
 #
 #   onchans($chan)        [list mustleave]                 # in config_chane


@@ -62,6 +73,21 @@ source userv.tcl
 #   onchans($chan)        [list forced]                    # for errchan
 #   onchans($chan)        [list shortly [after ...]]       # do a NAMES
 
 #   onchans($chan)        [list forced]                    # for errchan
 #   onchans($chan)        [list shortly [after ...]]       # do a NAMES
 

+proc ldebug {facil m} {
+    global debugusers
+    # facil is
+    #    m$monname
+    #    d$deviceset
+    #    c$lchan
+    #    {}             for system stuff
+    if {![llength debugusers]} return
+    if {[regexp {[md]([^:]+)\:} $facil dummy username] &&
+        [lsearch -exact $debugusers $username]==-1} return
+
+    regsub {^(.)} $facil {\1 } cc
+    reporterr "DEBUG $cc $m"
+}    
+

 proc list_objs {vp} {
     set l {}
     foreach v [info globals] {
 proc list_objs {vp} {
     set l {}
     foreach v [info globals] {


@@ -111,6 +137,12 @@ proc mon_nick_is {globlist ln} {
     return 0
 }
 
     return 0
 }
 

+proc_mon gotchanlist {ch nll} {
+    if {[lsearch -exact $mm(chans) $ch] == -1} return
+    set mm(present-$ch) $nll
+    mon_updateall $m
+}
+

 proc_mon speech {chan ln} {
     if {[lsearch -exact $mm(chans) $chan] == -1} return
     if {[mon_nick_is $mm(ignore) $ln]} return
 proc_mon speech {chan ln} {
     if {[lsearch -exact $mm(chans) $chan] == -1} return
     if {[mon_nick_is $mm(ignore) $ln]} return


@@ -121,16 +153,33 @@ proc_mon speech {chan ln} {
 }
 
 proc_mon calcstate {} {
 }
 
 proc_mon calcstate {} {

-    set s " "
-    if {[llength $mm(present)]} { append s "present " }
+    set s " default "
+    foreach ch $mm(chans) {
+       if {[llength $mm(present-$ch)]} { append s "present "; break }
+    }

     set now [clock seconds]
     set now [clock seconds]

+    set valid_until [expr {$now + 86400}]
+    set refresh_later 0
+    catch { after cancel $mm(talkchange) }

     foreach p {{} pref} {
        foreach t {{} now} {
     foreach p {{} pref} {
        foreach t {{} now} {

-           set since [expr {$now - $mm(time-recent$t)}]
-           if {[expr {$mm(last-talk$p) < $since}]} continue
+           set vu [expr {$mm(last-talk$p) + $mm(time-recent$t)}]
+           if {$vu < $now} continue

            append s "${p}talk${t} "
            append s "${p}talk${t} "

+           set refresh_later 1
+           if {$vu < $valid_until} { set valid_until $vu }

        }
     }
        }
     }

+    regsub {^ default } $s { } ss
+    set ds [string trim $ss]
+    if {$refresh_later} {
+       set interval [expr {$valid_until - $now + 2}]
+       set ivms [expr {$interval*1000}]
+       set mm(talkchange) [after $ivms [list mon_updateall $m]]
+       ldebug m$m "until now+${interval}: $ds"
+    } else {
+       ldebug m$m "indefinitely: $ds"
+    }

     return $s
 }
 
     return $s
 }
 


@@ -144,6 +193,8 @@ proc_mon updateall {} {
 }
 
 proc_mon destroy {} {
 }
 
 proc_mon destroy {} {

+    ldebug m$m "destroying"
+    catch { after cancel $mm(talkchange) }

     catch { unset mm }
 }
 
     catch { unset mm }
 }
 


@@ -152,7 +203,7 @@ proc proc_dset {name argl body} {
     upvar #0 deviceset/\$d dd
     if {\[catch {
         $body
     upvar #0 deviceset/\$d dd
     if {\[catch {
         $body

-    } emsg\]} {
+    } emsg\]==1} {

        reporterr \"error on \$d: \$emsg\"
     }"
 }
        reporterr \"error on \$d: \$emsg\"
     }"
 }


@@ -162,26 +213,45 @@ proc timed_log {m} {
 }
 
 proc_dset setbystate {s} {
 }
 
 proc_dset setbystate {s} {

-    set lv {}
-    foreach {sq v} $s {
+    foreach {sq v} $dd(states) {

        if {![string match *$sq* $s]} continue
        set lv $v; break
     }
        if {![string match *$sq* $s]} continue
        set lv $v; break
     }

+    if {![info exists lv]} {
+       reporterr "no state for $d matching$s"
+       return
+    }
+    ldebug d$d "matches $sq: $v"

     timed_log "->$d $lv"
     timed_log "->$d $lv"

-    puts $dd(fchan) $lv
+    set dd(values) "$sq=$lv"
+    puts $dd(ichan) $lv

 }
 
 proc_dset destroy {} {
 }
 
 proc_dset destroy {} {

+    ldebug d$d "destroying"

     catch { after cancel $dd(retry) }
     catch {
     catch { after cancel $dd(retry) }
     catch {

-       if {[info exists dd(fchan)]} { timed_log ">\$$d destroy" }
-       close $dd(fchan)
+       if {[info exists dd(ochan)]} { timed_log ">\$$d destroy" }
+       close $dd(ochan)
+       close $dd(ichan)

     }
     catch { unset dd }
 }
 
     }
     catch { unset dd }
 }
 

+proc modvar_save_copy {cv defv} {
+    upvar 1 m m
+    upvar 1 mm mm
+    upvar 1 save/$m save
+    if {[info exists save($cv)]} {
+       set mm($cv) $save($cv)
+    } else {
+       set mm($cv) $defv
+    }
+}
+

 proc reloaduser {username} {
     check_username $username
 proc reloaduser {username} {
     check_username $username

+    ldebug u$username "reloading"

     if {[catch {
        set cfg [exec userv --timeout 3 $username irc-ledcontrol-config \
                < /dev/null]
     if {[catch {
        set cfg [exec userv --timeout 3 $username irc-ledcontrol-config \
                < /dev/null]


@@ -196,10 +266,11 @@ proc reloaduser {username} {
     }
     foreach m [list_objs monitor] {
        if {![string match $username* $m]} continue
     }
     foreach m [list_objs monitor] {
        if {![string match $username* $m]} continue

-       mon_destroy $m
+       upvar #0 monitor/$m mm
+       foreach cv [array names mm] { set save/${m}($cv) $mm($cv) }

     }
     if {![string length $cfg]} {
     }
     if {![string length $cfg]} {

-       file remove pwdb/$username
+       file delete pwdb/$username

        return "no config from $username"
     } elseif {[catch {
        exec userv --timeout 3 $username irc-ledcontrol-passwords \
        return "no config from $username"
     } elseif {[catch {
        exec userv --timeout 3 $username irc-ledcontrol-passwords \


@@ -208,6 +279,7 @@ proc reloaduser {username} {
        reporterr "error reading passwords for $username: $emsg"
        return ""
     } elseif {[catch {
        reporterr "error reading passwords for $username: $emsg"
        return ""
     } elseif {[catch {

+       ldebug u$username "parsing"

        foreach cv {ignore nopresence prefer} { set cc($cv) {} }
        set cc(time-recentnow) 120
        set cc(time-recent) 450
        foreach cv {ignore nopresence prefer} { set cc($cv) {} }
        set cc(time-recentnow) 120
        set cc(time-recent) 450


@@ -241,8 +313,13 @@ proc reloaduser {username} {
                }
                upvar #0 monitor/$m mm
                foreach cv [array names cc] { set mm($cv) $cc($cv) }
                }
                upvar #0 monitor/$m mm
                foreach cv [array names cc] { set mm($cv) $cc($cv) }

-               foreach cv {{} pref} { set mm(last-talk$cv) 0 }
-               set mm(present) {}
+               foreach cv {{} pref} {
+                   modvar_save_copy last-talk$cv 0
+               }
+               foreach cv [array names mm(chans)] {
+                   modvar_save_copy present-$cv {}
+               }
+               ldebug m$m "created"

            } elseif {[regexp \
  {^leds\s+([0-9A-Za-z][-:/0-9A-Za-z]+)\s+(\S+)\s+(\S+.*)$} \
                    $l dummy g m states]} {
            } elseif {[regexp \
  {^leds\s+([0-9A-Za-z][-:/0-9A-Za-z]+)\s+(\S+)\s+(\S+.*)$} \
                    $l dummy g m states]} {


@@ -252,8 +329,8 @@ proc reloaduser {username} {
                foreach sv [split $states " "] {
                    if {![string length $sv]} continue
                    if {![regexp \
                foreach sv [split $states " "] {
                    if {![string length $sv]} continue
                    if {![regexp \

- {^((pref)?talk(now)?|present|default)\=([0-9a-z][,/+0-9A-Za-z]*)$} \
-                          $sv dummy lhs dummy dummy rhs]} {
+ {^((?:pref)?talk(?:now)?|present|default)\=([0-9a-z][,/+0-9A-Za-z]*)$} \
+                          $sv dummy lhs rhs]} {

                        error "invalid state spec"
                    }
                    lappend sl $lhs $rhs
                        error "invalid state spec"
                    }
                    lappend sl $lhs $rhs


@@ -262,8 +339,10 @@ proc reloaduser {username} {
                set dd(monname) $m
                set dd(states) $sl
                set dd(group) $g
                set dd(monname) $m
                set dd(states) $sl
                set dd(group) $g

+               set dd(values) startup

                set dd(username) $username
                dset_start $d
                set dd(username) $username
                dset_start $d

+               ldebug d$d "created"

            }
        }
     } emsg]} {
            }
        }
     } emsg]} {


@@ -286,40 +365,53 @@ proc check_monname {m} {
 proc_dset start {} {
     catch { unset dd(retry) }
     set username $dd(username)
 proc_dset start {} {
     catch { unset dd(retry) }
     set username $dd(username)

+    ldebug d$d "starting"

     if {[catch {
        set cmdl [list remoteleds --pipe $dd(group) \
     if {[catch {
        set cmdl [list remoteleds --pipe $dd(group) \

-                      --passfile-only pwdb/p$username]
+                      --human --passfile-only pwdb/p$username]

        timed_log "!-$d [join $cmdl " "]"
        timed_log "!-$d [join $cmdl " "]"

-       set fchan [open |[concat $cmdl {|& cat}] r+]
-       fconfigure $fchan -blocking 0
-       fileevent $fchan readable [list dset_rledout $d]
-       set dd(fchan) $fchan
+       lappend cmdl < pwdb/fifo |& cat
+       catch { file delete pwdb/fifo }
+       exec mkfifo -m 0600 pwdb/fifo
+       set ichan [open pwdb/fifo r+]
+       set ochan [open |$cmdl r]
+       fconfigure $ichan -blocking 0 -buffering line
+       fconfigure $ochan -blocking 0 -buffering line
+       fileevent $ochan readable [list dset_rledout $d]
+       set dd(ichan) $ichan
+       set dd(ochan) $ochan

     } emsg]} {
        reporterr "remoteleds startup $d: $emsg"
     } emsg]} {
        reporterr "remoteleds startup $d: $emsg"

+       catch { close $ichan }
+       catch { close $ochan }

        dset_trylater $d
     }
 }
 
 proc_dset rledout {} {
     global errchan
        dset_trylater $d
     }
 }
 
 proc_dset rledout {} {
     global errchan

-    while {[gets $dd(fchan) l] != -1} { reporterr "remoteleds on $d: $l" }
-    if {[fblocked $dd(fchan)]} return
-    catch {
-       timed_log ">\$$d failure";
-       close $dd(fchan)
+    while {[gets $dd(ochan) l] != -1} {
+       reporterr "remoteleds on $d: $dd(values): $l"

     }
     }

-    unset dd(fchan)
+    if {[fblocked $dd(ochan)]} return
+    timed_log ">\$$d failure";
+    catch { close $dd(ichan) }
+    catch { close $dd(ochan) }
+    unset dd(ichan)
+    unset dd(ochan)

     reporterr "remoteleds on $d died"
     dset_trylater $d
 }
 
 proc_dset trylater {} {
     global retry_after
     reporterr "remoteleds on $d died"
     dset_trylater $d
 }
 
 proc_dset trylater {} {
     global retry_after

+    ldebug d$d "will try again later"

     set dd(retry) [after $retry_after [list dset_start $d]]
 }
 
 proc config_change {} {
     set dd(retry) [after $retry_after [list dset_start $d]]
 }
 
 proc config_change {} {

-    global onchans chans_retry errchan
+    global onchans chans_retry errchan config_retry_after
+    ldebug {} "rechecking configuration etc"

     foreach ch [array names onchans] {
        manyset $onchans($ch) status after
        if {"$status" == "shortly"} {
     foreach ch [array names onchans] {
        manyset $onchans($ch) status after
        if {"$status" == "shortly"} {


@@ -341,7 +433,8 @@ proc config_change {} {
        sendout PART $ch
        unset onchans($ch)
     }
        sendout PART $ch
        unset onchans($ch)
     }

-    after $chans_retry config_change
+    catch { after cancel $config_retry_after }
+    set config_retry_after [after $chans_retry config_change]

 }
 
 proc chan_shortly {ch} {
 }
 
 proc chan_shortly {ch} {


@@ -349,13 +442,27 @@ proc chan_shortly {ch} {
     upvar #0 onchans($ch) oc
     if {[info exists oc]} {
        manyset $oc status after
     upvar #0 onchans($ch) oc
     if {[info exists oc]} {
        manyset $oc status after

-       if {"$status" == "shortly"} return
+       if {"$status" == "shortly"} {
+           ldebug c$ch "queued check already pending"
+           return
+       }

     }
     }

+    ldebug c$ch "queueing check"

     set oc [list shortly [after $chan_after chan_sendnames $ch]]
 }
 
     set oc [list shortly [after $chan_after chan_sendnames $ch]]
 }
 

+proc msg_353 {p c dest type chan nicklist} {
+    set lchan [irctolower $chan]
+    set nll [irctolower $nicklist]
+    ldebug c$lchan "got names $nll"
+    foreach m [list_objs monitor] {
+       mon_gotchanlist $m $lchan $nll
+    }
+}
+

 proc chan_sendnames {ch} {
     upvar #0 onchans($ch) oc
 proc chan_sendnames {ch} {
     upvar #0 onchans($ch) oc

+    ldebug c$ch "asking for namelist"

     sendout NAMES $ch
     set oc idle
 }
     sendout NAMES $ch
     set oc idle
 }


@@ -368,6 +475,33 @@ def_ucmd reload {
     ucmdr {} $m
 }
 
     ucmdr {} $m
 }
 

+proc debug_reset {} {
+    global debugusers debug_cancelling
+    unset debug_cancelling
+    set debugusers {}
+    reporterr "debug mode timed out"
+}
+
+def_ucmd debug {
+    prefix_nick
+    global debugusers debug_cancelling debug_reset_after
+    if {![string length $text]} { error "must give list of usernames" }
+    llength $text
+    set debugusers $text
+    catch { after cancel $debug_cancelling }
+    set debug_cancelling [after $debug_reset_after debug_reset]
+    reporterr "debug enabled by $n: $debugusers"
+}
+
+def_ucmd nodebug {
+    prefix_nick
+    global debugusers debug_cancelling
+    set debugusers {}
+    catch { after cancel $debug_cancelling }
+    catch { unset debug_cancelling }
+    reporterr "debug disabled by $n"
+}
+

 def_ucmd who {
     set r {}
     foreach m [list_objs monitor] {
 def_ucmd who {
     set r {}
     foreach m [list_objs monitor] {


@@ -379,9 +513,11 @@ def_ucmd who {
        regexp {^[^:]*\:[^:]*} $dd(group) dest
        lappend r "sending $dd(monname) to $dest"
     }
        regexp {^[^:]*\:[^:]*} $dd(group) dest
        lappend r "sending $dd(monname) to $dest"
     }

+    ucmdr [join $r "\n"] {}

 }
 
 proc connected {} {
 }
 
 proc connected {} {

+    ldebug {} "connected"

     foreach f [glob -nocomplain pwdb/p*] {
        regexp {^pwdb/p(.*)$} $f dummy username
        set m [reloaduser $username]
     foreach f [glob -nocomplain pwdb/p*] {
        regexp {^pwdb/p(.*)$} $f dummy username
        set m [reloaduser $username]


@@ -389,8 +525,6 @@ proc connected {} {
     config_change
 }
 
     config_change
 }
 

-# fixme
-# 353

 # JOIN PART
 # KICK KILL QUIT
 
 # JOIN PART
 # KICK KILL QUIT