chiark - git - mdw - ircbot/blob - bot.tcl

   1 #!/usr/bin/tclsh8.2
   2
   3 set host chiark
   4 set port 6667
   5 if {![info exists nick]} { set nick Blight }
   6
   7 proc sendout {command args} {
   8     global sock
   9     if {[llength $args]} {
  10         set la [lindex $args end]
  11         set args [lreplace $args end end]
  12         foreach i $args {
  13             if {[regexp {[: ]} $i]} {
  14                 error "bad argument in output $i ($command $args)"
  15             }
  16         }
  17         lappend args :$la
  18     }
  19     set args [lreplace $args 0 -1 $command]
  20     set string [join $args { }]
  21     puts "[clock seconds] -> $string"
  22     puts $sock $string
  23 }
  24
  25 proc log {data} {
  26     puts $data
  27 }
  28
  29 proc logerror {data} {
  30     log $data
  31 }
  32
  33 proc saveeic {} {
  34     global saveei saveec errorInfo errorCode
  35
  36     set saveei $errorInfo
  37     set saveec $errorCode
  38
  39     puts ">$saveec|$saveei<"
  40 }
  41
  42 proc bgerror {msg} {
  43     global save
  44     logerror $msg
  45     saveeic
  46 }
  47
  48 proc onread {args} {
  49     global sock
  50
  51     if {[gets $sock line] == -1} { set terminate 1; return }
  52     regsub -all "\[^ -\176\240-\376\]" $line ? line
  53     set org $line
  54     if {[regexp -nocase {^:([^ ]+) (.*)} $line dummy prefix remain]} {
  55         set line $remain
  56     } else {
  57         set prefix {}
  58     }
  59     if {![string length $line]} { return }
  60     if {![regexp -nocase {^([0-9a-z]+) *(.*)} $line dummy command line]} {
  61         log "bad command: $org"
  62         return
  63     }
  64     set command [string toupper $command]
  65     set params {}
  66     while {[regexp {^([^ :]+) *(.*)} $line dummy thisword line]} {
  67         lappend params $thisword
  68     }
  69     if {[regexp {^:(.*)} $line dummy thisword]} {
  70         lappend params $thisword
  71     } elseif {[string length $line]} {
  72         log "junk at end: $org"
  73         return
  74     }
  75     if {"$command" == "PRIVMSG" &&
  76         [regexp {^[&#+!]} [lindex $params 0]] &&
  77         ![regexp {^!} [lindex $params 1]]} {
  78         # on-channel message, ignore
  79         catch {
  80             recordlastseen_p $prefix "talking on [lindex $params 0]" 1
  81         }
  82         return
  83     }
  84     log "[clock seconds] <- $org"
  85     set procname msg_$command
  86     if {[catch { info body $procname }]} { return }
  87     if {[catch {
  88         eval [list $procname $prefix $command] $params
  89     } emsg]} {
  90         logerror "error: $emsg ($prefix $command $params)"
  91         saveeic
  92     }
  93 }
  94
  95 proc sendprivmsg {dest l} {
  96     sendout [expr {[ischan $dest] ? "PRIVMSG" : "NOTICE"}] $dest $l
  97 }
  98 proc sendaction {dest what} { sendout PRIVMSG $dest "\001ACTION $what\001" }
  99 proc msendprivmsg {dest ll} { foreach l $ll { sendprivmsg $dest $l } }
 100 proc msendprivmsg_delayed {delay dest ll} { after $delay [list msendprivmsg $dest $ll] }
 101
 102 proc prefix_none {} {
 103     upvar 1 p p
 104     if {[string length $p]} { error "prefix specified" }
 105 }
 106
 107 proc msg_PING {p c s1} {
 108     prefix_none
 109     sendout PONG $s1
 110 }
 111
 112 proc check_nick {n} {
 113     if {[regexp -nocase {[^][\\`_^{|}a-z0-9-]} $n]} { error "bad char in nick" }
 114     if {[regexp {^[-0-9]} $n]} { error "bad nick start" }
 115 }
 116
 117 proc ischan {dest} {
 118     return [regexp {^[&#+!]} $dest]
 119 }
 120
 121 proc irctolower {v} {
 122     foreach {from to} [list "\\\[" "{" \
 123                           "\\\]" "}" \
 124                           "\\\\" "|" \
 125                           "~"    "^"] {
 126         regsub -all $from $v $to v
 127     }
 128     return [string tolower $v]
 129 }
 130
 131 proc prefix_nick {} {
 132     global nick
 133     upvar 1 p p
 134     upvar 1 n n
 135     if {![regexp {^([^!]+)!} $p dummy n]} { error "not from nick" }
 136     check_nick $n
 137     if {"[irctolower $n]" == "[irctolower $nick]"} { error "from myself" }
 138 }
 139
 140 proc showintervalsecs {howlong} {
 141     if {$howlong < 1000} {
 142         return "${howlong}s"
 143     } else {
 144         if {$howlong < 1000000} {
 145             set pfx k
 146             set scale 1000
 147         } else {
 148             set pfx M
 149             set scale 1000000
 150         }
 151         set value [expr "$howlong.0 / $scale"]
 152         foreach {min format} {100 %.0f 10 %.1f 1 %.2f} {
 153             if {$value < $min} continue
 154             return [format "$format${pfx}s" $value]
 155         }
 156     }
 157 }
 158
 159 proc showinterval {howlong} {
 160     if {$howlong <= 0} {
 161         return {just now}
 162     } else {
 163         return "[showintervalsecs $howlong] ago"
 164     }
 165 }
 166
 167 proc showtime {when} {
 168     return [showinterval [expr {[clock seconds] - $when}]]
 169 }
 170
 171 proc def_msgproc {name argl body} {
 172     proc msg_$name "varbase $argl" "\
 173     upvar #0 msg/\$varbase/dest d\n\
 174     upvar #0 msg/\$varbase/str s\n\
 175     upvar #0 msg/\$varbase/accum a\n\
 176 $body"
 177 }
 178
 179 def_msgproc begin {dest str} {
 180     set d $dest
 181     set s $str
 182     set a {}
 183 }
 184
 185 def_msgproc append {str} {
 186     set ns "$s$str"
 187     if {[string length $s] && [string length $ns] > 65} {
 188         msg__sendout $varbase
 189         set s " [string trimleft $str]"
 190     } else {
 191         set s $ns
 192     }
 193 }
 194
 195 def_msgproc finish {} {
 196     msg__sendout $varbase
 197     unset s
 198     unset d
 199     return $a
 200 }
 201
 202 def_msgproc _sendout {} {
 203     lappend a [string trimright $s]
 204     set s {}
 205 }
 206
 207 proc looking_whenwhere {when where} {
 208     set str [showtime [expr {$when-1}]]
 209     if {[string length $where]} { append str " on $where" }
 210     return $str
 211 }
 212
 213 proc recordlastseen_n {n how here} {
 214     global lastseen lookedfor
 215     set lastseen([irctolower $n]) [list $n [clock seconds] $how]
 216     if {!$here} return
 217     upvar #0 lookedfor([irctolower $n]) lf
 218     if {[info exists lf]} {
 219         switch -exact [llength $lf] {
 220             0 {
 221                 set ml {}
 222             }
 223             1 {
 224                 manyset [lindex $lf 0] when who where
 225                 set ml [list \
 226  "FYI, $who was looking for you [looking_whenwhere $when $where]."]
 227             }
 228             default {
 229                 msg_begin tosend $n "FYI, people have been looking for you:"
 230                 set i 0
 231                 set fin ""
 232                 foreach e $lf {
 233                     incr i
 234                     if {$i == 1} {
 235                         msg_append tosend " "
 236                     } elseif {$i == [llength $lf]} {
 237                         msg_append tosend " and "
 238                         set fin .
 239                     } else {
 240                         msg_append tosend ", "
 241                     }
 242                     manyset $e when who where
 243                     msg_append tosend \
 244                             "$who ([looking_whenwhere $when $where])$fin"
 245                 }
 246                 set ml [msg_finish tosend]
 247             }
 248         }
 249         unset lf
 250         msendprivmsg_delayed 1000 $n $ml
 251     }
 252 }
 253
 254 proc recordlastseen_p {p how here} {
 255     prefix_nick
 256     recordlastseen_n $n $how $here
 257 }
 258
 259 proc chanmode_arg {} {
 260     upvar 2 args cm_args
 261     set rv [lindex $cm_args 0]
 262     set cm_args [lreplace cm_args 0 0]
 263     return $rv
 264 }
 265
 266 proc chanmode_o1 {m g p chan} {
 267     global nick
 268     prefix_nick
 269     set who [chanmode_arg]
 270     recordlastseen_n $n "being nice to $who" 1
 271     if {"[irctolower $who]" == "[irctolower $nick]"} {
 272         sendprivmsg $n Thanks.
 273     }
 274 }
 275
 276 proc chanmode_o0 {m g p chan} {
 277     global nick chandeop
 278     prefix_nick
 279     set who [chanmode_arg]
 280     recordlastseen_p $p "being mean to $who" 1
 281     if {"[irctolower $who]" == "[irctolower $nick]"} {
 282         set chandeop($chan) [list [clock seconds] $p]
 283     }
 284 }
 285
 286 proc msg_MODE {p c dest modelist args} {
 287     if {![ischan $dest]} return
 288     if {[regexp {^\-(.+)$} $modelist dummy modelist]} {
 289         set give 0
 290     } elseif {[regexp {^\+(.+)$} $modelist dummy modelist]} {
 291         set give 1
 292     } else {
 293         error "invalid modelist"
 294     }
 295     foreach m [split $modelist] {
 296         set procname chanmode_$m$give
 297         if {[catch { info body $procname }]} {
 298             recordlastseen_p $p "fiddling with $dest" 1
 299         } else {
 300             $procname $m $give  $p $dest
 301         }
 302     }
 303 }
 304
 305 proc msg_NICK {p c newnick} {
 306     prefix_nick
 307     recordlastseen_n $n "changing nicks to $newnick" 0
 308     recordlastseen_n $newnick "changing nicks from $n" 1
 309 }
 310
 311 proc msg_JOIN {p c chan} { recordlastseen_p $p "joining $chan" 1 }
 312 proc msg_PART {p c chan} { recordlastseen_p $p "leaving $chan" 1 }
 313 proc msg_QUIT {p c why} { recordlastseen_p $p "leaving ($why)" 0 }
 314
 315 proc msg_PRIVMSG {p c dest text} {
 316     prefix_nick
 317     if {[ischan $dest]} {
 318         recordlastseen_n $n "invoking me in $dest" 1
 319         set output $dest
 320     } else {
 321         recordlastseen_n $n "talking to me" 1
 322         set output $n
 323     }
 324
 325     if {[catch {
 326         regsub {^! *} $text {} text
 327         set ucmd [ta_word]
 328         set procname ucmd/[string tolower $ucmd]
 329         if {[catch { info body $procname }]} {
 330             error "unknown command; try help for help"
 331         }
 332         $procname $p $dest
 333     } rv]} {
 334         sendprivmsg $n "error: $rv"
 335     } else {
 336         manyset $rv priv_msgs pub_msgs priv_acts pub_acts
 337         foreach {td val} [list $n $priv_msgs $output $pub_msgs] {
 338             foreach l [split $val "\n"] {
 339                 sendprivmsg $td $l
 340             }
 341         }
 342         foreach {td val} [list $n $priv_acts $output $pub_acts] {
 343             foreach l [split $val "\n"] {
 344                 sendaction $td $l
 345             }
 346         }
 347     }
 348 }
 349
 350 proc ta_nomore {} {
 351     upvar 1 text text
 352     if {[string length $text]} { error "too many parameters" }
 353 }
 354
 355 proc ta_word {} {
 356     upvar 1 text text
 357     if {![regexp {^([^  ]+) *(.*)} $text dummy firstword text]} {
 358         error "too few parameters"
 359     }
 360     return $firstword
 361 }
 362
 363 proc ta_nick {} {
 364     upvar 1 text text
 365     set v [ta_word]
 366     check_nick $v
 367     return $v
 368 }
 369
 370 proc def_ucmd {cmdname body} {
 371     proc ucmd/$cmdname {p dest} "    upvar 1 text text\n$body"
 372 }
 373
 374 proc ucmdr {priv pub args} {
 375     return -code return [concat [list $priv $pub] $args]
 376 }
 377
 378 def_ucmd help {
 379     ta_nomore
 380     ucmdr \
 381 {Commands currently understood:
 382 help              get this list of commands
 383 seen <nick>       ask after someone (I'll tell them you asked)
 384 summon <username> invite a logged-on user onto IRC} {}
 385 }
 386
 387 proc manyset {list args} {
 388     foreach val $list var $args {
 389         upvar 1 $var my
 390         set my $val
 391     }
 392 }
 393
 394 def_ucmd summon {
 395     set target [ta_word]
 396     ta_nomore
 397     if {
 398         [string length $target] > 8 ||
 399         [regexp {[^-0-9a-z]} $target] ||
 400         ![regexp {^[a-z]} $target]
 401     } { error "invalid username" }
 402     prefix_nick
 403
 404     upvar #0 lastsummon($target) ls
 405     set now [clock seconds]
 406     if {[info exists ls]} {
 407         set interval [expr {$now - $ls}]
 408         if {$interval < 30} {
 409             ucmdr {} \
 410  "Please be patient; $target was summoned only [showinterval $interval]."
 411         }
 412     }
 413     regsub {^[^!]*!} $p {} path
 414     if {[catch {
 415         exec userv --timeout 3 $target irc-summon $n $path \
 416                 [expr {[ischan $dest] ? "$dest" : ""}] \
 417                 < /dev/null
 418     } rv]} {
 419         regsub -all "\n" $rv { / } rv
 420         error $rv
 421     }
 422     if {[regexp {^problem (.*)} $rv dummy problem]} {
 423         ucmdr {} "The user `$target' $problem."
 424     } elseif {[regexp {^ok ([^ ]+) ([0-9]+)$} $rv dummy tty idlesince]} {
 425         set idletime [expr {$now - $idlesince}]
 426         set ls $now
 427         ucmdr {} {} {} "invites $target ($tty[expr {
 428             $idletime > 10 ? ", idle for [showintervalsecs $idletime]" : ""
 429         }]) to [expr {
 430             [ischan $dest] ? "join us here" : "talk to you"
 431         }]."
 432     } else {
 433         error "unexpected response from userv service: $rv"
 434     }
 435 }
 436
 437 def_ucmd seen {
 438     global lastseen nick
 439     prefix_nick
 440     set ncase [ta_nick]
 441     set nlower [irctolower $ncase]
 442     ta_nomore
 443     set now [clock seconds]
 444     if {"$nlower" == "[irctolower $nick]"} {
 445         error "I am not self-aware."
 446     } elseif {![info exists lastseen($nlower)]} {
 447         set rstr "I've never seen $ncase."
 448     } else {
 449         manyset $lastseen($nlower) realnick time what
 450         set howlong [expr {$now - $time}]
 451         set string [showinterval $howlong]
 452         set rstr "I last saw $realnick $string, $what."
 453     }
 454     if {[ischan $dest]} {
 455         set where $dest
 456     } else {
 457         set where {}
 458     }
 459     upvar #0 lookedfor($nlower) lf
 460     if {[info exists lf]} { set oldvalue $lf } else { set oldvalue {} }
 461     set lf [list [list $now $n $where]]
 462     foreach v $oldvalue {
 463         if {"[irctolower [lindex $v 1]]" == "[irctolower $n]"} continue
 464         lappend lf $v
 465     }
 466     ucmdr {} $rstr
 467 }
 468
 469 if {![info exists sock]} {
 470     set sock [socket $host $port]
 471     fconfigure $sock -buffering line
 472     #fconfigure $sock -translation binary
 473     fconfigure $sock -translation crlf
 474
 475     sendout USER guest 0 * "chiark testing bot"
 476     sendout NICK $nick
 477     fileevent $sock readable onread
 478 }
 479
 480 #if {![regexp {tclsh} $argv0]} {
 481 #    vwait terminate
 482 #}