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