X-Git-Url: https://git.distorted.org.uk/~mdw/ircbot/blobdiff_plain/28c8ab788e2733e81f35d586bdbbe1678ce0398f..37a9f1adbed3ab89c14bf4c8c4dbac5cd0ca29ed:/bot.tcl diff --git a/bot.tcl b/bot.tcl index 55d93c7..81583ee 100755 --- a/bot.tcl +++ b/bot.tcl @@ -1,275 +1,32 @@ -#!/usr/bin/tclsh8.2 - -set host chiark -set port 6667 -if {![info exists nick]} { set nick Blight } -if {![info exists ownfullname]} { set ownfullname "here to Help" } -set ownmailaddr blight@chiark.greenend.org.uk - -set musthaveping_ms 10000 -set out_maxburst 6 -set out_interval 2100 -set out_lag_lag 5000 -set out_lag_very 25000 - -proc manyset {list args} { - foreach val $list var $args { - upvar 1 $var my - set my $val - } -} - -proc try_except_finally {try except finally} { - global errorInfo errorCode - set er [catch { uplevel 1 $try } emsg] - if {$er} { - set ei $errorInfo - set ec $errorCode - if {[catch { uplevel 1 $except } emsg3]} { - append ei "\nALSO ERROR HANDLING ERROR:\n$emsg3" - } - } - set er2 [catch { uplevel 1 $finally } emsg2] - if {$er} { - if {$er2} { - append ei "\nALSO ERROR CLEANING UP:\n$emsg2" - } - return -code $er -errorinfo $ei -errorcode $ec $emsg - } elseif {$er2} { - return -code $er2 -errorinfo $errorInfo -errorcode $errorCode $emsg2 - } else { - return $emsg - } -} - -proc out__vars {} { - uplevel 1 { - global out_queue out_creditms out_creditat out_interval out_maxburst - global out_lag_lag out_lag_very -#set pr [lindex [info level 0] 0] -#puts $pr>[clock seconds]|$out_creditat|$out_creditms|[llength $out_queue]< - } -} - -proc out_lagged {} { - out__vars - if {[llength $out_queue]*$out_interval > $out_lag_very} { - return 2 - } elseif {[llength $out_queue]*$out_interval > $out_lag_lag} { - return 1 - } else { - return 0 - } -} - -proc out_restart {} { - out__vars - - set now [clock seconds] - incr out_creditms [expr {($now - $out_creditat) * 1000}] - set out_creditat $now - if {$out_creditms > $out_maxburst*$out_interval} { - set out_creditms [expr {$out_maxburst*$out_interval}] - } - out_runqueue $now -} - -proc out_runqueue {now} { - global sock - out__vars - - while {[llength $out_queue] && $out_creditms >= $out_interval} { -#puts rq>$now|$out_creditat|$out_creditms|[llength $out_queue]< - manyset [lindex $out_queue 0] orgwhen msg - set out_queue [lrange $out_queue 1 end] - if {[llength $out_queue]} { - append orgwhen "+[expr {$now - $orgwhen}]" - append orgwhen ([llength $out_queue])" - } - puts "$orgwhen -> $msg" - puts $sock $msg - incr out_creditms -$out_interval - } - if {[llength $out_queue]} { - after $out_interval out_nextmessage - } -} - -proc out_nextmessage {} { - out__vars - set now [clock seconds] - incr out_creditms $out_interval - set out_creditat $now - out_runqueue $now -} - -proc sendout_priority {priority command args} { - global sock out_queue - if {[llength $args]} { - set la [lindex $args end] - set args [lreplace $args end end] - foreach i $args { - if {[regexp {[: ]} $i]} { - error "bad argument in output $i ($command $args)" - } - } - lappend args :$la - } - set args [lreplace $args 0 -1 $command] - set string [join $args { }] - set now [clock seconds] - set newe [list $now $string] - if {$priority} { - set out_queue [concat [list $newe] $out_queue] - } else { - lappend out_queue $newe - } - if {[llength $out_queue] == 1} { - out_restart - } -} - -proc sendout {command args} { eval sendout_priority [list 0 $command] $args } - -proc log {data} { - puts $data -} - -proc logerror {data} { - log $data -} - -proc saveeic {} { - global saveei saveec errorInfo errorCode - - set saveei $errorInfo - set saveec $errorCode - - puts ">$saveec|$saveei<" -} - -proc bgerror {msg} { - global save - logerror $msg - saveeic -} - -proc onread {args} { - global sock nick calling_nick errorInfo errorCode - - if {[gets $sock line] == -1} { fail "EOF/error on input" } - regsub -all "\[^ -\176\240-\376\]" $line ? line - set org $line - - set ei $errorInfo - set ec $errorCode - catch { unset calling_nick } - set errorInfo $ei - set errorCode $ec - - if {[regexp -nocase {^:([^ ]+) (.*)} $line dummy prefix remain]} { - set line $remain - if {[regexp {^([^!]+)!} $prefix dummy maybenick]} { - set calling_nick $maybenick - if {"[irctolower $maybenick]" == "[irctolower $nick]"} return - } - } else { - set prefix {} - } - if {![string length $line]} { return } - if {![regexp -nocase {^([0-9a-z]+) *(.*)} $line dummy command line]} { - log "bad command: $org" - return - } - set command [string toupper $command] - set params {} - while {[regexp {^([^ :]+) *(.*)} $line dummy thisword line]} { - lappend params $thisword - } - if {[regexp {^:(.*)} $line dummy thisword]} { - lappend params $thisword - } elseif {[string length $line]} { - log "junk at end: $org" - return - } - if {"$command" == "PRIVMSG" && - [regexp {^[&#+!]} [lindex $params 0]] && - ![regexp {^!} [lindex $params 1]]} { - # on-channel message, ignore - catch { - recordlastseen_p $prefix "talking on [lindex $params 0]" 1 - } - return - } - log "[clock seconds] <- $org" - set procname msg_$command - if {[catch { info body $procname }]} { return } - if {[catch { - eval [list $procname $prefix $command] $params - } emsg]} { - logerror "error: $emsg ($prefix $command $params)" - saveeic - } -} - -proc sendprivmsg {dest l} { - foreach v [split $l "\n"] { - sendout [expr {[ischan $dest] ? "PRIVMSG" : "NOTICE"}] $dest $v - } -} -proc sendaction_priority {priority dest what} { - sendout_priority $priority PRIVMSG $dest "\001ACTION $what\001" -} -proc msendprivmsg {dest ll} { foreach l $ll { sendprivmsg $dest $l } } -proc msendprivmsg_delayed {delay dest ll} { after $delay [list msendprivmsg $dest $ll] } - -proc prefix_none {} { - upvar 1 p p - if {[string length $p]} { error "prefix specified" } -} - -proc msg_PING {p c s1} { - global musthaveping_after - prefix_none - sendout PONG $s1 - if {[info exists musthaveping_after]} { after cancel $musthaveping_after] } -} +# Actual IRC bot code -proc check_nick {n} { - if {[regexp -nocase {[^][\\`_^{|}a-z0-9-]} $n]} { error "bad char in nick" } - if {[regexp {^[-0-9]} $n]} { error "bad nick start" } -} +set helpfile helpinfos -proc ischan {dest} { - return [regexp {^[&#+!]} $dest] -} +source irccore.tcl +source parsecmd.tcl +source stdhelp.tcl -proc irctolower {v} { - foreach {from to} [list "\\\[" "{" \ - "\\\]" "}" \ - "\\\\" "|" \ - "~" "^"] { - regsub -all $from $v $to v - } - return [string tolower $v] -} +defset marktime_min 300 +defset marktime_join_startdelay 5000 -proc prefix_nick {} { - global nick - upvar 1 p p - upvar 1 n n - if {![regexp {^([^!]+)!} $p dummy n]} { error "not from nick" } - check_nick $n - if {"[irctolower $n]" == "[irctolower $nick]"} { - error "from myself" {} {} +proc privmsg_unlogged {prefix ischan params} { + if {!$ischan || + [regexp {^![a-z][-a-z]*[a-z]( .*)?$} [lindex $params 1]]} { + return 0 } + # on-channel message, ignore + set chan [lindex $params 0] + upvar #0 chan_lastactivity([irctolower $chan]) la + set la [clock seconds] + catch_logged { recordlastseen_p $prefix "talking on $chan" 2 } + return 1 } -proc showintervalsecs {howlong} { - return [showintervalsecs/[opt timeformat] $howlong] +proc showintervalsecs {howlong abbrev} { + return [showintervalsecs/[opt timeformat] $howlong $abbrev] } -proc showintervalsecs/ks {howlong} { +proc showintervalsecs/ks {howlong abbrev} { if {$howlong < 1000} { return "${howlong}s" } else { @@ -288,15 +45,19 @@ proc showintervalsecs/ks {howlong} { } } -proc format_qty {qty unit} { +proc format_qty {qty unit abbrev} { set o $qty - append o " " - append o $unit - if {$qty != 1} { append o s } + if {$abbrev} { + append o [string range $unit 0 0] + } else { + append o " " + append o $unit + if {$qty != 1} { append o s } + } return $o } -proc showintervalsecs/hms {qty} { +proc showintervalsecs/hms {qty abbrev} { set ul {second 60 minute 60 hour 24 day 7 week} set remainv 0 while {[llength $ul] > 1 && $qty >= [set uv [lindex $ul 1]]} { @@ -305,10 +66,10 @@ proc showintervalsecs/hms {qty} { set qty [expr {($qty-$remainv)/$uv}] set ul [lreplace $ul 0 1] } - set o [format_qty $qty [lindex $ul 0]] + set o [format_qty $qty [lindex $ul 0] $abbrev] if {$remainv} { - append o " " - append o [format_qty $remainv $remainu] + if {!$abbrev} { append o " " } + append o [format_qty $remainv $remainu $abbrev] } return $o } @@ -317,7 +78,7 @@ proc showinterval {howlong} { if {$howlong <= 0} { return {just now} } else { - return "[showintervalsecs $howlong] ago" + return "[showintervalsecs $howlong 0] ago" } } @@ -325,6 +86,23 @@ proc showtime {when} { return [showinterval [expr {[clock seconds] - $when}]] } +proc parse_interval {specified min} { + if {![regexp {^([0-9]+)([a-z]+)$} $specified dummy value unit]} { + error "invalid syntax for interval" + } + switch -exact $unit { + s { set u 1 } + ks { set u 1000 } + m { set u 60 } + h { set u 3600 } + default { error "unknown unit of time $unit" } + } + if {$value > 86400*21/$u} { error "interval too large" } + set result [expr {$value*$u}] + if {$result < $min} { error "interval too small (<${min}s)" } + return $result +} + proc def_msgproc {name argl body} { proc msg_$name "varbase $argl" "\ upvar #0 msg/\$varbase/dest d\n\ @@ -367,11 +145,112 @@ proc looking_whenwhere {when where} { return $str } +proc check_telling {nl event} { + # event is `talk', `act' or `come' + + set iml [msgdb_get $nl inbound] + if {![llength $iml]} return + + upvar #0 nick_telling($nl) telling + upvar #0 nick_unique($nl) u + + if {[info exists telling]} { + manyset $telling u2 stt telling_when + if {"$u2" != "$u"} { unset telling; unset stt; unset telling_when } + } + + if {![info exists stt]} { + set stt norecord + set telling_when $now + } + + set ago [expr {$now - $telling_when}] + + # evstate is string of letters + # event + # t talk + # a act + # c come + # current state + # n NORECORD + # m MENTIONED + # p PASSED + # security level and timing + # ii Insecure + # ss Secure and soon (before interval) + # sl Secure and late (after interval) + # reliability and timing + # uu Unreliable + # rv Remind, very soon (before within-interval) + # rs Remind, soon (between) + # rl Remind, late (aftr every-interval) + # ps Pester, soon (before interval) + # pl Pester, late (after interval) + # current identification + # i Identified + # u Unidentified + # current visibility + # v Visible + # h Hidden (invisible, no unique) + + set evstate [string range $stt 0 0] + + manyset [nickdb_get $n tellsec] sec secwhen + switch -exact $sec { + insecure { append evstate ii } + secure { append evstate [expr {$ago<$secwhen ? "sl" : "ss"}] } + default { append evstate "#$sec#" } + } + + manyset [nickdb_set $n tellrel] rel relint relwithin + switch -exact $rel { + unreliable { append evstate uu } + remind { append evstate [expr { + $ago<$relwithin ? "rv" : $ago<$relint ? "rs" : "rl" + }]} + pester { append evstate [expr {$ago<$relint ? "ps" : "pl"}] } + default { append evstate "#$rel#" } + } + + upvar #0 nick_username($nl) nu + if {[info exists nu] && "$nu" == "[nickdb_get $nl username]"} { + append evstate i + } else { + append evstate u + } + + append evstate [expr {[info exists u] ? "v" : "h"}] + + switch -glob $evstate { + + + + + if {[ + set security + + switch -exact + + if {![info exists u]} { catch { unset telling } } + && [info exists telling]} { + + + } + + if {![info exists telling]} { + + proc recordlastseen_n {n how here} { global lastseen lookedfor - set lastseen([irctolower $n]) [list $n [clock seconds] $how] + set nl [irctolower $n] + set now [clock seconds] + set lastseen($nl) [list $n $now $how] + if {!$here} return - upvar #0 lookedfor([irctolower $n]) lf + + check_telling $nl [lindex {x act talk} $here] + + upvar #0 lookedfor($nl) lf if {[info exists lf]} { switch -exact [llength $lf] { 0 { @@ -407,7 +286,31 @@ proc recordlastseen_n {n how here} { msendprivmsg_delayed 1000 $n $ml } } - + +proc note_topic {showoff whoby topic} { + set msg "FYI, $whoby has changed the topic on $showoff" + if {[string length $topic] < 160} { + append msg " to $topic" + } else { + append msg " but it is too long to reproduce here !" + } + set showoff [irctolower $showoff] + set tell [chandb_get $showoff topictell] + if {[lsearch -exact $tell *] >= 0} { + set tryspies [chandb_list] + } else { + set tryspies $tell + } + foreach spy $tryspies { + set see [chandb_get $spy topicsee] + if {[lsearch -exact $see $showoff] >= 0 || \ + ([lsearch -exact $see *] >= 0 && \ + [lsearch -exact $tell $spy] >= 0)} { + sendprivmsg $spy $msg + } + } +} + proc recordlastseen_p {p how here} { prefix_nick recordlastseen_n $n $how $here @@ -426,8 +329,8 @@ proc chanmode_o1 {m g p chan} { set who [chanmode_arg] recordlastseen_n $n "being nice to $who" 1 if {"[irctolower $who]" == "[irctolower $nick]"} { - set nl [irctolower $n] - upvar #0 nick_unique($n) u + set nlower [irctolower $n] + upvar #0 nick_unique($nlower) u if {[chandb_exists $chan]} { sendprivmsg $n Thanks. } elseif {![info exists u]} { @@ -473,27 +376,75 @@ proc msg_MODE {p c dest modelist args} { } } -proc channel_noone_seen {chan} { - global nick_onchans - foreach n [array names nick_onchans] { - upvar #0 nick_onchans($n) oc - set oc [grep tc {"$tc" != "$chan"} $oc] +proc leaving {lchan} { + foreach luser [array names nick_onchans] { + upvar #0 nick_onchans($luser) oc + set oc [grep tc {"$tc" != "$lchan"} $oc] + } + upvar #0 chan_nicks($lchan) nlist + unset nlist + upvar #0 chan_lastactivity($lchan) la + catch { unset la } +} + +proc doleave {lchan} { + sendout PART $lchan + leaving $lchan +} + +proc dojoin {lchan} { + global chan_nicks + sendout JOIN $lchan + set chan_nicks($lchan) {} +} + +proc check_justme {lchan} { + global nick + upvar #0 chan_nicks($lchan) nlist + if {[llength $nlist] != 1} return + if {"[lindex $nlist 0]" != "[irctolower $nick]"} return + if {[chandb_exists $lchan]} { + set mode [chandb_get $lchan mode] + if {"$mode" != "*"} { + sendout MODE $lchan $mode + } + set topic [chandb_get $lchan topicset] + if {[string length $topic]} { + sendout TOPIC $lchan $topic + } + } else { + doleave $lchan } } proc process_kickpart {chan user} { global nick check_nick $user + set luser [irctolower $user] + set lchan [irctolower $chan] if {![ischan $chan]} { error "not a channel" } - if {"[irctolower $user]" == "[irctolower $nick]"} { - channel_noone_seen $chan + if {"$luser" == "[irctolower $nick]"} { + leaving $lchan + } else { + upvar #0 nick_onchans($luser) oc + upvar #0 chan_nicks($lchan) nlist + set oc [grep tc {"$tc" != "$lchan"} $oc] + set nlist [grep tn {"$tn" != "$luser"} $nlist] + nick_case $user + if {![llength $oc]} { + nick_forget $luser + } else { + check_justme $lchan + } } - upvar #0 nick_onchans($user) oc - set lc [irctolower $chan] - set oc [grep tc {"$tc" != "$lc"} $oc] - if {![llength $oc]} { nick_forget $user } - nick_case $user -} +} + +proc msg_TOPIC {p c dest topic} { + prefix_nick + if {![ischan $dest]} return + recordlastseen_n $n "changing the topic on $dest" 1 + note_topic [irctolower $dest] $n $topic +} proc msg_KICK {p c chans users comment} { set chans [split $chans ,] @@ -511,52 +462,96 @@ proc msg_KILL {p c user why} { set nick_counter 0 set nick_arys {onchans username unique} - -proc nick_forget {n} { - global nick_arys +# nick_onchans($luser) -> [list ... $lchan ...] +# nick_username($luser) -> +# nick_unique($luser) -> +# nick_case($luser) -> $user (valid even if no longer visible) +# nick_markid($luser) -> +# nick_telling($luser) -> mentioned|passed + +# chan_nicks($lchan) -> [list ... $luser ...] +# chan_lastactivity($lchan) -> [clock seconds] + +proc lnick_forget {luser} { + global nick_arys chan_nicks + lnick_marktime_cancel $luser foreach ary $nick_arys { - upvar #0 nick_${ary}($n) av + upvar #0 nick_${ary}($luser) av catch { unset av } } - nick_case $n + foreach lch [array names chan_nicks] { + upvar #0 chan_nicks($lch) nlist + set nlist [grep tn {"$tn" != "$luser"} $nlist] + check_justme $lch + } +} + +proc nick_forget {user} { + global nick_arys chan_nicks + lnick_forget [irctolower $user] + nick_case $user } -proc nick_case {n} { +proc nick_case {user} { global nick_case - set nick_case([irctolower $n]) $n + set nick_case([irctolower $user]) $user } proc msg_NICK {p c newnick} { - global nick_arys nick_case + global nick_arys nick_case calling_nick prefix_nick recordlastseen_n $n "changing nicks to $newnick" 0 + set calling_nick $newnick recordlastseen_n $newnick "changing nicks from $n" 1 + set luser [irctolower $n] + lnick_marktime_cancel $luser + set lusernew [irctolower $newnick] foreach ary $nick_arys { - upvar #0 nick_${ary}($n) old - upvar #0 nick_${ary}($newnick) new + upvar #0 nick_${ary}($luser) old + upvar #0 nick_${ary}($lusernew) new if {[info exists new]} { error "nick collision ?! $ary $n $newnick" } if {[info exists old]} { set new $old; unset old } } + upvar #0 nick_onchans($lusernew) oc + foreach ch $oc { + upvar #0 chan_nicks($ch) nlist + set nlist [grep tn {"$tn" != "$luser"} $nlist] + lappend nlist $lusernew + } + lnick_marktime_start $lusernew "Hi." 500 1 nick_case $newnick } proc nick_ishere {n} { global nick_counter - upvar #0 nick_unique($n) u + upvar #0 nick_unique([irctolower $n]) u if {![info exists u]} { set u [incr nick_counter].$n.[clock seconds] } nick_case $n } proc msg_JOIN {p c chan} { prefix_nick - recordlastseen_n $n "joining $chan" 1 - upvar #0 nick_onchans($n) oc - lappend oc [irctolower $chan] nick_ishere $n -} -proc msg_PART {p c chan} { + recordlastseen_n $n "joining $chan" 1 + set nl [irctolower $n] + set lchan [irctolower $chan] + upvar #0 nick_onchans($nl) oc + upvar #0 chan_nicks($lchan) nlist + if {![info exists oc]} { + global marktime_join_startdelay + lnick_marktime_start $nl "Welcome." $marktime_join_startdelay 1 + } + lappend oc $lchan + lappend nlist $nl +} +proc msg_PART {p c chan args} { prefix_nick - recordlastseen_n $n "leaving $chan" 1 + set msg "leaving $chan" + if {[llength $args]} { + set why [lindex $args 0] + if {"[irctolower $why]" != "[irctolower $n]"} { append msg " ($why)" } + } + recordlastseen_n $n $msg 1 process_kickpart $chan $n } proc msg_QUIT {p c why} { @@ -566,6 +561,8 @@ proc msg_QUIT {p c why} { } proc msg_PRIVMSG {p c dest text} { + global errorCode + prefix_nick if {[ischan $dest]} { recordlastseen_n $n "invoking me in $dest" 1 @@ -576,33 +573,11 @@ proc msg_PRIVMSG {p c dest text} { } nick_case $n - if {[catch { - regsub {^! *} $text {} text - set ucmd [ta_word] - set procname ucmd/[string tolower $ucmd] - if {[catch { info body $procname }]} { - error "unknown command; try help for help" - } - $procname $p $dest - } rv]} { - sendprivmsg $n "error: $rv" - } else { - manyset $rv priv_msgs pub_msgs priv_acts pub_acts - foreach {td val} [list $n $priv_acts $output $pub_acts] { - foreach l [split $val "\n"] { - sendaction_priority 0 $td $l - } - } - foreach {td val} [list $n $priv_msgs $output $pub_msgs] { - foreach l [split $val "\n"] { - sendprivmsg $td $l - } - } - } + execute_usercommand $p $c $n $output $dest $text } proc msg_INVITE {p c n chan} { - after 1000 [list sendout JOIN $chan] + after 1000 [list dojoin [irctolower $chan]] } proc grep {var predicate list} { @@ -616,123 +591,43 @@ proc grep {var predicate list} { proc msg_353 {p c dest type chan nicklist} { global names_chans nick_onchans - if {![info exists names_chans]} { set names_chans {} } - set chan [irctolower $chan] - lappend names_chans $chan - channel_noone_seen $chan - foreach n [split $nicklist { }] { - regsub {^[@+]} $n {} n - if {![string length $n]} continue - check_nick $n - upvar #0 nick_onchans($n) oc - lappend oc $chan - nick_ishere $n + set lchan [irctolower $chan] + upvar #0 chan_nicks($lchan) nlist + lappend names_chans $lchan + if {![info exists nlist]} { + # We don't think we're on this channel, so ignore it ! + # Unfortunately, because we don't get a reply to PART, + # we have to remember ourselves whether we're on a channel, + # and ignore stuff if we're not, to avoid races. Feh. + return + } + set nlist_new {} + foreach user [split $nicklist { }] { + regsub {^[@+]} $user {} user + if {![string length $user]} continue + check_nick $user + set luser [irctolower $user] + upvar #0 nick_onchans($luser) oc + lappend oc $lchan + lappend nlist_new $luser + nick_ishere $user } + set nlist $nlist_new } proc msg_366 {p c args} { global names_chans nick_onchans - if {[llength names_chans] > 1} { - foreach n [array names nick_onchans] { - upvar #0 nick_onchans($n) oc + set lchan [irctolower $c] + foreach luser [array names nick_onchans] { + upvar #0 nick_onchans($luser) oc + if {[llength names_chans] > 1} { set oc [grep tc {[lsearch -exact $tc $names_chans] >= 0} $oc] - if {![llength $oc]} { nick_forget $n } } + if {![llength $oc]} { lnick_forget $n } } unset names_chans } -proc ta_anymore {} { - upvar 1 text text - return [expr {!![string length $text]}] -} - -proc ta_nomore {} { - upvar 1 text text - if {[string length $text]} { error "too many parameters" } -} - -proc ta_word {} { - upvar 1 text text - if {![regexp {^([^ ]+) *(.*)} $text dummy firstword text]} { - error "too few parameters" - } - return $firstword -} - -proc ta_nick {} { - upvar 1 text text - set v [ta_word] - check_nick $v - return $v -} - -proc def_ucmd {cmdname body} { - proc ucmd/$cmdname {p dest} " upvar 1 text text\n$body" -} - -proc ucmdr {priv pub args} { - return -code return [concat [list $priv $pub] $args] -} - -proc loadhelp {} { - global help_topics - - catch { unset help_topics } - set f [open helpinfos r] - try_except_finally { - set lno 0 - while {[gets $f l] >= 0} { - incr lno - if {[regexp {^#.*} $l]} { - } elseif {[regexp {^ *$} $l]} { - if {[info exists topic]} { - set help_topics($topic) [join $lines "\n"] - unset topic - unset lines - } - } elseif {[regexp {^!([-+._0-9a-z]*)$} $l dummy newtopic]} { - if {[info exists topic]} { - error "help $newtopic while in $topic" - } - set topic $newtopic - set lines {} - } elseif {[regexp {^[^!#]} $l]} { - set topic - lappend lines [string trimright $l] - } else { - error "eh ? $lno: $l" - } - } - if {[info exists topic]} { error "unfinished topic $topic" } - } {} { - close $f - } -} - -def_ucmd help { - if {[set lag [out_lagged]]} { - if {[ischan $dest]} { set replyto $dest } else { set replyto $n } - if {$lag > 1} { - sendaction_priority 1 $replyto \ - "is very lagged. Please ask for help again later." - ucmdr {} {} - } else { - sendaction_priority 1 $replyto \ - "is lagged. Your help will arrive shortly ..." - } - } - - upvar #0 help_topics([irctolower [string trim $text]]) info - if {![info exists info]} { ucmdr "No help on $text, sorry." {} } - ucmdr $info {} -} - -def_ucmd ? { - global help_topics - ucmdr $help_topics() {} -} - proc check_username {target} { if { [string length $target] > 8 || @@ -757,25 +652,63 @@ proc somedb__head {} { } proc def_somedb {name arglist body} { - foreach {nickchan fprefix} {nick users/n chan chans/c} { + foreach {nickchan fprefix} { + nick users/n + chan chans/c + msgs users/m + } { proc ${nickchan}db_$name $arglist \ - "set nickchan $nickchan; set fprefix $fprefix; somedb__head; $body" + "set nickchan $nickchan; set fprefix $fprefix; $body" } } -def_somedb exists {id} { +def_somedb list {} { + set list {} + foreach path [glob -nocomplain -path $fprefix *] { + binary scan $path "A[string length $fprefix]A*" afprefix thinghex + if {"$afprefix" != "$fprefix"} { error "wrong prefix $path $afprefix" } + lappend list [binary format H* $thinghex] + } + return $list +} + +proc def_somedb_id {name arglist body} { + def_somedb $name [concat id $arglist] "somedb__head; $body" +} + +def_somedb_id exists {} { return [info exists iddbe] } -def_somedb delete {id} { +def_somedb_id delete {} { catch { unset iddbe } file delete $idfn } -set default_settings_nick {timeformat ks} -set default_settings_chan {autojoin 1} +set default_settings_nick { + timeformat ks + marktime off + tellsec insecure + tellrel {remind 3600 30} +} + +set default_settings_chan { + autojoin 1 + mode * + userinvite pub + topicset {} + topicsee {} + topictell {} +} + +set default_settings_msgs { + inbound {} + outbound {} +} +# inbound -> [ ] ... +# outbound -> [ ] ... -def_somedb set {id args} { +def_somedb_id set {args} { upvar #0 default_settings_$nickchan def if {![info exists iddbe]} { set iddbe $def } foreach {key value} [concat $iddbe $args] { set a($key) $value } @@ -793,10 +726,10 @@ def_somedb set {id args} { set iddbe $newval } -def_somedb get {id key} { +def_somedb_id get {key} { upvar #0 default_settings_$nickchan def if {[info exists iddbe]} { - set l $iddbe + set l [concat $iddbe $def] } else { set l $def } @@ -814,35 +747,44 @@ proc opt {key} { proc check_notonchan {} { upvar 1 dest dest - if {[ischan $dest]} { error "that command must be sent privately" } + if {[ischan $dest]} { usererror "That command must be sent privately." } } proc nick_securitycheck {strict} { upvar 1 n n - if {![nickdb_exists $n]} { error "you are unknown to me, use `register'." } + if {![nickdb_exists $n]} { + usererror "You are unknown to me, use `register'." + } set wantu [nickdb_get $n username] if {![string length $wantu]} { if {$strict} { - error "that feature is only available to secure users, sorry." + usererror "That feature is only available to secure users, sorry." } else { return } } - upvar #0 nick_username($n) nu + set luser [irctolower $n] + upvar #0 nick_username($luser) nu if {![info exists nu]} { - error "nick $n is secure, you must identify yourself first." + usererror "Nick $n is secure, you must identify yourself first." } if {"$wantu" != "$nu"} { - error "you are the wrong user - the nick $n belongs to $wantu, not $nu" + usererror "You are the wrong user -\ + the nick $n belongs to $wantu, not $nu." } } -proc channel_securitycheck {channel n} { - # You must also call `nick_securitycheck 1' +proc channel_ismanager {channel n} { set mgrs [chandb_get $channel managers] - if {[lsearch -exact [irctolower $mgrs] [irctolower $n]] < 0} { - error "you are not a manager of $channel" + return [expr {[lsearch -exact [irctolower $mgrs] [irctolower $n]] >= 0}] +} + +proc channel_securitycheck {channel} { + upvar n n + if {![channel_ismanager $channel $n]} { + usererror "You are not a manager of $channel." } + nick_securitycheck 1 } proc def_chancmd {name body} { @@ -850,34 +792,52 @@ proc def_chancmd {name body} { " upvar 1 target chan; upvar 1 n n; upvar 1 text text; $body" } -def_chancmd manager { +proc ta_listop {findnow procvalue} { + # findnow and procvalue are code fragments which will be executed + # in the caller's level. findnow should set ta_listop_ev to + # the current list, and procvalue should treat ta_listop_ev as + # a proposed value in the list and check and possibly modify + # (canonicalise?) it. After ta_listop, ta_listop_ev will + # be the new value of the list. + upvar 1 ta_listop_ev exchg + upvar 1 text text set opcode [ta_word] switch -exact _$opcode { - _= { set ml {} } + _= { } _+ - _- { - if {[chandb_exists $chan]} { - set ml [chandb_get $chan managers] - } else { - set ml [list [irctolower $n]] - } + uplevel 1 $findnow + foreach item $exchg { set array($item) 1 } } default { - error "`channel manager' opcode must be one of + - =" + error "list change opcode must be one of + - =" } } - foreach nn [split $text " "] { - if {![string length $nn]} continue - check_nick $nn - set nn [irctolower $nn] + foreach exchg [split $text " "] { + if {![string length $exchg]} continue + uplevel 1 $procvalue if {"$opcode" != "-"} { - lappend ml $nn + set array($exchg) 1 + } else { + catch { unset array($exchg) } + } + } + set exchg [lsort [array names array]] +} + +def_chancmd manager { + ta_listop { + if {[chandb_exists $chan]} { + set ta_listop_ev [chandb_get $chan managers] } else { - set ml [grep nq {"$nq" != "$nn"} $ml] + set ta_listop_ev [list [irctolower $n]] } + } { + check_nick $ta_listop_ev + set ta_listop_ev [irctolower $ta_listop_ev] } - if {[llength $ml]} { - chandb_set $chan managers $ml - ucmdr "Managers of $chan: $ml" {} + if {[llength $ta_listop_ev]} { + chandb_set $chan managers $ta_listop_ev + ucmdr "Managers of $chan: $ta_listop_ev" {} } else { chandb_delete $chan ucmdr {} {} "forgets about managing $chan." {} @@ -892,33 +852,213 @@ def_chancmd autojoin { default { error "channel autojoin must be `yes' or `no' } } chandb_set $chan autojoin $nv + ucmdr [expr {$nv ? "I will join $chan when I'm restarted " : \ + "I won't join $chan when I'm restarted "}] {} +} + +def_chancmd userinvite { + set nv [string tolower [ta_word]] + switch -exact $nv { + pub { set txt "!invite will work for $chan, but it won't work by /msg" } + here { set txt "!invite and /msg invite will work, but only for users who are already on $chan." } + all { set txt "Any user will be able to invite themselves or anyone else to $chan." } + none { set txt "I will not invite anyone to $chan." } + default { + error "channel userinvite must be `pub', `here', `all' or `none' + } + } + chandb_set $chan userinvite $nv + ucmdr $txt {} +} + +def_chancmd topic { + set what [ta_word] + switch -exact $what { + leave { + ta_nomore + chandb_set $chan topicset {} + ucmdr "I won't ever change the topic of $chan." {} + } + set { + set t [string trim $text] + if {![string length $t]} { + error "you must specific the topic to set" + } + chandb_set $chan topicset $t + ucmdr "Whenever I'm alone on $chan, I'll set the topic to $t." {} + } + see - tell { + ta_listop { + set ta_listop_ev [chandb_get $chan topic$what] + } { + if {"$ta_listop_ev" != "*"} { + if {![ischan $ta_listop_ev]} { + error "bad channel \`$ta_listop_ev' in topic $what" + } + set ta_listop_ev [irctolower $ta_listop_ev] + } + } + chandb_set $chan topic$what $ta_listop_ev + ucmdr "Topic $what list for $chan: $ta_listop_ev" {} + } + default { + usererror "Unknown channel topic subcommand - see help channel." + } + } +} + +def_chancmd mode { + set mode [ta_word] + if {"$mode" != "*" && ![regexp {^(([-+][imnpst]+)+)$} $mode mode]} { + error {channel mode must be * or match ([-+][imnpst]+)+} + } + chandb_set $chan mode $mode + if {"$mode" == "*"} { + ucmdr "I won't ever change the mode of $chan." {} + } else { + ucmdr "Whenever I'm alone on $chan, I'll set the mode to $mode." {} + } } def_chancmd show { if {[chandb_exists $chan]} { set l "Settings for $chan: autojoin " append l [lindex {no yes} [chandb_get $chan autojoin]] + append l ", mode " [chandb_get $chan mode] + append l ", userinvite " [chandb_get $chan userinvite] "." append l "\nManagers: " append l [join [chandb_get $chan managers] " "] + foreach {ts sep} {see "\n" tell " "} { + set t [chandb_get $chan topic$ts] + append l $sep + if {[llength $t]} { + append l "Topic $ts list: $t." + } else { + append l "Topic $ts list is empty." + } + } + append l "\n" + set t [chandb_get $chan topicset] + if {[string length $t]} { + append l "Topic to set: $t" + } else { + append l "I will not change the topic." + } ucmdr {} $l } else { ucmdr {} "The channel $chan is not managed." } } -def_ucmd op { +proc channelmgr_monoop {} { + upvar 1 dest dest + upvar 1 text text + upvar 1 n n + upvar 1 p p + upvar 1 target target + global chan_nicks + + prefix_nick + if {[ischan $dest]} { set target $dest } if {[ta_anymore]} { set target [ta_word] } ta_nomore - if {![info exists target]} { error "you must specify, or !... on, the channel" } + if {![info exists target]} { + usererror "You must specify, or invoke me on, the relevant channel." + } + if {![info exists chan_nicks([irctolower $target])]} { + usererror "I am not on $target." + } if {![ischan $target]} { error "not a valid channel" } - if {![chandb_exists $target]} { error "$target is not a managed channel." } - prefix_nick - nick_securitycheck 1 - channel_securitycheck $target $n + + if {![chandb_exists $target]} { + usererror "$target is not a managed channel." + } + channel_securitycheck $target +} + +def_ucmd op { + channelmgr_monoop sendout MODE $target +o $n } +def_ucmd leave { + channelmgr_monoop + doleave $target +} + +def_ucmd invite { + global chan_nicks errorCode errorInfo + prefix_nick + + if {[ischan $dest]} { + set target $dest + set onchan 1 + } else { + set target [ta_word] + set onchan 0 + } + set ltarget [irctolower $target] + if {![ischan $target]} { error "$target is not a channel" } + if {![info exists chan_nicks($ltarget)]} { + usererror "I am not on $target." + } + set ui [chandb_get $ltarget userinvite] + if {[catch { + if {"$ui" == "pub" && !$onchan} { + usererror "Invitations to $target must be made there with !invite." + } + if {"$ui" != "all"} { + if {[lsearch -exact $chan_nicks($ltarget) [irctolower $n]] < 0} { + usererror "Invitations to $target may only be made\ + by a user on the channel." + } + } + if {"$ui" == "none"} { + usererror "Sorry, I've not been authorised\ + to invite people to $target." + } + } emsg]} { + if {"$errorCode" == "BLIGHT USER" && [channel_ismanager $target $n]} { + if {[catch { + nick_securitycheck 1 + } emsg2]} { + if {"$errorCode" == "BLIGHT USER"} { + usererror "$emsg2 Therefore you can't use your\ + channel manager privilege. $emsg" + } else { + error $error $errorInfo $errorCode + } + } + } else { + error $emsg $errorInfo $errorCode + } + } + if {![ta_anymore]} { + usererror "You have to say who to invite." + } + set invitees {} + while {[ta_anymore]} { + set invitee [ta_word] + check_nick $invitee + lappend invitees $invitee + } + foreach invitee $invitees { + sendout INVITE $invitee $ltarget + } + set who [lindex $invitees 0] + switch -exact llength $invitees { + 0 { error "zero invitees" } + 1 { } + 2 { append who " and [lindex $invitees 1]" } + * { + set who [join [lreplace $invitees end end] ", "] + append who " and [lindex $invitees [llength $invitees]]" + } + } + ucmdr {} {} {} "invites $who to $target." +} + def_ucmd channel { if {[ischan $dest]} { set target $dest } if {![ta_anymore]} { @@ -937,22 +1077,111 @@ def_ucmd channel { if {![info exists target]} { error "privately, you must specify a channel" } set procname channel/$subcmd if {"$subcmd" != "show"} { - if {[catch { info body $procname }]} { error "unknown channel setting $subcmd" } + if {[catch { info body $procname }]} { + usererror "unknown channel setting $subcmd." + } prefix_nick - nick_securitycheck 1 if {[chandb_exists $target]} { - channel_securitycheck $target $n + channel_securitycheck $target } else { + nick_securitycheck 1 upvar #0 chan_initialop([irctolower $target]) io - upvar #0 nick_unique($n) u - if {![info exists io]} { error "$target is not a managed channel" } - if {"$io" != "$u"} { error "you are not the interim manager of $target" } - if {"$subcmd" != "manager"} { error "use `channel manager' first" } + upvar #0 nick_unique([irctolower $n]) u + if {![info exists io]} { + usererror "$target is not a managed channel." + } + if {"$io" != "$u"} { + usererror "You are not the interim manager of $target." + } + if {"$subcmd" != "manager"} { + usererror "Please use `channel manager' first." + } } } channel/$subcmd } +def_ucmd tell { + global nick_case ownmailaddr ownfullname + + prefix_nick + set target [ta_word] + if {![string length $text]} { error "tell them what?" } + + set ltarget [irctolower $target] + set ctarget $target + if {[info exists nick_case($ltarget)]} { set ctarget $nick_case($ltarget) } + + manyset [nickdb_get $target tellsec] sec mailtoint mailwhy + manyset [nickdb_get $target tellrel] rel relint relwithin + switch -exact $sec { + insecure - secure { + set now [clock seconds] + set inbound [msgsdb_get $ltarget inbound] + lappend inbound $n $now $text + msgsdb_set $ltarget inbound $inbound + + set outbound [msgsdb_get $n outbound] + set noutbound {} + set found 0 + foreach {recip time count} $outbound { + if {"[irctolower $recip]" == "$ltarget"} { + incr count + set recip $ctarget + set found 1 + } + lappend noutbound $recip $time $count + } + if {!$found} { + lappend noutbound $ctarget $now 1 + } + msgsdb_set $n outbound $noutbound + set msg "OK, I'll tell $ctarget" + if {$found} { append msg " that too" } + append msg ", " + if {"$sec" != "secure"} { + switch -exact $rel { + unreliable { append msg "neither reliably nor securely" } + remind { append msg "pretty reliably, but not securely" } + pester { append msg "reliably but not securely" } + } + } else { + switch -exact $rel { + unreliable { append msg "securely but not reliably" } + remind { append msg "securely and pretty reliably" } + pester { append msg "reliably and securely" } + } + } + append msg . + ucmdr $msg {} + } + mailto { + set fmtmsg [exec fmt << " $text"] + exec /usr/sbin/sendmail -odb -oi -t -oee -f $mailwhy \ + > /dev/null << \ + "From: $ownmailaddr ($ownfullname) +To: $mailtoint +Subject: IRC tell from $n + +$n asked me[expr {[ischan $dest] ? " on $dest" : ""}] to tell you: +[exec fmt << " $text"] + +(This message was for your nick $ctarget; your account $mailwhy + arranged for it to be forwarded to $mailtoint.) +" + ucmdr \ + "I've mailed $ctarget, which is what they prefer." \ + {} + } + refuse { + usererror "Sorry, $ctarget does not want me to take messages." + } + default { + error "bad tellsec $sec" + } + } +} + def_ucmd who { if {[ta_anymore]} { set target [ta_word]; ta_nomore @@ -962,21 +1191,22 @@ def_ucmd who { set target $n set myself [expr {"$target" != "$n"}] } - upvar #0 nick_case([irctolower $target]) nc + set ltarget [irctolower $target] + upvar #0 nick_case($ltarget) ctarget set nshow $target - if {[info exists nc]} { - upvar #0 nick_onchans($nc) oc - upvar #0 nick_username($nc) nu - if {[info exists oc]} { set nshow $nc } + if {[info exists ctarget]} { + upvar #0 nick_onchans($ltarget) oc + upvar #0 nick_username($ltarget) nu + if {[info exists oc]} { set nshow $ctarget } } - if {![nickdb_exists $target]} { + if {![nickdb_exists $ltarget]} { set ol "$nshow is not a registered nick." } elseif {[string length [set username [nickdb_get $target username]]]} { set ol "The nick $nshow belongs to the user $username." } else { set ol "The nick $nshow is registered (but not to a username)." } - if {![info exists nc] || ![info exists oc]} { + if {![info exists ctarget] || ![info exists oc]} { if {$myself} { append ol "\nI can't see $nshow on anywhere." } else { @@ -999,9 +1229,10 @@ def_ucmd register { check_notonchan set old [nickdb_exists $n] if {$old} { nick_securitycheck 0 } + set luser [irctolower $n] switch -exact [string tolower [string trim $text]] { {} { - upvar #0 nick_username($n) nu + upvar #0 nick_username($luser) nu if {![info exists nu]} { ucmdr {} \ "You must identify yourself before using `register'. See `help identify', or use `register insecure'." @@ -1021,6 +1252,9 @@ def_ucmd register { ucmdr {} "This is fine, but bear in mind that people will be able to mess with your settings. Channel management features need a secure registration." "makes an insecure registration for your nick." } } + default { + error "you mean register / register delete / register insecure" + } } } @@ -1032,7 +1266,10 @@ proc timeformat_desc {tf} { } } +set settings {} proc def_setting {opt show_body set_body} { + global settings + lappend settings $opt proc set_show/$opt {} " upvar 1 n n set opt $opt @@ -1045,6 +1282,47 @@ proc def_setting {opt show_body set_body} { $set_body" } +proc tellme_sec_desc {v} { + manyset $v sec mailtoint + switch -exact $sec { + insecure { + return "I'll tell you your messages whenever I see you." + } + secure { + return \ + "I'll keep the bodies of your messages private until you identify yourself, reminding you every [showintervalsecs $mailtoint 1]." + } + refuse { + return "I shan't accept messages for you." + } + mailto { + return "I'll forward your messages by email to $mailtoint." + } + default { + error "bad tellsec $sec" + } + } +} + +proc tellme_rel_desc {v} { + manyset $v rel every within + switch -exact $rel { + unreliable { + return "As soon as I've told you, I'll forget the message - note that this means messages can get lost !" + } + pester { + set u {} + } + remind { + set u ", or talk on channel within [showintervalsecs $within 1] of me having told you" + } + default { + error "bad tellrel $rel" + } + } + return "I'll remind you every [showintervalsecs $every 1] until you say delmsg$u." +} + def_setting timeformat { set tf [nickdb_get $n timeformat] return "$tf: [timeformat_desc $tf]" @@ -1056,6 +1334,37 @@ def_setting timeformat { ucmdr {} $desc } +proc marktime_desc {mt} { + if {"$mt" == "off"} { + return "I will not send you periodic messages." + } elseif {"$mt" == "once"} { + return "I will send you one informational message when I see you." + } else { + return "I'll send you a message every [showintervalsecs $mt 0]." + } +} + +def_setting marktime { + set mt [nickdb_get $n marktime] + set p $mt + if {[string match {[0-9]*} $mt]} { append p s } + append p ": " + append p [marktime_desc $mt] + return $p +} { + global marktime_min + set mt [string tolower [ta_word]] + ta_nomore + + if {"$mt" == "off" || "$mt" == "once"} { + } else { + set mt [parse_interval $mt $marktime_min] + } + nickdb_set $n marktime $mt + lnick_marktime_start [irctolower $n] "So:" 500 0 + ucmdr {} [marktime_desc $mt] +} + def_setting security { set s [nickdb_get $n username] if {[string length $s]} { @@ -1065,7 +1374,105 @@ def_setting security { } } {} +def_setting tellme { + set secv [nickdb_get $n tellsec] + set ms [tellme_sec_desc $secv] + manyset $secv sec + switch -exact $sec { + insecure - secure { + set mr [tellme_rel_desc [nickdb_get $n tellrel]] + return "$ms $mr" + } + refuse - mailto { + return $ms + } + } +} { + set setting [string tolower [ta_word]] + switch -exact $setting { + insecure - secure - refuse { + ta_nomore + if {"$setting" == "refuse" && [llength [msgsdb_get $n inbound]]} { + usererror "You must delete the messages you have, first." + } + set sr sec + set v $setting + } + mailto { + set u [nickdb_get $n username] + if {![string length $u]} { + usererror "Sorry, you must register secure to have your messages mailed (to prevent the use of this feature for spamming)." + } + set sr sec + set v [list mailto [ta_word] $u] + } + unreliable - pester - remind { + manyset [nickdb_get $n tellsec] sec + switch -exact $sec { + refuse - mailto { + error "can't change message delivery conditions when message disposition prevents messages from being left" + } + } + set sr rel + set v $setting + if {"$setting" != "unreliable"} { + set every [parse_interval [ta_word] 300] + lappend v $every + } + if {"$setting" == "remind"} { + if {[ta_anymore]} { + set within [parse_interval [ta_word] 5] + } else { + set within 30 + } + if {$within > $every} { + error "remind interval must be at least time to respond" + } + lappend v $within + } + ta_nomore + } + default { + error "invalid tellme setting $setting" + } + } + nickdb_set $n tell$sr $v + ucmdr [tellme_${sr}_desc $v] {} +} + +proc lnick_checktold {luser} { + set ml [msgsdb_get $luser outbound] + if {![llength $ml]} return + set is1 [expr {[llength $ml]==3}] + set m1 "FYI, I haven't yet passed on your" + set ol {} + set now [clock seconds] + while {[llength $ml]} { + manyset $ml r t n + set ml [lreplace $ml 0 2] + set td [expr {$now-$t}] + if {$n == 1} { + set iv [showinterval $td] + set ifo "$r, $iv" + set if1 "message to $r, $iv." + } else { + set iv [showintervalsecs $td 0] + set ifo "$r, $n messages, oldest $iv" + set if1 "$n messages to $r, oldest $iv." + } + if {$is1} { + sendprivmsg $luser "$m1 $if1" + return + } else { + lappend ol " to $ifo[expr {[llength $ml] ? ";" : "."}]" + } + } + sendprivmsg $luser "$m1 messages:" + msendprivmsg $luser $ol +} + def_ucmd set { + global settings prefix_nick check_notonchan if {![nickdb_exists $n]} { @@ -1073,8 +1480,7 @@ def_ucmd set { } if {![ta_anymore]} { set ol {} - foreach proc [lsort [info procs]] { - if {![regexp {^set_show/(.*)$} $proc dummy opt]} continue + foreach opt $settings { lappend ol [format "%-10s %s" $opt [set_show/$opt]] } ucmdr {} [join $ol "\n"] @@ -1084,7 +1490,7 @@ def_ucmd set { error "no setting $opt" } if {![ta_anymore]} { - ucmdr {} "$opt [set_show/$opt]" + ucmdr {} "$opt: [set_show/$opt]" } else { nick_securitycheck 0 if {[catch { info body set_set/$opt }]} { @@ -1101,14 +1507,15 @@ def_ucmd identpass { ta_nomore prefix_nick check_notonchan - upvar #0 nick_onchans($n) onchans + set luser [irctolower $n] + upvar #0 nick_onchans($luser) onchans if {![info exists onchans] || ![llength $onchans]} { ucmdr "You must be on a channel with me to identify yourself." {} } check_username $username exec userv --timeout 3 $username << "$passmd5\n" > /dev/null \ irc-identpass $n - upvar #0 nick_username($n) rec_username + upvar #0 nick_username($luser) rec_username set rec_username $username ucmdr "Pleased to see you, $username." {} } @@ -1143,7 +1550,7 @@ def_ucmd summon { set idletime [expr {$now - $idlesince}] set ls $now ucmdr {} {} {} "invites $target ($tty[expr { - $idletime > 10 ? ", idle for [showintervalsecs $idletime]" : "" + $idletime > 10 ? ", idle for [showintervalsecs $idletime 0]" : "" }]) to [expr { [ischan $dest] ? "join us here" : "talk to you" }]." @@ -1162,7 +1569,7 @@ def_ucmd seen { ta_nomore set now [clock seconds] if {"$nlower" == "[irctolower $nick]"} { - error "I am not self-aware." + usererror "I am not self-aware." } elseif {![info exists lastseen($nlower)]} { set rstr "I've never seen $ncase." } else { @@ -1186,6 +1593,94 @@ def_ucmd seen { ucmdr {} $rstr } +proc lnick_marktime_cancel {luser} { + upvar #0 nick_markid($luser) mi + if {![info exists mi]} return + catch { after cancel $mi } + catch { unset mi } +} + +proc lnick_marktime_doafter {luser why ms mentiontold} { + lnick_marktime_cancel $luser + upvar #0 nick_markid($luser) mi + set mi [after $ms [list lnick_marktime_now $luser $why 0]] +} + +proc lnick_marktime_reset {luser} { + set mt [nickdb_get $luser marktime] + if {"$mt" == "off" || "$mt" == "once"} return + lnick_marktime_doafter $luser "Time passes." [expr {$mt*1000}] 0 +} + +proc lnick_marktime_start {luser why ms mentiontold} { + set mt [nickdb_get $luser marktime] + if {"$mt" == "off"} { + lnick_marktime_cancel $luser + after $ms [list lnick_checktold $luser] + } else { + lnick_marktime_doafter $luser $why $ms $mentiontold + } +} + +proc lnick_marktime_now {luser why mentiontold} { + upvar #0 nick_onchans($luser) oc + global calling_nick + set calling_nick $luser + sendprivmsg $luser [lnick_pingstring $why $oc ""] + if {$mentiontold} { lnick_checktold $luser } + lnick_marktime_reset $luser +} + +proc lnick_pingstring {why oc apstring} { + global nick_onchans + catch { exec uptime } uptime + set nnicks [llength [array names nick_onchans]] + if {[regexp \ + {^ *([0-9:apm]+) +up.*, +(\d+) users?, +load average: +([0-9., ]+) *$} \ + $uptime dummy time users load]} { + regsub -all , $load {} load + set uptime "$time $nnicks/$users $load" + } else { + append uptime ", $nnicks nicks" + } + if {[llength $oc]} { + set best_la 0 + set activity quiet + foreach ch $oc { + upvar #0 chan_lastactivity($ch) la + if {![info exists la]} continue + if {$la <= $best_la} continue + set since [showintervalsecs [expr {[clock seconds]-$la}] 1] + set activity "$ch $since" + set best_la $la + } + } else { + set activity unseen + } + set str $why + append str " " $uptime " " $activity + if {[string length $apstring]} { append str " " $apstring } + return $str +} + +def_ucmd ping { + prefix_nick + set ln [irctolower $n] + if {[ischan $dest]} { + set oc [irctolower $dest] + } else { + global nick_onchans + if {[info exists nick_onchans($ln)]} { + set oc $nick_onchans($ln) + } else { + set oc {} + } + if {[llength $oc]} { lnick_marktime_reset $ln } + } + lnick_checktold $ln + ucmdr {} [lnick_pingstring "Pong!" $oc $text] +} + proc ensure_globalsecret {} { global globalsecret @@ -1198,43 +1693,12 @@ proc ensure_globalsecret {} { unset gsfile } -proc ensure_outqueue {} { - out__vars - if {[info exists out_queue]} return - set out_creditms [expr {$out_maxburst*$out_interval}] - set out_creditat [clock seconds] - set out_queue {} - set out_lag_reported 0 - set out_lag_reportwhen $out_creditat -} - -proc fail {msg} { - logerror "failing: $msg" - exit 1 -} - -proc ensure_connecting {} { - global sock ownfullname host port nick - global musthaveping_ms musthaveping_after - - if {[info exists sock]} return - set sock [socket $host $port] - fconfigure $sock -buffering line - fconfigure $sock -translation crlf - - sendout USER blight 0 * $ownfullname - sendout NICK $nick - fileevent $sock readable onread - - set musthaveping_after [after $musthaveping_ms \ - {fail "no ping within timeout"}] +proc connected {} { + foreach chan [chandb_list] { + if {[chandb_get $chan autojoin]} { dojoin $chan } + } } ensure_globalsecret -ensure_outqueue loadhelp ensure_connecting - -#if {![regexp {tclsh} $argv0]} { -# vwait terminate -#}