-# Core bot code
+# Actual IRC bot code
+
+set helpfile helpinfos
source irccore.tcl
+source parsecmd.tcl
+source stdhelp.tcl
+
+defset marktime_min 300
+defset marktime_join_startdelay 5000
-proc unlogged_content_msg {prefix params} {
- if {![regexp {^[&#+!]} [lindex $params 0]] ||
+proc privmsg_unlogged {prefix ischan params} {
+ if {!$ischan ||
[regexp {^![a-z][-a-z]*[a-z]( .*)?$} [lindex $params 1]]} {
- return 1
+ return 0
}
# on-channel message, ignore
set chan [lindex $params 0]
upvar #0 chan_lastactivity([irctolower $chan]) la
set la [clock seconds]
catch { recordlastseen_p $prefix "talking on $chan" 1 }
- return
-}
-
-proc usererror {emsg} { error $emsg {} {BLIGHT USER} }
-
-proc prefix_none {} {
- upvar 1 p p
- if {[string length $p]} { error "prefix specified" }
-}
-
-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 1
}
proc showintervalsecs {howlong abbrev} {
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\
}
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 nlist [grep tn {"$tn" != "$luser"} $nlist]
lappend nlist $lusernew
}
- lnick_marktime_start $lusernew "Hi." 500
+ lnick_marktime_start $lusernew "Hi." 500 1
nick_case $newnick
}
upvar #0 chan_nicks($lchan) nlist
if {![info exists oc]} {
global marktime_join_startdelay
- lnick_marktime_start $nl "Welcome." $marktime_join_startdelay
+ lnick_marktime_start $nl "Welcome." $marktime_join_startdelay 1
}
lappend oc $lchan
lappend nlist $nl
nick_ishere $n
}
-proc msg_PART {p c chan} {
+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} {
}
nick_case $n
- if {[catch {
- regsub {^! *} $text {} text
- set ucmd [ta_word]
- set procname ucmd/[string tolower $ucmd]
- if {[catch { info body $procname }]} {
- usererror "Unknown command; try help for help."
- }
- $procname $p $dest
- } rv]} {
- if {"$errorCode" != "BLIGHT USER"} { set rv "error: $rv" }
- sendprivmsg $n $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} {
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 errorInfo
-
- 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 {^\:\:} $l]} {
- } 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
- regsub -all {([^\\])\!\$?} _$l {\1} l
- regsub -all {\\(.)} $l {\1} l
- regsub {^_} $l {} l
- lappend lines [string trimright $l]
- } else {
- error "eh ? $lno: $l"
- }
- }
- if {[info exists topic]} { error "unfinished topic $topic" }
- } {
- set errorInfo "in helpinfos line $lno\n$errorInfo"
- } {
- close $f
- }
-}
-
-def_ucmd help {
- upvar 1 n n
-
- set topic [irctolower [string trim $text]]
- if {[string length $topic]} {
- set ontopic " on `$topic'"
- } else {
- set ontopic ""
- }
- 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$ontopic again later."
- ucmdr {} {}
- } else {
- sendaction_priority 1 $replyto \
- "is lagged. Your help$ontopic will arrive shortly ..."
- }
- }
-
- upvar #0 help_topics($topic) info
- if {![info exists info]} { ucmdr "No help on $topic, sorry." {} }
- ucmdr $info {}
-}
-
-def_ucmd ? {
- global help_topics
- ucmdr $help_topics() {}
-}
-
proc check_username {target} {
if {
[string length $target] > 8 ||
}
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; $body"
}
file delete $idfn
}
-set default_settings_nick {timeformat ks marktime off}
+set default_settings_nick {
+ timeformat ks
+ marktime off
+ tellsec insecure
+ tellrel {remind 3600 30}
+}
+
set default_settings_chan {
autojoin 1
mode *
topictell {}
}
+set default_settings_msgs {
+ inbound {}
+ outbound {}
+}
+# inbound -> [<nick> <time_t> <message>] ...
+# outbound -> [<nick> <time_t(earliest)> <count>] ...
+
def_somedb_id set {args} {
upvar #0 default_settings_$nickchan def
if {![info exists iddbe]} { set iddbe $def }
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 mailto 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: $mailto
+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 $mailto.)
+"
+ ucmdr \
+ "I've mailed $ctarget at $mailto, 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
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"
+ }
}
}
}
}
+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
$set_body"
}
+proc tellme_sec_desc {v} {
+ manyset $v sec mailto
+ 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."
+ }
+ refuse {
+ return "I shan't accept messages for you."
+ }
+ mailto {
+ return "I'll forward your messages by email to $mailto."
+ }
+ 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]"
ta_nomore
if {"$mt" == "off" || "$mt" == "once"} {
- } elseif {[regexp {^([0-9]+)([a-z]+)$} $mt dummy value unit]} {
- 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 "marktime interval too large" }
- set mt [expr {$value*$u}]
- if {$mt < $marktime_min} { error "marktime interval too small" }
} else {
- error "invalid syntax for marktime"
+ set mt [parse_interval $mt $marktime_min]
}
nickdb_set $n marktime $mt
- lnick_marktime_start [irctolower $n] "So:" 500
+ lnick_marktime_start [irctolower $n] "So:" 500 0
ucmdr {} [marktime_desc $mt]
}
}
} {}
+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]} {
}
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"]
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 }]} {
catch { unset mi }
}
-proc lnick_marktime_doafter {luser why ms} {
+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]]
+ 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}]
+ lnick_marktime_doafter $luser "Time passes." [expr {$mt*1000}] 0
}
-proc lnick_marktime_start {luser why ms} {
+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
+ lnick_marktime_doafter $luser $why $ms $mentiontold
}
}
-proc lnick_marktime_now {luser why} {
+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
}
catch { exec uptime } uptime
set nnicks [llength [array names nick_onchans]]
if {[regexp \
- {^ *([0-9:apm]+) +up.*, +(\d+) users, +load average: +([0-9., ]+) *$} \
+ {^ *([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"
}
def_ucmd ping {
+ prefix_nick
+ set ln [irctolower $n]
if {[ischan $dest]} {
set oc [irctolower $dest]
} else {
global nick_onchans
- prefix_nick
- set ln [irctolower $n]
if {[info exists nick_onchans($ln)]} {
set oc $nick_onchans($ln)
} else {
}
if {[llength $oc]} { lnick_marktime_reset $ln }
}
+ lnick_checktold $ln
ucmdr {} [lnick_pingstring "Pong!" $oc $text]
}
unset gsfile
}
-proc ensure_outqueue {} {
- out__vars
- if {[info exists out_queue]} return
- set out_creditms 0
- 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 socketargs
- global musthaveping_ms musthaveping_after
-
- if {[info exists sock]} return
- set sock [eval socket $socketargs [list $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 {} {
- global musthaveping_after
-
- after cancel $musthaveping_after
- unset musthaveping_after
-
foreach chan [chandb_list] {
if {[chandb_get $chan autojoin]} { dojoin $chan }
}
}
ensure_globalsecret
-ensure_outqueue
loadhelp
ensure_connecting