Commit | Line | Data |
---|---|---|
574abac6 | 1 | proc defset {varname val} { |
281f2c0e | 2 | upvar 1 $varname var |
574abac6 IJ |
3 | if {![info exists var]} { set var $val } |
4 | } | |
5 | ||
6 | # must set host | |
7 | defset port 6667 | |
cdbc7569 | 8 | defset socketargs {} |
574abac6 IJ |
9 | |
10 | defset nick testbot | |
9e738c1d | 11 | defset ident blight |
574abac6 IJ |
12 | defset ownfullname "testing bot" |
13 | defset ownmailaddr test-irc-bot@example.com | |
14 | ||
0d3ea3aa | 15 | defset muststartby_ms 10000 |
574abac6 IJ |
16 | defset out_maxburst 6 |
17 | defset out_interval 2100 | |
18 | defset out_lag_lag 5000 | |
19 | defset out_lag_very 25000 | |
ea990080 | 20 | defset ownping_every 300000 |
574abac6 | 21 | |
574abac6 IJ |
22 | proc manyset {list args} { |
23 | foreach val $list var $args { | |
24 | upvar 1 $var my | |
25 | set my $val | |
26 | } | |
27 | } | |
28 | ||
29 | proc try_except_finally {try except finally} { | |
30 | global errorInfo errorCode | |
31 | set er [catch { uplevel 1 $try } emsg] | |
32 | if {$er} { | |
33 | set ei $errorInfo | |
34 | set ec $errorCode | |
35 | if {[catch { uplevel 1 $except } emsg3]} { | |
36 | append ei "\nALSO ERROR HANDLING ERROR:\n$emsg3" | |
37 | } | |
38 | } | |
39 | set er2 [catch { uplevel 1 $finally } emsg2] | |
40 | if {$er} { | |
41 | if {$er2} { | |
42 | append ei "\nALSO ERROR CLEANING UP:\n$emsg2" | |
43 | } | |
44 | return -code $er -errorinfo $ei -errorcode $ec $emsg | |
45 | } elseif {$er2} { | |
46 | return -code $er2 -errorinfo $errorInfo -errorcode $errorCode $emsg2 | |
47 | } else { | |
48 | return $emsg | |
49 | } | |
50 | } | |
51 | ||
52 | proc out__vars {} { | |
53 | uplevel 1 { | |
54 | global out_queue out_creditms out_creditat out_interval out_maxburst | |
55 | global out_lag_lag out_lag_very | |
56 | #set pr [lindex [info level 0] 0] | |
57 | #puts $pr>[clock seconds]|$out_creditat|$out_creditms|[llength $out_queue]< | |
58 | } | |
59 | } | |
60 | ||
61 | proc out_lagged {} { | |
62 | out__vars | |
63 | if {[llength $out_queue]*$out_interval > $out_lag_very} { | |
64 | return 2 | |
65 | } elseif {[llength $out_queue]*$out_interval > $out_lag_lag} { | |
66 | return 1 | |
67 | } else { | |
68 | return 0 | |
69 | } | |
70 | } | |
71 | ||
72 | proc out_restart {} { | |
73 | out__vars | |
74 | ||
75 | set now [clock seconds] | |
76 | incr out_creditms [expr {($now - $out_creditat) * 1000}] | |
77 | set out_creditat $now | |
78 | if {$out_creditms > $out_maxburst*$out_interval} { | |
79 | set out_creditms [expr {$out_maxburst*$out_interval}] | |
80 | } | |
81 | out_runqueue $now | |
82 | } | |
83 | ||
84 | proc out_runqueue {now} { | |
85 | global sock | |
86 | out__vars | |
87 | ||
88 | while {[llength $out_queue] && $out_creditms >= $out_interval} { | |
89 | #puts rq>$now|$out_creditat|$out_creditms|[llength $out_queue]< | |
90 | manyset [lindex $out_queue 0] orgwhen msg | |
91 | set out_queue [lrange $out_queue 1 end] | |
92 | if {[llength $out_queue]} { | |
93 | append orgwhen "+[expr {$now - $orgwhen}]" | |
94 | append orgwhen "([llength $out_queue])" | |
95 | } | |
96 | puts "$orgwhen -> $msg" | |
97 | puts $sock $msg | |
98 | incr out_creditms -$out_interval | |
99 | } | |
100 | if {[llength $out_queue]} { | |
101 | after $out_interval out_nextmessage | |
102 | } | |
103 | } | |
104 | ||
105 | proc out_nextmessage {} { | |
106 | out__vars | |
107 | set now [clock seconds] | |
108 | incr out_creditms $out_interval | |
109 | set out_creditat $now | |
110 | out_runqueue $now | |
111 | } | |
112 | ||
113 | proc sendout_priority {priority command args} { | |
114 | global sock out_queue | |
115 | if {[llength $args]} { | |
116 | set la [lindex $args end] | |
117 | set args [lreplace $args end end] | |
118 | foreach i $args { | |
119 | if {[regexp {[: ]} $i]} { | |
120 | error "bad argument in output $i ($command $args)" | |
121 | } | |
122 | } | |
123 | lappend args :$la | |
124 | } | |
125 | set args [lreplace $args 0 -1 $command] | |
126 | set string [join $args { }] | |
127 | set now [clock seconds] | |
128 | set newe [list $now $string] | |
129 | if {$priority} { | |
130 | set out_queue [concat [list $newe] $out_queue] | |
131 | } else { | |
132 | lappend out_queue $newe | |
133 | } | |
134 | if {[llength $out_queue] == 1} { | |
135 | out_restart | |
136 | } | |
137 | } | |
138 | ||
139 | proc sendout {command args} { eval sendout_priority [list 0 $command] $args } | |
140 | ||
141 | proc log {data} { | |
142 | puts $data | |
143 | } | |
f9de645d IJ |
144 | |
145 | proc log_intern {what data} { | |
146 | puts "[clock seconds] ++ $what $data" | |
147 | } | |
574abac6 IJ |
148 | |
149 | proc logerror {data} { | |
150 | log $data | |
151 | } | |
152 | ||
153 | proc saveeic {} { | |
154 | global saveei saveec errorInfo errorCode | |
155 | ||
156 | set saveei $errorInfo | |
157 | set saveec $errorCode | |
158 | ||
159 | puts ">$saveec|$saveei<" | |
160 | } | |
161 | ||
162 | proc bgerror {msg} { | |
163 | global save | |
164 | logerror $msg | |
165 | saveeic | |
166 | } | |
167 | ||
168 | proc onread {args} { | |
892f5a82 | 169 | global sock nick calling_nick errorInfo errorCode line_org_endchar |
281f2c0e | 170 | |
30ea02af IJ |
171 | if {[catch { gets $sock line } rv]} { fail "error on input: $rv" } |
172 | if {$rv == -1} { fail "EOF on input" } | |
173 | ||
892f5a82 | 174 | set line_org_endchar [string range $line end end] |
574abac6 IJ |
175 | regsub -all "\[^ -\176\240-\376\]" $line ? line |
176 | set org $line | |
177 | ||
281f2c0e | 178 | new_event |
574abac6 IJ |
179 | |
180 | if {[regexp -nocase {^:([^ ]+) (.*)} $line dummy prefix remain]} { | |
181 | set line $remain | |
182 | if {[regexp {^([^!]+)!} $prefix dummy maybenick]} { | |
183 | set calling_nick $maybenick | |
bb72ec7b | 184 | if {![ircnick_compare $maybenick $nick]} return |
574abac6 IJ |
185 | } |
186 | } else { | |
187 | set prefix {} | |
188 | } | |
189 | if {![string length $line]} { return } | |
190 | if {![regexp -nocase {^([0-9a-z]+) *(.*)} $line dummy command line]} { | |
191 | log "bad command: $org" | |
192 | return | |
193 | } | |
194 | set command [string toupper $command] | |
195 | set params {} | |
196 | while {[regexp {^([^ :]+) *(.*)} $line dummy thisword line]} { | |
197 | lappend params $thisword | |
198 | } | |
199 | if {[regexp {^:(.*)} $line dummy thisword]} { | |
200 | lappend params $thisword | |
201 | } elseif {[string length $line]} { | |
202 | log "junk at end: $org" | |
203 | return | |
204 | } | |
bb72ec7b | 205 | if {![string compare $command "PRIVMSG"] && \ |
281f2c0e | 206 | [privmsg_unlogged $prefix [ischan [lindex $params 0]] $params]} { |
574abac6 IJ |
207 | return |
208 | } | |
209 | log "[clock seconds] <- $org" | |
210 | set procname msg_$command | |
211 | if {[catch { info body $procname }]} { return } | |
212 | if {[catch { | |
213 | eval [list $procname $prefix $command] $params | |
214 | } emsg]} { | |
215 | logerror "error: $emsg ($prefix $command $params)" | |
216 | saveeic | |
217 | } | |
218 | } | |
219 | ||
f9de645d IJ |
220 | proc catch_restoreei {body} { |
221 | global errorInfo errorCode | |
222 | set l [list $errorInfo $errorCode] | |
223 | catch { uplevel 1 $body } | |
224 | manyset $l errorInfo errorCode | |
225 | } | |
226 | ||
227 | proc catch_logged {body} { | |
228 | global errorInfo | |
229 | if {[catch { uplevel 1 $body } emsg]} { | |
230 | logerror "error (catch_logged): $emsg\n $errorInfo" | |
231 | } | |
232 | } | |
233 | ||
574abac6 IJ |
234 | proc sendprivmsg {dest l} { |
235 | foreach v [split $l "\n"] { | |
236 | sendout [expr {[ischan $dest] ? "PRIVMSG" : "NOTICE"}] $dest $v | |
237 | } | |
238 | } | |
239 | proc sendaction_priority {priority dest what} { | |
240 | sendout_priority $priority PRIVMSG $dest "\001ACTION $what\001" | |
241 | } | |
242 | proc msendprivmsg {dest ll} { foreach l $ll { sendprivmsg $dest $l } } | |
243 | proc msendprivmsg_delayed {delay dest ll} { after $delay [list msendprivmsg $dest $ll] } | |
244 | ||
245 | proc check_nick {n} { | |
246 | if {[regexp -nocase {[^][\\`_^{|}a-z0-9-]} $n]} { error "bad char in nick" } | |
247 | if {[regexp {^[-0-9]} $n]} { error "bad nick start" } | |
f9de645d | 248 | if {[string length $n] > 18} { error "nick too long" } |
574abac6 IJ |
249 | } |
250 | ||
b52676c0 IJ |
251 | proc check_chan {n} { |
252 | if {![regsub {^\#} $n {} n]} { error "bad chan start" } | |
253 | if {[regexp -nocase {[^][\\`_^{|}a-z0-9-]} $n]} { error "bad char in chan" } | |
254 | if {[regexp {^[-0-9]} $n]} { error "bad chan name start" } | |
255 | if {[string length $n] > 18} { error "chan name too long" } | |
256 | } | |
257 | ||
574abac6 IJ |
258 | proc ischan {dest} { |
259 | return [regexp {^[&#+!]} $dest] | |
260 | } | |
261 | ||
262 | proc irctolower {v} { | |
263 | foreach {from to} [list "\\\[" "{" \ | |
264 | "\\\]" "}" \ | |
265 | "\\\\" "|" \ | |
266 | "~" "^"] { | |
267 | regsub -all $from $v $to v | |
268 | } | |
269 | return [string tolower $v] | |
270 | } | |
271 | ||
bb72ec7b IJ |
272 | proc ircnick_compare {a b} { |
273 | return [string compare [irctolower $a] [irctolower $b]] | |
274 | } | |
275 | ||
281f2c0e IJ |
276 | proc prefix_none {} { |
277 | upvar 1 p p | |
278 | if {[string length $p]} { error "prefix specified" } | |
279 | } | |
280 | ||
281 | proc prefix_nick {} { | |
282 | global nick | |
283 | upvar 1 p p | |
284 | upvar 1 n n | |
285 | if {![regexp {^([^!]+)!} $p dummy n]} { error "not from nick" } | |
286 | check_nick $n | |
bb72ec7b | 287 | if {![ircnick_compare $n $nick]} { |
281f2c0e IJ |
288 | error "from myself" {} {} |
289 | } | |
290 | } | |
291 | ||
574abac6 | 292 | proc msg_PING {p c s1} { |
574abac6 IJ |
293 | prefix_none |
294 | sendout PONG $s1 | |
0d3ea3aa IJ |
295 | } |
296 | ||
ea990080 IJ |
297 | proc sendownping {} { |
298 | global ownping_every nick | |
299 | sendout ping $nick | |
300 | after $ownping_every sendownping | |
301 | } | |
302 | ||
0d3ea3aa IJ |
303 | proc msg_001 {args} { |
304 | global muststartby_after | |
305 | if {[info exists muststartby_after]} { | |
306 | after cancel $muststartby_after | |
307 | unset muststartby_after | |
ea990080 | 308 | sendownping |
281f2c0e IJ |
309 | connected |
310 | } | |
311 | } | |
312 | ||
313 | proc ensure_outqueue {} { | |
314 | out__vars | |
315 | if {[info exists out_queue]} return | |
316 | set out_creditms 0 | |
317 | set out_creditat [clock seconds] | |
318 | set out_queue {} | |
319 | set out_lag_reported 0 | |
320 | set out_lag_reportwhen $out_creditat | |
321 | } | |
322 | ||
323 | proc fail {msg} { | |
324 | logerror "failing: $msg" | |
325 | exit 1 | |
326 | } | |
327 | ||
328 | proc ensure_connecting {} { | |
9e738c1d | 329 | global sock ownfullname host port nick ident socketargs |
0d3ea3aa | 330 | global muststartby_ms muststartby_after |
281f2c0e IJ |
331 | |
332 | ensure_outqueue | |
333 | ||
334 | if {[info exists sock]} return | |
335 | set sock [eval socket $socketargs [list $host $port]] | |
336 | fconfigure $sock -buffering line | |
337 | fconfigure $sock -translation crlf | |
338 | ||
9e738c1d | 339 | sendout USER $ident 0 * $ownfullname |
281f2c0e IJ |
340 | sendout NICK $nick |
341 | fileevent $sock readable onread | |
342 | ||
0d3ea3aa IJ |
343 | set muststartby_after [after $muststartby_ms \ |
344 | {fail "no successfuly connect within timeout"}] | |
574abac6 | 345 | } |