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