2 # $Id: ledmodule.tcl,v 1.14 2002-06-10 03:13:26 ijackson Exp $
12 defset retry_after
900000
13 defset chan_after
1500
14 defset chans_retry
3600000
15 defset debug_reset_after
86400000
21 # monitor/$monname(chans) -> [list $chan1 $chan2 ...]
22 # monitor/$monname(ignore) -> [list $regexp ...]
23 # monitor/$monname(prefer) -> [list $regexp ...]
24 # monitor/$monname(present-$chan) -> [list $lnick ...]
25 # monitor/$monname(last-talk) -> $time_t
26 # monitor/$monname(last-talkpref) -> $time_t
27 # monitor/$monname(time-recent) -> $seconds
28 # monitor/$monname(time-recentnow) -> $seconds
29 # monitor/$monname(talkchange) -> [after ...] or unset
31 # deviceset/$username:$lno(monname) -> $monname
32 # deviceset/$username:$lno(group) -> $led_group
33 # deviceset/$username:$lno(username) -> $username
34 # deviceset/$username:$lno(values) -> $valuestring
35 # deviceset/$username:$lno(states) -> [list $state1 $value1 $state2 ...]
36 # deviceset/$username:$lno(ochan) -> [open remoteleds ... | r] or unset
37 # deviceset/$username:$lno(ichan) -> fifo for remoteleds input or unset
38 # deviceset/$username:$lno(retry) -> [after ... ] or unset
40 # onchans($chan) [list mustleave] # in config_chane
41 # onchans($chan) [list idle]
42 # onchans($chan) [list forced] # for errchan
43 # onchans($chan) [list shortly [after ...]] # do a NAMES
45 proc ldebug
{facil m
} {
52 if {![llength $debugusers]} return
53 if {[regexp {[mdu
]([^
:]+)\:} $facil dummy username
] &&
54 [lsearch -exact $debugusers $username]==-1} return
56 regsub {^
(.
)} $facil {\1 } cc
57 reporterr
"DEBUG $cc $m"
62 foreach v
[info globals
] {
63 if {![regsub ^
$vp/ $v {} v
]} continue
69 proc privmsg_unlogged
{p ischan params
} {
71 if {!$ischan} { return 0 }
76 foreach m
[list_objs monitor
] {
77 mon_speech
$m [irctolower
[lindex $params 0]] [irctolower
$n]
80 log
"processing error: $emsg\n$errorInfo"
87 sendprivmsg
$errchan $m
90 proc msg_PRIVMSG
{p c dest
text} {
93 execute_usercommand
$p $c $n $errchan $dest $text
96 proc proc_mon
{name argl body
} {
97 proc mon_
$name [concat m
$argl] "
98 upvar #0 monitor/\$m mm
102 proc mon_nick_is
{globlist ln
} {
103 foreach gl
$globlist {
104 if {[string match
$gl $ln]} { return 1 }
109 proc_mon gotchanlist
{ch nll
} {
111 if {[lsearch -exact $mm(chans
) $ch] == -1} return
114 if {![string compare
$nl [irctolower
$nick]]} continue
115 if {[mon_nick_is
$mm(nopresence
) $nl]} continue
116 if {[mon_nick_is
$mm(ignore
) $nl]} continue
119 ldebug m
$m "$ch names: $l"
120 set mm
(present-
$ch) $l
124 proc_mon speech
{chan ln
} {
125 if {[lsearch -exact $mm(chans
) $chan] == -1} return
126 if {[mon_nick_is
$mm(ignore
) $ln]} return
127 set now
[clock seconds
]
128 set mm
(last-talk
) $now
129 if {[mon_nick_is
$mm(prefer
) $ln]} { set mm
(last-talkpref
) $now }
133 proc_mon calcstate
{} {
135 foreach ch
$mm(chans
) {
136 if {[llength $mm(present-
$ch)]} { append s
"present "; break }
138 set now
[clock seconds
]
139 set valid_until
[expr {$now + 86400}]
141 catch { after cancel
$mm(talkchange
) }
142 foreach p
{{} pref
} {
144 set vu
[expr {$mm(last-talk
$p) + $mm(time-recent
$t)}]
145 if {$vu < $now} continue
146 append s
"${p}talk${t} "
148 if {$vu < $valid_until} { set valid_until
$vu }
151 regsub {^
default } $s { } ss
152 set ds
[string trim
$ss]
153 if {$refresh_later} {
154 set interval
[expr {$valid_until - $now + 2}]
155 set ivms
[expr {$interval*1000}]
156 set mm
(talkchange
) [after $ivms [list mon_updateall
$m]]
157 ldebug m
$m "until now+${interval}: $ds"
159 ldebug m
$m "indefinitely: $ds"
164 proc_mon updateall
{} {
165 set s
[mon_calcstate
$m]
166 foreach d
[list_objs deviceset
] {
167 upvar #0 deviceset/$d dd
168 if {[string compare
$m $dd(monname
)]} continue
169 dset_setbystate
$d $s
173 proc_mon
destroy {} {
174 ldebug m
$m "destroying"
175 catch { after cancel
$mm(talkchange
) }
179 proc proc_dset
{name argl body
} {
180 proc dset_
$name [concat d
$argl] "
181 upvar #0 deviceset/\$d dd
182 set returncode \[catch {
185 global errorInfo errorCode
186 if {\$returncode==1} {
187 reporterr \"error on \$d: \$emsg\"
188 } elseif {\$returncode==2} {
191 return -code \$returncode -errorinfo \$errorInfo -errorcode \$errorCode
196 log
"[clock seconds] $m"
199 proc_dset setbystate
{s
} {
200 foreach {sq v
} $dd(states
) {
201 if {![string match
*$sq* $s]} continue
204 if {![info exists dd
(ichan
)]} return
205 if {![info exists lv
]} {
206 reporterr
"no state for $d matching$s"
209 ldebug d
$d "matches $sq: $v"
211 set dd
(values
) "$sq=$lv"
215 proc_dset
destroy {} {
216 ldebug d
$d "destroying"
217 catch { after cancel
$dd(retry
) }
219 if {[info exists dd
(ochan
)]} { timed_log
">\$$d destroy" }
226 proc modvar_save_copy
{cv defv
} {
230 if {[info exists save
($cv)]} {
231 set mm
($cv) $save($cv)
237 proc reloaduser
{username
} {
238 check_username
$username
239 ldebug u
$username "reloading"
241 set cfg
[exec userv
--timeout 3 $username irc-ledcontrol-config
\
244 regsub "\n" $emsg " // " emsg
245 reporterr
"error reloading $username: $emsg"
248 foreach d
[list_objs deviceset
] {
249 if {![string match
$username:* $d]} continue
252 foreach m
[list_objs monitor
] {
253 if {![string match
$username* $m]} continue
254 upvar #0 monitor/$m mm
255 foreach cv
[array names mm
] { set save
/${m
}($cv) $mm($cv) }
257 if {![string length
$cfg]} {
258 file delete pwdb
/$username
259 return "no config from $username"
261 exec userv
--timeout 3 $username irc-ledcontrol-passwords
\
262 < /dev
/null
> pwdb
/p
$username
264 reporterr
"error reading passwords for $username: $emsg"
267 ldebug u
$username "parsing"
268 foreach cv
{ignore nopresence prefer
} { set cc
($cv) {} }
269 set cc
(time-recentnow
) 120
270 set cc
(time-recent
) 450
273 foreach l
[split $cfg "\n"] {
275 append contin
[string trim
$l]
276 if {[regsub {\\$} $contin { } contin
]} continue
279 if {[regexp {^
\#} $l]} {
280 } elseif
{![regexp {\S
} $l]} {
281 } elseif
{[regexp {^nick
\s
+(ignore|nopresence|prefer
)\s
+(.
*)$} \
282 "$l " dummy kind globs
]} {
284 foreach gl
[split $globs " "] {
285 if {![string length
$gl]} continue
287 lappend cc
($kind) $gl
289 } elseif
{[regexp {^times
\s
+(\d
+)\s
+(\d
+)$} $l dummy rnow r
]} {
290 foreach cv
{{} now
} { set cc
(time-recent
$cv) [set r
$cv] }
291 } elseif
{[regexp {^monitor
\s
+(\S
+)\s
+(\S.
*)$} $l dummy m cl
]} {
293 if {![string match
$username:* $m]} {
294 error "monname must start with $username:"
297 foreach ch
[split $cl " "] {
298 if {![string length
$ch]} continue
300 if {![ischan
$ch]} { error "invalid channel $ch" }
301 lappend cc
(chans
) [irctolower
$ch]
304 upvar #0 monitor/$m mm
305 foreach cv
[array names cc
] { set mm
($cv) $cc($cv) }
306 foreach cv
{{} pref
} {
307 modvar_save_copy last-talk
$cv 0
309 foreach cv
[array names mm
(chans
)] {
310 modvar_save_copy present-
$cv {}
314 {^leds
\s
+([0-9A-Za-z
][-.
:/0-9A-Za-z
]+)\s
+(\S
+)\s
+(\S
+.
*)$} \
315 $l dummy g m states
]} {
316 set d
$username:$lno:$g
319 foreach sv
[split $states " "] {
320 if {![string length
$sv]} continue
322 {^
((?
:pref
)?talk
(?
:now
)?|present|
default)\=([0-9a-z
][,/+0-9A-Za-z
]*)$} \
323 $sv dummy lhs rhs
]} {
324 error "invalid state spec"
328 upvar #0 deviceset/$d dd
332 set dd
(values
) startup
333 set dd
(username
) $username
337 error "invalid directive or syntax"
340 if {[string length
$contin]} {
341 error "continuation line at end of file"
344 reporterr
"setup error $username:$lno:$emsg"
347 return "reloaded $username"
351 proc check_monname
{m
} {
352 if {[regexp {[^
-_+:.
#0-9a-zA-Z]} $m badchar]} {
353 error "char $badchar not allowed in monnames"
355 if {![regexp {^
[0-9a-zA-Z
]} $m]} {
356 error "monname must start with alphanum"
361 catch { unset dd
(retry
) }
362 set username
$dd(username
)
363 ldebug d
$d "starting"
365 set cmdl
[list remoteleds
--pipe $dd(group
) \
366 --human --passfile-only pwdb
/p
$username]
367 timed_log
"!-$d [join $cmdl " "]"
368 lappend cmdl
< pwdb
/fifo |
& cat
369 catch { file delete pwdb
/fifo
}
370 exec mkfifo
-m 0600 pwdb
/fifo
371 set ichan
[open pwdb
/fifo r
+]
372 set ochan
[open |
$cmdl r
]
373 fconfigure $ichan -blocking 0 -buffering line
374 fconfigure $ochan -blocking 0 -buffering line
377 fileevent $ochan readable
[list dset_rledout
$d]
379 reporterr
"remoteleds startup $d: $emsg"
380 catch { close $ichan }
381 catch { close $ochan }
386 proc_dset rledout
{} {
388 while {[gets $dd(ochan
) l
] != -1} {
389 reporterr
"on $d: $dd(values): $l"
391 if {[fblocked $dd(ochan
)]} return
392 timed_log
">\$$d failure";
393 catch { close $dd(ichan
) }
394 catch { close $dd(ochan
) }
397 reporterr
"on $d died"
401 proc_dset trylater
{} {
403 ldebug d
$d "will try again later"
404 set dd
(retry
) [after $retry_after [list dset_start
$d]]
407 proc config_change
{} {
408 global onchans chans_retry errchan config_retry_after
409 ldebug
{} "rechecking configuration etc"
410 foreach ch
[array names onchans
] {
411 manyset
$onchans($ch) status
after
412 if {"$status" == "shortly"} {
413 catch { after cancel
$after }
415 set onchans
($ch) mustleave
417 sendout JOIN
$errchan
418 chan_shortly
$errchan
419 foreach m
[list_objs monitor
] {
420 upvar #0 monitor/$m mm
421 foreach ch
$mm(chans
) {
426 foreach ch
[array names onchans
] {
427 if {"[lindex $onchans($ch) 0]" != "mustleave"} continue
431 catch { after cancel
$config_retry_after }
432 set config_retry_after
[after $chans_retry config_change
]
435 proc allchans_shortly
{} {
437 foreach ch
[array names onchans
] { chan_shortly
$ch }
440 proc chan_shortly
{ch
} {
442 set ch
[irctolower
$ch]
443 upvar #0 onchans($ch) oc
444 if {[info exists oc
]} {
445 manyset
$oc status
after
446 if {"$status" == "shortly"} {
447 ldebug c
$ch "queued check already pending"
451 ldebug c
$ch "queueing check"
452 set oc
[list shortly
[after $chan_after chan_sendnames
$ch]]
455 proc msg_353
{p c dest type chan nicklist
} {
456 set lchan
[irctolower
$chan]
457 set nll
[irctolower
$nicklist]
458 regsub -all {[=@*]} $nll {} nll
459 ldebug c
$lchan "all names: $nll"
460 foreach m
[list_objs monitor
] {
461 mon_gotchanlist
$m $lchan $nll
465 proc chan_sendnames
{ch
} {
466 upvar #0 onchans($ch) oc
467 ldebug c
$ch "asking for namelist"
473 set username
[ta_word
]
475 set m
[reloaduser
$username]
480 proc debug_reset
{} {
481 global debugusers debug_cancelling
482 unset debug_cancelling
484 reporterr
"debug mode timed out"
489 global debugusers debug_cancelling debug_reset_after
490 if {![string length
$text]} { error "must give list of usernames" }
493 catch { after cancel
$debug_cancelling }
494 set debug_cancelling
[after $debug_reset_after debug_reset
]
495 reporterr
"debug enabled by $n: $debugusers"
501 global debugusers debug_cancelling
503 catch { after cancel
$debug_cancelling }
504 catch { unset debug_cancelling
}
505 reporterr
"debug disabled by $n"
508 proc_dset visibledest
{} {
509 regsub {\:[^
:]*/} $d/ { } p
510 regsub {^
([^
:]+)\:\d
+\:} $p {\1, } p
517 foreach m
[list_objs monitor
] {
518 upvar #0 monitor/$m mm
519 lappend r
"monitoring $mm(chans) for $m"
521 foreach d
[list_objs deviceset
] {
522 upvar #0 deviceset/$d dd
524 upvar #0 monitor/$m mm
525 if {![info exists mm
(chans
)]} continue
526 lappend r
"sending $m to [dset_visibledest $d]"
528 ucmdr
[join $r "\n"] {}
532 ldebug
{} "connected"
533 foreach f
[glob -nocomplain pwdb
/p
*] {
534 regexp {^pwdb
/p
(.
*)$} $f dummy username
535 set m
[reloaduser
$username]
541 set nl
[irctolower
$n]
543 foreach d
[list_objs deviceset
] {
544 upvar #0 deviceset/$d dd
546 upvar #0 monitor/$m mm
547 if {![info exists mm
(prefer
)]} continue
548 if {![mon_nick_is
$mm(prefer
) $nl]} continue
549 foreach ch
$mm(chans
) { set wch
($ch) 1 }
550 lappend l
[dset_visibledest
$d]
553 sendprivmsg
$nl "LEDs are watching on [\
554 join [lsort [array names wch]] ","]: [join $l " "]"
558 proc msg_JOIN
{p c chan
} {
560 set nl
[irctolower
$n]
564 proc msg_PART
{p c chan
} { chan_shortly
$chan }
565 proc msg_KILL
{p c user why
} { allchans_shortly
}
566 proc msg_QUIT
{p c why
} { allchans_shortly
}
567 proc msg_NICK
{p c newnick
} { allchans_shortly
; warn_pref
$newnick }
568 proc msg_KICK
{p c chans users comment
} {
569 if {[llength $chans] > 1} {
572 chan_shortly
[lindex $chans 0]
580 fail
"startup: $emsg"