bot.tcl

   1 #!/usr/bin/tclsh8.2
   2
   3 set host chiark
   4 set port 6667
   5 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 msendprivmsg {dest ll} {
  96     foreach l $ll { sendout PRIVMSG $dest $l }
  97 }
  98
  99 proc msendprivmsg_delayed {delay dest ll} {
 100     after $delay [list msendprivmsg $dest $ll]
 101 }
 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 showinterval {howlong} {
 142     if {$howlong <= 0} {
 143         return {just now}
 144     } elseif {$howlong < 1000} {
 145         return "${howlong}s ago"
 146     } else {
 147         if {$howlong < 1000000} {
 148             set pfx k
 149             set scale 1000
 150         } else {
 151             set pfx M
 152             set scale 1000000
 153         }
 154         set value [expr "$howlong.0 / $scale"]
 155         foreach {min format} {100 %.0f 10 %.1f 1 %.2f} {
 156             if {$value < $min} continue
 157             return [format "$format${pfx}s ago" $value]
 158         }
 159     }
 160 }
 161
 162 proc showtime {when} {
 163     return [showinterval [expr {[clock seconds] - $when}]]
 164 }
 165
 166 proc def_msgproc {name argl body} {
 167     proc msg_$name "varbase $argl" "\
 168     upvar #0 msg/\$varbase/dest d\n\
 169     upvar #0 msg/\$varbase/str s\n\
 170     upvar #0 msg/\$varbase/accum a\n\
 171 $body"
 172 }
 173
 174 def_msgproc begin {dest str} {
 175     set d $dest
 176     set s $str
 177     set a {}
 178 }
 179
 180 def_msgproc append {str} {
 181     set ns "$s$str"
 182     if {[string length $s] && [string length $ns] > 65} {
 183         msg__sendout $varbase
 184         set s " [string trimleft $str]"
 185     } else {
 186         set s $ns
 187     }
 188 }
 189
 190 def_msgproc finish {} {
 191     msg__sendout $varbase
 192     unset s
 193     unset d
 194     return $a
 195 }
 196
 197 def_msgproc _sendout {} {
 198     lappend a [string trimright $s]
 199     set s {}
 200 }
 201
 202 proc looking_whenwhere {when where} {
 203     set str [showtime [expr {$when-1}]]
 204     if {[string length $where]} { append str " on $where" }
 205     return $str
 206 }
 207
 208 proc recordlastseen_n {n how here} {
 209     global lastseen lookedfor
 210     set lastseen([irctolower $n]) [list $n [clock seconds] $how]
 211     if {!$here} return
 212     upvar #0 lookedfor([irctolower $n]) lf
 213     if {[info exists lf]} {
 214         switch -exact [llength $lf] {
 215             0 {
 216                 set ml {}
 217             }
 218             1 {
 219                 manyset [lindex $lf 0] when who where
 220                 set ml [list \
 221  "FYI, $who was looking for you [looking_whenwhere $when $where]."]
 222             }
 223             default {
 224                 msg_begin tosend $n "FYI, people have been looking for you:"
 225                 set i 0
 226                 set fin ""
 227                 foreach e $lf {
 228                     incr i
 229                     if {$i == 1} {
 230                         msg_append tosend " "
 231                     } elseif {$i == [llength $lf]} {
 232                         msg_append tosend " and "
 233                         set fin .
 234                     } else {
 235                         msg_append tosend ", "
 236                     }
 237                     manyset $e when who where
 238                     msg_append tosend \
 239                             "$who ([looking_whenwhere $when $where])$fin"
 240                 }
 241                 set ml [msg_finish tosend]
 242             }
 243         }
 244         unset lf
 245         msendprivmsg_delayed 1000 $n $ml
 246     }
 247 }
 248
 249 proc recordlastseen_p {p how here} {
 250     prefix_nick
 251     recordlastseen_n $n $how $here
 252 }
 253
 254 proc chanmode_arg {} {
 255     upvar 2 args cm_args
 256     set rv [lindex $cm_args 0]
 257     set cm_args [lreplace cm_args 0 0]
 258     return $rv
 259 }
 260
 261 proc chanmode_o1 {m g p chan} {
 262     global nick
 263     prefix_nick
 264     set who [chanmode_arg]
 265     recordlastseen_n $n "being nice to $who" 1
 266     if {"[irctolower $who]" == "[irctolower $nick]"} {
 267         sendout PRIVMSG $n Thanks.
 268     }
 269 }
 270
 271 proc chanmode_o0 {m g p chan} {
 272     global nick chandeop
 273     prefix_nick
 274     set who [chanmode_arg]
 275     recordlastseen_p $p "being mean to $who" 1
 276     if {"[irctolower $who]" == "[irctolower $nick]"} {
 277         set chandeop($chan) [list [clock seconds] $p]
 278     }
 279 }
 280
 281 proc msg_MODE {p c dest modelist args} {
 282     if {![ischan $dest]} return
 283     if {[regexp {^\-(.+)$} $modelist dummy modelist]} {
 284         set give 0
 285     } elseif {[regexp {^\+(.+)$} $modelist dummy modelist]} {
 286         set give 1
 287     } else {
 288         error "invalid modelist"
 289     }
 290     foreach m [split $modelist] {
 291         set procname chanmode_$m$give
 292         if {[catch { info body $procname }]} {
 293             recordlastseen_p $p "fiddling with $dest" 1
 294         } else {
 295             $procname $m $give  $p $dest
 296         }
 297     }
 298 }
 299
 300 proc msg_NICK {p c newnick} {
 301     prefix_nick
 302     recordlastseen_n $n "changing nicks to $newnick" 0
 303     recordlastseen_n $newnick "changing nicks from $n" 1
 304 }
 305
 306 proc msg_JOIN {p c chan} { recordlastseen_p $p "joining $chan" 1 }
 307 proc msg_PART {p c chan} { recordlastseen_p $p "leaving $chan" 1 }
 308 proc msg_QUIT {p c why} { recordlastseen_p $p "leaving ($why)" 0 }
 309
 310 proc msg_PRIVMSG {p c dest text} {
 311     prefix_nick
 312     if {[ischan $dest]} {
 313         recordlastseen_n $n "invoking me in $dest" 1
 314         set output $dest
 315     } else {
 316         recordlastseen_n $n "talking to me" 1
 317         set output $n
 318     }
 319
 320     if {[catch {
 321         regsub {^! *} $text {} text
 322         set ucmd [ta_word]
 323         set procname ucmd/[string tolower $ucmd]
 324         if {[catch { info body $procname }]} {
 325             error "unknown command; try help for help"
 326         }
 327         $procname $p $dest
 328     } rv]} {
 329         sendout PRIVMSG $n "error: $rv"
 330     } else {
 331         foreach {td val} [list $n [lindex $rv 0] $output [lindex $rv 1]] {
 332             foreach l [split $val "\n"] {
 333                 sendout PRIVMSG $td $l
 334             }
 335         }
 336     }
 337 }
 338
 339 proc ta_nomore {} {
 340     upvar 1 text text
 341     if {[string length $text]} { error "too many parameters" }
 342 }
 343
 344 proc ta_word {} {
 345     upvar 1 text text
 346     if {![regexp {^([^  ]+) *(.*)} $text dummy firstword text]} {
 347         error "too few parameters"
 348     }
 349     return $firstword
 350 }
 351
 352 proc ta_nick {} {
 353     upvar 1 text text
 354     set v [ta_word]
 355     check_nick $v
 356     return $v
 357 }
 358
 359 proc def_ucmd {cmdname body} {
 360     proc ucmd/$cmdname {p dest} "    upvar 1 text text\n$body"
 361 }
 362
 363 proc ucmdr {priv pub} {
 364     return -code return [list $priv $pub]
 365 }
 366
 367 def_ucmd help {
 368     ta_nomore
 369     ucmdr \
 370 {Commands currently understood:
 371 help             get this list of commands
 372 seen <nick>      ask after someone (I'll tell them you asked)} {}
 373 }
 374
 375 proc manyset {list args} {
 376     foreach val $list var $args {
 377         upvar 1 $var my
 378         set my $val
 379     }
 380 }
 381
 382 def_ucmd seen {
 383     global lastseen nick
 384     prefix_nick
 385     set ncase [ta_nick]
 386     set nlower [irctolower $ncase]
 387     ta_nomore
 388     set now [clock seconds]
 389     if {"$nlower" == "[irctolower $nick]"} {
 390         error "I am not self-aware."
 391     } elseif {![info exists lastseen($nlower)]} {
 392         set rstr "I've never seen $ncase."
 393     } else {
 394         manyset $lastseen($nlower) realnick time what
 395         set howlong [expr {$now - $time}]
 396         set string [showinterval $howlong]
 397         set rstr "I last saw $realnick $string, $what."
 398     }
 399     if {[ischan $dest]} {
 400         set where $dest
 401     } else {
 402         set where {}
 403     }
 404     upvar #0 lookedfor($nlower) lf
 405     if {[info exists lf]} { set oldvalue $lf } else { set oldvalue {} }
 406     set lf [list [list $now $n $where]]
 407     foreach v $oldvalue {
 408         if {"[irctolower [lindex $v 1]]" == "[irctolower $n]"} continue
 409         lappend lf $v
 410     }
 411     ucmdr {} $rstr
 412 }
 413
 414 if {![info exists sock]} {
 415     set sock [socket $host $port]
 416     fconfigure $sock -buffering line
 417     #fconfigure $sock -translation binary
 418     fconfigure $sock -translation crlf
 419
 420     sendout USER guest 0 * "chiark testing bot"
 421     sendout NICK $nick
 422     fileevent $sock readable onread
 423 }
 424
 425 #if {![regexp {tclsh} $argv0]} {
 426 #    vwait terminate
 427 #}