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 "-> $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         return
  80     }
  81     log "<- $org"
  82     set procname msg_$command
  83     if {[catch { info body $procname }]} { return }
  84     if {[catch {
  85         eval [list $procname $prefix $command] $params
  86     } emsg]} {
  87         logerror "error: $emsg ($prefix $command $params)"
  88         saveeic
  89     }
  90 }
  91
  92 proc prefix_none {} {
  93     upvar 1 p p
  94     if {[string length $p]} { error "prefix specified" }
  95 }
  96
  97 proc msg_PING {p c s1} {
  98     prefix_none
  99     sendout PONG $s1
 100 }
 101
 102 proc check_nick {n} {
 103     if {[regexp -nocase {[^][\\`_^{|}a-z0-9-]} $n]} { error "bad char in nick" }
 104     if {[regexp {^[-0-9]} $n]} { error "bad nick start" }
 105 }
 106
 107 proc prefix_nick {} {
 108     global nick
 109     upvar 1 p p
 110     upvar 1 n n
 111     if {![regexp {^([^!]+)!} $p dummy n]} { error "not from nick" }
 112     check_nick $n
 113     if {"[string tolower $n]" == "$nick"} { error "from myself" }
 114 }
 115
 116 proc msg_PRIVMSG {p c dest text} {
 117     prefix_nick
 118     if {[regexp {^[&#+!]} $dest]} {
 119         set what "!..."
 120         set them it
 121     } else {
 122         set what "private messages"
 123         set them them
 124     }
 125     sendout PRIVMSG $n \
 126             "I will respond to $what at some point; for now I just log $them."
 127 }
 128
 129 if {![info exists sock]} {
 130     set sock [socket $host $port]
 131     fconfigure $sock -buffering line
 132     #fconfigure $sock -translation binary
 133     fconfigure $sock -translation crlf
 134
 135     sendout USER guest 0 * ":chiark testing bot"
 136     sendout NICK $nick
 137     fileevent $sock readable onread
 138 }
 139
 140 if {![regexp {tclsh} $argv0]} {
 141     vwait terminate
 142 }