Commit | Line | Data |
---|---|---|
9bc33297 IJ |
1 | #!/usr/bin/tclsh8.2 |
2 | ||
3 | set host chiark | |
4 | set port 6667 | |
5 | set nick Blight | |
6 | ||
cc2d31de IJ |
7 | proc sendout {command args} { |
8 | global sock | |
9bc33297 IJ |
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]} { | |
cc2d31de | 14 | error "bad argument in output $i ($command $args)" |
9bc33297 IJ |
15 | } |
16 | } | |
cc2d31de | 17 | lappend args :$la |
9bc33297 IJ |
18 | } |
19 | set args [lreplace $args 0 -1 $command] | |
cc2d31de IJ |
20 | set string [join $args { }] |
21 | puts "-> $string" | |
9bc33297 IJ |
22 | puts $sock $string |
23 | } | |
9bc33297 IJ |
24 | |
25 | proc log {data} { | |
26 | puts $data | |
27 | } | |
28 | ||
29 | proc logerror {data} { | |
30 | log $data | |
cc2d31de IJ |
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 | } | |
9bc33297 IJ |
47 | |
48 | proc onread {args} { | |
cc2d31de | 49 | global sock |
9bc33297 | 50 | |
cc2d31de IJ |
51 | if {[gets $sock line] == -1} { set terminate 1; return } |
52 | regsub -all "\[^ -\176\240-\376\]" $line ? line | |
9bc33297 IJ |
53 | set org $line |
54 | if {[regexp -nocase {^:([^ ]+) (.*)} $line dummy prefix remain]} { | |
55 | set line $remain | |
56 | } else { | |
57 | set prefix {} | |
58 | } | |
cc2d31de | 59 | if {![string length $line]} { return } |
9bc33297 IJ |
60 | if {![regexp -nocase {^([0-9a-z]+) *(.*)} $line dummy command line]} { |
61 | log "bad command: $org" | |
62 | return | |
63 | } | |
cc2d31de | 64 | set command [string toupper $command] |
9bc33297 | 65 | set params {} |
cc2d31de | 66 | while {[regexp {^([^ :]+) *(.*)} $line dummy thisword line]} { |
9bc33297 IJ |
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 | } | |
cc2d31de IJ |
75 | if {"$command" == "PRIVMSG" && |
76 | [regexp {^[&#+!]} [lindex $params 0]] && | |
77 | ![regexp {^!} [lindex $params 1]]} { | |
78 | # on-channel message, ignore | |
422f52e4 IJ |
79 | catch { |
80 | recordlastseen_p $prefix "talking on [lindex $params 0]" | |
81 | } | |
cc2d31de IJ |
82 | return |
83 | } | |
84 | log "<- $org" | |
9bc33297 | 85 | set procname msg_$command |
cc2d31de | 86 | if {[catch { info body $procname }]} { return } |
9bc33297 IJ |
87 | if {[catch { |
88 | eval [list $procname $prefix $command] $params | |
89 | } emsg]} { | |
90 | logerror "error: $emsg ($prefix $command $params)" | |
cc2d31de | 91 | saveeic |
9bc33297 IJ |
92 | } |
93 | } | |
94 | ||
cc2d31de IJ |
95 | proc prefix_none {} { |
96 | upvar 1 p p | |
9bc33297 | 97 | if {[string length $p]} { error "prefix specified" } |
cc2d31de | 98 | } |
9bc33297 | 99 | |
cc2d31de IJ |
100 | proc msg_PING {p c s1} { |
101 | prefix_none | |
102 | sendout PONG $s1 | |
9bc33297 IJ |
103 | } |
104 | ||
cc2d31de IJ |
105 | proc check_nick {n} { |
106 | if {[regexp -nocase {[^][\\`_^{|}a-z0-9-]} $n]} { error "bad char in nick" } | |
107 | if {[regexp {^[-0-9]} $n]} { error "bad nick start" } | |
108 | } | |
109 | ||
422f52e4 IJ |
110 | proc ischan {dest} { |
111 | return [regexp {^[&#+!]} $dest] | |
112 | } | |
113 | ||
114 | proc irctolower {v} { | |
115 | foreach {from to} [list "\\\[" "{" \ | |
116 | "\\\]" "}" \ | |
117 | "\\\\" "|" \ | |
118 | "~" "^"] { | |
119 | regsub -all $from $v $to v | |
120 | } | |
121 | return [string tolower $v] | |
122 | } | |
123 | ||
cc2d31de IJ |
124 | proc prefix_nick {} { |
125 | global nick | |
126 | upvar 1 p p | |
127 | upvar 1 n n | |
128 | if {![regexp {^([^!]+)!} $p dummy n]} { error "not from nick" } | |
129 | check_nick $n | |
422f52e4 IJ |
130 | if {"[irctolower $n]" == "[irctolower $nick]"} { error "from myself" } |
131 | } | |
132 | ||
133 | proc recordlastseen_n {n how} { | |
134 | global lastseen | |
135 | set lastseen([irctolower $n]) [list $n [clock seconds] $how] | |
136 | } | |
137 | ||
138 | proc recordlastseen_p {p how} { | |
139 | prefix_nick | |
140 | recordlastseen_n $n $how | |
141 | } | |
142 | ||
143 | proc chanmode_arg {} { | |
144 | upvar 2 args cm_args | |
145 | set rv [lindex $cm_args 0] | |
146 | set cm_args [lreplace cm_args 0 0] | |
147 | return $rv | |
148 | } | |
149 | ||
150 | proc chanmode_o0 {m g p chan} { | |
151 | global nick chandeop | |
152 | prefix_nick | |
153 | set who [chanmode_arg] | |
154 | recordlastseen_p $p "being mean to $who" | |
155 | if {"[irctolower $who]" == "[irctolower $nick]"} { | |
156 | set chandeop($chan) [list [clock seconds] $p] | |
157 | } | |
cc2d31de | 158 | } |
9bc33297 | 159 | |
422f52e4 IJ |
160 | proc msg_MODE {p c dest modelist args} { |
161 | if {![ischan $dest]} return | |
162 | if {[regexp {^\-(.+)$} $modelist dummy modelist]} { | |
163 | set give 0 | |
164 | } elseif {[regexp {^\+(.+)$} $modelist dummy modelist]} { | |
165 | set give 1 | |
166 | } else { | |
167 | error "invalid modelist" | |
168 | } | |
169 | foreach m [split $modelist] { | |
170 | set procname chanmode_$m$give | |
171 | if {[catch { info body $procname }]} { | |
172 | recordlastseen_p $p "fiddling with $dest" | |
173 | } else { | |
174 | $procname $m $give $p $dest | |
175 | } | |
176 | } | |
177 | } | |
178 | ||
179 | proc msg_JOIN {p c chan} { recordlastseen_p $p "joining $chan" } | |
180 | proc msg_PART {p c chan} { recordlastseen_p $p "leaving $chan" } | |
181 | proc msg_QUIT {p c why} { recordlastseen_p $p "leaving ($why)" } | |
182 | ||
cc2d31de IJ |
183 | proc msg_PRIVMSG {p c dest text} { |
184 | prefix_nick | |
422f52e4 IJ |
185 | if {[ischan $dest]} { |
186 | recordlastseen_n $n "invoking me in $dest" | |
187 | set output $dest | |
cc2d31de | 188 | } else { |
422f52e4 IJ |
189 | recordlastseen_n $n "talking to me" |
190 | set output $n | |
191 | } | |
192 | ||
193 | if {[catch { | |
194 | regsub {^! *} $text {} text | |
195 | set ucmd [ta_word] | |
196 | set procname ucmd_[string tolower $ucmd] | |
197 | if {[catch { info body $procname }]} { | |
198 | error "unknown command; try help for help" | |
199 | } | |
200 | $procname | |
201 | } rv]} { | |
202 | sendout PRIVMSG $n "error: $rv" | |
203 | } else { | |
204 | foreach {td val} [list $n [lindex $rv 0] $output [lindex $rv 1]] { | |
205 | foreach l [split $val "\n"] { | |
206 | sendout PRIVMSG $td $l | |
207 | } | |
208 | } | |
209 | } | |
210 | } | |
211 | ||
212 | proc ta_nomore {} { | |
213 | upvar 1 text text | |
214 | if {[string length $text]} { error "too many parameters" } | |
215 | } | |
216 | ||
217 | proc ta_word {} { | |
218 | upvar 1 text text | |
219 | if {![regexp {^([^ ]+) *(.*)} $text dummy firstword text]} { | |
220 | error "too few parameters" | |
221 | } | |
222 | return $firstword | |
223 | } | |
224 | ||
225 | proc ta_nick {} { | |
226 | upvar 1 text text | |
227 | set v [ta_word] | |
228 | check_nick $v | |
229 | return $v | |
230 | } | |
231 | ||
232 | proc ucmdr {priv pub} { | |
233 | return -code return [list $priv $pub] | |
234 | } | |
235 | ||
236 | proc ucmd_help {} { | |
237 | upvar 1 text text | |
238 | ta_nomore | |
239 | ucmdr \ | |
240 | {Commands currently understood: | |
241 | help | |
242 | seen <nick>} {} | |
243 | } | |
244 | ||
245 | proc manyset {list args} { | |
246 | foreach val $list var $args { | |
247 | upvar 1 $var my | |
248 | set my $val | |
249 | } | |
250 | } | |
251 | ||
252 | proc ucmd_seen {} { | |
253 | global lastseen nick | |
254 | upvar 1 text text | |
255 | set n [irctolower [ta_nick]] | |
256 | ta_nomore | |
257 | if {"$n" == "[irctolower $nick]"} { | |
258 | error "I am not self-aware." | |
259 | } elseif {![info exists lastseen($n)]} { | |
260 | ucmdr {} "I've never seen $n." | |
261 | } else { | |
262 | manyset $lastseen($n) realnick time what | |
263 | set howlong [expr {[clock seconds] - $time}] | |
264 | if {$howlong <= 0} { | |
265 | set string now | |
266 | } elseif {$howlong < 1000} { | |
267 | set string "${howlong}s ago" | |
268 | } else { | |
269 | if {$howlong < 1000000} { | |
270 | set pfx k | |
271 | set scale 1000 | |
272 | } else { | |
273 | set pfx M | |
274 | set scale 1000000 | |
275 | } | |
276 | set value [expr "$howlong.0 / $scale"] | |
277 | foreach {min format} {100 %.0f 10 %.1f 1 %.2f} { | |
278 | if {$value < $min} continue | |
279 | set string [format "$format${pfx}s ago" $value] | |
280 | break | |
281 | } | |
282 | } | |
283 | if {![info exists string]} { set string now } | |
284 | ucmdr {} "I last saw $realnick $string, $what." | |
cc2d31de | 285 | } |
cc2d31de IJ |
286 | } |
287 | ||
288 | if {![info exists sock]} { | |
289 | set sock [socket $host $port] | |
290 | fconfigure $sock -buffering line | |
291 | #fconfigure $sock -translation binary | |
292 | fconfigure $sock -translation crlf | |
293 | ||
732b11e0 | 294 | sendout USER guest 0 * "chiark testing bot" |
cc2d31de IJ |
295 | sendout NICK $nick |
296 | fileevent $sock readable onread | |
297 | } | |
298 | ||
8979e0d6 IJ |
299 | #if {![regexp {tclsh} $argv0]} { |
300 | # vwait terminate | |
301 | #} |