X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~mdw/git/ircbot/blobdiff_plain/c362e1729f5517438d2d96c9793cf5754cdb3f3e..8db8c10f98ce1085510a1d17d609fc516ced1143:/bot.tcl diff --git a/bot.tcl b/bot.tcl index b187113..fe62bc5 100755 --- a/bot.tcl +++ b/bot.tcl @@ -1,230 +1,89 @@ -#!/usr/bin/tclsh8.2 +# Actual IRC bot code -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 helpfile helpinfos -if {![info exists globalsecret]} { - set gsfile [open /dev/urandom r] - fconfigure $gsfile -translation binary - set globalsecret [read $gsfile 32] - binary scan $globalsecret H* globalsecret - close $gsfile - unset gsfile -} - -proc manyset {list args} { - foreach val $list var $args { - upvar 1 $var my - set my $val - } -} +source irccore.tcl +source parsecmd.tcl +source stdhelp.tcl +source userv.tcl -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 - } -} +defset marktime_min 300 +defset marktime_join_startdelay 5000 -proc sendout {command args} { - global sock - 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 +proc privmsg_unlogged {prefix ischan params} { + if {!$ischan || + [regexp {^![a-z][-a-z]*[a-z]( .*)?$} [lindex $params 1]]} { + return 0 } - set args [lreplace $args 0 -1 $command] - set string [join $args { }] - puts "[clock seconds] -> $string" - puts $sock $string -} - -proc log {data} { - puts $data -} - -proc logerror {data} { - log $data + # 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 saveeic {} { - global saveei saveec errorInfo errorCode - - set saveei $errorInfo - set saveec $errorCode - - puts ">$saveec|$saveei<" +proc showintervalsecs {howlong abbrev} { + return [showintervalsecs/[opt timeformat] $howlong $abbrev] } -proc bgerror {msg} { - global save - logerror $msg - saveeic +proc formatsf {pfx value} { + foreach {min format} { 100 %.0f 10 %.1f 0 %.2f} { + set fval [format $format $value] + if {$fval < $min} continue + return [format "$fval${pfx}" $value] + } } -proc onread {args} { - global sock nick calling_nick errorInfo errorCode - - if {[gets $sock line] == -1} { set terminate 1; return } - 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 - } +proc showintervalsecs/beat {howlong abbrev} { + # We split in two to avoid overflow problems. + if {$howlong < 86 } { + # mB's + set pfx mB + return [format "%.0fmB" [expr {round($howlong * 1.157)*10} ]] } 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 + if {$howlong < 86400 } { + # B's + set pfx B + set value [expr {$howlong / 86.4}] + } else { + # kB's + set pfx kB + set value [expr {$howlong / 86400.0}] } - 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 {dest what} { sendout 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} { - prefix_none - sendout PONG $s1 -} - -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" } -} - -proc ischan {dest} { - return [regexp {^[&#+!]} $dest] -} - -proc irctolower {v} { - foreach {from to} [list "\\\[" "{" \ - "\\\]" "}" \ - "\\\\" "|" \ - "~" "^"] { - regsub -all $from $v $to v - } - return [string tolower $v] -} - -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" {} {} } + return [formatsf $pfx $value] } -proc showintervalsecs {howlong} { - return [showintervalsecs/[opt timeformat] $howlong] -} - -proc showintervalsecs/ks {howlong} { +proc showintervalsecs/ks {howlong abbrev} { if {$howlong < 1000} { return "${howlong}s" } else { if {$howlong < 1000000} { - set pfx k + set pfx ks set scale 1000 } else { - set pfx M + set pfx Ms set scale 1000000 } set value [expr "$howlong.0 / $scale"] - foreach {min format} {100 %.0f 10 %.1f 1 %.2f} { - if {$value < $min} continue - return [format "$format${pfx}s" $value] - } + return [formatsf $pfx $value] } } -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]]} { @@ -233,10 +92,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 } @@ -245,7 +104,7 @@ proc showinterval {howlong} { if {$howlong <= 0} { return {just now} } else { - return "[showintervalsecs $howlong] ago" + return "[showintervalsecs $howlong 0] ago" } } @@ -253,6 +112,26 @@ 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 } + mb { set u 0.0864 } + b { set u 86.4 } + kb { set u 86400 } + default { error "unknown unit of time $unit" } + } + if {$value > 86400*21/$u} { error "interval too large" } + set result [expr {round($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\ @@ -295,11 +174,249 @@ proc looking_whenwhere {when where} { return $str } +proc tell_getcstate {} { + # uses nl from caller's context + # imports telling (as the nick_telling) and u + # sets stt, telling_when + uplevel 1 { + upvar #0 nick_telling($nl) telling + upvar #0 nick_unique($nl) u + + if {[info exists telling]} { + manyset $telling u_last stt telling_when + if {![info exists u] || "$u_last" != "$u"} { + set stt undelivered + } + } else { + set stt undelivered + set telling_when 0 + } + } +} + +proc tell_event {nl event} { + # For `act' we *haven't* yet done the 750ms delay; we implement + # that here. Also, here we turn `talk' into `talk' now and `act' + # later. We also support the psuedo-event `none'. The del msg + # and new msg events are handled by the command procedures, not here. + global calling_nick + if {[info exists calling_nick]} { set save $calling_nick } + set r DELAYED + switch -exact $event { + none { } + talk { + tell_event_core $nl talk + tell_event $nl act + } + act { + after 750 [list tell_event_core $nl $event] + } + ident - msgsarrive { + tell_event_core $nl $event + } + tellme { + set r [tell_event_core $nl TELLME] + } + default { + error "tell_event $nl $event" + } + } + if {[info exists save]} { set calling_nick $save } + return $r +} + +proc tell_event_core {nl event} { + global tell_event_teventi errorInfo + set tell_event_teventi "*$event* $nl" + if {[catch { + tell_event_core1 $nl $event + } emsg]} { + log_intern "tell event error" "$emsg >$errorInfo<" + set emsg ERROR + } else { + if {"$emsg" != "nomsgs"} { + log_intern "tell event" "done $tell_event_teventi $emsg" + } + } + return $emsg +} + +proc tell_event_core1 {nl event} { + # event is `talk', `act', `ident', `msgsarrive' or `TELLME' + # When user talks we actually get talk now and act later + global calling_nick + set calling_nick $nl + set iml [msgsdb_get $nl inbound] + if {![llength $iml]} { return nomsgs } + + set now [clock seconds] + tell_getcstate + set ago [expr {$now - $telling_when}] + + # Now we have the components of a telling state + # u - nick_unique (unset if not visible) + # stt - state: undelivered, mentioned, passede + # ago - how long ago since we did anything + + # We compute an evstate to dispatch on as follows: + + # evstate is string of letters + # current state + # u UNDELIVERED (MESSAGES) + # m MENTIONED + # p PASSED + # event + # t talk + # a act + # i ident + # m msgsarrive + # T tellme (user command) + # security level and timing + # ii Insecure + # ss Secure and soon (before interval) + # sl Secure and late (after interval) + # current identification + # i Identified + # u Unidentified + # reliability and timing + # uu Unreliable + # rv Remind, very soon (before within-interval) + # rs Remind, soon (between) + # rl Remind, late (after every-interval) + # ps Pester, soon (before interval) + # pl Pester, late (after interval) + + set evstate {} + + append evstate [string range $stt 0 0] + append evstate [string range $event 0 0] + + manyset [nickdb_get_sec_effective $nl] sec secwhen + switch -exact $sec { + insecure { append evstate ii } + secure { append evstate [expr {$ago<$secwhen ? "ss" : "sl"}] } + default { append evstate "#$sec#" } + } + + upvar #0 nick_username($nl) nu + if {[info exists nu] && ![string compare $nu [nickdb_get_username $nl]]} { + append evstate i + } else { + append evstate u + } + + manyset [nickdb_get $nl 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#" } + } + + global tell_event_teventi + set tell_event_teventi "$evstate $ago $nl" + switch -glob $evstate { + pt???rv { + # consider delivered: + # (very recently passed, and the user talks) + set ndel [tell_delete_msgs {} $nl] + sendprivmsg $nl \ + "I'm assuming you got the $ndel message(s) I just passed on." + return delivered + } + pm????? { + # oops, messages passed are now out of date + catch_restoreei { unset telling } + return reset + } + ?m????? { + # ignore new msgs if we haven't passed yet + return ignorenew + } + ut????? - mt????? - + pt???uu - pt???rs - pt???rl - pt???p? { + # ignore (any other `talk's) - act handles these + return ignoretalk + } + ui????? - + uaii?uu - uaii??l - uas?iuu - uas?i?l - + mi????? - pa????l - + ?Tii??? - ?Ts?i?? { + # pass and then stuff + if {[llength $iml] == 3} { + manyset $iml sender sentwhen msg + sendprivmsg $nl \ + "$sender asked me, [showinterval [expr {$now-$sentwhen}]],\ + to tell you: $msg" + } else { + sendprivmsg $nl \ + "I have [expr {[llength $iml]/3}] messages for you:" + while {[llength $iml] >= 3} { + manyset [lrange $iml 0 2] sender sentwhen msg + set iml [lrange $iml 3 end] + sendprivmsg $nl \ + " [showintervalsecs [expr {$now-$sentwhen}] 1] <$sender> $msg" + } + } + if {![string compare $rel "unreliable"]} { + tell_delete_msgs {} $nl + return toldunreliable + } + set stt passed + set re passed + } + uaslu?? { + sendprivmsg $nl {You have messages (so identify yourself please).} + set stt mentioned + set re mentioned + } + ?Ts?u?? { + sendprivmsg $nl {You must identify yourself to see your messages.} + return ignoreuitm + } + masl??? { + sendprivmsg $nl {Don't forget about your messages.} + set re remind + } + pi????? { + return ignorepi + } + mass??? - pa????v - pa????s - + uaii??v - uaii??s - + uas?i?v - uas?i?s - + uassu?? { + # too soon + return ignoresoon + } + * { + error "tell_event_core nl=$nl evstate=$evstate ?" + } + } + if {![info exists u]} { + set telling [list {} undelivered $now] + } else { + set telling [list $u $stt $now] + } + return $re +} + proc recordlastseen_n {n how here} { + # here is: + # 0 - nick was seen leaving (or changing to another nicks or some such) + # 1 - nick was seen doing something else + # 2 - nick was seen talking on channel 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 + + tell_event $nl [lindex {none act talk} $here] + + upvar #0 lookedfor($nl) lf if {[info exists lf]} { switch -exact [llength $lf] { 0 { @@ -335,7 +452,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 @@ -353,9 +494,9 @@ proc chanmode_o1 {m g p chan} { prefix_nick 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 + if {![ircnick_compare $who $nick]} { + set nlower [irctolower $n] + upvar #0 nick_unique($nlower) u if {[chandb_exists $chan]} { sendprivmsg $n Thanks. } elseif {![info exists u]} { @@ -363,8 +504,8 @@ proc chanmode_o1 {m g p chan} { } else { set chan_initialop([irctolower $chan]) $u sendprivmsg $n \ - "Thanks. You can use `channel manager ...' to register this channel." - if {![nickdb_exists $n] || ![string length [nickdb_get $n username]]} { + "Thanks. You can use `channel manager ...' to register this channel." + if {![string length [nickdb_get_username $n]]} { sendprivmsg $n \ "(But to do that you must register your nick securely first.)" } @@ -377,7 +518,7 @@ proc chanmode_o0 {m g p chan} { prefix_nick set who [chanmode_arg] recordlastseen_p $p "being mean to $who" 1 - if {"[irctolower $who]" == "[irctolower $nick]"} { + if {![ircnick_compare $who $nick]} { set chandeop($chan) [list [clock seconds] $p] } } @@ -401,27 +542,76 @@ proc msg_MODE {p c dest modelist args} { } } -proc channel_noone_seen {chan} { +proc leaving {lchan} { global nick_onchans - foreach n [array names nick_onchans] { - upvar #0 nick_onchans($n) oc - set oc [grep tc {"$tc" != "$chan"} $oc] + 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 {![ircnick_compare $luser $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 ,] @@ -439,52 +629,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} { @@ -494,6 +728,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 @@ -504,33 +740,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 $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} { @@ -544,119 +758,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 $luser } } 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 { - 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 || - [regexp {[^-0-9a-z]} $target] || - ![regexp {^[a-z]} $target] - } { error "invalid username" } -} - proc somedb__head {} { uplevel 1 { set idl [irctolower $id] @@ -673,25 +811,65 @@ 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 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 exists {id} { +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 {secure 600} + tellrel {remind 3600 30} +} + +set default_settings_chan { + autojoin 1 + mode * + userinvite pub + topicset {} + topicsee {} + topictell {} +} + +set default_settings_msgs { + inbound {} + outbound {} +} +# inbound -> [ ] ... +# outbound -> [ ] ... +# neither are sorted particularly; only one entry per recipient in +# output; both sender and recipient are cased -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 } @@ -709,15 +887,15 @@ 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 } foreach {tkey value} $l { - if {"$tkey" == "$key"} { return $value } + if {![string compare $tkey $key]} { return $value } } error "unset setting $key" } @@ -730,35 +908,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} { @@ -766,34 +953,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 { - set ml [grep nq {"$nq" != "$nn"} $ml] + catch { unset array($exchg) } } } - if {[llength $ml]} { - chandb_set $chan managers $ml - ucmdr "Managers of $chan: $ml" {} + 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 ta_listop_ev [list [irctolower $n]] + } + } { + check_nick $ta_listop_ev + set ta_listop_ev [irctolower $ta_listop_ev] + } + 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." {} @@ -808,31 +1013,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 {![string compare $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 + ucmdr {} {} +} + +def_ucmd leave { + channelmgr_monoop + doleave $target + ucmdr {} {} +} + +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 {![string compare $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 {[!string compare $ui "none"]} { + usererror "Sorry, I've not been authorised\ + to invite people to $target." + } + } emsg]} { + if {![string compare $errorCode "BLIGHT USER"] && + [channel_ismanager $target $n]} { + if {[catch { + nick_securitycheck 1 + } emsg2]} { + if {![string compare $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_nick] + 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 { @@ -853,46 +1240,284 @@ 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 } +proc nickdb_get_username {n} { + if {![nickdb_exists $n]} { return "" } + return [nickdb_get $n username] +} + +proc nickdb_get_sec_effective {n} { + set l [nickdb_get $n tellsec] + set u [nickdb_get_username $n] + if {![string compare [lindex $l 0] "secure"] && + ![string length $u]} { set l insecure } + return $l +} + +proc tell_peernicks {text} { + global errorInfo errorCode + set text [irctolower [string trim $text]] + set senders [split $text " "] + foreach sender $senders { + if {[catch { check_nick $sender } emsg]} { + error "invalid nick `$sender': $emsg" $errorInfo $errorCode + } + } + return $senders +} + +proc msgsdb_set_maydelete {n key l otherkey} { + msgsdb_set $n $key $l + if {[llength $l]} return + if {[llength [msgsdb_get $n $otherkey]]} return + msgsdb_delete $n +} + +proc tell_delete_msgs {lsenders lrecip} { + set new_inbound {} + set ndel 0 + foreach {s t m} [msgsdb_get $lrecip inbound] { + if {[llength $lsenders]} { + if {[lsearch -exact $lsenders [irctolower $s]] == -1} { + lappend new_inbound $s $t $m + continue + } + } + set rsenders($s) 1 + incr ndel + } + msgsdb_set_maydelete $lrecip inbound $new_inbound outbound + if {![llength $new_inbound]} { + upvar #0 nick_telling($lrecip) telling + catch { unset telling } + } + foreach s [array names rsenders] { + set new_outbound {} + foreach {r t c} [msgsdb_get $s outbound] { + if {![ircnick_compare $r $lrecip]} continue + lappend new_outbound $r $t $c + } + msgsdb_set_maydelete $s outbound $new_outbound inbound + } + return $ndel +} + +def_ucmd untell { + prefix_nick + check_notonchan + if {[nickdb_exists $n]} { nick_securitycheck 0 } + set recipients [tell_peernicks $text] + if {![llength $recipients]} { + usererror "You must say which recipients' messages from you to forget." + } + set ndel 0 + foreach recip $recipients { + incr ndel [tell_delete_msgs [irctolower $n] $recip] + } + ucmdr "Removed $ndel as yet undelivered message(s)." {} +} + +def_ucmd_alias delmsgs delmsg +def_ucmd delmsg { + global errorInfo errorCode + prefix_nick + set nl [irctolower $n] + check_notonchan + manyset [nickdb_get_sec_effective $n] sec secwhen + switch -exact $sec { + insecure { } + reject - mailto { + usererror \ + "There are no messages to delete\ + because your message disposition prevents them from being left." + } + secure { + nick_securitycheck 1 + } + default { + error "delmsg sec $sec" + } + } + if {![llength [msgsdb_get $n inbound]]} { + ucmdr "No incoming messages to delete." {} + } + tell_getcstate + if {![info exists u]} { + usererror \ + "I can't delete your messages unless I can see you on a channel with me.\ + Otherwise I might delete a message I hadn't told you about yet." + } + if {"$stt" != "passed"} { + set telling [list $u undelivered 0] + usererror \ + "There are message(s) you may not yet have seen;\ + I'll deliver them to you now.\ + If you actually want to delete them, just tell me `delmsg' again." + } + set senders [tell_peernicks $text] + set ndel [tell_delete_msgs [irctolower $senders] [irctolower $n]] + if {!$ndel} { + if {[llength $senders]} { + ucmdr "No relevant incoming messages to delete." {} + } + } + switch -exact [llength $senders] { + 0 { ucmdr {} {} "deletes your $ndel message(s)." } + 1 { ucmdr {} {} "deletes your $ndel message(s) from $senders." } + default { + ucmdr {} {} "deletes your $ndel message(s) from\ + [lreplace $senders end end] and/or [lindex $senders end]." + } + } +} + +def_ucmd tellme { + prefix_nick + ta_nomore + check_notonchan + manyset [nickdb_get $n tellsec] sec + switch -exact $sec { + reject { ucmdr "But, you asked me to reject messages for you !" {} } + mailto { ucmdr "But, you asked me to mail your messages to you !" {} } + } + switch -exact [tell_event [irctolower $n] tellme] { + ERROR - INVALID { ucmdr {} {is ill. Help!} } + nomsgs { ucmdr {You have no messages.} {} } + default { } + } +} + +def_ucmd tell { + global nick_case ownmailaddr ownfullname + + prefix_nick + set target [ta_nick] + if {![string length $text]} { error "tell them what?" } + if {[string length $text] > 400} { error "message too long" } + + set ltarget [irctolower $target] + set ctarget $target + if {[info exists nick_case($ltarget)]} { set ctarget $nick_case($ltarget) } + + manyset [nickdb_get_sec_effective $target] 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 {![ircnick_compare $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 . + tell_event $ltarget msgsarrive + 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." \ + {} + } + reject { + 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 + set target [ta_nick]; ta_nomore set myself 1 } else { prefix_nick 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 { @@ -915,9 +1540,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'." @@ -937,6 +1563,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" + } } } @@ -944,11 +1573,15 @@ proc timeformat_desc {tf} { switch -exact $tf { ks { return "Times will be displayed in seconds or kiloseconds." } hms { return "Times will be displayed in hours, minutes, etc." } + beat { return "Times will be displayed in beats (1000B = 1d)." } default { error "invalid timeformat: $v" } } } +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 @@ -961,6 +1594,56 @@ proc def_setting {opt show_body set_body} { $set_body" } +proc tellme_sec_desc {v n} { + manyset $v sec mailtoint + switch -exact $sec { + insecure { + return "I'll tell you your messages whenever I see you." + } + secure { + if {[string length [nickdb_get_username $n]]} { + return \ + "I'll keep the bodies of your messages private until you identify yourself, reminding you every [showintervalsecs $mailtoint 1]." + } else { + return \ + "I'll tell you your messages whenever I see you.\ + (Secure message delivery is enabled, but your nick is not registered\ + securely. See `help register'.)" + } + } + reject { + 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 n} { + manyset $v rel every within + switch -exact $rel { + unreliable { + return "As soon as I've told you message(s), I'll forget them\ + - 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 "After delivering messages, 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]" @@ -972,6 +1655,44 @@ def_setting timeformat { ucmdr {} $desc } +proc marktime_desc {mt} { + switch -exact $mt { + off { + return "I will not send you periodic messages." + } + once { + return "I will send you one informational message when I see you." + } + default { + 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 + + switch -exact $mt { + off - once { + } + default { + 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]} { @@ -981,7 +1702,132 @@ def_setting security { } } {} +proc tellme_setting_sec_simple {} { + uplevel 1 { + ta_nomore + set sr sec + set v $setting + } +} + +proc tellme_setting_neednomsgs {} { + uplevel 1 { + if {[llength [msgsdb_get $n inbound]]} { + usererror "You must delete the incoming messages you have, first." + } + } +} + +def_setting tellme { + set secv [nickdb_get $n tellsec] + set ms [tellme_sec_desc $secv $n] + manyset $secv sec + switch -exact $sec { + insecure - secure { + set mr [tellme_rel_desc [nickdb_get $n tellrel] $n] + return "$ms $mr" + } + reject - mailto { + return $ms + } + } +} { + set setting [string tolower [ta_word]] + set nl [irctolower $n] + switch -exact $setting { + insecure { + tellme_setting_sec_simple + } + secure { + set every [ta_interval_optional 60 600] + ta_nomore + set sr sec + set v [list secure $every] + } + reject { + tellme_setting_neednomsgs + tellme_setting_sec_simple + } + mailto { + tellme_setting_neednomsgs + + upvar #0 nick_username($nl) nu + if {!([info exists nu] && [string length $nu])} { + usererror \ + "Sorry, you must register securely to have your messages mailed\ + (to prevent the use of this feature for spamming). See `help register'." + } + set sr sec + set v [list mailto [ta_word] $nu] + } + unreliable - pester - remind { + manyset [nickdb_get $n tellsec] sec + switch -exact $sec { + reject - mailto { + usererror \ + "Sorry, I shan't change when I'll consider a message delivered, because\ + you've asked me not to keep messages, or to mail them to you.\ + You should say `set tellme secure' or some such, first." + } + } + set sr rel + set v $setting + if {"$setting" != "unreliable"} { + set every [ta_interval_optional 300 3600] + lappend v $every + } + if {![string compare $setting remind]} { + set within [ta_interval_optional 5 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 + upvar #0 nick_telling($nl) telling + catch { unset telling } + ucmdr [tellme_${sr}_desc $v $n] {} +} + +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 delivered 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]} { @@ -989,8 +1835,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"] @@ -1000,7 +1845,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 }]} { @@ -1012,26 +1857,47 @@ def_ucmd set { } def_ucmd identpass { + prefix_nick + check_notonchan + set luser [irctolower $n] set username [ta_word] set passmd5 [md5sum "[ta_word]\n"] ta_nomore - prefix_nick - check_notonchan - upvar #0 nick_onchans($n) onchans + 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 + after 50 [list tell_event $luser ident] ucmdr "Pleased to see you, $username." {} } +def_ucmd kill { + global nick + prefix_nick + set target [ta_nick] + if {![nickdb_exists $target]} { error "$target is not a registered nick." } + set wantu [nickdb_get $target username] + if {![string length $wantu]} { error "$target is insecurely registred." } + upvar #0 nick_username([irctolower $n]) nu + if {![info exists nu]} { error "You must identify yourself first." } + if {"$wantu" != "$nu"} { + error "You are the wrong user, $nu - $target belongs to $wantu." + } + set reason "at request of user $nu" + if {[ta_anymore]} { append reason "; $text" } + sendout KILL $target $reason + ucmdr {} {} +} + def_ucmd summon { set target [ta_word] ta_nomore + # fixme would be nice if the rest of the text was passed on instead check_username $target prefix_nick @@ -1059,7 +1925,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" }]." @@ -1068,7 +1934,7 @@ def_ucmd summon { } } -proc md5sum {value} { exec md5sum << $value } +proc md5sum {value} { lindex [exec md5sum << $value] 0 } def_ucmd seen { global lastseen nick @@ -1077,8 +1943,8 @@ def_ucmd seen { set nlower [irctolower $ncase] ta_nomore set now [clock seconds] - if {"$nlower" == "[irctolower $nick]"} { - error "I am not self-aware." + if {![ircnick_compare $nlower $nick]} { + usererror "I am not self-aware." } elseif {![info exists lastseen($nlower)]} { set rstr "I've never seen $ncase." } else { @@ -1096,25 +1962,129 @@ def_ucmd seen { if {[info exists lf]} { set oldvalue $lf } else { set oldvalue {} } set lf [list [list $now $n $where]] foreach v $oldvalue { - if {"[irctolower [lindex $v 1]]" == "[irctolower $n]"} continue + if {![ircnick_compare [lindex $v 1] $n]} continue lappend lf $v } ucmdr {} $rstr } -if {![info exists sock]} { - set sock [socket $host $port] - fconfigure $sock -buffering line - #fconfigure $sock -translation binary - fconfigure $sock -translation crlf +proc lnick_marktime_cancel {luser} { + upvar #0 nick_markid($luser) mi + if {![info exists mi]} return + catch { after cancel $mi } + catch { unset mi } +} - sendout USER blight 0 * $ownfullname - sendout NICK $nick - fileevent $sock readable onread +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]] } -loadhelp +proc lnick_marktime_reset {luser} { + set mt [nickdb_get $luser marktime] + switch -exact $mt { + off - once { } + default { + lnick_marktime_doafter $luser "Time passes." [expr {$mt*1000}] 0 + } + } +} -#if {![regexp {tclsh} $argv0]} { -# vwait terminate -#} +proc lnick_marktime_start {luser why ms mentiontold} { + set mt [nickdb_get $luser marktime] + switch -exact $mt { + off { + lnick_marktime_cancel $luser + if {$mentiontold} { after $ms [list lnick_checktold $luser] } + } + default { + 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} { after 150 [list 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 } + } + after 150 [list lnick_checktold $ln] + ucmdr {} [lnick_pingstring "Pong!" $oc $text] +} + +proc ensure_globalsecret {} { + global globalsecret + + if {[info exists globalsecret]} return + set gsfile [open /dev/urandom r] + fconfigure $gsfile -translation binary + set globalsecret [read $gsfile 32] + binary scan $globalsecret H* globalsecret + close $gsfile + unset gsfile +} + +proc connected {} { + global operuserpass + if {[info exists operuserpass]} { + eval sendout OPER $operuserpass + } + foreach chan [chandb_list] { + if {[chandb_get $chan autojoin]} { dojoin $chan } + } +} + +ensure_globalsecret +loadhelp +ensure_connecting